packages feed

ghc-lib-parser 9.2.8.20230729 → 9.4.1.20220807

raw patch · 337 files changed

+51066/−26162 lines, 337 filesdep ~basedep ~bytestringdep ~ghc-prim

Dependency ranges changed: base, bytestring, ghc-prim, time, transformers

Files

+ compiler/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++/*-------------------------------------------------------------------------*/
+ compiler/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
+ compiler/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
+ compiler/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
compiler/GHC/Builtin/Names.hs view
@@ -133,8 +133,6 @@    ) where -#include "GhclibHsVersions.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 ]
compiler/GHC/Builtin/PrimOps.hs view
@@ -24,31 +24,34 @@         PrimCall(..)     ) where -#include "GhclibHsVersions.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
+ compiler/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]
compiler/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 "GhclibHsVersions.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
compiler/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
compiler/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 "GhclibHsVersions.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  #if MIN_VERSION_ghc_prim(0, 7, 0) bcoPrimTyConName              = mkPrimTc (fsLit "BCO") bcoPrimTyConKey bcoPrimTyCon@@ -369,13 +383,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@@ -389,23 +406,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'@@ -420,7 +475,7 @@ -}  funTyConName :: Name-funTyConName = mkPrimTyConName (fsLit "FUN") funTyConKey funTyCon+funTyConName = mkPrimTcName UserSyntax (fsLit "FUN") funTyConKey funTyCon  -- | The @FUN@ type constructor. --@@ -450,8 +505,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 @@ -518,51 +573,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@@ -582,141 +608,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  {- ************************************************************************@@ -755,7 +759,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.@@ -835,7 +839,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@@ -870,7 +874,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:@@ -905,7 +909,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@@ -914,7 +918,7 @@ -}  realWorldTyCon :: TyCon-realWorldTyCon = mkLiftedPrimTyCon realWorldTyConName [] liftedTypeKind []+realWorldTyCon = mkPrimTyCon realWorldTyConName [] liftedTypeKind [] realWorldTy :: Type realWorldTy          = mkTyConTy realWorldTyCon realWorldStatePrimTy :: Type@@ -930,7 +934,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 [] @@ -946,7 +950,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]@@ -957,7 +961,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]@@ -968,7 +972,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]@@ -986,33 +990,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]   {- *********************************************************************@@ -1022,10 +1020,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]  {- ************************************************************************@@ -1036,10 +1034,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]  {- ************************************************************************@@ -1051,10 +1049,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]  {- ************************************************************************@@ -1065,10 +1063,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]  {- ************************************************************************@@ -1079,10 +1077,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]  {- ************************************************************************@@ -1093,10 +1091,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]  {- ************************************************************************@@ -1107,7 +1105,7 @@ -}  compactPrimTyCon :: TyCon-compactPrimTyCon = pcPrimTyCon0 compactPrimTyConName UnliftedRep+compactPrimTyCon = pcPrimTyCon0 compactPrimTyConName unliftedRepTy  compactPrimTy :: Type compactPrimTy = mkTyConTy compactPrimTyCon@@ -1115,6 +1113,21 @@ {- ************************************************************************ *                                                                      *+   The @StackSnapshot#@ type+*                                                                      *+************************************************************************+-}++stackSnapshotPrimTyCon :: TyCon+stackSnapshotPrimTyCon = pcPrimTyCon0 stackSnapshotPrimTyConName unliftedRepTy++stackSnapshotPrimTy :: Type+stackSnapshotPrimTy = mkTyConTy stackSnapshotPrimTyCon+++{-+************************************************************************+*                                                                      *    The ``bytecode object'' type *                                                                      * ************************************************************************@@ -1126,13 +1139,7 @@ bcoPrimTy    :: Type bcoPrimTy    = mkTyConTy bcoPrimTyCon bcoPrimTyCon :: TyCon--#if MIN_VERSION_ghc_prim(0, 7, 0)-bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName LiftedRep-#else-bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName UnliftedRep-#endif-+bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName liftedRepTy  {- ************************************************************************@@ -1143,10 +1150,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]  {- ************************************************************************@@ -1168,7 +1175,7 @@ threadIdPrimTy :: Type threadIdPrimTy    = mkTyConTy threadIdPrimTyCon threadIdPrimTyCon :: TyCon-threadIdPrimTyCon = pcPrimTyCon0 threadIdPrimTyConName UnliftedRep+threadIdPrimTyCon = pcPrimTyCon0 threadIdPrimTyConName unliftedRepTy  {- ************************************************************************
compiler/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 "GhclibHsVersions.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  --------------------------------------------------
compiler/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
compiler/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
compiler/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))-
compiler/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 "GhclibHsVersions.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.
+ compiler/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+
compiler/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*
compiler/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
compiler/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.
compiler/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
compiler/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. --
compiler/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
− compiler/GHC/CmmToAsm/Config.hs 
@@ -1,58 +0,0 @@--- | Native code generator configuration-module GHC.CmmToAsm.Config-   ( NCGConfig(..)-   , ncgWordWidth-   , ncgSpillPreallocSize-   , platformWordWidth-   )-where--import GHC.Prelude-import GHC.Platform-import GHC.Cmm.Type (Width(..))-import GHC.CmmToAsm.CFG.Weight-import GHC.Unit.Module (Module)-import GHC.Utils.Outputable---- | Native code generator configuration-data NCGConfig = NCGConfig-   { ncgPlatform              :: !Platform        -- ^ Target platform-   , ncgAsmContext            :: !SDocContext     -- ^ Context for ASM code generation-   , ncgThisModule            :: !Module          -- ^ The name of the module we are currently compiling-   , ncgProcAlignment         :: !(Maybe Int)     -- ^ Mandatory proc alignment-   , ncgExternalDynamicRefs   :: !Bool            -- ^ Generate code to link against dynamic libraries-   , ncgPIC                   :: !Bool            -- ^ Enable Position-Independent Code-   , ncgInlineThresholdMemcpy :: !Word            -- ^ If inlining `memcpy` produces less than this threshold (in pseudo-instruction unit), do it-   , ncgInlineThresholdMemset :: !Word            -- ^ Ditto for `memset`-   , ncgSplitSections         :: !Bool            -- ^ Split sections-   , ncgRegsIterative         :: !Bool-   , ncgAsmLinting            :: !Bool            -- ^ Perform ASM linting pass-   , ncgDoConstantFolding     :: !Bool            -- ^ Perform CMM constant folding-   , ncgSseVersion            :: Maybe SseVersion -- ^ (x86) SSE instructions-   , ncgBmiVersion            :: Maybe BmiVersion -- ^ (x86) BMI instructions-   , ncgDumpRegAllocStages    :: !Bool-   , ncgDumpAsmStats          :: !Bool-   , ncgDumpAsmConflicts      :: !Bool-   , ncgCfgWeights            :: !Weights         -- ^ CFG edge weights-   , ncgCfgBlockLayout        :: !Bool            -- ^ Use CFG based block layout algorithm-   , ncgCfgWeightlessLayout   :: !Bool            -- ^ Layout based on last instruction per block.-   , ncgDwarfEnabled          :: !Bool            -- ^ Enable Dwarf generation-   , ncgDwarfUnwindings       :: !Bool            -- ^ Enable unwindings-   , ncgDwarfStripBlockInfo   :: !Bool            -- ^ Strip out block information from generated Dwarf-   , ncgExposeInternalSymbols :: !Bool            -- ^ Expose symbol table entries for internal symbols-   , ncgDwarfSourceNotes      :: !Bool            -- ^ Enable GHC-specific source note DIEs-   }---- | Return Word size-ncgWordWidth :: NCGConfig -> Width-ncgWordWidth config = platformWordWidth (ncgPlatform config)---- | Size in bytes of the pre-allocated spill space on the C stack-ncgSpillPreallocSize :: NCGConfig -> Int-ncgSpillPreallocSize config = pc_RESERVED_C_STACK_BYTES (platformConstants (ncgPlatform config))---- | Return Word size-platformWordWidth :: Platform -> Width-platformWordWidth platform = case platformWordSize platform of-   PW4 -> W32-   PW8 -> W64
compiler/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 "GhclibHsVersions.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
compiler/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 "GhclibHsVersions.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)
compiler/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 "GhclibHsVersions.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)
compiler/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'
compiler/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 "GhclibHsVersions.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
compiler/GHC/Core/Coercion/Opt.hs view
@@ -9,30 +9,33 @@    ) where -#include "GhclibHsVersions.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 :: * -> *
compiler/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 "GhclibHsVersions.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 {})         = []
compiler/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 "GhclibHsVersions.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
compiler/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 "GhclibHsVersions.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
compiler/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 "GhclibHsVersions.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'.
compiler/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 "GhclibHsVersions.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)
compiler/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 "GhclibHsVersions.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 <*>
compiler/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 "GhclibHsVersions.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
+ compiler/GHC/Core/Map/Expr.hs view
@@ -0,0 +1,449 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}++{-# OPTIONS_GHC -Wno-orphans #-}+ -- Eq (DeBruijn CoreExpr) and Eq (DeBruijn CoreAlt)++module GHC.Core.Map.Expr (+   -- * Maps over Core expressions+   CoreMap, emptyCoreMap, extendCoreMap, lookupCoreMap, foldCoreMap,+   -- * Alpha equality+   eqDeBruijnExpr, eqCoreExpr,+   -- * 'TrieMap' class reexports+   TrieMap(..), insertTM, deleteTM,+   lkDFreeVar, xtDFreeVar,+   lkDNamed, xtDNamed,+   (>.>), (|>), (|>>),+ ) where++import GHC.Prelude++import GHC.Data.TrieMap+import GHC.Core.Map.Type+import GHC.Core+import GHC.Core.Type+import GHC.Types.Tickish+import GHC.Types.Var++import GHC.Utils.Misc+import GHC.Utils.Outputable++import qualified Data.Map    as Map+import GHC.Types.Name.Env+import Control.Monad( (>=>) )++{-+This module implements TrieMaps over Core related data structures+like CoreExpr or Type. It is built on the Tries from the TrieMap+module.++The code is very regular and boilerplate-like, but there is+some neat handling of *binders*.  In effect they are deBruijn+numbered on the fly.+++-}++----------------------+-- Recall that+--   Control.Monad.(>=>) :: (a -> Maybe b) -> (b -> Maybe c) -> a -> Maybe c++-- The CoreMap makes heavy use of GenMap. However the CoreMap Types are not+-- known when defining GenMap so we can only specialize them here.++{-# SPECIALIZE lkG :: Key CoreMapX     -> CoreMapG a     -> Maybe a #-}+{-# SPECIALIZE xtG :: Key CoreMapX     -> XT a -> CoreMapG a -> CoreMapG a #-}+{-# SPECIALIZE mapG :: (a -> b) -> CoreMapG a     -> CoreMapG b #-}+{-# SPECIALIZE fdG :: (a -> b -> b) -> CoreMapG a     -> b -> b #-}+++{-+************************************************************************+*                                                                      *+                   CoreMap+*                                                                      *+************************************************************************+-}++{-+Note [Binders]+~~~~~~~~~~~~~~+ * In general we check binders as late as possible because types are+   less likely to differ than expression structure.  That's why+      cm_lam :: CoreMapG (TypeMapG a)+   rather than+      cm_lam :: TypeMapG (CoreMapG a)++ * We don't need to look at the type of some binders, notably+     - the case binder in (Case _ b _ _)+     - the binders in an alternative+   because they are totally fixed by the context++Note [Empty case alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* For a key (Case e b ty (alt:alts))  we don't need to look the return type+  'ty', because every alternative has that type.++* For a key (Case e b ty []) we MUST look at the return type 'ty', because+  otherwise (Case (error () "urk") _ Int  []) would compare equal to+            (Case (error () "urk") _ Bool [])+  which is utterly wrong (#6097)++We could compare the return type regardless, but the wildly common case+is that it's unnecessary, so we have two fields (cm_case and cm_ecase)+for the two possibilities.  Only cm_ecase looks at the type.++See also Note [Empty case alternatives] in GHC.Core.+-}++-- | @CoreMap a@ is a map from 'CoreExpr' to @a@.  If you are a client, this+-- is the type you want.+newtype CoreMap a = CoreMap (CoreMapG a)++instance TrieMap CoreMap where+    type Key CoreMap = CoreExpr+    emptyTM = CoreMap emptyTM+    lookupTM k (CoreMap m) = lookupTM (deBruijnize k) m+    alterTM k f (CoreMap m) = CoreMap (alterTM (deBruijnize k) f m)+    foldTM k (CoreMap m) = foldTM k m+    mapTM f (CoreMap m) = CoreMap (mapTM f m)+    filterTM f (CoreMap m) = CoreMap (filterTM f m)++-- | @CoreMapG a@ is a map from @DeBruijn CoreExpr@ to @a@.  The extended+-- key makes it suitable for recursive traversal, since it can track binders,+-- but it is strictly internal to this module.  If you are including a 'CoreMap'+-- inside another 'TrieMap', this is the type you want.+type CoreMapG = GenMap CoreMapX++-- | @CoreMapX a@ is the base map from @DeBruijn CoreExpr@ to @a@, but without+-- the 'GenMap' optimization.+data CoreMapX a+  = CM { cm_var   :: VarMap a+       , cm_lit   :: LiteralMap a+       , cm_co    :: CoercionMapG a+       , cm_type  :: TypeMapG a+       , cm_cast  :: CoreMapG (CoercionMapG a)+       , cm_tick  :: CoreMapG (TickishMap a)+       , cm_app   :: CoreMapG (CoreMapG a)+       , cm_lam   :: CoreMapG (BndrMap a)    -- Note [Binders]+       , cm_letn  :: CoreMapG (CoreMapG (BndrMap a))+       , cm_letr  :: ListMap CoreMapG (CoreMapG (ListMap BndrMap a))+       , cm_case  :: CoreMapG (ListMap AltMap a)+       , cm_ecase :: CoreMapG (TypeMapG a)    -- Note [Empty case alternatives]+     }++instance Eq (DeBruijn CoreExpr) where+    (==) = eqDeBruijnExpr++eqDeBruijnExpr :: DeBruijn CoreExpr -> DeBruijn CoreExpr -> Bool+eqDeBruijnExpr (D env1 e1) (D env2 e2) = go e1 e2 where+    go (Var v1) (Var v2) = eqDeBruijnVar (D env1 v1) (D env2 v2)+    go (Lit lit1)    (Lit lit2)      = lit1 == lit2+    -- 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+    go (Tick n1 e1) (Tick n2 e2)+      =  eqDeBruijnTickish (D env1 n1) (D env2 n2)+      && go e1 e2++    go (Lam b1 e1)  (Lam b2 e2)+          -- 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)+      && eqDeBruijnExpr (D (extendCME env1 b1) e1) (D (extendCME env2 b2) e2)++    go (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2)+      =  go r1 r2 -- See Note [Alpha-equality for let-bindings]+      && eqDeBruijnExpr (D (extendCME env1 v1) e1) (D (extendCME env2 v2) e2)++    go (Let (Rec ps1) e1) (Let (Rec ps2) e2)+      = equalLength ps1 ps2+      -- See Note [Alpha-equality for let-bindings]+      && all2 (\b1 b2 -> -- 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+      && eqDeBruijnExpr (D env1' e1) (D env2' e2)+      where+        (bs1,rs1) = unzip ps1+        (bs2,rs2) = unzip ps2+        env1' = extendCMEs env1 bs1+        env2' = extendCMEs env2 bs2++    go (Case e1 b1 t1 a1) (Case e2 b2 t2 a2)+      | null a1   -- See Note [Empty case alternatives]+      = null a2 && go e1 e2 && D env1 t1 == D env2 t2+      | otherwise+      = go e1 e2 && D (extendCME env1 b1) a1 == D (extendCME env2 b2) a2++    go _ _ = False++eqDeBruijnTickish :: DeBruijn CoreTickish -> DeBruijn CoreTickish -> Bool+eqDeBruijnTickish (D env1 t1) (D env2 t2) = go t1 t2 where+    go (Breakpoint lext lid lids) (Breakpoint rext rid rids)+        =  lid == rid+        && D env1 lids == D env2 rids+        && lext == rext+    go l r = l == r++-- Compares for equality, modulo alpha+eqCoreExpr :: CoreExpr -> CoreExpr -> Bool+eqCoreExpr e1 e2 = eqDeBruijnExpr (deBruijnize e1) (deBruijnize e2)++{- Note [Alpha-equality for Coercion arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The 'Coercion' constructor only appears in argument positions, and so, if the+functions are equal, then the arguments must have equal types. Because the+comparison for coercions (correctly) checks only their types, checking for+alpha-equality of the coercions is redundant.+-}++{- Note [Alpha-equality for let-bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For /recursive/ let-bindings we need to check that the types of the binders+are alpha-equivalent. Otherwise++  letrec (x : Bool) = x in x++and++  letrec (y : Char) = y in y++would be considered alpha-equivalent, which they are obviously not.++For /non-recursive/ let-bindings, we do not have to check that the types of+the binders are alpha-equivalent. When the RHSs (the expressions) of the+non-recursive let-binders are well-formed and well-typed (which we assume they+are at this point in the compiler), and the RHSs are alpha-equivalent, then the+bindings must have the same type.++In addition, it is also worth pointing out that++  letrec { x = e1; y = e2 } in b++is NOT considered equal to++  letrec { y = e2; x = e1 } in b+-}++emptyE :: CoreMapX a+emptyE = CM { cm_var = emptyTM, cm_lit = emptyTM+            , cm_co = emptyTM, cm_type = emptyTM+            , cm_cast = emptyTM, cm_app = emptyTM+            , cm_lam = emptyTM, cm_letn = emptyTM+            , cm_letr = emptyTM, cm_case = emptyTM+            , cm_ecase = emptyTM, cm_tick = emptyTM }++instance TrieMap CoreMapX where+   type Key CoreMapX = DeBruijn CoreExpr+   emptyTM  = emptyE+   lookupTM = lkE+   alterTM  = xtE+   foldTM   = fdE+   mapTM    = mapE+   filterTM = ftE++--------------------------+mapE :: (a->b) -> CoreMapX a -> CoreMapX b+mapE f (CM { cm_var = cvar, cm_lit = clit+           , cm_co = cco, cm_type = ctype+           , cm_cast = ccast , cm_app = capp+           , cm_lam = clam, cm_letn = cletn+           , cm_letr = cletr, cm_case = ccase+           , cm_ecase = cecase, cm_tick = ctick })+  = CM { cm_var = mapTM f cvar, cm_lit = mapTM f clit+       , cm_co = mapTM f cco, cm_type = mapTM f ctype+       , cm_cast = mapTM (mapTM f) ccast, cm_app = mapTM (mapTM f) capp+       , cm_lam = mapTM (mapTM f) clam, cm_letn = mapTM (mapTM (mapTM f)) cletn+       , cm_letr = mapTM (mapTM (mapTM f)) cletr, cm_case = mapTM (mapTM f) ccase+       , cm_ecase = mapTM (mapTM f) cecase, cm_tick = mapTM (mapTM f) ctick }++ftE :: (a->Bool) -> CoreMapX a -> CoreMapX a+ftE f (CM { cm_var = cvar, cm_lit = clit+          , cm_co = cco, cm_type = ctype+          , cm_cast = ccast , cm_app = capp+          , cm_lam = clam, cm_letn = cletn+          , cm_letr = cletr, cm_case = ccase+          , cm_ecase = cecase, cm_tick = ctick })+  = CM { cm_var = filterTM f cvar, cm_lit = filterTM f clit+       , cm_co = filterTM f cco, cm_type = filterTM f ctype+       , cm_cast = mapTM (filterTM f) ccast, cm_app = mapTM (filterTM f) capp+       , cm_lam = mapTM (filterTM f) clam, cm_letn = mapTM (mapTM (filterTM f)) cletn+       , cm_letr = mapTM (mapTM (filterTM f)) cletr, cm_case = mapTM (filterTM f) ccase+       , cm_ecase = mapTM (filterTM f) cecase, cm_tick = mapTM (filterTM f) ctick }++--------------------------+lookupCoreMap :: CoreMap a -> CoreExpr -> Maybe a+lookupCoreMap cm e = lookupTM e cm++extendCoreMap :: CoreMap a -> CoreExpr -> a -> CoreMap a+extendCoreMap m e v = alterTM e (\_ -> Just v) m++foldCoreMap :: (a -> b -> b) -> b -> CoreMap a -> b+foldCoreMap k z m = foldTM k m z++emptyCoreMap :: CoreMap a+emptyCoreMap = emptyTM++instance Outputable a => Outputable (CoreMap a) where+  ppr m = text "CoreMap elts" <+> ppr (foldTM (:) m [])++-------------------------+fdE :: (a -> b -> b) -> CoreMapX a -> b -> b+fdE k m+  = foldTM k (cm_var m)+  . foldTM k (cm_lit m)+  . foldTM k (cm_co m)+  . foldTM k (cm_type m)+  . foldTM (foldTM k) (cm_cast m)+  . foldTM (foldTM k) (cm_tick m)+  . foldTM (foldTM k) (cm_app m)+  . foldTM (foldTM k) (cm_lam m)+  . foldTM (foldTM (foldTM k)) (cm_letn m)+  . foldTM (foldTM (foldTM k)) (cm_letr m)+  . foldTM (foldTM k) (cm_case m)+  . foldTM (foldTM k) (cm_ecase m)++-- lkE: lookup in trie for expressions+lkE :: DeBruijn CoreExpr -> CoreMapX a -> Maybe a+lkE (D env expr) cm = go expr cm+  where+    go (Var v)              = cm_var  >.> lkVar env v+    go (Lit l)              = cm_lit  >.> lookupTM l+    go (Type t)             = cm_type >.> lkG (D env t)+    go (Coercion c)         = cm_co   >.> lkG (D env c)+    go (Cast e c)           = cm_cast >.> lkG (D env e) >=> lkG (D env c)+    go (Tick tickish e)     = cm_tick >.> lkG (D env e) >=> lkTickish tickish+    go (App e1 e2)          = cm_app  >.> lkG (D env e2) >=> lkG (D env e1)+    go (Lam v e)            = cm_lam  >.> lkG (D (extendCME env v) e)+                              >=> lkBndr env v+    go (Let (NonRec b r) e) = cm_letn >.> lkG (D env r)+                              >=> lkG (D (extendCME env b) e) >=> lkBndr env b+    go (Let (Rec prs) e)    = let (bndrs,rhss) = unzip prs+                                  env1 = extendCMEs env bndrs+                              in cm_letr+                                 >.> lkList (lkG . D env1) rhss+                                 >=> lkG (D env1 e)+                                 >=> lkList (lkBndr env1) bndrs+    go (Case e b ty as)     -- See Note [Empty case alternatives]+               | null as    = cm_ecase >.> lkG (D env e) >=> lkG (D env ty)+               | otherwise  = cm_case >.> lkG (D env e)+                              >=> lkList (lkA (extendCME env b)) as++xtE :: DeBruijn CoreExpr -> XT a -> CoreMapX a -> CoreMapX a+xtE (D env (Var v))              f m = m { cm_var  = cm_var m+                                                 |> xtVar env v f }+xtE (D env (Type t))             f m = m { cm_type = cm_type m+                                                 |> xtG (D env t) f }+xtE (D env (Coercion c))         f m = m { cm_co   = cm_co m+                                                 |> xtG (D env c) f }+xtE (D _   (Lit l))              f m = m { cm_lit  = cm_lit m  |> alterTM l f }+xtE (D env (Cast e c))           f m = m { cm_cast = cm_cast m |> xtG (D env e)+                                                 |>> xtG (D env c) f }+xtE (D env (Tick t e))           f m = m { cm_tick = cm_tick m |> xtG (D env e)+                                                 |>> xtTickish t f }+xtE (D env (App e1 e2))          f m = m { cm_app = cm_app m |> xtG (D env e2)+                                                 |>> xtG (D env e1) f }+xtE (D env (Lam v e))            f m = m { cm_lam = cm_lam m+                                                 |> xtG (D (extendCME env v) e)+                                                 |>> xtBndr env v f }+xtE (D env (Let (NonRec b r) e)) f m = m { cm_letn = cm_letn m+                                                 |> xtG (D (extendCME env b) e)+                                                 |>> xtG (D env r)+                                                 |>> xtBndr env b f }+xtE (D env (Let (Rec prs) e))    f m = m { cm_letr =+                                              let (bndrs,rhss) = unzip prs+                                                  env1 = extendCMEs env bndrs+                                              in cm_letr m+                                                 |>  xtList (xtG . D env1) rhss+                                                 |>> xtG (D env1 e)+                                                 |>> xtList (xtBndr env1)+                                                            bndrs f }+xtE (D env (Case e b ty as))     f m+                     | null as   = m { cm_ecase = cm_ecase m |> xtG (D env e)+                                                 |>> xtG (D env ty) f }+                     | otherwise = m { cm_case = cm_case m |> xtG (D env e)+                                                 |>> let env1 = extendCME env b+                                                     in xtList (xtA env1) as f }++-- TODO: this seems a bit dodgy, see 'eqTickish'+type TickishMap a = Map.Map CoreTickish a+lkTickish :: CoreTickish -> TickishMap a -> Maybe a+lkTickish = lookupTM++xtTickish :: CoreTickish -> XT a -> TickishMap a -> TickishMap a+xtTickish = alterTM++------------------------+data AltMap a   -- A single alternative+  = AM { am_deflt :: CoreMapG a+       , am_data  :: DNameEnv (CoreMapG a)+       , am_lit   :: LiteralMap (CoreMapG a) }++instance TrieMap AltMap where+   type Key AltMap = CoreAlt+   emptyTM  = AM { am_deflt = emptyTM+                 , am_data = emptyDNameEnv+                 , am_lit  = emptyTM }+   lookupTM = lkA emptyCME+   alterTM  = xtA emptyCME+   foldTM   = fdA+   mapTM    = mapA+   filterTM = ftA++instance Eq (DeBruijn CoreAlt) where+  D env1 a1 == D env2 a2 = go a1 a2 where+    go (Alt DEFAULT _ rhs1) (Alt DEFAULT _ rhs2)+        = D env1 rhs1 == D env2 rhs2+    go (Alt (LitAlt lit1) _ rhs1) (Alt (LitAlt lit2) _ rhs2)+        = lit1 == lit2 && D env1 rhs1 == D env2 rhs2+    go (Alt (DataAlt dc1) bs1 rhs1) (Alt (DataAlt dc2) bs2 rhs2)+        = dc1 == dc2 &&+          D (extendCMEs env1 bs1) rhs1 == D (extendCMEs env2 bs2) rhs2+    go _ _ = False++mapA :: (a->b) -> AltMap a -> AltMap b+mapA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit })+  = AM { am_deflt = mapTM f adeflt+       , am_data = mapTM (mapTM f) adata+       , am_lit = mapTM (mapTM f) alit }++ftA :: (a->Bool) -> AltMap a -> AltMap a+ftA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit })+  = AM { am_deflt = filterTM f adeflt+       , am_data = mapTM (filterTM f) adata+       , am_lit = mapTM (filterTM f) alit }++lkA :: CmEnv -> CoreAlt -> AltMap a -> Maybe a+lkA env (Alt DEFAULT      _  rhs) = am_deflt >.> lkG (D env rhs)+lkA env (Alt (LitAlt lit) _  rhs) = am_lit >.> lookupTM lit >=> lkG (D env rhs)+lkA env (Alt (DataAlt dc) bs rhs) = am_data >.> lkDNamed dc+                                        >=> lkG (D (extendCMEs env bs) rhs)++xtA :: CmEnv -> CoreAlt -> XT a -> AltMap a -> AltMap a+xtA env (Alt DEFAULT _ rhs)      f m =+    m { am_deflt = am_deflt m |> xtG (D env rhs) f }+xtA env (Alt (LitAlt l) _ rhs)   f m =+    m { am_lit   = am_lit m   |> alterTM l |>> xtG (D env rhs) f }+xtA env (Alt (DataAlt d) bs rhs) f m =+    m { am_data  = am_data m  |> xtDNamed d+                             |>> xtG (D (extendCMEs env bs) rhs) f }++fdA :: (a -> b -> b) -> AltMap a -> b -> b+fdA k m = foldTM k (am_deflt m)+        . foldTM (foldTM k) (am_data m)+        . foldTM (foldTM k) (am_lit m)
compiler/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 #-}
compiler/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
compiler/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 "GhclibHsVersions.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)
compiler/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
compiler/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 "GhclibHsVersions.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. -}
+ compiler/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
compiler/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
compiler/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 "GhclibHsVersions.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 }
compiler/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 "GhclibHsVersions.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
compiler/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
compiler/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
+ compiler/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])+           -}
+ compiler/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
+ compiler/GHC/Core/Rules.hs view
@@ -0,0 +1,1596 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[CoreRules]{Rewrite rules}+-}+++-- | Functions for collecting together and applying rewrite rules to a module.+-- The 'CoreRule' datatype itself is declared elsewhere.+module GHC.Core.Rules (+        -- ** Constructing+        emptyRuleBase, mkRuleBase, extendRuleBaseList,+        pprRuleBase, extendRuleEnv,++        -- ** Checking rule applications+        ruleCheckProgram,++        -- ** Manipulating 'RuleInfo' rules+        extendRuleInfo, addRuleInfo,+        addIdSpecialisations,++        -- * Misc. CoreRule helpers+        rulesOfBinds, getRules, pprRulesForUser,++        lookupRule, mkRule, roughTopNames, initRuleOpts+    ) where++import GHC.Prelude++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, 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, 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+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Types.Name    ( Name, NamedThing(..), nameIsLocalOrFrom )+import GHC.Types.Name.Set+import GHC.Types.Name.Env+import GHC.Types.Unique.FM+import GHC.Types.Tickish+import GHC.Types.Basic++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 )++{-+Note [Overall plumbing for rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* After the desugarer:+   - The ModGuts initially contains mg_rules :: [CoreRule] of+     locally-declared rules for imported Ids.+   - Locally-declared rules for locally-declared Ids are attached to+     the IdInfo for that Id.  See Note [Attach rules to local ids] in+     GHC.HsToCore.Binds++* GHC.Iface.Tidy strips off all the rules from local Ids and adds them to+  mg_rules, so that the ModGuts has *all* the locally-declared rules.++* The HomePackageTable contains a ModDetails for each home package+  module.  Each contains md_rules :: [CoreRule] of rules declared in+  that module.  The HomePackageTable grows as ghc --make does its+  up-sweep.  In batch mode (ghc -c), the HPT is empty; all imported modules+  are treated by the "external" route, discussed next, regardless of+  which package they come from.++* The ExternalPackageState has a single eps_rule_base :: RuleBase for+  Ids in other packages.  This RuleBase simply grow monotonically, as+  ghc --make compiles one module after another.++  During simplification, interface files may get demand-loaded,+  as the simplifier explores the unfoldings for Ids it has in+  its hand.  (Via an unsafePerformIO; the EPS is really a cache.)+  That in turn may make the EPS rule-base grow.  In contrast, the+  HPT never grows in this way.++* The result of all this is that during Core-to-Core optimisation+  there are four sources of rules:++    (a) Rules in the IdInfo of the Id they are a rule for.  These are+        easy: fast to look up, and if you apply a substitution then+        it'll be applied to the IdInfo as a matter of course.++    (b) Rules declared in this module for imported Ids, kept in the+        ModGuts. If you do a substitution, you'd better apply the+        substitution to these.  There are seldom many of these.++    (c) Rules declared in the HomePackageTable.  These never change.++    (d) Rules in the ExternalPackageTable. These can grow in response+        to lazy demand-loading of interfaces.++* At the moment (c) is carried in a reader-monad way by the GHC.Core.Opt.Monad.+  The HomePackageTable doesn't have a single RuleBase because technically+  we should only be able to "see" rules "below" this module; so we+  generate a RuleBase for (c) by combing rules from all the modules+  "below" us.  That's why we can't just select the home-package RuleBase+  from HscEnv.++  [NB: we are inconsistent here.  We should do the same for external+  packages, but we don't.  Same for type-class instances.]++* So in the outer simplifier loop (simplifyPgmIO), we combine (b & c) into a single+  RuleBase, reading+     (b) from the ModGuts,+     (c) from the GHC.Core.Opt.Monad, and+  just before doing rule matching we read+     (d) from its mutable variable+  and combine it with the results from (b & c).++  In a single simplifier run new rules can be added into the EPS so it matters+  to keep an up-to-date view of which rules have been loaded. For examples of+  where this went wrong and caused cryptic performance regressions seee+  see T19790 and !6735.+++************************************************************************+*                                                                      *+\subsection[specialisation-IdInfo]{Specialisation info about an @Id@}+*                                                                      *+************************************************************************++A @CoreRule@ holds details of one rule for an @Id@, which+includes its specialisations.++For example, if a rule for @f@ contains the mapping:+\begin{verbatim}+        forall a b d. [Type (List a), Type b, Var d]  ===>  f' a b+\end{verbatim}+then when we find an application of f to matching types, we simply replace+it by the matching RHS:+\begin{verbatim}+        f (List Int) Bool dict ===>  f' Int Bool+\end{verbatim}+All the stuff about how many dictionaries to discard, and what types+to apply the specialised function to, are handled by the fact that the+Rule contains a template for the result of the specialisation.++There is one more exciting case, which is dealt with in exactly the same+way.  If the specialised value is unboxed then it is lifted at its+definition site and unlifted at its uses.  For example:++        pi :: forall a. Num a => a++might have a specialisation++        [Int#] ===>  (case pi' of Lift pi# -> pi#)++where pi' :: Lift Int# is the specialised version of pi.+-}++mkRule :: Module -> Bool -> Bool -> RuleName -> Activation+       -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule+-- ^ Used to make 'CoreRule' for an 'Id' defined in the module being+-- compiled. See also 'GHC.Core.CoreRule'+mkRule this_mod is_auto is_local name act fn bndrs args rhs+  = Rule { ru_name = name, ru_fn = fn, ru_act = act,+           ru_bndrs = bndrs, ru_args = args,+           ru_rhs = rhs,+           ru_rough = roughTopNames args,+           ru_origin = this_mod,+           ru_orphan = orph,+           ru_auto = is_auto, ru_local = is_local }+  where+        -- Compute orphanhood.  See Note [Orphans] in GHC.Core.InstEnv+        -- A rule is an orphan only if none of the variables+        -- mentioned on its left-hand side are locally defined+    lhs_names = extendNameSet (exprsOrphNames args) fn++        -- Since rules get eventually attached to one of the free names+        -- from the definition when compiling the ABI hash, we should make+        -- it deterministic. This chooses the one with minimal OccName+        -- as opposed to uniq value.+    local_lhs_names = filterNameSet (nameIsLocalOrFrom this_mod) lhs_names+    orph = chooseOrphanAnchor local_lhs_names++--------------+roughTopNames :: [CoreExpr] -> [Maybe Name]+-- ^ Find the \"top\" free names of several expressions.+-- Such names are either:+--+-- 1. The function finally being applied to in an application chain+--    (if that name is a GlobalId: see "GHC.Types.Var#globalvslocal"), or+--+-- 2. The 'TyCon' if the expression is a 'Type'+--+-- This is used for the fast-match-check for rules;+--      if the top names don't match, the rest can't+roughTopNames args = map roughTopName args++roughTopName :: CoreExpr -> Maybe Name+roughTopName (Type ty) = case tcSplitTyConApp_maybe ty of+                               Just (tc,_) -> Just (getName tc)+                               Nothing     -> Nothing+roughTopName (Coercion _) = Nothing+roughTopName (App f _) = roughTopName f+roughTopName (Var f)   | isGlobalId f   -- Note [Care with roughTopName]+                       , isDataConWorkId f || idArity f > 0+                       = Just (idName f)+roughTopName (Tick t e) | tickishFloatable t+                        = roughTopName e+roughTopName _ = Nothing++ruleCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool+-- ^ @ruleCantMatch tpl actual@ returns True only if @actual@+-- definitely can't match @tpl@ by instantiating @tpl@.+-- It's only a one-way match; unlike instance matching we+-- don't consider unification.+--+-- Notice that [_$_]+--      @ruleCantMatch [Nothing] [Just n2] = False@+--      Reason: a template variable can be instantiated by a constant+-- Also:+--      @ruleCantMatch [Just n1] [Nothing] = False@+--      Reason: a local variable @v@ in the actuals might [_$_]++ruleCantMatch (Just n1 : ts) (Just n2 : as) = n1 /= n2 || ruleCantMatch ts as+ruleCantMatch (_       : ts) (_       : as) = ruleCantMatch ts as+ruleCantMatch _              _              = False++{-+Note [Care with roughTopName]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this+    module M where { x = a:b }+    module N where { ...f x...+                     RULE f (p:q) = ... }+You'd expect the rule to match, because the matcher can+look through the unfolding of 'x'.  So we must avoid roughTopName+returning 'M.x' for the call (f x), or else it'll say "can't match"+and we won't even try!!++However, suppose we have+         RULE g (M.h x) = ...+         foo = ...(g (M.k v))....+where k is a *function* exported by M.  We never really match+functions (lambdas) except by name, so in this case it seems like+a good idea to treat 'M.k' as a roughTopName of the call.+-}++pprRulesForUser :: [CoreRule] -> SDoc+-- (a) tidy the rules+-- (b) sort them into order based on the rule name+-- (c) suppress uniques (unless -dppr-debug is on)+-- This combination makes the output stable so we can use in testing+-- It's here rather than in GHC.Core.Ppr because it calls tidyRules+pprRulesForUser rules+  = withPprStyle defaultUserStyle $+    pprRules $+    sortBy (lexicalCompareFS `on` ruleName) $+    tidyRules emptyTidyEnv rules++{-+************************************************************************+*                                                                      *+                RuleInfo: the rules in an IdInfo+*                                                                      *+************************************************************************+-}++extendRuleInfo :: RuleInfo -> [CoreRule] -> RuleInfo+extendRuleInfo (RuleInfo rs1 fvs1) rs2+  = RuleInfo (rs2 ++ rs1) (rulesFreeVarsDSet rs2 `unionDVarSet` fvs1)++addRuleInfo :: RuleInfo -> RuleInfo -> RuleInfo+addRuleInfo (RuleInfo rs1 fvs1) (RuleInfo rs2 fvs2)+  = RuleInfo (rs1 ++ rs2) (fvs1 `unionDVarSet` fvs2)++addIdSpecialisations :: Id -> [CoreRule] -> Id+addIdSpecialisations id rules+  | null rules+  = id+  | otherwise+  = setIdSpecialisation id $+    extendRuleInfo (idSpecialisation id) rules++-- | Gather all the rules for locally bound identifiers from the supplied bindings+rulesOfBinds :: [CoreBind] -> [CoreRule]+rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds++getRules :: RuleEnv -> Id -> [CoreRule]+-- See Note [Where rules are found]+getRules (RuleEnv { re_base = rule_base, re_visible_orphs = orphs }) fn+  = idCoreRules fn ++ concatMap imp_rules rule_base+  where+    imp_rules rb = filter (ruleIsVisible orphs) (lookupNameEnv rb (idName fn) `orElse` [])++ruleIsVisible :: ModuleSet -> CoreRule -> Bool+ruleIsVisible _ BuiltinRule{} = True+ruleIsVisible vis_orphs Rule { ru_orphan = orph, ru_origin = origin }+    = notOrphan orph || origin `elemModuleSet` vis_orphs++{- Note [Where rules are found]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The rules for an Id come from two places:+  (a) the ones it is born with, stored inside the Id itself (idCoreRules fn),+  (b) rules added in other modules, stored in the global RuleBase (imp_rules)++It's tempting to think that+     - LocalIds have only (a)+     - non-LocalIds have only (b)++but that isn't quite right:++     - PrimOps and ClassOps are born with a bunch of rules inside the Id,+       even when they are imported++     - The rules in GHC.Core.Opt.ConstantFold.builtinRules should be active even+       in the module defining the Id (when it's a LocalId), but+       the rules are kept in the global RuleBase+++************************************************************************+*                                                                      *+                RuleBase+*                                                                      *+************************************************************************+-}++-- RuleBase itself is defined in GHC.Core, along with CoreRule++emptyRuleBase :: RuleBase+emptyRuleBase = emptyNameEnv++mkRuleBase :: [CoreRule] -> RuleBase+mkRuleBase rules = extendRuleBaseList emptyRuleBase rules++extendRuleBaseList :: RuleBase -> [CoreRule] -> RuleBase+extendRuleBaseList rule_base new_guys+  = foldl' extendRuleBase rule_base new_guys++extendRuleBase :: RuleBase -> CoreRule -> RuleBase+extendRuleBase rule_base rule+  = extendNameEnv_Acc (:) Utils.singleton rule_base (ruleIdName rule) rule++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)+       | rs <- rss ]++{-+************************************************************************+*                                                                      *+                        Matching+*                                                                      *+************************************************************************+-}++-- | The main rule matching function. Attempts to apply all (active)+-- supplied rules to this instance of an application in a given+-- context, returning the rule applied and the resulting expression if+-- successful.+lookupRule :: RuleOpts -> InScopeEnv+           -> (Activation -> Bool)      -- When rule is active+           -> Id -- Function head+           -> [CoreExpr] -- Args+           -> [CoreRule] -- Rules+           -> Maybe (CoreRule, CoreExpr)++-- See Note [Extra args in the target]+-- See comments on matchRule+lookupRule opts rule_env@(in_scope,_) is_active fn args rules+  = -- pprTrace "matchRules" (ppr fn <+> ppr args $$ ppr rules ) $+    case go [] rules of+        []     -> Nothing+        (m:ms) -> Just (findBest in_scope (fn,args') m ms)+  where+    rough_args = map roughTopName args++    -- Strip ticks from arguments, see Note [Tick annotations in RULE+    -- matching]. We only collect ticks if a rule actually matches -+    -- this matters for performance tests.+    args' = map (stripTicksTopE tickishFloatable) args+    ticks = concatMap (stripTicksTopT tickishFloatable) args++    go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)]+    go ms [] = ms+    go ms (r:rs)+      | Just e <- matchRule opts rule_env is_active fn args' rough_args r+      = go ((r,mkTicks ticks e):ms) rs+      | otherwise+      = -- pprTrace "match failed" (ppr r $$ ppr args $$+        --   ppr [ (arg_id, unfoldingTemplate unf)+        --       | Var arg_id <- args+        --       , let unf = idUnfolding arg_id+        --       , isCheapUnfolding unf] )+        go ms rs++findBest :: InScopeSet -> (Id, [CoreExpr])+         -> (CoreRule,CoreExpr) -> [(CoreRule,CoreExpr)] -> (CoreRule,CoreExpr)+-- All these pairs matched the expression+-- Return the pair the most specific rule+-- The (fn,args) is just for overlap reporting++findBest _        _      (rule,ans)   [] = (rule,ans)+findBest in_scope target (rule1,ans1) ((rule2,ans2):prs)+  | isMoreSpecific in_scope rule1 rule2 = findBest in_scope target (rule1,ans1) prs+  | isMoreSpecific in_scope rule2 rule1 = findBest in_scope target (rule2,ans2) prs+  | debugIsOn = let pp_rule rule+                      = ifPprDebug (ppr rule)+                                   (doubleQuotes (ftext (ruleName rule)))+                in pprTrace "Rules.findBest: rule overlap (Rule 1 wins)"+                         (vcat [ whenPprDebug $+                                 text "Expression to match:" <+> ppr fn+                                 <+> sep (map ppr args)+                               , text "Rule 1:" <+> pp_rule rule1+                               , text "Rule 2:" <+> pp_rule rule2]) $+                findBest in_scope target (rule1,ans1) prs+  | otherwise = findBest in_scope target (rule1,ans1) prs+  where+    (fn,args) = target++isMoreSpecific :: InScopeSet -> CoreRule -> CoreRule -> Bool+-- This tests if one rule is more specific than another+-- We take the view that a BuiltinRule is less specific than+-- anything else, because we want user-define rules to "win"+-- In particular, class ops have a built-in rule, but we+-- any user-specific rules to win+--   eg (#4397)+--      truncate :: (RealFrac a, Integral b) => a -> b+--      {-# RULES "truncate/Double->Int" truncate = double2Int #-}+--      double2Int :: Double -> Int+--   We want the specific RULE to beat the built-in class-op rule+isMoreSpecific _        (BuiltinRule {}) _                = False+isMoreSpecific _        (Rule {})        (BuiltinRule {}) = True+isMoreSpecific in_scope (Rule { ru_bndrs = bndrs1, ru_args = args1 })+                        (Rule { ru_bndrs = bndrs2, ru_args = args2+                              , ru_name = rule_name2, ru_rhs = rhs2 })+  = isJust (matchN (full_in_scope, id_unfolding_fun)+                   rule_name2 bndrs2 args2 args1 rhs2)+  where+   id_unfolding_fun _ = NoUnfolding     -- Don't expand in templates+   full_in_scope = in_scope `extendInScopeSetList` bndrs1++noBlackList :: Activation -> Bool+noBlackList _ = False           -- Nothing is black listed++{- Note [Extra args in the target]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we find a matching rule, we return (Just (rule, rhs)),+/but/ the rule firing has only consumed as many of the input args+as the ruleArity says.  The unused arguments are handled by the code in+GHC.Core.Opt.Simplify.tryRules, using the arity of the returned rule.++E.g. Rule "foo":  forall a b.  f p1 p2 = rhs+     Target:      f e1 e2 e3++Then lookupRule returns Just (Rule "foo", rhs), where Rule "foo"+has ruleArity 2.  The real rewrite is+        f e1 e2 e3 ==> rhs e3++You might think it'd be cleaner for lookupRule to deal with the+leftover arguments, by applying 'rhs' to them, but the main call+in the Simplifier works better as it is.  Reason: the 'args' passed+to lookupRule are the result of a lazy substitution++Historical note:++At one stage I tried to match even if there are more args in the+/template/ than the target.  I now think this is probably a bad idea.+Should the template (map f xs) match (map g)?  I think not.  For a+start, in general eta expansion wastes work.  SLPJ July 99+-}++------------------------------------+matchRule :: RuleOpts -> InScopeEnv -> (Activation -> Bool)+          -> Id -> [CoreExpr] -> [Maybe Name]+          -> CoreRule -> Maybe CoreExpr++-- If (matchRule rule args) returns Just (name,rhs)+-- then (f args) matches the rule, and the corresponding+-- rewritten RHS is rhs+--+-- The returned expression is occurrence-analysed+--+--      Example+--+-- The rule+--      forall f g x. map f (map g x) ==> map (f . g) x+-- is stored+--      CoreRule "map/map"+--               [f,g,x]                -- tpl_vars+--               [f,map g x]            -- tpl_args+--               map (f.g) x)           -- rhs+--+-- Then the call: matchRule the_rule [e1,map e2 e3]+--        = Just ("map/map", (\f,g,x -> rhs) e1 e2 e3)+--+-- Any 'surplus' arguments in the input are simply put on the end+-- of the output.++matchRule opts rule_env _is_active fn args _rough_args+          (BuiltinRule { ru_try = match_fn })+-- Built-in rules can't be switched off, it seems+  = case match_fn opts rule_env fn args of+        Nothing   -> Nothing+        Just expr -> Just expr++matchRule _ rule_env is_active _ args rough_args+          (Rule { ru_name = rule_name, ru_act = act, ru_rough = tpl_tops+                , ru_bndrs = tpl_vars, ru_args = tpl_args, ru_rhs = rhs })+  | not (is_active act)               = Nothing+  | ruleCantMatch tpl_tops rough_args = Nothing+  | otherwise = matchN rule_env rule_name tpl_vars tpl_args args rhs+++-- | Initialize RuleOpts from DynFlags+initRuleOpts :: DynFlags -> RuleOpts+initRuleOpts dflags = RuleOpts+  { roPlatform                = targetPlatform dflags+  , roNumConstantFolding      = gopt Opt_NumConstantFolding dflags+  , roExcessRationalPrecision = gopt Opt_ExcessPrecision dflags+    -- disable bignum rules in ghc-prim and ghc-bignum itself+  , roBignumRules             = homeUnitId_ dflags /= primUnitId+                                && homeUnitId_ dflags /= bignumUnitId+  }+++---------------------------------------+matchN  :: InScopeEnv+        -> RuleName -> [Var] -> [CoreExpr]+        -> [CoreExpr] -> CoreExpr           -- ^ Target; can have more elements than the template+        -> Maybe CoreExpr+-- For a given match template and context, find bindings to wrap around+-- the entire result and what should be substituted for each template variable.+--+-- Fail if there are too few actual arguments from the target to match the template+--+-- See Note [Extra args in the target]+-- If there are too /many/ actual arguments, we simply ignore the+-- trailing ones, returning the result of applying the rule to a prefix+-- of the actual arguments.++matchN (in_scope, id_unf) rule_name tmpl_vars tmpl_es target_es rhs+  = do  { rule_subst <- match_exprs init_menv emptyRuleSubst tmpl_es target_es+        ; let (_, matched_es) = mapAccumL (lookup_tmpl rule_subst)+                                          (mkEmptyTCvSubst in_scope) $+                                tmpl_vars `zip` tmpl_vars1+              bind_wrapper = rs_binds rule_subst+                             -- Floated bindings; see Note [Matching lets]+       ; return (bind_wrapper $+                 mkLams tmpl_vars rhs `mkApps` matched_es) }+  where+    (init_rn_env, tmpl_vars1) = mapAccumL rnBndrL (mkRnEnv2 in_scope) tmpl_vars+                  -- See Note [Cloning the template binders]++    init_menv = RV { rv_tmpls = mkVarSet tmpl_vars1+                   , rv_lcl   = init_rn_env+                   , rv_fltR  = mkEmptySubst (rnInScopeSet init_rn_env)+                   , rv_unf   = id_unf }++    lookup_tmpl :: RuleSubst -> TCvSubst -> (InVar,OutVar) -> (TCvSubst, CoreExpr)+                   -- Need to return a RuleSubst solely for the benefit of mk_fake_ty+    lookup_tmpl (RS { rs_tv_subst = tv_subst, rs_id_subst = id_subst })+                tcv_subst (tmpl_var, tmpl_var1)+        | isId tmpl_var1+        = case lookupVarEnv id_subst tmpl_var1 of+            Just e | Coercion co <- e+                   -> (Type.extendCvSubst tcv_subst tmpl_var1 co, Coercion co)+                   | otherwise+                   -> (tcv_subst, e)+            Nothing | Just refl_co <- isReflCoVar_maybe tmpl_var1+                    , let co = Coercion.substCo tcv_subst refl_co+                    -> -- See Note [Unbound RULE binders]+                       (Type.extendCvSubst tcv_subst tmpl_var1 co, Coercion co)+                    | otherwise+                    -> unbound tmpl_var++        | otherwise+        = (Type.extendTvSubst tcv_subst tmpl_var1 ty', Type ty')+        where+          ty' = case lookupVarEnv tv_subst tmpl_var1 of+                  Just ty -> ty+                  Nothing -> fake_ty   -- See Note [Unbound RULE binders]+          fake_ty = anyTypeOfKind (Type.substTy tcv_subst (tyVarKind tmpl_var1))+                    -- This substitution is the sole reason we accumulate+                    -- TCvSubst in lookup_tmpl++    unbound tmpl_var+       = pprPanic "Template variable unbound in rewrite rule" $+         vcat [ text "Variable:" <+> ppr tmpl_var <+> dcolon <+> ppr (varType tmpl_var)+              , text "Rule" <+> pprRuleName rule_name+              , text "Rule bndrs:" <+> ppr tmpl_vars+              , text "LHS args:" <+> ppr tmpl_es+              , text "Actual args:" <+> ppr target_es ]+++{- Note [Unbound RULE binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It can be the case that the binder in a rule is not actually+bound on the LHS:++* Type variables.  Type synonyms with phantom args can give rise to+  unbound template type variables.  Consider this (#10689,+  simplCore/should_compile/T10689):++    type Foo a b = b++    f :: Eq a => a -> Bool+    f x = x==x++    {-# RULES "foo" forall (x :: Foo a Char). f x = True #-}+    finkle = f 'c'++  The rule looks like+    forall (a::*) (d::Eq Char) (x :: Foo a Char).+         f (Foo a Char) d x = True++  Matching the rule won't bind 'a', and legitimately so.  We fudge by+  pretending that 'a' is bound to (Any :: *).++* Coercion variables.  On the LHS of a RULE for a local binder+  we might have+    RULE forall (c :: a~b). f (x |> c) = e+  Now, if that binding is inlined, so that a=b=Int, we'd get+    RULE forall (c :: Int~Int). f (x |> c) = e+  and now when we simplify the LHS (Simplify.simplRule) we+  optCoercion (look at the CoVarCo case) will turn that 'c' into Refl:+    RULE forall (c :: Int~Int). f (x |> <Int>) = e+  and then perhaps drop it altogether.  Now 'c' is unbound.++  It's tricky to be sure this never happens, so instead I+  say it's OK to have an unbound coercion binder in a RULE+  provided its type is (c :: t~t).  Then, when the RULE+  fires we can substitute <t> for c.++  This actually happened (in a RULE for a local function)+  in #13410, and also in test T10602.++Note [Cloning the template binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the following match (example 1):+        Template:  forall x.  f x+        Target:               f (x+1)+This should succeed, because the template variable 'x' has nothing to+do with the 'x' in the target.++Likewise this one (example 2):+        Template:  forall x. f (\x.x)+        Target:              f (\y.y)++We achieve this simply by using rnBndrL to clone the template+binders if they are already in scope.++------ Historical note -------+At one point I tried simply adding the template binders to the+in-scope set /without/ cloning them, but that failed in a horribly+obscure way in #14777.  Problem was that during matching we look+up target-term variables in the in-scope set (see Note [Lookup+in-scope]).  If a target-term variable happens to name-clash with a+template variable, that lookup will find the template variable, which+is /utterly/ bogus.  In #14777, this transformed a term variable+into a type variable, and then crashed when we wanted its idInfo.+------ End of historical note -------+++************************************************************************+*                                                                      *+                   The main matcher+*                                                                      *+********************************************************************* -}++data RuleMatchEnv+  = RV { rv_lcl   :: RnEnv2          -- Renamings for *local bindings*+                                     --   (lambda/case)+       , rv_tmpls :: VarSet          -- Template variables+                                     --   (after applying envL of rv_lcl)+       , rv_fltR  :: Subst           -- Renamings for floated let-bindings+                                     --   (domain disjoint from envR of rv_lcl)+                                     -- See Note [Matching lets]+                                     -- N.B. The InScopeSet of rv_fltR is always ignored;+                                     -- see (4) in Note [Matching lets].+       , rv_unf :: IdUnfoldingFun+       }++{- Note [rv_lcl in RuleMatchEnv]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider matching+  Template: \x->f+  Target:   \f->f++where 'f' is free in the template. When we meet the lambdas we must+remember to rename f :-> f' in the target, as well as x :-> f+in the template.  The rv_lcl::RnEnv2 does that.++Similarly, consider matching+     Template: {a}  \b->b+     Target:        \a->3+We must rename the \a.  Otherwise when we meet the lambdas we might+substitute [b :-> a] in the template, and then erroneously succeed in+matching what looks like the template variable 'a' against 3.++So we must add the template vars to the in-scope set before starting;+see `init_menv` in `matchN`.+-}++rvInScopeEnv :: RuleMatchEnv -> InScopeEnv+rvInScopeEnv renv = (rnInScopeSet (rv_lcl renv), rv_unf renv)++-- * The domain of the TvSubstEnv and IdSubstEnv are the template+--   variables passed into the match.+--+-- * The BindWrapper in a RuleSubst are the bindings floated out+--   from nested matches; see the Let case of match, below+--+data RuleSubst = RS { rs_tv_subst :: TvSubstEnv   -- Range is the+                    , rs_id_subst :: IdSubstEnv   --   template variables+                    , rs_binds    :: BindWrapper  -- Floated bindings+                    , rs_bndrs    :: [Var]        -- Variables bound by floated lets+                    }++type BindWrapper = CoreExpr -> CoreExpr+  -- See Notes [Matching lets] and [Matching cases]+  -- we represent the floated bindings as a core-to-core function++emptyRuleSubst :: RuleSubst+emptyRuleSubst = RS { rs_tv_subst = emptyVarEnv, rs_id_subst = emptyVarEnv+                    , rs_binds = \e -> e, rs_bndrs = [] }++----------------------+match_exprs :: RuleMatchEnv -> RuleSubst+            -> [CoreExpr]       -- Templates+            -> [CoreExpr]       -- Targets+            -> Maybe RuleSubst+-- If the targets are longer than templates, succeed, simply ignoring+-- the leftover targets. This matters in the call in matchN.+--+-- Precondition: corresponding elements of es1 and es2 have the same+--               type, assumuing earlier elements match+-- Example:  f :: forall v. v -> blah+--   match_exprs [Type a, y::a] [Type Int, 3]+-- Then, after matching Type a against Type Int,+-- the type of (y::a) matches that of (3::Int)+match_exprs _ subst [] _+  = Just subst+match_exprs renv subst (e1:es1) (e2:es2)+  = do { subst' <- match renv subst e1 e2 MRefl+       ; match_exprs renv subst' es1 es2 }+match_exprs _ _ _ _ = Nothing+++{- Note [Casts in the target]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As far as possible we don't want casts in the target to get in the way of+matching.  E.g.+* (let bind in e)  |> co+* (case e of alts) |> co+* (\ a b. f a b)   |> co++In the first two cases we want to float the cast inwards so we can match on+the let/case.  This is not important in practice because the Simplifier does+this anyway.++But the third case /is/ important: we don't want the cast to get in the way+of eta-reduction.  See Note [Cancel reflexive casts] for a real life example.++The most convenient thing is to make 'match' take an MCoercion argument, thus:++* The main matching function+      match env subst template target mco+  matches   template ~ (target |> mco)++* Invariant: typeof( subst(template) ) = typeof( target |> mco )++Note that for applications+     (e1 e2) ~ (d1 d2) |> co+where 'co' is non-reflexive, we simply fail.  You might wonder about+     (e1 e2) ~ ((d1 |> co1) d2) |> co2+but the Simplifer pushes the casts in an application to to the+right, if it can, so this doesn't really arise.++Note [Coercion arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~+What if we have (f co) in the template, where the 'co' is a coercion+argument to f?  Right now we have nothing in place to ensure that a+coercion /argument/ in the template is a variable.  We really should,+perhaps by abstracting over that variable.++C.f. the treatment of dictionaries in GHC.HsToCore.Binds.decompseRuleLhs.++For now, though, we simply behave badly, by failing in match_co.+We really should never rely on matching the structure of a coercion+(which is just a proof).++Note [Casts in the template]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the definition+  f x = e,+and SpecConstr on call pattern+  f ((e1,e2) |> co)++We'll make a RULE+   RULE forall a,b,g.  f ((a,b)|> g) = $sf a b g+   $sf a b g = e[ ((a,b)|> g) / x ]++So here is the invariant:++  In the template, in a cast (e |> co),+  the cast `co` is always a /variable/.++Matching should bind that variable to an actual coercion, so that we+can use it in $sf.  So a Cast on the LHS (the template) calls+match_co, which succeeds when the template cast is a variable -- which+it always is.  That is why match_co has so few cases.++See also+* Note [Coercion arguments]+* Note [Matching coercion variables] in GHC.Core.Unify.+* Note [Cast swizzling on rule LHSs] in GHC.Core.Opt.Simplify.Utils:+  sm_cast_swizzle is switched off in the template of a RULE+-}++----------------------+match :: RuleMatchEnv+      -> RuleSubst              -- Substitution applies to template only+      -> CoreExpr               -- Template+      -> CoreExpr               -- Target+      -> MCoercion+      -> Maybe RuleSubst++-- Postcondition (TypeInv): if matching succeeds, then+--                          typeof( subst(template) ) = typeof( target |> mco )+--     But this is /not/ a pre-condition! The types of template and target+--     may differ, see the (App e1 e2) case+--+-- Invariant (CoInv):   if mco :: ty ~ ty, then it is MRefl, not MCo co+--                      See Note [Cancel reflexive casts]+--+-- See the notes with Unify.match, which matches types+-- Everything is very similar for terms+++------------------------ Ticks ---------------------+-- We look through certain ticks. See Note [Tick annotations in RULE matching]+match renv subst e1 (Tick t e2) mco+  | tickishFloatable t+  = match renv subst' e1 e2 mco+  | otherwise+  = Nothing+  where+    subst' = subst { rs_binds = rs_binds subst . mkTick t }++match renv subst e@(Tick t e1) e2 mco+  | tickishFloatable t  -- Ignore floatable ticks in rule template.+  =  match renv subst e1 e2 mco+  | otherwise+  = pprPanic "Tick in rule" (ppr e)++------------------------ Types ---------------------+match renv subst (Type ty1) (Type ty2) _mco+  = match_ty renv subst ty1 ty2++------------------------ Coercions ---------------------+-- See Note [Coercion arguments] for why this isn't really right+match renv subst (Coercion co1) (Coercion co2) MRefl+  = match_co renv subst co1 co2+  -- The MCo case corresponds to matching  co ~ (co2 |> co3)+  -- and I have no idea what to do there -- or even if it can occur+  -- Failing seems the simplest thing to do; it's certainly safe.++------------------------ Casts ---------------------+-- See Note [Casts in the template]+--     Note [Casts in the target]+--     Note [Cancel reflexive casts]++match renv subst e1 (Cast e2 co2) mco+  = match renv subst e1 e2 (checkReflexiveMCo (mkTransMCoR co2 mco))+    -- checkReflexiveMCo: cancel casts if possible+    -- This is important: see Note [Cancel reflexive casts]++match renv subst (Cast e1 co1) e2 mco+  = -- See Note [Casts in the template]+    do { let co2 = case mco of+                     MRefl   -> mkRepReflCo (exprType e2)+                     MCo co2 -> co2+       ; subst1 <- match_co renv subst co1 co2+         -- If match_co succeeds, then (exprType e1) = (exprType e2)+         -- Hence the MRefl in the next line+       ; match renv subst1 e1 e2 MRefl }++------------------------ Literals ---------------------+match _ subst (Lit lit1) (Lit lit2) mco+  | lit1 == lit2+  = assertPpr (isReflMCo mco) (ppr mco) $+    Just subst++------------------------ Variables ---------------------+-- The Var case follows closely what happens in GHC.Core.Unify.match+match renv subst (Var v1) e2 mco+  = match_var renv subst v1 (mkCastMCo e2 mco)++match renv subst e1 (Var v2) mco  -- Note [Expanding variables]+  | not (inRnEnvR rn_env v2)      -- Note [Do not expand locally-bound variables]+  , Just e2' <- expandUnfolding_maybe (rv_unf renv v2')+  = match (renv { rv_lcl = nukeRnEnvR rn_env }) subst e1 e2' mco+  where+    v2'    = lookupRnInScope rn_env v2+    rn_env = rv_lcl renv+        -- Notice that we look up v2 in the in-scope set+        -- See Note [Lookup in-scope]+        -- No need to apply any renaming first (hence no rnOccR)+        -- because of the not-inRnEnvR++------------------------ Applications ---------------------+-- Note the match on MRefl!  We fail if there is a cast in the target+--     (e1 e2) ~ (d1 d2) |> co+-- See Note [Cancel reflexive casts]: in the Cast equations for 'match'+-- we agressively ensure that if MCo is reflective, it really is MRefl.+match renv subst (App f1 a1) (App f2 a2) MRefl+  = do  { subst' <- match renv subst f1 f2 MRefl+        ; match renv subst' a1 a2 MRefl }++------------------------ Float lets ---------------------+match renv subst e1 (Let bind e2) mco+  | -- pprTrace "match:Let" (vcat [ppr bind, ppr $ okToFloat (rv_lcl renv) (bindFreeVars bind)]) $+    not (isJoinBind bind) -- can't float join point out of argument position+  , okToFloat (rv_lcl renv) (bindFreeVars bind) -- See Note [Matching lets]+  = match (renv { rv_fltR = flt_subst'+                , rv_lcl  = rv_lcl renv `extendRnInScopeSetList` new_bndrs })+                -- We are floating the let-binding out, as if it had enclosed+                -- the entire target from Day 1.  So we must add its binders to+                -- the in-scope set (#20200)+          (subst { rs_binds = rs_binds subst . Let bind'+                 , rs_bndrs = new_bndrs ++ rs_bndrs subst })+          e1 e2 mco+  | otherwise+  = Nothing+  where+    in_scope  = rnInScopeSet (rv_lcl renv) `extendInScopeSetList` rs_bndrs subst+                -- in_scope: see (4) in Note [Matching lets]+    flt_subst = rv_fltR renv `setInScope` in_scope+    (flt_subst', bind') = substBind flt_subst bind+    new_bndrs           = bindersOf bind'++------------------------  Lambdas ---------------------+match renv subst (Lam x1 e1) e2 mco+  | Just (x2, e2', ts) <- exprIsLambda_maybe (rvInScopeEnv renv) (mkCastMCo e2 mco)+    -- See Note [Lambdas in the template]+  = let renv'  = rnMatchBndr2 renv x1 x2+        subst' = subst { rs_binds = rs_binds subst . flip (foldr mkTick) ts }+    in  match renv' subst' e1 e2' MRefl++match renv subst e1 e2@(Lam {}) mco+  | Just (renv', e2') <- eta_reduce renv e2  -- See Note [Eta reduction in the target]+  = match renv' subst e1 e2' mco++{- Note [Lambdas in the template]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we match+   Template:   (\x. blah_template)+   Target:     (\y. blah_target)+then we want to match inside the lambdas, using rv_lcl to match up+x and y.++But what about this?+   Template   (\x. (blah1 |> cv))+   Target     (\y. blah2) |> co++This happens quite readily, because the Simplifier generally moves+casts outside lambdas: see Note [Casts and lambdas] in+GHC.Core.Opt.Simplify.Utils. So, tiresomely, we want to push `co`+back inside, which is what `exprIsLambda_maybe` does.  But we've+stripped off that cast, so now we need to put it back, hence mkCastMCo.++Unlike the target, where we attempt eta-reduction, we do not attempt+to eta-reduce the template, and may therefore fail on+  Template:   \x. f True x+  Target      f True++It's not especially easy to deal with eta reducing the template,+and never happens, because no one write eta-expanded left-hand-sides.+-}++------------------------ Case expression ---------------------+{- Disabled: see Note [Matching cases] below+match renv (tv_subst, id_subst, binds) e1+      (Case scrut case_bndr ty [(con, alt_bndrs, rhs)])+  | exprOkForSpeculation scrut  -- See Note [Matching cases]+  , okToFloat rn_env bndrs (exprFreeVars scrut)+  = match (renv { me_env = rn_env' })+          (tv_subst, id_subst, binds . case_wrap)+          e1 rhs+  where+    rn_env   = me_env renv+    rn_env'  = extendRnInScopeList rn_env bndrs+    bndrs    = case_bndr : alt_bndrs+    case_wrap rhs' = Case scrut case_bndr ty [(con, alt_bndrs, rhs')]+-}++match renv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2) mco+  = do  { subst1 <- match_ty renv subst ty1 ty2+        ; subst2 <- match renv subst1 e1 e2 MRefl+        ; let renv' = rnMatchBndr2 renv x1 x2+        ; match_alts renv' subst2 alts1 alts2 mco   -- Alts are both sorted+        }++-- Everything else fails+match _ _ _e1 _e2 _mco = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text "e2:" <+> ppr _e2)) $+                         Nothing++-------------+eta_reduce :: RuleMatchEnv -> CoreExpr -> Maybe (RuleMatchEnv, CoreExpr)+-- See Note [Eta reduction in the target]+eta_reduce renv e@(Lam {})+  = go renv id [] e+  where+    go :: RuleMatchEnv -> BindWrapper -> [Var] -> CoreExpr+       -> Maybe (RuleMatchEnv, CoreExpr)+    go renv bw vs (Let b e) = go renv (bw . Let b) vs e++    go renv bw vs (Lam v e) = go renv' bw (v':vs) e+      where+         (rn_env', v') = rnBndrR (rv_lcl renv) v+         renv' = renv { rv_lcl = rn_env' }++    go renv bw (v:vs) (App f arg)+      | Var a <- arg, v == rnOccR (rv_lcl renv) a+      = go renv bw vs f++      | Type ty <- arg, Just tv <- getTyVar_maybe ty+      , v == rnOccR (rv_lcl renv) tv+      = go renv bw vs f++    go renv bw []    e = Just (renv, bw e)+    go _    _  (_:_) _ = Nothing++eta_reduce _ _ = Nothing++{- Note [Eta reduction in the target]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we are faced with this (#19790)+   Template {x}  f x+   Target        (\a b c. let blah in f x a b c)++You might wonder why we have an eta-expanded target (see first subtle+point below), but regardless of how it came about, we'd like+eta-expansion not to impede matching.++So eta_reduce does on-the-fly eta-reduction of the target expression.+Given (\a b c. let blah in e a b c), it returns (let blah in e).++Subtle points:+* Consider a target:  \x. f <expensive> x+  In the main eta-reducer we do not eta-reduce this, because doing so+  might reduce the arity of the expression (from 1 to zero, because of+  <expensive>).  But for rule-matching we /do/ want to match template+  (f a) against target (\x. f <expensive> x), with a := <expensive>++  This is a compelling reason for not relying on the Simplifier's+  eta-reducer.++* The Lam case of eta_reduce renames as it goes. Consider+  (\x. \x. f x x).  We should not eta-reduce this.  As we go we rename+  the first x to x1, and the second to x2; then both argument x's are x2.++* eta_reduce does /not/ need to check that the bindings 'blah'+  and expression 'e' don't mention a b c; but it /does/ extend the+  rv_lcl RnEnv2 (see rn_bndr in eta_reduce).+  * If 'blah' mentions the binders, the let-float rule won't+    fire; and+  * if 'e' mentions the binders we we'll also fail to match+    e.g. because of the exprFreeVars test in match_tmpl_var.++  Example: Template: {x}  f a         -- Some top-level 'a'+           Target:   (\a b. f a a b)  -- The \a shadows top level 'a'+  Then eta_reduce will /succeed/, with+      (rnEnvR = [a :-> a'], f a)+  The returned RnEnv will map [a :-> a'], where a' is fresh. (There is+  no need to rename 'b' because (in this example) it is not in scope.+  So it's as if we'd returned (f a') from eta_reduce; the renaming applied+  to the target is simply deferred.++Note [Cancel reflexive casts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Here is an example (from #19790) which we want to catch+   (f x) ~ (\a b. (f x |> co) a b) |> sym co+where+   f :: Int -> Stream+   co :: Stream ~ T1 -> T2 -> T3++when we eta-reduce (\a b. blah a b) to 'blah', we'll get+  (f x) ~ (f x) |> co |> sym co++and we really want to spot that the co/sym-co cancels out.+Hence+  * We keep an invariant that the MCoercion is always MRefl+    if the MCoercion is reflextve+  * We maintain this invariant via the call to checkReflexiveMCo+    in the Cast case of 'match'.+-}++-------------+match_co :: RuleMatchEnv+         -> RuleSubst+         -> Coercion+         -> Coercion+         -> Maybe RuleSubst+-- We only match if the template is a coercion variable or Refl:+--   see Note [Casts in the template]+-- Like 'match' it is /not/ guaranteed that+--     coercionKind template  =  coercionKind target+-- But if match_co succeeds, it /is/ guaranteed that+--     coercionKind (subst template) = coercionKind target++match_co renv subst co1 co2+  | Just cv <- getCoVar_maybe co1+  = match_var renv subst cv (Coercion co2)++  | Just (ty1, r1) <- isReflCo_maybe co1+  = do { (ty2, r2) <- isReflCo_maybe co2+       ; guard (r1 == r2)+       ; match_ty renv subst ty1 ty2 }++  | debugIsOn+  = pprTrace "match_co: needs more cases" (ppr co1 $$ ppr co2) Nothing+    -- Currently just deals with CoVarCo and Refl++  | otherwise+  = Nothing++-------------+rnMatchBndr2 :: RuleMatchEnv -> Var -> Var -> RuleMatchEnv+rnMatchBndr2 renv x1 x2+  = renv { rv_lcl  = rnBndr2 (rv_lcl renv) x1 x2+         , rv_fltR = delBndr (rv_fltR renv) x2 }+++------------------------------------------+match_alts :: RuleMatchEnv+           -> RuleSubst+           -> [CoreAlt]                 -- Template+           -> [CoreAlt] -> MCoercion    -- Target+           -> Maybe RuleSubst+match_alts _ subst [] [] _+  = return subst+match_alts renv subst (Alt c1 vs1 r1:alts1) (Alt c2 vs2 r2:alts2) mco+  | c1 == c2+  = do  { subst1 <- match renv' subst r1 r2 mco+        ; match_alts renv subst1 alts1 alts2 mco }+  where+    renv' = foldl' mb renv (vs1 `zip` vs2)+    mb renv (v1,v2) = rnMatchBndr2 renv v1 v2++match_alts _ _ _ _ _+  = Nothing++------------------------------------------+okToFloat :: RnEnv2 -> VarSet -> Bool+okToFloat rn_env bind_fvs+  = allVarSet not_captured bind_fvs+  where+    not_captured fv = not (inRnEnvR rn_env fv)++------------------------------------------+match_var :: RuleMatchEnv+          -> RuleSubst+          -> Var        -- Template+          -> CoreExpr   -- Target+          -> Maybe RuleSubst+match_var renv@(RV { rv_tmpls = tmpls, rv_lcl = rn_env, rv_fltR = flt_env })+          subst v1 e2+  | v1' `elemVarSet` tmpls+  = match_tmpl_var renv subst v1' e2++  | otherwise   -- v1' is not a template variable; check for an exact match with e2+  = case e2 of  -- Remember, envR of rn_env is disjoint from rv_fltR+       Var v2 | Just v2' <- rnOccR_maybe rn_env v2+              -> -- v2 was bound by a nested lambda or case+                 if v1' == v2' then Just subst+                               else Nothing++              -- v2 is not bound nestedly; it is free+              -- in the whole expression being matched+              -- So it will be in the InScopeSet for flt_env (#20200)+              | Var v2' <- lookupIdSubst flt_env v2+              , v1' == v2'+              -> Just subst+              | otherwise+              -> Nothing++       _ -> Nothing++  where+    v1' = rnOccL rn_env v1+        -- If the template is+        --      forall x. f x (\x -> x) = ...+        -- Then the x inside the lambda isn't the+        -- template x, so we must rename first!++------------------------------------------+match_tmpl_var :: RuleMatchEnv+               -> RuleSubst+               -> Var                -- Template+               -> CoreExpr           -- Target+               -> Maybe RuleSubst++match_tmpl_var renv@(RV { rv_lcl = rn_env, rv_fltR = flt_env })+               subst@(RS { rs_id_subst = id_subst, rs_bndrs = let_bndrs })+               v1' e2+  | any (inRnEnvR rn_env) (exprFreeVarsList e2)+  = Nothing     -- Skolem-escape failure+                -- e.g. match forall a. (\x-> a x) against (\y. y y)++  | Just e1' <- lookupVarEnv id_subst v1'+  = if eqCoreExpr e1' e2'+    then Just subst+    else Nothing++  | otherwise   -- See Note [Matching variable types]+  = do { subst' <- match_ty renv subst (idType v1') (exprType e2)+       ; return (subst' { rs_id_subst = id_subst' }) }+  where+    -- e2' is the result of applying flt_env to e2+    e2' | null let_bndrs = e2+        | otherwise = substExpr flt_env e2++    id_subst' = extendVarEnv (rs_id_subst subst) v1' e2'+         -- No further renaming to do on e2',+         -- because no free var of e2' is in the rnEnvR of the envt++------------------------------------------+match_ty :: RuleMatchEnv+         -> RuleSubst+         -> Type                -- Template+         -> Type                -- Target+         -> Maybe RuleSubst+-- Matching Core types: use the matcher in GHC.Tc.Utils.TcType.+-- Notice that we treat newtypes as opaque.  For example, suppose+-- we have a specialised version of a function at a newtype, say+--      newtype T = MkT Int+-- We only want to replace (f T) with f', not (f Int).++match_ty renv subst ty1 ty2+  = do  { tv_subst'+            <- Unify.ruleMatchTyKiX (rv_tmpls renv) (rv_lcl renv) tv_subst ty1 ty2+        ; return (subst { rs_tv_subst = tv_subst' }) }+  where+    tv_subst = rs_tv_subst subst++{- Note [Matching variable types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When matching x ~ e, where 'x' is a template variable, we must check that+x's type matches e's type, to establish (TypeInv).  For example+  forall (c::Char->Int) (x::Char).+     f (c x) = "RULE FIRED"+We must not match on, say (f (pred (3::Int))).++It's actually quite difficult to come up with an example that shows+you need type matching, esp since matching is left-to-right, so type+args get matched first.  But it's possible (e.g. simplrun008) and this+is the Right Thing to do.++An alternative would be to make (TypeInf) into a /pre-condition/.  It+is threatened only by the App rule.  So when matching an application+(e1 e2) ~ (d1 d2) would be to collect args of the application chain,+match the types of the head, then match arg-by-arg.++However that alternative seems a bit more complicated.  And by+matching types at variables we do one match_ty for each template+variable, rather than one for each application chain.  Usually there are+fewer template variables, although for simple rules it could be the other+way around.++Note [Expanding variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Here is another Very Important rule: if the term being matched is a+variable, we expand it so long as its unfolding is "expandable". (Its+occurrence information is not necessarily up to date, so we don't use+it.)  By "expandable" we mean a WHNF or a "constructor-like" application.+This is the key reason for "constructor-like" Ids.  If we have+     {-# NOINLINE [1] CONLIKE g #-}+     {-# RULE f (g x) = h x #-}+then in the term+   let v = g 3 in ....(f v)....+we want to make the rule fire, to replace (f v) with (h 3).++Note [Do not expand locally-bound variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Do *not* expand locally-bound variables, else there's a worry that the+unfolding might mention variables that are themselves renamed.+Example+          case x of y { (p,q) -> ...y... }+Don't expand 'y' to (p,q) because p,q might themselves have been+renamed.  Essentially we only expand unfoldings that are "outside"+the entire match.++Hence, (a) the guard (not (isLocallyBoundR v2))+       (b) when we expand we nuke the renaming envt (nukeRnEnvR).++Note [Tick annotations in RULE matching]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We used to unconditionally look through ticks in both template and+expression being matched. This is actually illegal for counting or+cost-centre-scoped ticks, because we have no place to put them without+changing entry counts and/or costs. So now we just fail the match in+these cases.++On the other hand, where we are allowed to insert new cost into the+tick scope, we can float them upwards to the rule application site.++Moreover, we may encounter ticks in the template of a rule. There are a few+ways in which these may be introduced (e.g. #18162, #17619). Such ticks are+ignored by the matcher. See Note [Simplifying rules] in+GHC.Core.Opt.Simplify.Utils for details.++cf Note [Tick annotations in call patterns] in GHC.Core.Opt.SpecConstr+++Note [Matching lets]+~~~~~~~~~~~~~~~~~~~~+Matching a let-expression.  Consider+        RULE forall x.  f (g x) = <rhs>+and target expression+        f (let { w=R } in g E))+Then we'd like the rule to match, to generate+        let { w=R } in (\x. <rhs>) E+In effect, we want to float the let-binding outward, to enable+the match to happen.  This is the WHOLE REASON for accumulating+bindings in the RuleSubst++We can only do this if the free variables of R are not bound by the+part of the target expression outside the let binding; e.g.+        f (\v. let w = v+1 in g E)+Here we obviously cannot float the let-binding for w.  Hence the+use of okToFloat.++There are a couple of tricky points:+  (a) What if floating the binding captures a variable that is+      free in the entire expression?+        f (let v = x+1 in v) v+      --> NOT!+        let v = x+1 in f (x+1) v++  (b) What if the let shadows a local binding?+        f (\v -> (v, let v = x+1 in (v,v))+      --> NOT!+        let v = x+1 in f (\v -> (v, (v,v)))++  (c) What if two non-nested let bindings bind the same variable?+        f (let v = e1 in b1) (let v = e2 in b2)+      --> NOT!+        let v = e1 in let v = e2 in (f b2 b2)+      See testsuite test `T4814`.++Our cunning plan is this:+  (1) Along with the growing substitution for template variables+      we maintain a growing set of floated let-bindings (rs_binds)+      plus the set of variables thus bound (rs_bndrs).++  (2) The RnEnv2 in the MatchEnv binds only the local binders+      in the term (lambdas, case), not the floated let-bndrs.++  (3) When we encounter a `let` in the term to be matched, in the Let+      case of `match`, we use `okToFloat` to check that it does not mention any+      locally bound (lambda, case) variables.  If so we fail.++  (4) In the Let case of `match`, we use GHC.Core.Subst.substBind to+      freshen the binding (which, remember (3), mentions no locally+      bound variables), in a lexically-scoped way (via rv_fltR in+      MatchEnv).++      The subtle point is that we want an in-scope set for this+      substitution that includes /two/ sets:+      * The in-scope variables at this point, so that we avoid using+        those local names for the floated binding; points (a) and (b) above.+      * All "earlier" floated bindings, so that we avoid using the+        same name for two different floated bindings; point (c) above.++      Because we have to compute the in-scope set here, the in-scope set+      stored in `rv_fltR` is always ignored; we leave it only because it's+      convenient to have `rv_fltR :: Subst` (with an always-ignored `InScopeSet`)+      rather than storing three separate substitutions.++  (5) We apply that freshening substitution, in a lexically-scoped+      way to the term, although lazily; this is the rv_fltR field.++See #4814, which is an issue resulting from getting this wrong.++Note [Matching cases]+~~~~~~~~~~~~~~~~~~~~~+{- NOTE: This idea is currently disabled.  It really only works if+         the primops involved are OkForSpeculation, and, since+         they have side effects readIntOfAddr and touch are not.+         Maybe we'll get back to this later .  -}++Consider+   f (case readIntOffAddr# p# i# realWorld# of { (# s#, n# #) ->+      case touch# fp s# of { _ ->+      I# n# } } )+This happened in a tight loop generated by stream fusion that+Roman encountered.  We'd like to treat this just like the let+case, because the primops concerned are ok-for-speculation.+That is, we'd like to behave as if it had been+   case readIntOffAddr# p# i# realWorld# of { (# s#, n# #) ->+   case touch# fp s# of { _ ->+   f (I# n# } } )++Note [Lookup in-scope]+~~~~~~~~~~~~~~~~~~~~~~+Consider this example+        foo :: Int -> Maybe Int -> Int+        foo 0 (Just n) = n+        foo m (Just n) = foo (m-n) (Just n)++SpecConstr sees this fragment:++        case w_smT of wild_Xf [Just A] {+          Data.Maybe.Nothing -> lvl_smf;+          Data.Maybe.Just n_acT [Just S(L)] ->+            case n_acT of wild1_ams [Just A] { GHC.Base.I# y_amr [Just L] ->+              $wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf+            }};++and correctly generates the rule++        RULES: "SC:$wfoo1" [0] __forall {y_amr [Just L] :: GHC.Prim.Int#+                                          sc_snn :: GHC.Prim.Int#}+          $wfoo_smW sc_snn (Data.Maybe.Just @ GHC.Base.Int (GHC.Base.I# y_amr))+          = $s$wfoo_sno y_amr sc_snn ;]++BUT we must ensure that this rule matches in the original function!+Note that the call to $wfoo is+            $wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf++During matching we expand wild_Xf to (Just n_acT).  But then we must also+expand n_acT to (I# y_amr).  And we can only do that if we look up n_acT+in the in-scope set, because in wild_Xf's unfolding it won't have an unfolding+at all.++That is why the 'lookupRnInScope' call in the (Var v2) case of 'match'+is so important.+++************************************************************************+*                                                                      *+                   Rule-check the program+*                                                                      *+************************************************************************++   We want to know what sites have rules that could have fired but didn't.+   This pass runs over the tree (without changing it) and reports such.+-}++-- | Report partial matches for rules beginning with the specified+-- string for the purposes of error reporting+ruleCheckProgram :: RuleOpts                    -- ^ Rule options+                 -> CompilerPhase               -- ^ Rule activation test+                 -> String                      -- ^ Rule pattern+                 -> (Id -> [CoreRule])          -- ^ Rules for an Id+                 -> CoreProgram                 -- ^ Bindings to check in+                 -> SDoc                        -- ^ Resulting check message+ruleCheckProgram ropts phase rule_pat rules binds+  | isEmptyBag results+  = text "Rule check results: no rule application sites"+  | otherwise+  = vcat [text "Rule check results:",+          line,+          vcat [ p $$ line | p <- bagToList results ]+         ]+  where+    env = RuleCheckEnv { rc_is_active = isActive phase+                       , rc_id_unf    = idUnfolding     -- Not quite right+                                                        -- Should use activeUnfolding+                       , rc_pattern   = rule_pat+                       , rc_rules     = rules+                       , rc_ropts     = ropts+                       }+    results = unionManyBags (map (ruleCheckBind env) binds)+    line = text (replicate 20 '-')++data RuleCheckEnv = RuleCheckEnv {+    rc_is_active :: Activation -> Bool,+    rc_id_unf  :: IdUnfoldingFun,+    rc_pattern :: String,+    rc_rules :: Id -> [CoreRule],+    rc_ropts :: RuleOpts+}++ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc+   -- The Bag returned has one SDoc for each call site found+ruleCheckBind env (NonRec _ r) = ruleCheck env r+ruleCheckBind env (Rec prs)    = unionManyBags [ruleCheck env r | (_,r) <- prs]++ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc+ruleCheck _   (Var _)       = emptyBag+ruleCheck _   (Lit _)       = emptyBag+ruleCheck _   (Type _)      = emptyBag+ruleCheck _   (Coercion _)  = emptyBag+ruleCheck env (App f a)     = ruleCheckApp env (App f a) []+ruleCheck env (Tick _ e)  = ruleCheck env e+ruleCheck env (Cast e _)    = ruleCheck env e+ruleCheck env (Let bd e)    = ruleCheckBind env bd `unionBags` ruleCheck env e+ruleCheck env (Lam _ e)     = ruleCheck env e+ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags`+                                unionManyBags [ruleCheck env r | Alt _ _ r <- as]++ruleCheckApp :: RuleCheckEnv -> Expr CoreBndr -> [Arg CoreBndr] -> Bag SDoc+ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as)+ruleCheckApp env (Var f) as   = ruleCheckFun env f as+ruleCheckApp env other _      = ruleCheck env other++ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc+-- Produce a report for all rules matching the predicate+-- saying why it doesn't match the specified application++ruleCheckFun env fn args+  | null name_match_rules = emptyBag+  | otherwise             = unitBag (ruleAppCheck_help env fn args name_match_rules)+  where+    name_match_rules = filter match (rc_rules env fn)+    match rule = (rc_pattern env) `isPrefixOf` unpackFS (ruleName rule)++ruleAppCheck_help :: RuleCheckEnv -> Id -> [CoreExpr] -> [CoreRule] -> SDoc+ruleAppCheck_help env fn args rules+  =     -- The rules match the pattern, so we want to print something+    vcat [text "Expression:" <+> ppr (mkApps (Var fn) args),+          vcat (map check_rule rules)]+  where+    n_args = length args+    i_args = args `zip` [1::Int ..]+    rough_args = map roughTopName args++    check_rule rule = rule_herald rule <> colon <+> rule_info (rc_ropts env) rule++    rule_herald (BuiltinRule { ru_name = name })+        = text "Builtin rule" <+> doubleQuotes (ftext name)+    rule_herald (Rule { ru_name = name })+        = text "Rule" <+> doubleQuotes (ftext name)++    rule_info opts rule+        | Just _ <- matchRule opts (emptyInScopeSet, rc_id_unf env)+                              noBlackList fn args rough_args rule+        = text "matches (which is very peculiar!)"++    rule_info _ (BuiltinRule {}) = text "does not match"++    rule_info _ (Rule { ru_act = act,+                        ru_bndrs = rule_bndrs, ru_args = rule_args})+        | not (rc_is_active env act)  = text "active only in later phase"+        | n_args < n_rule_args        = text "too few arguments"+        | n_mismatches == n_rule_args = text "no arguments match"+        | n_mismatches == 0           = text "all arguments match (considered individually), but rule as a whole does not"+        | otherwise                   = text "arguments" <+> ppr mismatches <+> text "do not match (1-indexing)"+        where+          n_rule_args  = length rule_args+          n_mismatches = length mismatches+          mismatches   = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args,+                              not (isJust (match_fn rule_arg arg))]++          lhs_fvs = exprsFreeVars rule_args     -- Includes template tyvars+          match_fn rule_arg arg = match renv emptyRuleSubst rule_arg arg MRefl+                where+                  in_scope = mkInScopeSet (lhs_fvs `unionVarSet` exprFreeVars arg)+                  renv = RV { rv_lcl   = mkRnEnv2 in_scope+                            , rv_tmpls = mkVarSet rule_bndrs+                            , rv_fltR  = mkEmptySubst in_scope+                            , rv_unf   = rc_id_unf env }
compiler/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)
compiler/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 "GhclibHsVersions.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)])
compiler/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 "GhclibHsVersions.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.
+ compiler/GHC/Core/Tidy.hs view
@@ -0,0 +1,422 @@+{-+(c) The University of Glasgow 2006+(c) The AQUA Project, Glasgow University, 1996-1998+++This module contains "tidying" code for *nested* expressions, bindings, rules.+The code for *top-level* bindings is in GHC.Iface.Tidy.+-}+++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+module GHC.Core.Tidy (+        tidyExpr, tidyRules, tidyUnfolding, tidyCbvInfoTop+    ) where++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, 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)++{-+************************************************************************+*                                                                      *+\subsection{Tidying expressions, rules}+*                                                                      *+************************************************************************+-}++tidyBind :: TidyEnv+         -> CoreBind+         ->  (TidyEnv, CoreBind)++tidyBind env (NonRec bndr rhs)+  = -- pprTrace "tidyBindNonRec" (ppr bndr) $+    let cbv_bndr = (tidyCbvInfoLocal bndr rhs)+        (env', bndr') = tidyLetBndr env env cbv_bndr+        tidy_rhs = (tidyExpr env' rhs)+    in (env', NonRec bndr' tidy_rhs)++tidyBind env (Rec prs)+  = -- pprTrace "tidyBindRec" (ppr $ map fst prs) $+    let+       cbv_bndrs = map ((\(bnd,rhs) -> tidyCbvInfoLocal bnd rhs)) prs+       (_bndrs, rhss)  = unzip prs+       (env', bndrs') = mapAccumL (tidyLetBndr env') env cbv_bndrs+    in+    map (tidyExpr env') rhss =: \ rhss' ->+    (env', Rec (zip bndrs' rhss'))+++-- Note [Attaching CBV Marks to ids]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- See Note [CBV Function Ids] for the *why*.+-- Before tidy, we turn all worker functions into worker like ids.+-- This way we can later tell if we can assume the existence of a wrapper. This also applies to+-- specialized versions of functions generated by SpecConstr for which we, in a sense,+-- consider the unspecialized version to be the wrapper.+-- During tidy we take the demands on the arguments for these ids and compute+-- CBV (call-by-value) semantics for each individual argument.+-- The marks themselves then are put onto the function id itself.+-- This means the code generator can get the full calling convention by only looking at the function+-- itself without having to inspect the RHS.+--+-- The actual logic is in 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)+tidyExpr env (Type ty)     = Type (tidyType env ty)+tidyExpr env (Coercion co) = Coercion (tidyCo env co)+tidyExpr _   (Lit lit)     = Lit lit+tidyExpr env (App f a)     = App (tidyExpr env f) (tidyExpr env a)+tidyExpr env (Tick t e)    = Tick (tidyTickish env t) (tidyExpr env e)+tidyExpr env (Cast e co)   = Cast (tidyExpr env e) (tidyCo env co)++tidyExpr env (Let b e)+  = tidyBind env b      =: \ (env', b') ->+    Let b' (tidyExpr env' e)++tidyExpr env (Case e b ty alts)+  = tidyBndr env b  =: \ (env', b) ->+    Case (tidyExpr env e) b (tidyType env ty)+         (map (tidyAlt env') alts)++tidyExpr env (Lam b e)+  = tidyBndr env b      =: \ (env', b) ->+    Lam b (tidyExpr env' e)++------------  Case alternatives  --------------+tidyAlt :: TidyEnv -> CoreAlt -> CoreAlt+tidyAlt env (Alt con vs rhs)+  = tidyBndrs env vs    =: \ (env', vs) ->+    (Alt con vs (tidyExpr env' rhs))++------------  Tickish  --------------+tidyTickish :: TidyEnv -> CoreTickish -> CoreTickish+tidyTickish env (Breakpoint ext ix ids)+  = Breakpoint ext ix (map (tidyVarOcc env) ids)+tidyTickish _   other_tickish       = other_tickish++------------  Rules  --------------+tidyRules :: TidyEnv -> [CoreRule] -> [CoreRule]+tidyRules _   [] = []+tidyRules env (rule : rules)+  = tidyRule env rule           =: \ rule ->+    tidyRules env rules         =: \ rules ->+    (rule : rules)++tidyRule :: TidyEnv -> CoreRule -> CoreRule+tidyRule _   rule@(BuiltinRule {}) = rule+tidyRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs,+                          ru_fn = fn, ru_rough = mb_ns })+  = tidyBndrs env bndrs         =: \ (env', bndrs) ->+    map (tidyExpr env') args    =: \ args ->+    rule { ru_bndrs = bndrs, ru_args = args,+           ru_rhs   = tidyExpr env' rhs,+           ru_fn    = tidyNameOcc env fn,+           ru_rough = map (fmap (tidyNameOcc env')) mb_ns }++{-+************************************************************************+*                                                                      *+\subsection{Tidying non-top-level binders}+*                                                                      *+************************************************************************+-}++tidyNameOcc :: TidyEnv -> Name -> Name+-- In rules and instances, we have Names, and we must tidy them too+-- Fortunately, we can lookup in the VarEnv with a name+tidyNameOcc (_, var_env) n = case lookupUFM_Directly var_env (getUnique n) of+                                Nothing -> n+                                Just v  -> idName v++tidyVarOcc :: TidyEnv -> Var -> Var+tidyVarOcc (_, var_env) v = lookupVarEnv var_env v `orElse` v++-- tidyBndr is used for lambda and case binders+tidyBndr :: TidyEnv -> Var -> (TidyEnv, Var)+tidyBndr env var+  | isTyCoVar var = tidyVarBndr env var+  | otherwise     = tidyIdBndr env var++tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var])+tidyBndrs env vars = mapAccumL tidyBndr env vars++-- Non-top-level variables, not covars+tidyIdBndr :: TidyEnv -> Id -> (TidyEnv, Id)+tidyIdBndr env@(tidy_env, var_env) id+  = -- Do this pattern match strictly, otherwise we end up holding on to+    -- stuff in the OccName.+    case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') ->+    let+        -- Give the Id a fresh print-name, *and* rename its type+        -- The SrcLoc isn't important now,+        -- though we could extract it from the Id+        --+        ty'      = tidyType env (idType id)+        mult'    = tidyType env (idMult id)+        name'    = mkInternalName (idUnique id) occ' noSrcSpan+        id'      = mkLocalIdWithInfo name' mult' ty' new_info+        var_env' = extendVarEnv var_env id id'++        -- Note [Tidy IdInfo]+        new_info = vanillaIdInfo `setOccInfo` occInfo old_info+                                 `setUnfoldingInfo` new_unf+                                  -- see Note [Preserve OneShotInfo]+                                 `setOneShotInfo` oneShotInfo old_info+        old_info = idInfo id+        old_unf  = realUnfoldingInfo old_info+        new_unf  = trimUnfolding old_unf  -- See Note [Preserve evaluatedness]+    in+    ((tidy_env', var_env'), id')+   }++tidyLetBndr :: TidyEnv         -- Knot-tied version for unfoldings+            -> TidyEnv         -- The one to extend+            -> Id -> (TidyEnv, Id)+-- Used for local (non-top-level) let(rec)s+-- Just like tidyIdBndr above, but with more IdInfo+tidyLetBndr rec_tidy_env env@(tidy_env, var_env) id+  = case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') ->+    let+        ty'      = tidyType env (idType id)+        mult'    = tidyType env (idMult id)+        name'    = mkInternalName (idUnique id) occ' noSrcSpan+        details  = idDetails id+        id'      = mkLocalVar details name' mult' ty' new_info+        var_env' = extendVarEnv var_env id id'++        -- Note [Tidy IdInfo]+        -- We need to keep around any interesting strictness and+        -- demand info because later on we may need to use it when+        -- converting to A-normal form.+        -- eg.+        --      f (g x),  where f is strict in its argument, will be converted+        --      into  case (g x) of z -> f z  by CorePrep, but only if f still+        --      has its strictness info.+        --+        -- Similarly for the demand info - on a let binder, this tells+        -- CorePrep to turn the let into a case.+        -- But: Remove the usage demand here+        --      (See Note [Zapping DmdEnv after Demand Analyzer] in GHC.Core.Opt.WorkWrap)+        --+        -- Similarly arity info for eta expansion in CorePrep+        -- Don't attempt to recompute arity here; this is just tidying!+        -- Trying to do so led to #17294+        --+        -- Set inline-prag info so that we preserve it across+        -- separate compilation boundaries+        old_info = idInfo id+        new_info = vanillaIdInfo+                    `setOccInfo`        occInfo old_info+                    `setArityInfo`      arityInfo old_info+                    `setDmdSigInfo` zapDmdEnvSig (dmdSigInfo old_info)+                    `setDemandInfo`     demandInfo old_info+                    `setInlinePragInfo` inlinePragInfo old_info+                    `setUnfoldingInfo`  new_unf++        old_unf = realUnfoldingInfo old_info+        new_unf | isStableUnfolding old_unf = tidyUnfolding rec_tidy_env old_unf old_unf+                | otherwise                 = trimUnfolding old_unf+                                              -- See Note [Preserve evaluatedness]++    in+    ((tidy_env', var_env'), id') }++------------ Unfolding  --------------+tidyUnfolding :: TidyEnv -> Unfolding -> Unfolding -> Unfolding+tidyUnfolding tidy_env df@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) _+  = df { df_bndrs = bndrs', df_args = map (tidyExpr tidy_env') args }+  where+    (tidy_env', bndrs') = tidyBndrs tidy_env bndrs++tidyUnfolding tidy_env+              unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src })+              unf_from_rhs+  | isStableSource src+  = seqIt $ unf { uf_tmpl = tidyExpr tidy_env unf_rhs }    -- Preserves OccInfo+    -- This seqIt avoids a space leak: otherwise the uf_is_value,+    -- uf_is_conlike, ... fields may retain a reference to the+    -- pre-tidied expression forever (GHC.CoreToIface doesn't look at them)++  | otherwise+  = unf_from_rhs+  where seqIt unf = seqUnfolding unf `seq` unf+tidyUnfolding _ unf _ = unf     -- NoUnfolding or OtherCon++{-+Note [Tidy IdInfo]+~~~~~~~~~~~~~~~~~~+All nested Ids now have the same IdInfo, namely vanillaIdInfo, which+should save some space; except that we preserve occurrence info for+two reasons:++  (a) To make printing tidy core nicer++  (b) Because we tidy RULES and InlineRules, which may then propagate+      via --make into the compilation of the next module, and we want+      the benefit of that occurrence analysis when we use the rule or+      or inline the function.  In particular, it's vital not to lose+      loop-breaker info, else we get an infinite inlining loop++Note that tidyLetBndr puts more IdInfo back.++Note [Preserve evaluatedness]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  data T = MkT !Bool+  ....(case v of MkT y ->+       let z# = case y of+                  True -> 1#+                  False -> 2#+       in ...)++The z# binding is ok because the RHS is ok-for-speculation,+but Lint will complain unless it can *see* that.  So we+preserve the evaluated-ness on 'y' in tidyBndr.++(Another alternative would be to tidy unboxed lets into cases,+but that seems more indirect and surprising.)++Note [Preserve OneShotInfo]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+We keep the OneShotInfo because we want it to propagate into the interface.+Not all OneShotInfo is determined by a compiler analysis; some is added by a+call of GHC.Exts.oneShot, which is then discarded before the end of the+optimisation pipeline, leaving only the OneShotInfo on the lambda. Hence we+must preserve this info in inlinings. See Note [The oneShot function] in GHC.Types.Id.Make.++This applies to lambda binders only, hence it is stored in IfaceLamBndr.+-}++(=:) :: a -> (a -> b) -> b+m =: k = m `seq` k m
compiler/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 "GhclibHsVersions.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-  {- ********************************************************************* *                                                                      *
compiler/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 "GhclibHsVersions.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 GhclibHsVersions.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  {- ********************************************************************* *                                                                      *
compiler/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
compiler/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 "GhclibHsVersions.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
compiler/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 --
compiler/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 "GhclibHsVersions.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
compiler/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 "GhclibHsVersions.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
compiler/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 "GhclibHsVersions.h"  import GHC.Prelude
compiler/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 "GhclibHsVersions.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
compiler/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])
compiler/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 "GhclibHsVersions.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)
compiler/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 "GhclibHsVersions.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.+-}
compiler/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 "GhclibHsVersions.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],
compiler/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 "GhclibHsVersions.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
compiler/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 "GhclibHsVersions.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)
compiler/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
+ compiler/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
compiler/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
compiler/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 "GhclibHsVersions.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 #-}
compiler/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 "GhclibHsVersions.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]  {- ************************************************************************
compiler/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
compiler/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 "GhclibHsVersions.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 */
compiler/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
compiler/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 "GhclibHsVersions.h"  import GHC.Prelude
+ compiler/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 #)
+ compiler/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)
compiler/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 "GhclibHsVersions.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.
compiler/GHC/Driver/Backend.hs view
@@ -103,7 +103,6 @@          ArchX86_64    -> True          ArchPPC       -> True          ArchPPC_64 {} -> True-         ArchSPARC     -> True          ArchAArch64   -> True          _             -> False
compiler/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)
compiler/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 "GhclibHsVersions.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
compiler/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+    }+
+ compiler/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+  }+
+ compiler/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+  }+
+ compiler/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+
compiler/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 "GhclibHsVersions.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
+ compiler/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+-}+
compiler/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  }-
compiler/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
+ compiler/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
+ compiler/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
compiler/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+                   ]
compiler/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)))   }
compiler/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-
compiler/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 "GhclibHsVersions.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"
compiler/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 }, ())
+ compiler/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)
compiler/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 {
compiler/GHC/Driver/Plugins.hs-boot view
@@ -5,6 +5,9 @@ import GHC.Prelude ()  data Plugin+data Plugins++emptyPlugins :: Plugins  data LoadedPlugin data StaticPlugin
compiler/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]
− compiler/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
compiler/GHC/Driver/Session.hs view
@@ -23,13 +23,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',@@ -40,12 +38,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(..),@@ -59,15 +56,12 @@         DynLibLoader(..),         fFlags, fLangFlags, xFlags,         wWarningFlags,-        wWarningFlagMap,-        dynFlagDependencies,         makeDynFlagsConsistent,         positionIndependent,         optimisationFlags,         setFlagsFromEnvFile,         pprDynFlagsDiff,         flagSpecOf,-        smallestGroups,          targetProfile, @@ -89,7 +83,6 @@         sGhciUsagePath,         sToolDir,         sTopDir,-        sTmpDir,         sGlobalPackageDatabasePath,         sLdSupportsCompactUnwind,         sLdSupportsBuildId,@@ -100,6 +93,7 @@         sPgm_P,         sPgm_F,         sPgm_c,+        sPgm_cxx,         sPgm_a,         sPgm_l,         sPgm_lm,@@ -130,19 +124,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,@@ -156,7 +147,8 @@         initDynFlags,                   -- DynFlags -> IO DynFlags         defaultFatalMessager,         defaultFlushOut,-        defaultFlushErr,+        setOutputFile, setDynOutputFile, setOutputHi, setDynOutputHi,+        augmentByWorkingDirectory,          getOpts,                        -- DynFlags -> (DynFlags -> [a]) -> [a]         getVerbFlags,@@ -171,6 +163,11 @@         impliedOffGFlags,         impliedXFlags, +        -- ** State+        CmdLineP(..), runCmdLineP,+        getCmdLineState, putCmdLineState,+        processCmdLineP,+         -- ** Parsing DynFlags         parseDynamicFlagsCmdLine,         parseDynamicFilePragma,@@ -189,6 +186,9 @@         -- ** DynFlags C compiler options         picCCOpts, picPOpts, +        -- ** DynFlags C linker options+        pieCCLDOpts,+         -- * Compiler configuration suitable for display to the user         compilerInfo, @@ -197,8 +197,6 @@         setUnsafeGlobalDynFlags,          -- * SSE and AVX-        isSseEnabled,-        isSse2Enabled,         isSse4_2Enabled,         isBmiEnabled,         isBmi2Enabled,@@ -222,8 +220,6 @@         initSDocContext, initDefaultSDocContext,   ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Platform@@ -240,21 +236,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@@ -271,11 +270,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@@ -298,6 +299,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] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -373,7 +375,7 @@ data IncludeSpecs   = IncludeSpecs { includePathsQuote  :: [String]                  , includePathsGlobal :: [String]-                 -- | See note [Implicit include paths]+                 -- | See Note [Implicit include paths]                  , includePathsQuoteImplicit :: [String]                  }   deriving Show@@ -392,7 +394,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 }@@ -450,17 +452,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@@ -487,13 +489,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'@@ -520,6 +526,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 @@ -539,7 +551,6 @@   hiSuf_                :: String,   hieSuf                :: String, -  dynamicTooFailed      :: IORef Bool,   dynObjectSuf_         :: String,   dynHiSuf_             :: String, @@ -554,11 +565,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,@@ -578,6 +590,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*@@ -657,7 +671,6 @@   ghciHistSize          :: Int,    flushOut              :: FlushOut,-  flushErr              :: FlushErr,    ghcVersionFile        :: Maybe FilePath,   haddockOptions        :: Maybe String,@@ -680,8 +693,6 @@    interactivePrint      :: Maybe String, -  nextWrapperNum        :: IORef (ModuleEnv Int),-   -- | Machine dependent flags (-m\<blah> stuff)   sseVersion            :: Maybe SseVersion,   bmiVersion            :: Maybe BmiVersion,@@ -695,9 +706,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.@@ -767,7 +781,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)]                              }@@ -800,8 +814,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@@ -814,11 +826,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@@ -939,6 +953,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@@ -1039,41 +1054,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 =@@ -1081,31 +1083,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 ->@@ -1121,15 +1107,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@@ -1142,13 +1129,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,@@ -1156,6 +1141,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,@@ -1184,6 +1170,11 @@         homeUnitInstanceOf_     = Nothing,         homeUnitInstantiations_ = [], +        workingDirectory        = Nothing,+        thisPackageName         = Nothing,+        hiddenModules           = Set.empty,+        reexportedModules       = Set.empty,+         objectDir               = Nothing,         dylibInstallName        = Nothing,         hiDir                   = Nothing,@@ -1196,7 +1187,6 @@         hiSuf_                  = "hi",         hieSuf                  = "hie", -        dynamicTooFailed        = panic "defaultDynFlags: No dynamicTooFailed",         dynObjectSuf_           = "dyn_" ++ phaseInputExt StopLn,         dynHiSuf_               = "dyn_hi",         dynamicNow              = False,@@ -1210,7 +1200,7 @@         outputHi                = Nothing,         dynOutputHi             = Nothing,         dynLibLoader            = SystemDependent,-        dumpPrefix              = Nothing,+        dumpPrefix              = "non-module.",         dumpPrefixForce         = Nothing,         ldInputs                = [],         includePaths            = IncludeSpecs [] [] [],@@ -1239,8 +1229,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",@@ -1278,7 +1271,6 @@         ghciHistSize = 50, -- keep a log of length 50 by default          flushOut = defaultFlushOut,-        flushErr = defaultFlushErr,         pprUserLength = 5,         pprCols = 100,         useUnicode = False,@@ -1288,7 +1280,6 @@         profAuto = NoProfAuto,         callerCcFilters = [],         interactivePrint = Nothing,-        nextWrapperNum = panic "defaultDynFlags: No nextWrapperNum",         sseVersion = Nothing,         bmiVersion = Nothing,         avx = False,@@ -1299,6 +1290,7 @@         avx512pf = False,         rtldInfo = panic "defaultDynFlags: no rtldInfo",         rtccInfo = panic "defaultDynFlags: no rtccInfo",+        rtasmInfo = panic "defaultDynFlags: no rtasmInfo",          maxInlineAllocSize = 128,         maxInlineMemcpyInsns = 32,@@ -1323,11 +1315,6 @@ defaultFlushOut :: FlushOut defaultFlushOut = FlushOut $ hFlush stdout -newtype FlushErr = FlushErr (IO ())--defaultFlushErr :: FlushErr-defaultFlushErr = FlushErr $ hFlush stderr- {- Note [Verbosity levels] ~~~~~~~~~~~~~~~~~~~~~~~@@ -1435,7 +1422,7 @@        LangExt.InstanceSigs,        LangExt.KindSignatures,        LangExt.MultiParamTypeClasses,-       LangExt.RecordPuns,+       LangExt.NamedFieldPuns,        LangExt.NamedWildCards,        LangExt.NumericUnderscores,        LangExt.PolyKinds,@@ -1470,7 +1457,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@@ -1484,6 +1470,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@@ -1604,10 +1591,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@@ -1643,7 +1626,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@@ -1839,18 +1822,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@@ -1881,22 +1881,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@@ -1909,26 +1945,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.@@ -2087,7 +2116,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)) @@ -2115,12 +2147,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.@@ -2129,7 +2155,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"@@ -2139,20 +2166,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"@@ -2224,6 +2261,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) @@ -2258,7 +2297,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))@@ -2343,8 +2382,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)@@ -2392,6 +2435,7 @@                   setGeneralFlag Opt_SuppressTicks                   setGeneralFlag Opt_SuppressStgExts                   setGeneralFlag Opt_SuppressTypeSignatures+                  setGeneralFlag Opt_SuppressCoreSizes                   setGeneralFlag Opt_SuppressTimestamps)          ------ Debugging ----------------------------------------------------@@ -2450,8 +2494,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"@@ -2466,6 +2508,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"@@ -2478,6 +2522,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"@@ -2490,15 +2536,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"@@ -2536,8 +2588,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"@@ -2554,7 +2604,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"@@ -2579,6 +2629,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"@@ -2591,10 +2643,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"@@ -2699,8 +2753,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"@@ -2736,6 +2791,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"@@ -2753,7 +2810,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"@@ -2954,7 +3011,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]@@ -2978,6 +3035,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)@@ -3037,6 +3100,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)@@ -3048,6 +3122,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@@ -3115,6 +3202,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 ++@@ -3133,136 +3226,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\>@@@ -3291,7 +3380,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\>@@@ -3345,7 +3435,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,@@ -3388,6 +3479,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@@ -3412,17 +3506,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 @@ -3621,7 +3725,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,@@ -3654,7 +3758,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,@@ -3711,7 +3815,8 @@       Opt_SharedImplib,       Opt_SimplPreInlining,       Opt_VersionMacros,-      Opt_RPath+      Opt_RPath,+      Opt_CompactUnwind     ]      ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns]@@ -3847,6 +3952,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)@@ -3880,10 +3989,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)@@ -3895,6 +4008,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@@ -3920,6 +4034,7 @@      , ([2],     Opt_LiberateCase)     , ([2],     Opt_SpecConstr)+    , ([2],     Opt_FastPAPCalls) --  , ([2],     Opt_RegsGraph) --   RegsGraph suffers performance regression. See #7679 --  , ([2],     Opt_StaticArgumentTransformation)@@ -3927,164 +4042,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@@ -4231,7 +4209,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 ()@@ -4295,8 +4273,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) }@@ -4324,9 +4300,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 }) @@ -4430,6 +4403,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 ()@@ -4453,13 +4463,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@@ -4501,6 +4504,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@@ -4593,7 +4597,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 @@ -4627,9 +4631,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.@@ -4651,13 +4653,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"]@@ -4665,8 +4668,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@@ -4695,6 +4698,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),@@ -4739,13 +4746,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)@@ -4789,6 +4794,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.@@ -4827,17 +4838,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@@ -4858,31 +4876,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 @@ -5052,11 +5045,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
− compiler/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
compiler/GHC/Hs.hs view
@@ -69,7 +69,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.@@ -90,39 +99,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@@ -134,13 +134,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,@@ -156,10 +156,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
compiler/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
compiler/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
compiler/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 "GhclibHsVersions.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.     }
+ compiler/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
compiler/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
compiler/GHC/Hs/Expr.hs view
@@ -28,8 +28,6 @@   , module GHC.Hs.Expr   ) where -#include "GhclibHsVersions.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
compiler/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
compiler/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
compiler/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  -- ---------------------------------------------------------------------
compiler/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 "GhclibHsVersions.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
compiler/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
compiler/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 "GhclibHsVersions.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
compiler/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 "GhclibHsVersions.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
+ compiler/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
+ compiler/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
+ compiler/GHC/HsToCore/Pmc/Ppr.hs view
@@ -0,0 +1,207 @@+++{-# 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+    ) where++import GHC.Prelude++import GHC.Types.Basic+import GHC.Types.Id+import GHC.Types.Var.Env+import GHC.Types.Unique.DFM+import GHC.Core.ConLike+import GHC.Core.DataCon+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.Data.Maybe+import Data.List.NonEmpty (NonEmpty, nonEmpty, toList)++import GHC.HsToCore.Pmc.Types++-- | Pretty-print the guts of an uncovered value vector abstraction, i.e., its+-- components and refutable shapes associated to any mentioned variables.+--+-- Example for @([Just p, q], [p :-> [3,4], q :-> [0,5]])@:+--+-- @+-- (Just p) q+--     where p is not one of {3, 4}+--           q is not one of {0, 5}+-- @+--+-- When the set of refutable shapes contains more than 3 elements, the+-- additional elements are indicated by "...".+pprUncovered :: Nabla -> [Id] -> SDoc+pprUncovered nabla vas+  | isNullUDFM refuts = fsep vec -- there are no refutations+  | otherwise         = hang (fsep vec) 4 $+                          text "where" <+> vcat (map (pprRefutableShapes . snd) (udfmToList refuts))+  where+    init_prec+      -- No outer parentheses when it's a unary pattern by assuming lowest+      -- precedence+      | [_] <- vas   = topPrec+      | otherwise    = appPrec+    ppr_action       = mapM (pprPmVar init_prec) vas+    (vec, renamings) = runPmPpr nabla ppr_action+    refuts           = prettifyRefuts nabla renamings++-- | Output refutable shapes of a variable in the form of @var is not one of {2,+-- Nothing, 3}@. Will never print more than 3 refutable shapes, the tail is+-- indicated by an ellipsis.+pprRefutableShapes :: (SDoc,[PmAltCon]) -> SDoc+pprRefutableShapes (var, alts)+  = var <+> text "is not one of" <+> format_alts alts+  where+    format_alts = braces . fsep . punctuate comma . shorten . map ppr_alt+    shorten (a:b:c:_:_)       = a:b:c:[text "..."]+    shorten xs                = xs+    ppr_alt (PmAltConLike cl) = ppr cl+    ppr_alt (PmAltLit lit)    = ppr lit++{- 1. Literals+~~~~~~~~~~~~~~+Starting with a function definition like:++    f :: Int -> Bool+    f 5 = True+    f 6 = True++The uncovered set looks like:+    { var |> var /= 5, var /= 6 }++Yet, we would like to print this nicely as follows:+   x , where x not one of {5,6}++Since these variables will be shown to the programmer, we give them better names+(t1, t2, ..) in 'prettifyRefuts', hence the SDoc in 'PrettyPmRefutEnv'.++2. Residual Constraints+~~~~~~~~~~~~~~~~~~~~~~~+Unhandled constraints that refer to HsExpr are typically ignored by the solver+(it does not even substitute in HsExpr so they are even printed as wildcards).+Additionally, the oracle returns a substitution if it succeeds so we apply this+substitution to the vectors before printing them out (see function `pprOne' in+"GHC.HsToCore.Pmc") to be more precise.+-}++-- | Extract and assigns pretty names to constraint variables with refutable+-- shapes.+prettifyRefuts :: Nabla -> DIdEnv (Id, SDoc) -> DIdEnv (SDoc, [PmAltCon])+prettifyRefuts nabla = listToUDFM_Directly . map attach_refuts . udfmToList+  where+    attach_refuts (u, (x, sdoc)) = (u, (sdoc, lookupRefuts nabla x))+++type PmPprM a = RWS Nabla () (DIdEnv (Id, SDoc), [SDoc]) a++-- Try nice names p,q,r,s,t before using the (ugly) t_i+nameList :: [SDoc]+nameList = map text ["p","q","r","s","t"] +++            [ text ('t':show u) | u <- [(0 :: Int)..] ]++runPmPpr :: Nabla -> PmPprM a -> (a, DIdEnv (Id, SDoc))+runPmPpr nabla m = case runRWS m nabla (emptyDVarEnv, nameList) of+  (a, (renamings, _), _) -> (a, renamings)++-- | Allocates a new, clean name for the given 'Id' if it doesn't already have+-- one.+getCleanName :: Id -> PmPprM SDoc+getCleanName x = do+  (renamings, name_supply) <- get+  let (clean_name:name_supply') = name_supply+  case lookupDVarEnv renamings x of+    Just (_, nm) -> pure nm+    Nothing -> do+      put (extendDVarEnv renamings x (x, clean_name), name_supply')+      pure clean_name++checkRefuts :: Id -> PmPprM (Maybe SDoc) -- the clean name if it has negative info attached+checkRefuts x = do+  nabla <- ask+  case lookupRefuts nabla x of+    [] -> pure Nothing -- Will just be a wildcard later on+    _  -> Just <$> getCleanName x++-- | Pretty print a variable, but remember to prettify the names of the variables+-- that refer to neg-literals. The ones that cannot be shown are printed as+-- underscores.+pprPmVar :: PprPrec -> Id -> PmPprM SDoc+pprPmVar prec x = do+  nabla <- ask+  case lookupSolution nabla x of+    Just (PACA alt _tvs args) -> pprPmAltCon prec alt args+    Nothing                   -> fromMaybe underscore <$> checkRefuts x++pprPmAltCon :: PprPrec -> PmAltCon -> [Id] -> PmPprM SDoc+pprPmAltCon _prec (PmAltLit l)      _    = pure (ppr l)+pprPmAltCon prec  (PmAltConLike cl) args = do+  nabla <- ask+  pprConLike nabla prec cl args++pprConLike :: Nabla -> PprPrec -> ConLike -> [Id] -> PmPprM SDoc+pprConLike nabla _prec cl args+  | Just pm_expr_list <- pmExprAsList nabla (PmAltConLike cl) args+  = case pm_expr_list of+      NilTerminated list ->+        brackets . fsep . punctuate comma <$> mapM (pprPmVar appPrec) list+      WcVarTerminated pref x ->+        parens   . fcat . punctuate colon <$> mapM (pprPmVar appPrec) (toList pref ++ [x])+pprConLike _nabla _prec (RealDataCon con) args+  | isUnboxedTupleDataCon con+  , let hash_parens doc = text "(#" <+> doc <+> text "#)"+  = hash_parens . fsep . punctuate comma <$> mapM (pprPmVar appPrec) args+  | isTupleDataCon con+  = parens . fsep . punctuate comma <$> mapM (pprPmVar appPrec) args+pprConLike _nabla prec cl args+  | conLikeIsInfix cl = case args of+      [x, y] -> do x' <- pprPmVar funPrec x+                   y' <- pprPmVar funPrec y+                   return (cparen (prec > opPrec) (x' <+> ppr cl <+> y'))+      -- can it be infix but have more than two arguments?+      list   -> pprPanic "pprConLike:" (ppr list)+  | null args = return (ppr cl)+  | otherwise = do args' <- mapM (pprPmVar appPrec) args+                   return (cparen (prec > funPrec) (fsep (ppr cl : args')))++-- | The result of 'pmExprAsList'.+data PmExprList+  = NilTerminated [Id]+  | WcVarTerminated (NonEmpty Id) Id++-- | Extract a list of 'Id's out of a sequence of cons cells, optionally+-- terminated by a wildcard variable instead of @[]@. Some examples:+--+-- * @pmExprAsList (1:2:[]) == Just ('NilTerminated' [1,2])@, a regular,+--   @[]@-terminated list. Should be pretty-printed as @[1,2]@.+-- * @pmExprAsList (1:2:x) == Just ('WcVarTerminated' [1,2] x)@, a list prefix+--   ending in a wildcard variable x (of list type). Should be pretty-printed as+--   (1:2:_).+-- * @pmExprAsList [] == Just ('NilTerminated' [])@+pmExprAsList :: Nabla -> PmAltCon -> [Id] -> Maybe PmExprList+pmExprAsList nabla = go_con []+  where+    go_var rev_pref x+      | Just (PACA alt _tvs args) <- lookupSolution nabla x+      = go_con rev_pref alt args+    go_var rev_pref x+      | Just pref <- nonEmpty (reverse rev_pref)+      = Just (WcVarTerminated pref x)+    go_var _ _+      = Nothing++    go_con rev_pref (PmAltConLike (RealDataCon c)) es+      | c == nilDataCon+      = assert (null es) $ Just (NilTerminated (reverse rev_pref))+      | c == consDataCon+      = assert (length es == 2) $ go_var (es !! 0 : rev_pref) (es !! 1)+    go_con _ _ _+      = Nothing
+ compiler/GHC/HsToCore/Pmc/Solver/Types.hs view
@@ -0,0 +1,798 @@+{-# LANGUAGE ApplicativeDo       #-}+{-# 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+-- types from the paper+-- [Lower Your Guards: A Compositional Pattern-Match Coverage Checker"](https://dl.acm.org/doi/abs/10.1145/3408989).+module GHC.HsToCore.Pmc.Solver.Types (++        -- * 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,++        -- ** Representations for Literals and AltCons+        PmLit(..), PmLitValue(..), PmAltCon(..), pmLitType, pmAltConType,+        isPmAltConMatchStrict, pmAltConImplBangs,++        -- *** PmAltConSet+        PmAltConSet, emptyPmAltConSet, isEmptyPmAltConSet, elemPmAltConSet,+        extendPmAltConSet, pmAltConSetElems,++        -- *** Equality on 'PmAltCon's+        PmEquality(..), eqPmAltCon,++        -- *** Operations on 'PmLit'+        literalToPmLit, negatePmLit, overloadPmLit,+        pmLitAsStringLit, coreExprAsPmLit++    ) where++import GHC.Prelude++import GHC.Data.Bag+import GHC.Data.FastString+import GHC.Types.Id+import GHC.Types.Var.Set+import GHC.Types.Unique.DSet+import GHC.Types.Unique.SDFM+import GHC.Types.Name+import GHC.Core.DataCon+import GHC.Core.ConLike+import GHC.Utils.Outputable+import GHC.Utils.Panic.Plain+import GHC.Utils.Misc (lastMaybe)+import GHC.Data.List.SetOps (unionLists)+import GHC.Data.Maybe+import GHC.Core.Type+import GHC.Core.TyCon+import GHC.Types.Literal+import GHC.Core+import GHC.Core.Map.Expr+import GHC.Core.Utils (exprType)+import GHC.Builtin.Names+import GHC.Builtin.Types+import GHC.Builtin.Types.Prim+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+                            , fractionalLitFromRational+                            , FractionalExponentBase(..))+import Numeric (fromRat)+import Data.Foldable (find)+import Data.Ratio+import GHC.Real (Ratio(..))+import qualified Data.Semigroup as Semi++-- import GHC.Driver.Ppr++--+-- * Normalised refinement types+--++-- | A normalised refinement type ∇ (\"nabla\"), comprised of an inert set of+-- canonical (i.e. mutually compatible) term and type constraints that form the+-- refinement type's predicate.+data Nabla+  = MkNabla+  { nabla_ty_st :: !TyState+  -- ^ Type oracle; things like a~Int+  , nabla_tm_st :: !TmState+  -- ^ Term oracle; things like x~Nothing+  }++-- | An initial nabla that is always satisfiable+initNabla :: Nabla+initNabla = MkNabla initTyState initTmState++instance Outputable Nabla where+  ppr nabla = hang (text "Nabla") 2 $ vcat [+      -- intentionally formatted this way enable the dev to comment in only+      -- the info they need+      ppr (nabla_tm_st nabla),+      ppr (nabla_ty_st nabla)+    ]++-- | A disjunctive bag of 'Nabla's, representing a refinement type.+newtype Nablas = MkNablas (Bag Nabla)++initNablas :: Nablas+initNablas = MkNablas (unitBag initNabla)++instance Outputable Nablas where+  ppr (MkNablas nablas) = ppr nablas++instance Semigroup Nablas where+  MkNablas l <> MkNablas r = MkNablas (l `unionBags` r)++instance Monoid Nablas where+  mempty = MkNablas emptyBag++-- | The type oracle state. An 'GHC.Tc.Solver.Monad.InertSet' that we+-- incrementally add local type constraints to, together with a sequence+-- number that counts the number of times we extended it with new facts.+data TyState = TySt { ty_st_n :: !Int, ty_st_inert :: !InertSet }++-- | Not user-facing.+instance Outputable TyState where+  ppr (TySt n inert) = ppr n <+> ppr inert++initTyState :: TyState+initTyState = TySt 0 emptyInert++-- | The term oracle state. Stores 'VarInfo' for encountered 'Id's. These+-- entries are possibly shared when we figure out that two variables must be+-- equal, thus represent the same set of values.+--+-- See Note [TmState invariants] in "GHC.HsToCore.Pmc.Solver".+data TmState+  = TmSt+  { ts_facts :: !(UniqSDFM Id VarInfo)+  -- ^ Facts about term variables. Deterministic env, so that we generate+  -- deterministic error messages.+  , ts_reps  :: !(CoreMap Id)+  -- ^ An environment for looking up whether we already encountered semantically+  -- equivalent expressions that we want to represent by the same 'Id'+  -- representative.+  , ts_dirty :: !DIdSet+  -- ^ Which 'VarInfo' needs to be checked for inhabitants because of new+  -- negative constraints (e.g. @x ≁ ⊥@ or @x ≁ K@).+  }++-- | Information about an 'Id'. Stores positive ('vi_pos') facts, like @x ~ Just 42@,+-- and negative ('vi_neg') facts, like "x is not (:)".+-- Also caches the type ('vi_ty'), the 'ResidualCompleteMatches' of a COMPLETE set+-- ('vi_rcm').+--+-- Subject to Note [The Pos/Neg invariant] in "GHC.HsToCore.Pmc.Solver".+data VarInfo+  = VI+  { vi_id  :: !Id+  -- ^ The 'Id' in question. Important for adding new constraints relative to+  -- this 'VarInfo' when we don't easily have the 'Id' available.++  , vi_pos :: ![PmAltConApp]+  -- ^ Positive info: 'PmAltCon' apps it is (i.e. @x ~ [Just y, PatSyn z]@), all+  -- at the same time (i.e. conjunctive).  We need a list because of nested+  -- pattern matches involving pattern synonym+  --    case x of { Just y -> case x of PatSyn z -> ... }+  -- However, no more than one RealDataCon in the list, otherwise contradiction+  -- because of generativity.++  , vi_neg :: !PmAltConSet+  -- ^ Negative info: A list of 'PmAltCon's that it cannot match.+  -- Example, assuming+  --+  -- @+  --     data T = Leaf Int | Branch T T | Node Int T+  -- @+  --+  -- then @x ≁ [Leaf, Node]@ means that @x@ cannot match a @Leaf@ or @Node@,+  -- and hence can only match @Branch@. Is orthogonal to anything from 'vi_pos',+  -- in the sense that 'eqPmAltCon' returns @PossiblyOverlap@ for any pairing+  -- between 'vi_pos' and 'vi_neg'.++  -- See Note [Why record both positive and negative info?]+  -- It's worth having an actual set rather than a simple association list,+  -- because files like Cabal's `LicenseId` define relatively huge enums+  -- that lead to quadratic or worse behavior.++  , vi_bot :: BotInfo+  -- ^ Can this variable be ⊥? Models (mutually contradicting) @x ~ ⊥@ and+  --   @x ≁ ⊥@ constraints. E.g.+  --    * 'MaybeBot': Don't know; Neither @x ~ ⊥@ nor @x ≁ ⊥@.+  --    * 'IsBot': @x ~ ⊥@+  --    * 'IsNotBot': @x ≁ ⊥@++  , vi_rcm :: !ResidualCompleteMatches+  -- ^ A cache of the associated COMPLETE sets. At any time a superset of+  -- possible constructors of each COMPLETE set. So, if it's not in here, we+  -- can't possibly match on it. Complementary to 'vi_neg'. We still need it+  -- to recognise completion of a COMPLETE set efficiently for large enums.+  }++data PmAltConApp+  = PACA+  { paca_con :: !PmAltCon+  , paca_tvs :: ![TyVar]+  , paca_ids :: ![Id]+  }++-- | See 'vi_bot'.+data BotInfo+  = IsBot+  | IsNotBot+  | MaybeBot+  deriving Eq++instance Outputable PmAltConApp where+  ppr PACA{paca_con = con, paca_tvs = tvs, paca_ids = ids} =+    hsep (ppr con : map ((char '@' <>) . ppr) tvs ++ map ppr ids)++instance Outputable BotInfo where+  ppr MaybeBot = underscore+  ppr IsBot    = text "~⊥"+  ppr IsNotBot = text "≁⊥"++-- | Not user-facing.+instance Outputable TmState where+  ppr (TmSt state reps dirty) = ppr state $$ ppr reps $$ ppr dirty++-- | Not user-facing.+instance Outputable VarInfo where+  ppr (VI x pos neg bot cache)+    = braces (hcat (punctuate comma [pp_x, pp_pos, pp_neg, ppr bot, pp_cache]))+    where+      pp_x = ppr x <> dcolon <> ppr (idType x)+      pp_pos+        | [] <- pos  = underscore+        | [p] <- pos = char '~' <> ppr p -- suppress outer [_] if singleton+        | otherwise  = char '~' <> ppr pos+      pp_neg+        | isEmptyPmAltConSet neg = underscore+        | otherwise              = char '≁' <> ppr neg+      pp_cache+        | RCM Nothing Nothing <- cache = underscore+        | otherwise                    = ppr cache++-- | Initial state of the term oracle.+initTmState :: TmState+initTmState = TmSt emptyUSDFM emptyCoreMap emptyDVarSet++-- | A data type that caches for the 'VarInfo' of @x@ the results of querying+-- 'dsGetCompleteMatches' and then striking out all occurrences of @K@ for+-- which we already know @x ≁ K@ from these sets.+--+-- For motivation, see Section 5.3 in Lower Your Guards.+-- See also Note [Implementation of COMPLETE pragmas]+data ResidualCompleteMatches+  = RCM+  { rcm_vanilla :: !(Maybe CompleteMatch)+  -- ^ The residual set for the vanilla COMPLETE set from the data defn.+  -- Tracked separately from 'rcm_pragmas', because it might only be+  -- known much later (when we have enough type information to see the 'TyCon'+  -- of the match), or not at all even. Until that happens, it is 'Nothing'.+  , rcm_pragmas :: !(Maybe [CompleteMatch])+  -- ^ The residual sets for /all/ COMPLETE sets from pragmas that are+  -- visible when compiling this module. Querying that set with+  -- 'dsGetCompleteMatches' requires 'DsM', so we initialise it with 'Nothing'+  -- until first needed in a 'DsM' context.+  }++getRcm :: ResidualCompleteMatches -> [CompleteMatch]+getRcm (RCM vanilla pragmas) = maybeToList vanilla ++ fromMaybe [] pragmas++isRcmInitialised :: ResidualCompleteMatches -> Bool+isRcmInitialised (RCM vanilla pragmas) = isJust vanilla && isJust pragmas++instance Outputable ResidualCompleteMatches where+  -- 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+-- equality between them, which is impossible with Hs (too expressive) and with+-- Core (no notion of overloaded literals, and even plain 'Int' literals are+-- actually constructor apps). Also String literals are troublesome.++-- | Literals (simple and overloaded ones) for pattern match checking.+--+-- See Note [Undecidable Equality for PmAltCons]+data PmLit = PmLit+           { pm_lit_ty  :: Type+           , pm_lit_val :: PmLitValue }++data PmLitValue+  = PmLitInt Integer+  | PmLitRat Rational+  | PmLitChar Char+  -- We won't actually see PmLitString in the oracle since we desugar strings to+  -- lists+  | PmLitString FastString+  | PmLitOverInt Int {- How often Negated? -} Integer+  | PmLitOverRat Int {- How often Negated? -} FractionalLit+  | PmLitOverString FastString++-- | Undecidable semantic equality result.+-- See Note [Undecidable Equality for PmAltCons]+data PmEquality+  = Equal+  | Disjoint+  | PossiblyOverlap+  deriving (Eq, Show)++-- | When 'PmEquality' can be decided. @True <=> Equal@, @False <=> Disjoint@.+decEquality :: Bool -> PmEquality+decEquality True  = Equal+decEquality False = Disjoint++-- | Undecidable equality for values represented by 'PmLit's.+-- See Note [Undecidable Equality for PmAltCons]+--+-- * @Just True@ ==> Surely equal+-- * @Just False@ ==> Surely different (non-overlapping, even!)+-- * @Nothing@ ==> Equality relation undecidable+eqPmLit :: PmLit -> PmLit -> PmEquality+eqPmLit (PmLit t1 v1) (PmLit t2 v2)+  -- no haddock | pprTrace "eqPmLit" (ppr t1 <+> ppr v1 $$ ppr t2 <+> ppr v2) False = undefined+  | not (t1 `eqType` t2) = Disjoint+  | otherwise            = go v1 v2+  where+    go (PmLitInt i1)        (PmLitInt i2)        = decEquality (i1 == i2)+    go (PmLitRat r1)        (PmLitRat r2)        = decEquality (r1 == r2)+    go (PmLitChar c1)       (PmLitChar c2)       = decEquality (c1 == c2)+    go (PmLitString s1)     (PmLitString s2)     = decEquality (s1 == s2)+    go (PmLitOverInt n1 i1) (PmLitOverInt n2 i2)+      | n1 == n2 && i1 == i2                     = Equal+    go (PmLitOverRat n1 r1) (PmLitOverRat n2 r2)+      | n1 == n2 && r1 == r2                     = Equal+    go (PmLitOverString s1) (PmLitOverString s2)+      | s1 == s2                                 = Equal+    go _                    _                    = PossiblyOverlap++-- | Syntactic equality.+instance Eq PmLit where+  a == b = eqPmLit a b == Equal++-- | Type of a 'PmLit'+pmLitType :: PmLit -> Type+pmLitType (PmLit ty _) = ty++-- | Undecidable equality for values represented by 'ConLike's.+-- See Note [Undecidable Equality for PmAltCons].+-- 'PatSynCon's aren't enforced to be generative, so two syntactically different+-- 'PatSynCon's might match the exact same values. Without looking into and+-- reasoning about the pattern synonym's definition, we can't decide if their+-- sets of matched values is different.+--+-- * @Just True@ ==> Surely equal+-- * @Just False@ ==> Surely different (non-overlapping, even!)+-- * @Nothing@ ==> Equality relation undecidable+eqConLike :: ConLike -> ConLike -> PmEquality+eqConLike (RealDataCon dc1) (RealDataCon dc2) = decEquality (dc1 == dc2)+eqConLike (PatSynCon psc1)  (PatSynCon psc2)+  | psc1 == psc2+  = Equal+eqConLike _                 _                 = PossiblyOverlap++-- | Represents the head of a match against a 'ConLike' or literal.+-- Really similar to 'GHC.Core.AltCon'.+data PmAltCon = PmAltConLike ConLike+              | PmAltLit     PmLit++data PmAltConSet = PACS !(UniqDSet ConLike) ![PmLit]++emptyPmAltConSet :: PmAltConSet+emptyPmAltConSet = PACS emptyUniqDSet []++isEmptyPmAltConSet :: PmAltConSet -> Bool+isEmptyPmAltConSet (PACS cls lits) = isEmptyUniqDSet cls && null lits++-- | Whether there is a 'PmAltCon' in the 'PmAltConSet' that compares 'Equal' to+-- the given 'PmAltCon' according to 'eqPmAltCon'.+elemPmAltConSet :: PmAltCon -> PmAltConSet -> Bool+elemPmAltConSet (PmAltConLike cl) (PACS cls _   ) = elementOfUniqDSet cl cls+elemPmAltConSet (PmAltLit lit)    (PACS _   lits) = elem lit lits++extendPmAltConSet :: PmAltConSet -> PmAltCon -> PmAltConSet+extendPmAltConSet (PACS cls lits) (PmAltConLike cl)+  = PACS (addOneToUniqDSet cls cl) lits+extendPmAltConSet (PACS cls lits) (PmAltLit lit)+  = PACS cls (unionLists lits [lit])++pmAltConSetElems :: PmAltConSet -> [PmAltCon]+pmAltConSetElems (PACS cls lits)+  = map PmAltConLike (uniqDSetToList cls) ++ map PmAltLit lits++instance Outputable PmAltConSet where+  ppr = ppr . pmAltConSetElems++-- | We can't in general decide whether two 'PmAltCon's match the same set of+-- values. In addition to the reasons in 'eqPmLit' and 'eqConLike', a+-- 'PmAltConLike' might or might not represent the same value as a 'PmAltLit'.+-- See Note [Undecidable Equality for PmAltCons].+--+-- * @Just True@ ==> Surely equal+-- * @Just False@ ==> Surely different (non-overlapping, even!)+-- * @Nothing@ ==> Equality relation undecidable+--+-- Examples (omitting some constructor wrapping):+--+-- * @eqPmAltCon (LitInt 42) (LitInt 1) == Just False@: Lit equality is+--   decidable+-- * @eqPmAltCon (DataCon A) (DataCon B) == Just False@: DataCon equality is+--   decidable+-- * @eqPmAltCon (LitOverInt 42) (LitOverInt 1) == Nothing@: OverLit equality+--   is undecidable+-- * @eqPmAltCon (PatSyn PA) (PatSyn PB) == Nothing@: PatSyn equality is+--   undecidable+-- * @eqPmAltCon (DataCon I#) (LitInt 1) == Nothing@: DataCon to Lit+--   comparisons are undecidable without reasoning about the wrapped @Int#@+-- * @eqPmAltCon (LitOverInt 1) (LitOverInt 1) == Just True@: We assume+--   reflexivity for overloaded literals+-- * @eqPmAltCon (PatSyn PA) (PatSyn PA) == Just True@: We assume reflexivity+--   for Pattern Synonyms+eqPmAltCon :: PmAltCon -> PmAltCon -> PmEquality+eqPmAltCon (PmAltConLike cl1) (PmAltConLike cl2) = eqConLike cl1 cl2+eqPmAltCon (PmAltLit     l1)  (PmAltLit     l2)  = eqPmLit l1 l2+eqPmAltCon _                  _                  = PossiblyOverlap++-- | Syntactic equality.+instance Eq PmAltCon where+  a == b = eqPmAltCon a b == Equal++-- | Type of a 'PmAltCon'+pmAltConType :: PmAltCon -> [Type] -> Type+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.+isPmAltConMatchStrict :: PmAltCon -> Bool+isPmAltConMatchStrict PmAltLit{}                      = True+isPmAltConMatchStrict (PmAltConLike PatSynCon{})      = True -- #17357+isPmAltConMatchStrict (PmAltConLike (RealDataCon dc)) = not (isNewDataCon dc)++pmAltConImplBangs :: PmAltCon -> [HsImplBang]+pmAltConImplBangs PmAltLit{}         = []+pmAltConImplBangs (PmAltConLike con) = conLikeImplBangs con++{- Note [Undecidable Equality for PmAltCons]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Equality on overloaded literals is undecidable in the general case. Consider+the following example:++  instance Num Bool where+    ...+    fromInteger 0 = False -- C-like representation of booleans+    fromInteger _ = True++    f :: Bool -> ()+    f 1 = ()        -- Clause A+    f 2 = ()        -- Clause B++Clause B is redundant but to detect this, we must decide the constraint:+@fromInteger 2 ~ fromInteger 1@ which means that we+have to look through function @fromInteger@, whose implementation could+be anything. This poses difficulties for:++1. The expressive power of the check.+   We cannot expect a reasonable implementation of pattern matching to detect+   that @fromInteger 2 ~ fromInteger 1@ is True, unless we unfold function+   fromInteger. This puts termination at risk and is undecidable in the+   general case.++2. Error messages/Warnings.+   What should our message for @f@ above be? A reasonable approach would be+   to issue:++     Pattern matches are (potentially) redundant:+       f 2 = ...    under the assumption that 1 == 2++   but seems to complex and confusing for the user.++We choose to equate only obviously equal overloaded literals, in all other cases+we signal undecidability by returning Nothing from 'eqPmAltCons'. We do+better for non-overloaded literals, because we know their fromInteger/fromString+implementation is actually injective, allowing us to simplify the constraint+@fromInteger 1 ~ fromInteger 2@ to @1 ~ 2@, which is trivially unsatisfiable.++The impact of this treatment of overloaded literals is the following:++  * Redundancy checking is rather conservative, since it cannot see that clause+    B above is redundant.++  * We have instant equality check for overloaded literals (we do not rely on+    the term oracle which is rather expensive, both in terms of performance and+    memory). This significantly improves the performance of functions `covered`+    `uncovered` and `divergent` in "GHC.HsToCore.Pmc" and effectively addresses+    #11161.++  * The warnings issued are simpler.++Similar reasoning applies to pattern synonyms: In contrast to data constructors,+which are generative, constraints like F a ~ G b for two different pattern+synonyms F and G aren't immediately unsatisfiable. We assume F a ~ F a, though.+-}++literalToPmLit :: Type -> Literal -> Maybe PmLit+literalToPmLit ty l = PmLit ty <$> go l+  where+    go (LitChar c)       = Just (PmLitChar c)+    go (LitFloat r)      = Just (PmLitRat r)+    go (LitDouble r)     = Just (PmLitRat r)+    go (LitString s)     = Just (PmLitString (mkFastStringByteString s))+    go (LitNumber _ i)   = Just (PmLitInt i)+    go _                 = Nothing++negatePmLit :: PmLit -> Maybe PmLit+negatePmLit (PmLit ty v) = PmLit ty <$> go v+  where+    go (PmLitInt i)       = Just (PmLitInt (-i))+    go (PmLitRat r)       = Just (PmLitRat (-r))+    go (PmLitOverInt n i) = Just (PmLitOverInt (n+1) i)+    go (PmLitOverRat n r) = Just (PmLitOverRat (n+1) r)+    go _                  = Nothing++overloadPmLit :: Type -> PmLit -> Maybe PmLit+overloadPmLit ty (PmLit _ v) = PmLit ty <$> go v+  where+    go (PmLitInt i)          = Just (PmLitOverInt 0 i)+    go (PmLitRat r)          = Just $! PmLitOverRat 0 $! fractionalLitFromRational r+    go (PmLitString s)+      | ty `eqType` stringTy = Just v+      | otherwise            = Just (PmLitOverString s)+    go ovRat@PmLitOverRat{}  = Just ovRat+    go _               = Nothing++pmLitAsStringLit :: PmLit -> Maybe FastString+pmLitAsStringLit (PmLit _ (PmLitString s)) = Just s+pmLitAsStringLit _                         = Nothing++coreExprAsPmLit :: CoreExpr -> Maybe PmLit+-- coreExprAsPmLit e | pprTrace "coreExprAsPmLit" (ppr e) False = undefined+coreExprAsPmLit (Tick _t e) = coreExprAsPmLit e+coreExprAsPmLit (Lit l) = literalToPmLit (literalType l) l+coreExprAsPmLit e = case collectArgs e of+  (Var x, [Lit l])+    | Just dc <- isDataConWorkId_maybe x+    , dc `elem` [intDataCon, wordDataCon, charDataCon, floatDataCon, doubleDataCon]+    -> literalToPmLit (exprType e) l+  (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 (n % d))++  (Var x, args)+    -- See Note [Detecting overloaded literals with -XRebindableSyntax]+    | is_rebound_name x fromIntegerName+    , 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>+    | is_rebound_name x fromRationalName+    , [r] <- dropWhile (not . is_ratio) args+    -> coreExprAsPmLit r >>= overloadPmLit (exprType e)++  --Rationals with large exponents+  (Var x, args)+    -- See Note [Detecting overloaded literals with -XRebindableSyntax]+    -- See Note [Dealing with rationals with large exponents]+    -- mkRationalBase* <rational> <exponent>+    | Just exp_base <- is_larg_exp_ratio x+    , [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+      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)++  (Var x, args)+    | is_rebound_name x fromStringName+    -- See Note [Detecting overloaded literals with -XRebindableSyntax]+    , s:_ <- filter (isStringTy . exprType) $ filter isValArg args+    -- NB: Calls coreExprAsPmLit and then overloadPmLit, so that we return PmLitOverStrings+    -> coreExprAsPmLit s >>= overloadPmLit (exprType e)+  -- These last two cases handle proper String literals+  (Var x, [Type ty])+    | Just dc <- isDataConWorkId_maybe x+    , dc == nilDataCon+    , ty `eqType` charTy+    -> literalToPmLit stringTy (mkLitString "")+  (Var x, [Lit l])+    | idName x `elem` [unpackCStringName, unpackCStringUtf8Name]+    -> literalToPmLit stringTy l++  _ -> Nothing+  where+    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)+      = tyConName tc == ratioTyConName+      | otherwise+      = False+    is_larg_exp_ratio x+      | is_rebound_name x mkRationalBase10Name+      = Just Base10+      | is_rebound_name x mkRationalBase2Name+      = Just Base2+      | otherwise+      = Nothing+++    -- See Note [Detecting overloaded literals with -XRebindableSyntax]+    is_rebound_name :: Id -> Name -> Bool+    is_rebound_name x n = getOccFS (idName x) == getOccFS n++{- Note [Detecting overloaded literals with -XRebindableSyntax]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Normally, we'd find e.g. overloaded string literals by comparing the+application head of an expression to `fromStringName`. But that doesn't work+with -XRebindableSyntax: The `Name` of a user-provided `fromString` function is+different to `fromStringName`, which lives in a certain module, etc.++There really is no other way than to compare `OccName`s and guess which+argument is the actual literal string (we assume it's the first argument of+type `String`).++The same applies to other overloaded literals, such as overloaded rationals+(`fromRational`)and overloaded integer literals (`fromInteger`).++Note [Dealing with rationals with large exponents]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Rationals with large exponents are *not* desugared to+a simple rational. As that would require us to compute+their value which can be expensive. Rather they desugar+to an expression. For example 1e1000 will desugar to an+expression of the form: `mkRationalWithExponentBase10 (1 :% 1) 1000`++Only overloaded literals desugar to this form however, so we+we can just return a overloaded rational literal.++The most complex case is if we have RebindableSyntax enabled.+By example if we have a pattern like this: `f 3.3 = True`++It will desugar to:+  fromRational+    [TYPE: Rational, mkRationalBase10 (:% @Integer 10 1) (-1)]++The fromRational is properly detected as an overloaded Rational by+coreExprAsPmLit and it's general code for detecting overloaded rationals.+See Note [Detecting overloaded literals with -XRebindableSyntax].++This case then recurses into coreExprAsPmLit passing only the expression+`mkRationalBase10 (:% @Integer 10 1) (-1)`. Which is caught by rationals+with large exponents case. This will return a `PmLitOverRat` literal.++Which is then passed to overloadPmLit which simply returns it as-is since+it's already overloaded.++-}++instance Outputable PmLitValue where+  ppr (PmLitInt i)        = ppr i+  ppr (PmLitRat r)        = ppr (double (fromRat r)) -- good enough+  ppr (PmLitChar c)       = pprHsChar c+  ppr (PmLitString s)     = pprHsString s+  ppr (PmLitOverInt n i)  = minuses n (ppr i)+  ppr (PmLitOverRat n r)  = minuses n (ppr r)+  ppr (PmLitOverString s) = pprHsString s++-- Take care of negated literals+minuses :: Int -> SDoc -> SDoc+minuses n sdoc = iterate (\sdoc -> parens (char '-' <> sdoc)) sdoc !! n++instance Outputable PmLit where+  ppr (PmLit ty v) = ppr v <> suffix+    where+      -- Some ad-hoc hackery for displaying proper lit suffixes based on type+      tbl = [ (intPrimTy, primIntSuffix)+            , (int64PrimTy, primInt64Suffix)+            , (wordPrimTy, primWordSuffix)+            , (word64PrimTy, primWord64Suffix)+            , (charPrimTy, primCharSuffix)+            , (floatPrimTy, primFloatSuffix)+            , (doublePrimTy, primDoubleSuffix) ]+      suffix = fromMaybe empty (snd <$> find (eqType ty . fst) tbl)++instance Outputable PmAltCon where+  ppr (PmAltConLike cl) = ppr cl+  ppr (PmAltLit l)      = ppr l++instance Outputable PmEquality where+  ppr = text . show
+ compiler/GHC/HsToCore/Pmc/Types.hs view
@@ -0,0 +1,238 @@++{-# LANGUAGE DeriveFunctor       #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns        #-}++{-+Author: George Karachalias <george.karachalias@cs.kuleuven.be>+        Sebastian Graf <sgraf1337@gmail.com>+-}++-- | Types used through-out pattern match checking. This module is mostly there+-- to be imported from "GHC.HsToCore.Types". The exposed API is that of+-- "GHC.HsToCore.Pmc".+--+-- These types model the paper+-- [Lower Your Guards: A Compositional Pattern-Match Coverage Checker"](https://dl.acm.org/doi/abs/10.1145/3408989).+module GHC.HsToCore.Pmc.Types (+        -- * LYG syntax++        -- ** Guard language+        SrcInfo(..), PmGrd(..), GrdVec(..),++        -- ** Guard tree language+        PmMatchGroup(..), PmMatch(..), PmGRHSs(..), PmGRHS(..), PmPatBind(..), PmEmptyCase(..),++        -- * Coverage Checking types+        RedSets (..), Precision (..), CheckResult (..),++        -- * Pre and post coverage checking synonyms+        Pre, Post,++        -- * Normalised refinement types+        module GHC.HsToCore.Pmc.Solver.Types++    ) where++import GHC.Prelude++import GHC.HsToCore.Pmc.Solver.Types++import GHC.Data.OrdList+import GHC.Types.Id+import GHC.Types.Var (EvVar)+import GHC.Types.SrcLoc+import GHC.Utils.Outputable+import GHC.Core.Type+import GHC.Core++import Data.List.NonEmpty ( NonEmpty(..) )+import qualified Data.List.NonEmpty as NE+import qualified Data.Semigroup as Semi++--+-- * Guard language+--++-- | A very simple language for pattern guards. Let bindings, bang patterns,+-- and matching variables against flat constructor patterns.+-- The LYG guard language.+data PmGrd+  = -- | @PmCon x K dicts args@ corresponds to a @K dicts args <- x@ guard.+    -- The @args@ are bound in this construct, the @x@ is just a use.+    -- For the arguments' meaning see 'GHC.Hs.Pat.ConPatOut'.+    PmCon {+      pm_id          :: !Id,+      pm_con_con     :: !PmAltCon,+      pm_con_tvs     :: ![TyVar],+      pm_con_dicts   :: ![EvVar],+      pm_con_args    :: ![Id]+    }++    -- | @PmBang x@ corresponds to a @seq x True@ guard.+    -- If the extra 'SrcInfo' is present, the bang guard came from a source+    -- bang pattern, in which case we might want to report it as redundant.+    -- See Note [Dead bang patterns] in GHC.HsToCore.Pmc.Check.+  | PmBang {+      pm_id   :: !Id,+      _pm_loc :: !(Maybe SrcInfo)+    }++    -- | @PmLet x expr@ corresponds to a @let x = expr@ guard. This actually+    -- /binds/ @x@.+  | PmLet {+      pm_id        :: !Id,+      _pm_let_expr :: !CoreExpr+    }++-- | Should not be user-facing.+instance Outputable PmGrd where+  ppr (PmCon x alt _tvs _con_dicts con_args)+    = hsep [ppr alt, hsep (map ppr con_args), text "<-", ppr x]+  ppr (PmBang x _loc) = char '!' <> ppr x+  ppr (PmLet x expr) = hsep [text "let", ppr x, text "=", ppr expr]++--+-- * Guard tree language+--++-- | Means by which we identify a source construct for later pretty-printing in+-- a warning message. 'SDoc' for the equation to show, 'Located' for the+-- location.+newtype SrcInfo = SrcInfo (Located SDoc)++-- | A sequence of 'PmGrd's.+newtype GrdVec = GrdVec [PmGrd]++-- | A guard tree denoting 'MatchGroup'.+newtype PmMatchGroup p = PmMatchGroup (NonEmpty (PmMatch p))++-- | A guard tree denoting 'Match': A payload describing the pats and a bunch of+-- GRHS.+data PmMatch p = PmMatch { pm_pats :: !p, pm_grhss :: !(PmGRHSs p) }++-- | A guard tree denoting 'GRHSs': A bunch of 'PmLet' guards for local+-- bindings from the 'GRHSs's @where@ clauses and the actual list of 'GRHS'.+-- See Note [Long-distance information for HsLocalBinds] in+-- "GHC.HsToCore.Pmc.Desugar".+data PmGRHSs p = PmGRHSs { pgs_lcls :: !p, pgs_grhss :: !(NonEmpty (PmGRHS p))}++-- | A guard tree denoting 'GRHS': A payload describing the grds and a 'SrcInfo'+-- useful for printing out in warnings messages.+data PmGRHS p = PmGRHS { pg_grds :: !p, pg_rhs :: !SrcInfo }++-- | A guard tree denoting an -XEmptyCase.+newtype PmEmptyCase = PmEmptyCase { pe_var :: Id }++-- | A guard tree denoting a pattern binding.+newtype PmPatBind p =+  -- just reuse GrdGRHS and pretend its @SrcInfo@ is info on the /pattern/,+  -- rather than on the pattern bindings.+  PmPatBind (PmGRHS p)++instance Outputable SrcInfo where+  ppr (SrcInfo (L (RealSrcSpan rss _) _)) = ppr (srcSpanStartLine rss)+  ppr (SrcInfo (L s                   _)) = ppr s++-- | Format LYG guards as @| True <- x, let x = 42, !z@+instance Outputable GrdVec where+  ppr (GrdVec [])     = empty+  ppr (GrdVec (g:gs)) = fsep (char '|' <+> ppr g : map ((comma <+>) . ppr) gs)++-- | Format a LYG sequence (e.g. 'Match'es of a 'MatchGroup' or 'GRHSs') as+-- @{ <first alt>; ...; <last alt> }@+pprLygSequence :: Outputable a => NonEmpty a -> SDoc+pprLygSequence (NE.toList -> as) =+  braces (space <> fsep (punctuate semi (map ppr as)) <> space)++instance Outputable p => Outputable (PmMatchGroup p) where+  ppr (PmMatchGroup matches) = pprLygSequence matches++instance Outputable p => Outputable (PmMatch p) where+  ppr (PmMatch { pm_pats = grds, pm_grhss = grhss }) =+    ppr grds <+> ppr grhss++instance Outputable p => Outputable (PmGRHSs p) where+  ppr (PmGRHSs { pgs_lcls = _lcls, pgs_grhss = grhss }) =+    ppr grhss++instance Outputable p => Outputable (PmGRHS p) where+  ppr (PmGRHS { pg_grds = grds, pg_rhs = rhs }) =+    ppr grds <+> text "->" <+> ppr rhs++instance Outputable p => Outputable (PmPatBind p) where+  ppr (PmPatBind PmGRHS { pg_grds = grds, pg_rhs = bind }) =+    ppr bind <+> ppr grds <+> text "=" <+> text "..."++instance Outputable PmEmptyCase where+  ppr (PmEmptyCase { pe_var = var }) =+    text "<empty case on " <> ppr var <> text ">"++data Precision = Approximate | Precise+  deriving (Eq, Show)++instance Outputable Precision where+  ppr = text . show++instance Semi.Semigroup Precision where+  Precise <> Precise = Precise+  _       <> _       = Approximate++instance Monoid Precision where+  mempty = Precise+  mappend = (Semi.<>)++-- | Redundancy sets, used to determine redundancy of RHSs and bang patterns+-- (later digested into a 'CIRB').+data RedSets+  = RedSets+  { rs_cov :: !Nablas+  -- ^ The /Covered/ set; the set of values reaching a particular program+  -- point.+  , rs_div :: !Nablas+  -- ^ The /Diverging/ set; empty if no match can lead to divergence.+  --   If it wasn't empty, we have to turn redundancy warnings into+  --   inaccessibility warnings for any subclauses.+  , rs_bangs :: !(OrdList (Nablas, SrcInfo))+  -- ^ If any of the 'Nablas' is empty, the corresponding 'SrcInfo' pin-points+  -- a bang pattern in source that is redundant. See Note [Dead bang patterns].+  }++instance Outputable RedSets where+  ppr RedSets { rs_cov = _cov, rs_div = _div, rs_bangs = _bangs }+    -- It's useful to change this definition for different verbosity levels in+    -- printf-debugging+    = empty++-- | Pattern-match coverage check result+data CheckResult a+  = CheckResult+  { cr_ret :: !a+  -- ^ A hole for redundancy info and covered sets.+  , cr_uncov   :: !Nablas+  -- ^ The set of uncovered values falling out at the bottom.+  --   (for -Wincomplete-patterns, but also important state for the algorithm)+  , cr_approx  :: !Precision+  -- ^ A flag saying whether we ran into the 'maxPmCheckModels' limit for the+  -- purpose of suggesting to crank it up in the warning message. Writer state.+  } deriving Functor++instance Outputable a => Outputable (CheckResult a) where+  ppr (CheckResult c unc pc)+    = text "CheckResult" <+> ppr_precision pc <+> braces (fsep+        [ field "ret" c <> comma+        , field "uncov" unc])+    where+      ppr_precision Precise     = empty+      ppr_precision Approximate = text "(Approximate)"+      field name value = text name <+> equals <+> ppr value++--+-- * Pre and post coverage checking synonyms+--++-- | Used as tree payload pre-checking. The LYG guards to check.+type Pre = GrdVec++-- | Used as tree payload post-checking. The redundancy info we elaborated.+type Post = RedSets
compiler/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 "GhclibHsVersions.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
compiler/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 "GhclibHsVersions.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
compiler/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 "GhclibHsVersions.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)
compiler/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
+ compiler/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+
compiler/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
+ compiler/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)
compiler/GHC/Parser.y view
@@ -6,12 +6,10 @@ -- -- Author(s): Simon Marlow, Sven Panne 1997, 1998, 1999 -- ---------------------------------------------------------------------------- {-{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -43,12 +41,10 @@ import Control.Monad    ( unless, liftM, when, (<=<) ) import GHC.Exts import Data.Maybe       ( maybeToList )-import Data.List.NonEmpty ( NonEmpty((:|)) )+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@@ -63,18 +59,22 @@ 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 )@@ -83,12 +83,15 @@ 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+import GHC.Parser.Errors.Types+import GHC.Parser.Errors.Ppr () -import GHC.Builtin.Types ( unitTyCon, unitDataCon, tupleTyCon, tupleDataCon, nilDataCon,+import GHC.Builtin.Types ( unitTyCon, unitDataCon, sumTyCon,+                           tupleTyCon, tupleDataCon, nilDataCon,                            unboxedUnitTyCon, unboxedUnitDataCon,-                           listTyCon_RDR, consDataCon_RDR, eqTyCon_RDR)+                           listTyCon_RDR, consDataCon_RDR)  import qualified Data.Semigroup as Semi }@@ -619,6 +622,7 @@  'dependency'   { L _ ITdependency }   '{-# INLINE'             { L _ (ITinline_prag _ _ _) } -- INLINE or INLINABLE+ '{-# OPAQUE'             { L _ (ITopaque_prag _) }  '{-# SPECIALISE'         { L _ (ITspec_prag _) }  '{-# SPECIALISE_INLINE'  { L _ (ITspec_inline_prag _ _) }  '{-# SOURCE'             { L _ (ITsource_prag _) }@@ -644,6 +648,7 @@  '='            { L _ ITequal }  '\\'           { L _ ITlam }  'lcase'        { L _ ITlcase }+ 'lcases'       { L _ ITlcases }  '|'            { L _ ITvbar }  '<-'           { L _ (ITlarrow _) }  '->'           { L _ (ITrarrow _) }@@ -809,7 +814,7 @@       | PREFIX_MINUS { [mj AnnMinus $1 ] }       | VARSYM  {% if (getVARSYM $1 == fsLit "-")                    then return [mj AnnMinus $1]-                   else do { addError $ PsError PsErrExpectedHyphen [] (getLoc $1)+                   else do { addError $ mkPlainErrorMsgEnvelope (getLoc $1) $ PsErrExpectedHyphen                            ; return [] } }  @@ -848,18 +853,12 @@                    NotBoot -> HsSrcFile                    IsBoot  -> HsBootFile)                  (reLoc $3)-                 (Just $ sL1 $1 (HsModule noAnn (thdOf3 $7) (Just $3) $5 (fst $ sndOf3 $7) (snd $ sndOf3 $7) $4 Nothing)) }+                 (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 }+                 (sL1 $1 (HsModule noAnn (thdOf3 $6) (Just $2) $4 (fst $ sndOf3 $6) (snd $ sndOf3 $6) $3 Nothing)) }         | 'dependency' unitid mayberns              { sL1 $1 $ IncludeD (IncludeDecl { idUnitId = $2                                               , idModRenaming = $3@@ -906,12 +905,12 @@ implicit_top :: { () }         : {- empty -}                           {% pushModuleContext } -maybemodwarning :: { Maybe (LocatedP WarningTxt) }+maybemodwarning :: { Maybe (LocatedP (WarningTxt GhcPs)) }     : '{-# DEPRECATED' strings '#-}'-                      {% fmap Just $ amsrp (sLL $1 $> $ DeprecatedTxt (sL1 $1 $ getDEPRECATED_PRAGs $1) (snd $ unLoc $2))+                      {% fmap Just $ amsrp (sLL $1 $> $ DeprecatedTxt (sL1 $1 $ getDEPRECATED_PRAGs $1) (map stringLiteralToHsDocWst $ 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))+                         {% fmap Just $ amsrp (sLL $1 $> $ WarningTxt (sL1 $1 $ getWARNING_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $2))                                  (AnnPragma (mo $1) (mc $3) (fst $ unLoc $2))}     |  {- empty -}                  { Nothing } @@ -1123,12 +1122,13 @@         : 'safe'                                { (Just (glAA $1),True) }         | {- empty -}                           { (Nothing,      False) } -maybe_pkg :: { (Maybe EpaLocation,Maybe StringLiteral) }+maybe_pkg :: { (Maybe EpaLocation, RawPkgQual) }         : 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) }+                             addError $ mkPlainErrorMsgEnvelope (getLoc $1) $+                               (PsErrInvalidPackageName pkgFS)+                        ; return (Just (glAA $1), RawPkgQual (StringLiteral (getSTRINGs $1) pkgFS Nothing)) } }+        | {- empty -}                           { (Nothing,NoRawPkgQual) }  optqualified :: { Located (Maybe EpaLocation) }         : 'qualified'                           { sL1 $1 (Just (glAA $1)) }@@ -1351,18 +1351,18 @@   | {- 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))) }+  : 'stock'                     {% acsA (\cs -> sL1 $1 (StockStrategy (EpAnn (glR $1) [mj AnnStock $1] cs))) }+  | 'anyclass'                  {% acsA (\cs -> sL1 $1 (AnyclassStrategy (EpAnn (glR $1) [mj AnnAnyclass $1] cs))) }+  | 'newtype'                   {% acsA (\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)+  : 'via' sigktype          {% acsA (\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))) }+  : 'stock'                     {% fmap Just $ acsA (\cs -> sL1 $1 (StockStrategy (EpAnn (glR $1) [mj AnnStock $1] cs))) }+  | 'anyclass'                  {% fmap Just $ acsA (\cs -> sL1 $1 (AnyclassStrategy (EpAnn (glR $1) [mj AnnAnyclass $1] cs))) }+  | 'newtype'                   {% fmap Just $ acsA (\cs -> sL1 $1 (NewtypeStrategy (EpAnn (glR $1) [mj AnnNewtype $1] cs))) }   | deriv_strategy_via          { Just $1 }   | {- empty -}                 { Nothing } @@ -1370,12 +1370,12 @@  opt_injective_info :: { Located ([AddEpAnn], Maybe (LInjectivityAnn GhcPs)) }         : {- empty -}               { noLoc ([], Nothing) }-        | '|' injectivity_cond      { sLL $1 $> ([mj AnnVbar $1]+        | '|' injectivity_cond      { sLL $1 (reLoc $>) ([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)))) }+           {% acsA (\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) }@@ -1511,24 +1511,24 @@         | '::' 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))}+        :               { noLoc     ([]               , noLocA (NoSig noExtField)         )}+        | '::' kind     { sLL $1 (reLoc $>) ([mu AnnDcolon $1], sLLa $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))}+        :              { noLoc     ([]               , noLocA     (NoSig    noExtField)   )}+        | '::' kind    { sLL $1 (reLoc $>) ([mu AnnDcolon $1], sLLa $1 (reLoc $>) (KindSig  noExtField $2))}         | '='  tv_bndr {% do { tvb <- fromSpecTyVarBndr $2-                             ; return $ sLL $1 (reLoc $>) ([mj AnnEqual $1], sLL $1 (reLoc $>) (TyVarSig noExtField tvb))} }+                             ; return $ sLL $1 (reLoc $>) ([mj AnnEqual $1], sLLa $1 (reLoc $>) (TyVarSig noExtField tvb))} }  opt_at_kind_inj_sig :: { Located ([AddEpAnn], ( LFamilyResultSig GhcPs                                             , Maybe (LInjectivityAnn GhcPs)))}-        :            { noLoc ([], (noLoc (NoSig noExtField), Nothing)) }+        :            { noLoc ([], (noLocA (NoSig noExtField), Nothing)) }         | '::' kind  { sLL $1 (reLoc $>) ( [mu AnnDcolon $1]-                                 , (sL1A $> (KindSig noExtField $2), Nothing)) }+                                 , (sL1a (reLoc $>) (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))} }+                      ; return $ sLL $1 (reLoc $>) ([mj AnnEqual $1, mj AnnVbar $3]+                                           , (sLLa $1 (reLoc $2) (TyVarSig noExtField tvb), Just $4))} }  -- tycl_hdr parses the header of a class or data type decl, -- which takes the form@@ -1794,7 +1794,7 @@                                                 -- 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)} }+                                  ; return (sL1 $1 $ HsValBinds (fixValbindsAnn $ 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)))) }@@ -1834,7 +1834,7 @@            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_name = L (noAnnSrcSpan $ 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 })) }@@ -1857,7 +1857,8 @@       : PREFIX_TILDE { [mj AnnTilde $1] }       | VARSYM  {% if (getVARSYM $1 == fsLit "~")                    then return [mj AnnTilde $1]-                   else do { addError $ PsError PsErrInvalidRuleActivationMarker [] (getLoc $1)+                   else do { addError $ mkPlainErrorMsgEnvelope (getLoc $1) $+                               PsErrInvalidRuleActivationMarker                            ; return [] } }  rule_explicit_activation :: { ([AddEpAnn]@@ -1892,8 +1893,8 @@         | {- 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))) }+        : varid                         { sL1l $1 (RuleTyTmVar noAnn $1 Nothing) }+        | '(' varid '::' ctype ')'      {% acsA (\cs -> sLL $1 $> (RuleTyTmVar (EpAnn (glR $1) [mop $1,mu AnnDcolon $3,mcp $5] cs) $2 (Just $4))) }  {- Note [Parsing explicit foralls in Rules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1942,7 +1943,7 @@         : namelist strings                 {% fmap unitOL $ acsA (\cs -> sLL $1 $>                      (Warning (EpAnn (glR $1) (fst $ unLoc $2) cs) (unLoc $1)-                              (WarningTxt (noLoc NoSourceText) $ snd $ unLoc $2))) }+                              (WarningTxt (noLoc NoSourceText) $ map stringLiteralToHsDocWst $ snd $ unLoc $2))) }  deprecations :: { OrdList (LWarnDecl GhcPs) }         : deprecations ';' deprecation@@ -1965,7 +1966,7 @@ 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))) }+                                          (DeprecatedTxt (noLoc NoSourceText) $ map stringLiteralToHsDocWst $ snd $ unLoc $2))) }  strings :: { Located ([AddEpAnn],[Located StringLiteral]) }     : STRING { sL1 $1 ([],[L (gl $1) (getStringLiteral $1)]) }@@ -2108,11 +2109,11 @@                                                          , hst_xforall = noExtField                                                          , hst_body = $2 } }         | context '=>' ctype          {% acsA (\cs -> (sLL (reLoc $1) (reLoc $>) $-                                            HsQualTy { hst_ctxt = Just (addTrailingDarrowC $1 $2 cs)+                                            HsQualTy { hst_ctxt = 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)) }+        | ipvar '::' ctype            {% acsA (\cs -> sLL $1 (reLoc $>) (HsIParamTy (EpAnn (glR $1) [mu AnnDcolon $2] cs) (reLocA $1) $3)) }         | type                        { $1 }  ----------------------@@ -2145,20 +2146,20 @@         -- 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) }+                                            $ HsFunTy (EpAnn (glAR $1) NoEpAnns cs) (HsUnrestrictedArrow (hsUniTok $2)) $1 $3) }          | btype mult '->' ctype        {% hintLinear (getLoc $2)-                                       >> let arr = (unLoc $2) (toUnicode $3)+                                       >> let arr = (unLoc $2) (hsUniTok $3)                                           in acsA (\cs -> sLL (reLoc $1) (reLoc $>)-                                           $ HsFunTy (EpAnn (glAR $1) (mau $3) cs) arr $1 $4) }+                                           $ HsFunTy (EpAnn (glAR $1) NoEpAnns 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) }+                                            $ HsFunTy (EpAnn (glAR $1) NoEpAnns cs) (HsLinearArrow (HsLolly (hsTok $2))) $1 $3) }                                               -- [mu AnnLollyU $2] } -mult :: { Located (IsUnicodeSyntax -> HsArrow GhcPs) }-        : PREFIX_PERCENT atype          { sLL $1 (reLoc $>) (\u -> mkMultTy u $1 $2) }+mult :: { Located (LHsUniToken "->" "\8594" GhcPs -> HsArrow GhcPs) }+        : PREFIX_PERCENT atype          { sLL $1 (reLoc $>) (mkMultTy (hsTok $1) $2) }  btype :: { LHsType GhcPs }         : infixtype                     {% runPV $1 }@@ -2168,14 +2169,15 @@         : ftype %shift                  { $1 }         | ftype tyop infixtype          { $1 >>= \ $1 ->                                           $3 >>= \ $3 ->-                                          do { when (looksLikeMult $1 $2 $3) $ hintLinear (getLocA $2)-                                             ; mkHsOpTyPV $1 $2 $3 } }+                                          do { let (op, prom) = $2+                                             ; when (looksLikeMult $1 op $3) $ hintLinear (getLocA op)+                                             ; mkHsOpTyPV prom $1 op $3 } }         | unpackedness infixtype        { $2 >>= \ $2 ->                                           mkUnpackednessPV $1 $2 }  ftype :: { forall b. DisambTD b => PV (LocatedA b) }         : atype                         { mkHsAppTyHeadPV $1 }-        | tyop                          { failOpFewArgs $1 }+        | tyop                          { failOpFewArgs (fst $1) }         | ftype tyarg                   { $1 >>= \ $1 ->                                           mkHsAppTyPV $1 $2 }         | ftype PREFIX_AT atype         { $1 >>= \ $1 ->@@ -2185,13 +2187,15 @@         : 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) []) }+tyop :: { (LocatedN RdrName, PromotionFlag) }+        : qtyconop                      { ($1, NotPromoted) }+        | tyvarop                       { ($1, NotPromoted) }+        | SIMPLEQUOTE qconop            {% do { op <- amsrn (sLL $1 (reLoc $>) (unLoc $2))+                                                            (NameAnnQuote (glAA $1) (gl $2) [])+                                              ; return (op, IsPromoted) } }+        | SIMPLEQUOTE varop             {% do { op <- amsrn (sLL $1 (reLoc $>) (unLoc $2))+                                                            (NameAnnQuote (glAA $1) (gl $2) [])+                                              ; return (op, IsPromoted) } }  atype :: { LHsType GhcPs }         : ntgtycon                       {% acsa (\cs -> sL1a (reLocN $1) (HsTyVar (EpAnn (glNR $1) [] cs) NotPromoted $1)) }      -- Not including unit tuples@@ -2433,7 +2437,7 @@         : 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))}+                                    (reverse (map (\ln@(L l n) -> L (l2l l) $ FieldOcc noExtField ln) (unLoc $1))) $3 Nothing))}  -- Reversed! maybe_derivings :: { Located (HsDeriving GhcPs) }@@ -2442,23 +2446,23 @@  -- 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] }+        : derivings deriving      { sLL $1 (reLoc $>) ($2 : unLoc $1) } -- AZ: order?+        | deriving                { sL1 (reLoc $>) [$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) }+                 in acsA (\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) }+                 in acsA (\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) }+              {% let { full_loc = comb2 $1 (reLoc $>) }+                 in acsA (\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 $@@ -2527,12 +2531,12 @@                                                 (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] }+        : gdrhs gdrh            { sLL $1 (reLoc $>) ($2 : unLoc $1) }+        | gdrh                  { sL1 (reLoc $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) }+                                     acsA (\cs -> sL (comb2A $1 $>) $ GRHS (EpAnn (glR $1) (GrhsAnn (Just $ glAA $1) (mj AnnEqual $3)) cs) (unLoc $2) $4) }  sigdecl :: { LHsDecl GhcPs }         :@@ -2565,7 +2569,7 @@          | pattern_synonym_sig   { sL1 $1 . SigD noExtField . unLoc $ $1 } -        | '{-# COMPLETE' con_list opt_tyconsig  '#-}'+        | '{-# COMPLETE' qcon_list opt_tyconsig  '#-}'                 {% let (dcolon, tc) = $3                    in acsA                        (\cs -> sLL $1 $>@@ -2576,14 +2580,16 @@                 {% 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))))) }-+        | '{-# OPAQUE' qvar '#-}'+                {% acsA (\cs -> (sLL $1 $> $ SigD noExtField (InlineSig (EpAnn (glR $1) [mo $1, mc $3] cs) $2+                            (mkOpaquePragma (getOPAQUE_PRAGs $1))))) }         | '{-# 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))))) }}+                ; acsA (\cs -> sLL $1 $> (SigD noExtField (SCCFunSig (EpAnn (glR $1) [mo $1, mc $4] cs) (getSCC_PRAGs $1) $2 (Just ( sL1a $3 str_lit))))) }}          | '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}'              {% acsA (\cs ->@@ -2790,23 +2796,25 @@                                    unECP $2 >>= \ $2 ->                                    mkHsNegAppPV (comb2A $1 $>) $2 [mj AnnMinus $1] } -        | '\\' apat apats '->' exp+        | '\\' apats '->' exp                    {  ECP $-                      unECP $5 >>= \ $5 ->+                      unECP $4 >>= \ $4 ->                       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) }])) }+                                                 , m_pats = $2+                                                 , m_grhss = unguardedGRHSs (comb2 $3 (reLoc $4)) $4 (EpAnn (glR $3) (GrhsAnn Nothing (mu AnnRarrow $3)) emptyComments) }])) }         | 'let' binds 'in' exp          {  ECP $                                            unECP $4 >>= \ $4 ->-                                           mkHsLetPV (comb2A $1 $>) (unLoc $2) $4-                                                 (AnnsLet (glAA $1) (glAA $3)) }-        | '\\' 'lcase' altslist+                                           mkHsLetPV (comb2A $1 $>) (hsTok $1) (unLoc $2) (hsTok $3) $4 }+        | '\\' 'lcase' altslist(pats1)             {  ECP $ $3 >>= \ $3 ->-                 mkHsLamCasePV (comb2 $1 (reLoc $>)) $3 [mj AnnLam $1,mj AnnCase $2] }+                 mkHsLamCasePV (comb2 $1 (reLoc $>)) LamCase $3 [mj AnnLam $1,mj AnnCase $2] }+        | '\\' 'lcases' altslist(apats)+            {  ECP $ $3 >>= \ $3 ->+                 mkHsLamCasePV (comb2 $1 (reLoc $>)) LamCases $3 [mj AnnLam $1,mj AnnCases $2] }         | 'if' exp optSemi 'then' exp optSemi 'else' exp                          {% runPV (unECP $2) >>= \ ($2 :: LHsExpr GhcPs) ->                             return $ ECP $@@ -2824,11 +2832,11 @@                                            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) []) }+        | 'case' exp 'of' altslist(pats1) {% 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@@ -2849,7 +2857,7 @@                        {% (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)) }+                           acsA (\cs -> sLLlA $1 $> $ HsProc (EpAnn (glR $1) [mj AnnProc $1,mu AnnRarrow $3] cs) p (sLLa $1 (reLoc $>) $ HsCmdTop noExtField cmd)) }          | aexp1                 { $1 } @@ -2866,7 +2874,7 @@         | 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+                 let fl = sLLa $2 $> (DotFieldOcc ((EpAnn (glR $2) (AnnFieldLabel (Just $ glAA $2)) emptyComments)) (reLocA $3)) in                  mkRdrGetField (noAnnSrcSpan $ comb2 (reLoc $1) $>) $1 fl (EpAnn (glAR $1) NoEpAnns cs))  }  @@ -2880,11 +2888,11 @@         | 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.+-- into HsOverLit when -XOverloadedStrings 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)) }+        | INTEGER   { ECP $ mkHsOverLitPV (sL1a $1 $ mkHsIntegral   (getINTEGER  $1)) }+        | RATIONAL  { ECP $ mkHsOverLitPV (sL1a $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@@ -2892,7 +2900,7 @@         -- 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)) }+                                           mkHsParPV (comb2 $1 $>) (hsTok $1) $2 (hsTok $3) }         | '(' tup_exprs ')'             { ECP $                                            $2 >>= \ $2 ->                                            mkSumOrTuplePV (noAnnSrcSpan $ comb2 $1 $>) Boxed $2@@ -2920,26 +2928,26 @@         | 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)) }+        | SIMPLEQUOTE  qvar     {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsUntypedBracket (EpAnn (glR $1) [mj AnnSimpleQuote $1] cs) (VarBr noExtField True  $2)) }+        | SIMPLEQUOTE  qcon     {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsUntypedBracket (EpAnn (glR $1) [mj AnnSimpleQuote $1] cs) (VarBr noExtField True  $2)) }+        | TH_TY_QUOTE tyvar     {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsUntypedBracket (EpAnn (glR $1) [mj AnnThTyQuote $1  ] cs) (VarBr noExtField False $2)) }+        | TH_TY_QUOTE gtycon    {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsUntypedBracket (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]+                                 acsA (\cs -> sLL $1 $> $ HsUntypedBracket (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)) }+                                 acsA (\cs -> sLL $1 $> $ HsTypedBracket (EpAnn (glR $1) (if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) cs) $2) }         | '[t|' ktype '|]'    {% fmap ecpFromExp $-                                 acsA (\cs -> sLL $1 $> $ HsBracket (EpAnn (glR $1) [mo $1,mu AnnCloseQ $3] cs) (TypBr noExtField $2)) }+                                 acsA (\cs -> sLL $1 $> $ HsUntypedBracket (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)) }+                                      acsA (\cs -> sLL $1 $> $ HsUntypedBracket (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))) }+                                  acsA (\cs -> sLL $1 $> $ HsUntypedBracket (EpAnn (glR $1) (mo $1:mu AnnCloseQ $3:fst $2) cs) (DecBrL noExtField (snd $2))) }         | quasiquote          { ECP $ pvA $ mkHsSplicePV $1 }          -- arrow notation extension@@ -2948,12 +2956,12 @@                                       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 :: { Located (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc 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) :| [])) }+                             {% acs (\cs -> sLL $1 $> ((sLLa $2 $> $ DotFieldOcc (EpAnn (glR $1) (AnnFieldLabel (Just $ glAA $2)) cs) (reLocA $3)) `NE.cons` unLoc $1)) }+        | PREFIX_PROJ field  {% acs (\cs -> sLL $1 $> ((sLLa $1 $> $ DotFieldOcc (EpAnn (glR $1) (AnnFieldLabel (Just $ glAA $1)) cs) (reLocA $2)) :| [])) }  splice_exp :: { LHsExpr GhcPs }         : splice_untyped { mapLoc (HsSpliceE noAnn) (reLocA $1) }@@ -2977,7 +2985,7 @@ acmd    :: { LHsCmdTop GhcPs }         : aexp                  {% runPV (unECP $1) >>= \ (cmd :: LHsCmd GhcPs) ->                                    runPV (checkCmdBlockArguments cmd) >>= \ _ ->-                                   return (sL1A cmd $ HsCmdTop noExtField cmd) }+                                   return (sL1a (reLoc cmd) $ HsCmdTop noExtField cmd) }  cvtopbody :: { ([AddEpAnn],[LHsDecl GhcPs]) }         :  '{'            cvtopdecls0 '}'      { ([mj AnnOpenC $1@@ -3042,11 +3050,13 @@                       ; return (Tuple (cos ++ $2)) } }             | texp bars   { unECP $1 >>= \ $1 -> return $-                            (Sum 1  (snd $2 + 1) $1 [] (fst $2)) }+                            (Sum 1  (snd $2 + 1) $1 [] (map (EpaSpan . realSrcSpan) $ fst $2)) }             | bars texp bars0                 { unECP $2 >>= \ $2 -> return $-                  (Sum (snd $1 + 1) (snd $1 + snd $3 + 1) $2 (fst $1) (fst $3)) }+                  (Sum (snd $1 + 1) (snd $1 + snd $3 + 1) $2+                    (map (EpaSpan . realSrcSpan) $ fst $1)+                    (map (EpaSpan . realSrcSpan) $ fst $3)) }  -- Always starts with commas; always follows an expr commas_tup_tail :: { forall b. DisambECP b => PV (SrcSpan,[Either (EpAnn EpaLocation) (LocatedA b)]) }@@ -3206,48 +3216,48 @@ ----------------------------------------------------------------------------- -- 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 [] }+altslist(PATS) :: { forall b. DisambECP b => PV (LocatedL [LMatch GhcPs (LocatedA b)]) }+        : '{'        alts(PATS) '}'    { $2 >>= \ $2 -> amsrl+                                           (sLL $1 $> (reverse (snd $ unLoc $2)))+                                           (AnnList (Just $ glR $2) (Just $ moc $1) (Just $ mcc $3) (fst $ unLoc $2) []) }+        | vocurly    alts(PATS)  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 $+alts(PATS) :: { forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)])) }+        : alts1(PATS)              { $1 >>= \ $1 -> return $                                      sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }-        | ';' alts                 { $2 >>= \ $2 -> return $+        | ';' alts(PATS)           { $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]) }+alts1(PATS) :: { forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)])) }+        : alts1(PATS) ';' alt(PATS) { $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(PATS) ';'           {  $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(PATS)                 { $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(PATS) :: { forall b. DisambECP b => PV (LMatch GhcPs (LocatedA b)) }+        : PATS alt_rhs { $2 >>= \ $2 ->+                         acsA (\cs -> sLLAsl $1 $>+                                         (Match { m_ext = EpAnn (listAsAnchor $1) [] cs+                                                , m_ctxt = CaseAlt -- for \case and \cases, this will be changed during post-processing+                                                , m_pats = $1+                                                , m_grhss = unLoc $2 }))}  alt_rhs :: { forall b. DisambECP b => PV (Located (GRHSs GhcPs (LocatedA b))) }         : ralt wherebinds           { $1 >>= \alt ->@@ -3263,8 +3273,8 @@ 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] }+                         return $ sLL gdpats (reLoc gdpat) (gdpat : unLoc gdpats) }+        | gdpat        { $1 >>= \gdpat -> return $ sL1A 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@@ -3278,7 +3288,7 @@ 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) }+                                     acsA (\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@@ -3287,9 +3297,14 @@ pat     :: { LPat GhcPs } pat     :  exp          {% (checkPattern <=< runPV) (unECP $1) } +-- 'pats1' does the same thing as 'pat', but returns it as a singleton+-- list so that it can be used with a parameterized production rule+pats1   :: { [LPat GhcPs] }+pats1   : pat { [ $1 ] }+ bindpat :: { LPat GhcPs }-bindpat :  exp            {% -- See Note [Parser-Validator Hint] in GHC.Parser.PostProcess-                             checkPattern_hints [SuggestMissingDo]+bindpat :  exp            {% -- See Note [Parser-Validator Details] in GHC.Parser.PostProcess+                             checkPattern_details incompleteDoBlock                                               (unECP $1) }  apat   :: { LPat GhcPs }@@ -3380,13 +3395,13 @@  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) }+                           fmap Left $ acsA (\cs -> sLL (reLocN $1) (reLoc $>) $ HsFieldBind (EpAnn (glNR $1) [mj AnnEqual $2] cs) (sL1l $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) }+                          fmap Left $ acsa (\cs -> sL1a (reLocN $1) $ HsFieldBind (EpAnn (glNR $1) [] cs) (sL1l $1 $ mkFieldOcc $1) rhs True) }                         -- In the punning case, use a place-holder                         -- The renamer fills in the final value @@ -3394,10 +3409,10 @@         -- 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+                            let top = sL1a $1 $ DotFieldOcc noAnn (reLocA $1)+                                ((L lf (DotFieldOcc _ f)):t) = reverse (unLoc $3)+                                lf' = comb2 $2 (reLoc $ L lf ())+                                fields = top : L (noAnnSrcSpan lf') (DotFieldOcc (EpAnn (spanAsAnchor lf') (AnnFieldLabel (Just $ glAA $2)) emptyComments) f) : t                                 final = last fields                                 l = comb2 $1 $3                                 isPun = False@@ -3410,24 +3425,24 @@         -- 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+                            let top =  sL1a $1 $ DotFieldOcc noAnn (reLocA $1)+                                ((L lf (DotFieldOcc _ f)):t) = reverse (unLoc $3)+                                lf' = comb2 $2 (reLoc $ L lf ())+                                fields = top : L (noAnnSrcSpan lf') (DotFieldOcc (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))+                            var <- mkHsVarPV (L (noAnnSrcSpan $ getLocA final) (mkRdrUnqual . mkVarOcc . unpackFS . unLoc . dfoLabel . unLoc $ final))                             fmap Right $ mkHsProjUpdatePV l (L l fields) var isPun []                         } -fieldToUpdate :: { Located [Located (HsFieldLabel GhcPs)] }+fieldToUpdate :: { Located [LocatedAn NoEpAnns (DotFieldOcc 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)) }+                                                     return (sLL $1 $> ((sLLa $2 $> (DotFieldOcc (EpAnn (glR $2) (AnnFieldLabel $ Just $ glAA $2) cs) (reLocA $3))) : unLoc $1)) }         | field       {% getCommentsFor (getLoc $1) >>= \cs ->-                        return (sL1 $1 [sL1 $1 (HsFieldLabel (EpAnn (glR $1) (AnnFieldLabel Nothing) cs) $1)]) }+                        return (sL1 $1 [sL1a $1 (DotFieldOcc (EpAnn (glR $1) (AnnFieldLabel Nothing) cs) (reLocA $1))]) }  ----------------------------------------------------------------------------- -- Implicit Parameter Bindings@@ -3448,7 +3463,7 @@  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)) }+                                          acsA (\cs -> sLLlA $1 $> (IPBind (EpAnn (glR $1) [mj AnnEqual $2] cs) (reLocA $1) $3)) }  ipvar   :: { Located HsIPName }         : IPDUPVARID            { sL1 $1 (HsIPName (getIPDUPVARID $1)) }@@ -3525,6 +3540,11 @@          | con ',' con_list     {% do { h <- addTrailingCommaN $1 (gl $2)                                       ; return (sLL (reLocN $1) $> (h : unLoc $3)) }} +qcon_list :: { Located [LocatedN RdrName] }+qcon_list : qcon                  { sL1N $1 [$1] }+          | qcon ',' qcon_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) []) }@@ -3570,6 +3590,8 @@         | '(#' commas '#)'      {% amsrn (sLL $1 $> $ getRdrName (tupleTyCon Unboxed                                                         (snd $2 + 1)))                                        (NameAnnCommas NameParensHash (glAA $1) (map (EpaSpan . realSrcSpan) (fst $2)) (glAA $3) []) }+        | '(#' bars '#)'        {% amsrn (sLL $1 $> $ getRdrName (sumTyCon (snd $2 + 1)))+                                       (NameAnnBars 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)@@ -3635,11 +3657,7 @@  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) }+        | VARSYM                { sL1n $1 $! mkUnqual tcClsName (getVARSYM $1) }         | ':'                   { sL1n $1 $! consDataCon_RDR }         | '-'                   { sL1n $1 $! mkUnqual tcClsName (fsLit "-") }         | '.'                   { sL1n $1 $! mkUnqual tcClsName (fsLit ".") }@@ -3861,13 +3879,13 @@         : commas ','             { ((fst $1)++[gl $2],snd $1 + 1) }         | ','                    { ([gl $1],1) } -bars0 :: { ([EpaLocation],Int) }     -- Zero or more bars+bars0 :: { ([SrcSpan],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) }+bars :: { ([SrcSpan],Int) }     -- One or more bars+        : bars '|'               { ((fst $1)++[gl $2],snd $1 + 1) }+        | '|'                    { ([gl $1],1) }  { happyError :: P a@@ -3896,8 +3914,8 @@ 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)+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 @@ -3910,7 +3928,8 @@ getPRIMWORDs    (L _ (ITprimword   src _)) = src  -- See Note [Pragma source text] in "GHC.Types.Basic" for the following-getINLINE_PRAGs       (L _ (ITinline_prag       src _ _)) = src+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@@ -3957,9 +3976,12 @@ 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)+                   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@@ -4024,6 +4046,10 @@ 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)@@ -4044,6 +4070,11 @@ 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 $>)@@ -4098,16 +4129,16 @@ hintLinear :: MonadP m => SrcSpan -> m () hintLinear span = do   linearEnabled <- getBit LinearTypesBit-  unless linearEnabled $ addError $ PsError PsErrLinearFunction [] span+  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 "%"-  , Just ty1_pos <- getBufSpan (getLocA ty1)-  , Just pct_pos <- getBufSpan (getLocA l_op)-  , Just ty2_pos <- getBufSpan (getLocA ty2)+  , 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@@ -4117,14 +4148,15 @@ hintMultiWayIf :: SrcSpan -> P () hintMultiWayIf span = do   mwiEnabled <- getBit MultiWayIfBit-  unless mwiEnabled $ addError $ PsError PsErrMultiWayIf [] span+  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 $ PsError (PsErrExplicitForall (isUnicode tok)) [] (getLoc tok)+    unless (forall || rulePrag) $ addError $ mkPlainErrorMsgEnvelope (getLoc tok) $+      (PsErrExplicitForall (isUnicode tok))  -- Hint about qualified-do hintQualifiedDo :: Located Token -> P ()@@ -4132,7 +4164,8 @@     qualifiedDo   <- getBit QualifiedDoBit     case maybeQDoDoc of       Just qdoDoc | not qualifiedDo ->-        addError $ PsError (PsErrIllegalQualifiedDo qdoDoc) [] (getLoc tok)+        addError $ mkPlainErrorMsgEnvelope (getLoc tok) $+          (PsErrIllegalQualifiedDo qdoDoc)       _ -> return ()   where     maybeQDoDoc = case unLoc tok of@@ -4146,7 +4179,7 @@ reportEmptyDoubleQuotes :: SrcSpan -> P a reportEmptyDoubleQuotes span = do     thQuotes <- getBit ThQuotesBit-    addFatalError $ PsError (PsErrEmptyDoubleQuotes thQuotes) [] span+    addFatalError $ mkPlainErrorMsgEnvelope span $ PsErrEmptyDoubleQuotes thQuotes  {- %************************************************************************@@ -4185,13 +4218,6 @@ 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@@ -4244,8 +4270,9 @@   csf <- getFinalCommentsFor l   meof <- getEofPos   let ce = case meof of-             Nothing  -> EpaComments []-             Just (pos, gap) -> EpaCommentsBalanced [] [L (realSpanAsAnchor pos) (EpaComment EpaEofComment gap)]+             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)@@ -4359,6 +4386,14 @@ 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)  -- -------------------------------------
compiler/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)
compiler/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 "GhclibHsVersions.h"  import GHC.Prelude
− compiler/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
+ compiler/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
compiler/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"
+ compiler/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
+ compiler/GHC/Parser/HaddockLex.x view
@@ -0,0 +1,201 @@+{+{-# 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+}++-- -----------------------------------------------------------------------------+-- Alex "Character set macros"+-- Copied from GHC/Parser/Lexer.x++-- 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 Note [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 Note [Unicode in Alex].+$decdigit  = $ascdigit -- exactly $ascdigit, no more no less.+$digit     = [$ascdigit $unidigit]++$special   = [\(\)\,\;\[\]\`\{\}]+$ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:]+$unisymbol = \x04 -- Trick Alex into handling Unicode. See Note [Unicode in Alex].+$symbol    = [$ascsymbol $unisymbol] # [$special \_\"\']++$unilarge  = \x01 -- Trick Alex into handling Unicode. See Note [Unicode in Alex].+$asclarge  = [A-Z]+$large     = [$asclarge $unilarge]++$unismall  = \x02 -- Trick Alex into handling Unicode. See Note [Unicode in Alex].+$ascsmall  = [a-z]+$small     = [$ascsmall $unismall \_]++$uniidchar = \x07 -- Trick Alex into handling Unicode. See Note [Unicode in Alex].+$idchar    = [$small $large $digit $uniidchar \']++$unigraphic = \x06 -- Trick Alex into handling Unicode. See Note [Unicode in Alex].+$graphic   = [$small $large $symbol $digit $idchar $special $unigraphic \"\']++$alpha     = [$small $large]++-- The character sets marked "TODO" are mostly overly inclusive+-- and should be defined more precisely once alex has better+-- support for unicode character sets (see+-- https://github.com/simonmar/alex/issues/126).++@id = $alpha $idchar* \#* | $symbol++@modname = $large $idchar*+@qualid = (@modname \.)* @id++:-+  \' @qualid \' | \` @qualid \` { getIdentifier 1 }+  \'\` @qualid \`\' | \'\( @qualid \)\' | \`\( @qualid \)\` { getIdentifier 2 }+  [. \n] ;++{+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+}
compiler/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 "GhclibHsVersions.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
compiler/GHC/Parser/Lexer.x view
@@ -42,10 +42,14 @@  { {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE UnboxedSums #-}+{-# LANGUAGE UnliftedNewtypes #-}+{-# LANGUAGE PatternSynonyms #-} + {-# OPTIONS_GHC -funbox-strict-fields #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -53,17 +57,18 @@    Token(..), lexer, lexerDbg,    ParserOpts(..), mkParserOpts,    PState (..), initParserState, initPragState,-   P(..), ParseResult(..),+   P(..), ParseResult(POk, PFailed),    allocateComments, allocatePriorComments, allocateFinalComments,    MonadP(..),    getRealSrcLoc, getPState,    failMsgP, failLocMsgP, srcParseFail,-   getErrorMessages, getMessages,+   getPsErrorMessages, getPsMessages,    popContext, pushModuleContext, setLastToken, setSrcLoc,    activeContext, nextIsEOF,    getLexState, popLexState, pushLexState,    ExtBits(..),    xtest, xunset, xset,+   disableHaddock,    lexTokenStream,    mkParensEpAnn,    getCommentsFor, getPriorCommentsFor, getFinalCommentsFor,@@ -71,16 +76,23 @@    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 @@ -95,11 +107,12 @@ import qualified Data.Map as Map  -- compiler-import GHC.Data.Bag+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@@ -114,7 +127,9 @@  import GHC.Parser.Annotation import GHC.Driver.Flags-import GHC.Parser.Errors+import GHC.Parser.Errors.Basic+import GHC.Parser.Errors.Types+import GHC.Parser.Errors.Ppr () }  -- -----------------------------------------------------------------------------@@ -122,41 +137,41 @@  -- 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].+$unispace    = \x05 -- Trick Alex into handling Unicode. See Note [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)+$unidigit  = \x03 -- Trick Alex into handling Unicode. See Note [Unicode in Alex].+$decdigit  = $ascdigit -- exactly $ascdigit, no more no less. $digit     = [$ascdigit $unidigit]  $special   = [\(\)\,\;\[\]\`\{\}] $ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:]-$unisymbol = \x04 -- Trick Alex into handling Unicode. See [Unicode in Alex].+$unisymbol = \x04 -- Trick Alex into handling Unicode. See Note [Unicode in Alex]. $symbol    = [$ascsymbol $unisymbol] # [$special \_\"\'] -$unilarge  = \x01 -- Trick Alex into handling Unicode. See [Unicode in Alex].+$unilarge  = \x01 -- Trick Alex into handling Unicode. See Note [Unicode in Alex]. $asclarge  = [A-Z] $large     = [$asclarge $unilarge] -$unismall  = \x02 -- Trick Alex into handling Unicode. See [Unicode in Alex].+$unismall  = \x02 -- Trick Alex into handling Unicode. See Note [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 \"\']+$uniidchar = \x07 -- Trick Alex into handling Unicode. See Note [Unicode in Alex].+$idchar    = [$small $large $digit $uniidchar \'] +$unigraphic = \x06 -- Trick Alex into handling Unicode. See Note [Unicode in Alex].+$graphic   = [$small $large $symbol $digit $idchar $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]+$pragmachar = [$small $large $digit $uniidchar ]  $docsym    = [\| \^ \* \$] @@ -218,7 +233,7 @@ -- are). We also rule out nested Haddock comments, if the -haddock flag is -- set. -"{-" / { isNormalComment } { nested_comment lexToken }+"{-" / { isNormalComment } { nested_comment }  -- 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@@ -272,7 +287,8 @@   ^\# line                              { begin line_prag1 }   ^\# / { followedByDigit }             { begin line_prag1 }   ^\# pragma .* \n                      ; -- GCC 3.3 CPP generated, apparently-  ^\# \! .* \n                          ; -- #!, for scripts+  ^\# \! .* \n                          ; -- #!, for scripts  -- gcc+  ^\  \# \! .* \n                       ; --  #!, for scripts -- clang; See #6132   ()                                    { do_bol } } @@ -351,12 +367,12 @@ <0> {   -- In the "0" mode we ignore these pragmas   "{-#"  $whitechar* $pragmachar+ / { known_pragma fileHeaderPrags }-                     { nested_comment lexToken }+                     { nested_comment } }  <0,option_prags> {-  "{-#"  { warnThen Opt_WarnUnrecognisedPragmas PsWarnUnrecognisedPragma-                    (nested_comment lexToken) }+  "{-#"  { warnThen PsWarnUnrecognisedPragma+                    (nested_comment ) } }  -- '0' state: ordinary lexemes@@ -431,11 +447,9 @@ }  <0> {-  "(#" / { ifExtension UnboxedTuplesBit `alexOrPred`-           ifExtension UnboxedSumsBit }+  "(#" / { ifExtension UnboxedParensBit }          { token IToubxparen }-  "#)" / { ifExtension UnboxedTuplesBit `alexOrPred`-           ifExtension UnboxedSumsBit }+  "#)" / { ifExtension UnboxedParensBit }          { token ITcubxparen } } @@ -745,8 +759,9 @@   | ITdependency   | ITrequires -  -- Pragmas, see  note [Pragma source text] in "GHC.Types.Basic"+  -- 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@@ -778,6 +793,7 @@   | ITequal   | ITlam   | ITlcase+  | ITlcases   | ITvbar   | ITlarrow            IsUnicodeSyntax   | ITrarrow            IsUnicodeSyntax@@ -872,13 +888,11 @@   | 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 {- -}+  | 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 @@ -948,6 +962,7 @@         [( "_",              ITunderscore,    0 ),          ( "as",             ITas,            0 ),          ( "case",           ITcase,          0 ),+         ( "cases",          ITlcases,        xbit LambdaCaseBit ),          ( "class",          ITclass,         0 ),          ( "data",           ITdata,          0 ),          ( "default",        ITdefault,       0 ),@@ -1136,7 +1151,8 @@                  Layout prev_off _ : _ -> prev_off < offset                  _                     -> True       if isOK then pop_and open_brace span buf len-              else addFatalError $ PsError PsErrMissingBlock [] (mkSrcSpanPs span)+              else addFatalError $+                     mkPlainErrorMsgEnvelope (mkSrcSpanPs span) PsErrMissingBlock  pop_and :: Action -> Action pop_and act span buf len = do _ <- popLexState@@ -1268,16 +1284,23 @@   = p1 userState in1 len in2 || p2 userState in1 len in2  multiline_doc_comment :: Action-multiline_doc_comment span buf _len = withLexedDocType (worker "")+multiline_doc_comment span buf _len = {-# SCC "multiline_doc_comment" #-} 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+    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@@ -1319,15 +1342,43 @@   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+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-  go (reverse $ lexemeToString buf len) (1::Int) input+  -- 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-    go commentAcc 0 input = do-      l <- getLastLocComment-      let finalizeComment str = (Nothing, ITblockComment str l)-      commentEnd cont input commentAcc finalizeComment buf span+    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@@ -1346,31 +1397,6 @@         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@@ -1417,7 +1443,8 @@ See #314 for more background on the bug this fixes. -} -withLexedDocType :: (AlexInput -> (String -> (HdkComment, Token)) -> Bool -> P (PsLocated Token))+{-# INLINE withLexedDocType #-}+withLexedDocType :: (AlexInput -> ((HsDocStringDecorator -> HsDocString) -> (HdkComment, Token)) -> Bool -> P (PsLocated Token))                  -> P (PsLocated Token) withLexedDocType lexDocComment = do   input@(AI _ buf) <- getInput@@ -1427,7 +1454,9 @@     -- 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+    '$' -> 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@@ -1436,19 +1465,29 @@       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)+    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 -mkHdkCommentNamed :: PsSpan -> String -> (HdkComment, Token)-mkHdkCommentNamed loc str =-  let (name, rest) = break isSpace str-  in (HdkCommentNamed name (mkHsDocString rest), ITdocCommentNamed str loc)+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 -mkHdkCommentSection :: PsSpan -> Int -> String -> (HdkComment, Token)-mkHdkCommentSection loc n str =-  (HdkCommentSection n (mkHsDocString str), ITdocSection n str loc)+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@@ -1491,37 +1530,36 @@ -- 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-           -> String-           -> (String -> (Maybe HdkComment, Token))+           -> (Maybe HdkComment, Token)            -> StringBuffer            -> PsSpan            -> P (PsLocated Token)-commentEnd cont input commentAcc finalizeComment buf span = do+commentEnd cont input (m_hdk_comment, hdk_token) 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 ->+{-# INLINE docCommentEnd #-}+docCommentEnd :: AlexInput -> (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+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) (PsError (PsErrLexer LexUnterminatedComment LexErrKind_EOF) [])+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@@ -1576,15 +1614,23 @@     Just (ITcase, _) -> do       lastTk <- getLastTk       keyword <- case lastTk of-        Just (L _ ITlam) -> do+        Strict.Just (L _ ITlam) -> do           lambdaCase <- getBit LambdaCaseBit           unless lambdaCase $ do             pState <- getPState-            addError $ PsError PsErrLambdaCase [] (mkSrcSpanPs (last_loc pState))+            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@@ -1612,8 +1658,7 @@ varsym_prefix :: Action varsym_prefix = sym $ \span exts s ->   let warnExtConflict errtok =-        do { addWarning Opt_WarnOperatorWhitespaceExtConflict $-               PsWarnOperatorWhitespaceExtConflict (mkSrcSpanPs span) errtok+        do { addPsMessage (mkSrcSpanPs span) (PsWarnOperatorWhitespaceExtConflict errtok)            ; return (ITvarsym s) }   in   if | s == fsLit "@" ->@@ -1639,20 +1684,20 @@      | s == fsLit "!" -> return ITbang      | s == fsLit "~" -> return ITtilde      | otherwise ->-         do { addWarning Opt_WarnOperatorWhitespace $-                PsWarnOperatorWhitespace (mkSrcSpanPs span) s-                  OperatorWhitespaceOccurrence_Prefix+         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 (PsError PsErrSuffixAT [])+  if | s == fsLit "@" -> failMsgP (\srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrSuffixAT)      | s == fsLit "." -> return ITdot      | otherwise ->-         do { addWarning Opt_WarnOperatorWhitespace $-                PsWarnOperatorWhitespace (mkSrcSpanPs span) s-                  OperatorWhitespaceOccurrence_Suffix+         do { addPsMessage+                (mkSrcSpanPs span)+                (PsWarnOperatorWhitespace s OperatorWhitespaceOccurrence_Suffix)             ; return (ITvarsym s) }  -- See Note [Whitespace-sensitive operator parsing]@@ -1662,9 +1707,9 @@      | s == fsLit ".", OverloadedRecordDotBit `xtest` exts  -> return (ITproj False)      | s == fsLit "." -> return ITdot      | otherwise ->-         do { addWarning Opt_WarnOperatorWhitespace $-                PsWarnOperatorWhitespace (mkSrcSpanPs span) s-                  OperatorWhitespaceOccurrence_TightInfix+         do { addPsMessage+                (mkSrcSpanPs span)+                (PsWarnOperatorWhitespace s (OperatorWhitespaceOccurrence_TightInfix))             ;  return (ITvarsym s) }  -- See Note [Whitespace-sensitive operator parsing]@@ -1720,7 +1765,8 @@   let src = lexemeToString buf len   when ((not numericUnderscores) && ('_' `elem` src)) $ do     pState <- getPState-    addError $ PsError (PsErrNumUnderscores NumUnderscore_Integral) [] (mkSrcSpanPs (last_loc pState))+    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@@ -1761,7 +1807,8 @@   let src = lexemeToString buf (len-drop)   when ((not numericUnderscores) && ('_' `elem` src)) $ do     pState <- getPState-    addError $ PsError (PsErrNumUnderscores NumUnderscore_Float) [] (mkSrcSpanPs (last_loc pState))+    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@@ -1825,6 +1872,7 @@           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@@ -1940,7 +1988,9 @@               = 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) [])+          err (AI end _) = failLocMsgP (realSrcSpanStart (psRealSpan span))+                                       (psRealLoc end)+                                       (\srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrLexer LexUnterminatedOptions LexErrKind_EOF)  -- ----------------------------------------------------------------------------- -- Strings & Chars@@ -1977,7 +2027,8 @@                 setInput i                 when (any (> '\xFF') s') $ do                   pState <- getPState-                  let err = PsError PsErrPrimStringInvalidChar [] (mkSrcSpanPs (last_loc pState))+                  let msg = PsErrPrimStringInvalidChar+                  let err = mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) msg                   addError err                 return (ITprimstring (SourceText s') (unsafeMkByteString s'))               _other ->@@ -2240,7 +2291,7 @@ quasiquote_error start = do   (AI end buf) <- getInput   reportLexError start (psRealLoc end) buf-    (\k -> PsError (PsErrLexer LexUnterminatedQQ k) [])+    (\k srcLoc -> mkPlainErrorMsgEnvelope srcLoc (PsErrLexer LexUnterminatedQQ k))  -- ----------------------------------------------------------------------------- -- Warnings@@ -2250,9 +2301,9 @@     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))+warnThen :: PsMessage -> Action -> Action+warnThen warning action srcspan buf len = do+    addPsMessage (RealSrcSpan (psRealSpan srcspan) Strict.Nothing) warning     action srcspan buf len  -- -----------------------------------------------------------------------------@@ -2274,18 +2325,26 @@   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.+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@@ -2294,12 +2353,20 @@ -- -- See 'mkParserOpts' to construct this. data ParserOpts = ParserOpts-  { pWarningFlags   :: EnumSet WarningFlag -- ^ enabled warning flags-  , pExtsBitmap     :: !ExtsBitmap -- ^ bitmap of permitted extensions+  { pExtsBitmap     :: !ExtsBitmap -- ^ bitmap of permitted extensions+  , pDiagOpts       :: !DiagOpts+    -- ^ Options to construct diagnostic messages.+  , pSupportedExts  :: [String]+    -- ^ supported extensions (only used for suggestions in error messages)   } --- | Haddock comment as produced by the lexer. These are accumulated in--- 'PState' and then processed in "GHC.Parser.PostProcess.Haddock".+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@@ -2310,11 +2377,11 @@ 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+        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    :: Maybe (PsLocated Token), -- last non-comment token+        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]@@ -2346,9 +2413,9 @@         -- 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],+        -- 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@@ -2399,14 +2466,14 @@                 POk s1 a         -> (unP (k a)) s1                 PFailed s1 -> PFailed s1 -failMsgP :: (SrcSpan -> PsError) -> P a+failMsgP :: (SrcSpan -> MsgEnvelope PsMessage) -> P a failMsgP f = do   pState <- getPState   addFatalError (f (mkSrcSpanPs (last_loc pState))) -failLocMsgP :: RealSrcLoc -> RealSrcLoc -> (SrcSpan -> PsError) -> P a+failLocMsgP :: RealSrcLoc -> RealSrcLoc -> (SrcSpan -> MsgEnvelope PsMessage) -> P a failLocMsgP loc1 loc2 f =-  addFatalError (f (RealSrcSpan (mkRealSrcSpan loc1 loc2) Nothing))+  addFatalError (f (RealSrcSpan (mkRealSrcSpan loc1 loc2) Strict.Nothing))  getPState :: P PState getPState = P $ \s -> POk s s@@ -2436,7 +2503,7 @@ 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) } ()+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 {@@ -2445,7 +2512,7 @@   } ()  setLastTk :: PsLocated Token -> P ()-setLastTk tk@(L l _) = P $ \s -> POk s { last_tk = Just tk+setLastTk tk@(L l _) = P $ \s -> POk s { last_tk = Strict.Just tk                                        , prev_loc = l                                        , prev_loc2 = prev_loc s} () @@ -2453,7 +2520,7 @@ setLastComment (L l _) = P $ \s -> POk s { prev_loc = l                                          , prev_loc2 = prev_loc s} () -getLastTk :: P (Maybe (PsLocated Token))+getLastTk :: P (Strict.Maybe (PsLocated Token)) getLastTk = P $ \s@(PState { last_tk = last_tk }) -> POk s last_tk  -- see Note [PsSpan in Comments]@@ -2521,7 +2588,7 @@                   SpacingCombiningMark  -> other_graphic                   EnclosingMark         -> other_graphic                   DecimalNumber         -> digit-                  LetterNumber          -> other_graphic+                  LetterNumber          -> digit                   OtherNumber           -> digit -- see #4373                   ConnectorPunctuation  -> symbol                   DashPunctuation       -> symbol@@ -2563,6 +2630,7 @@         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)@@ -2697,8 +2765,7 @@   | RecursiveDoBit -- mdo   | QualifiedDoBit -- .do and .mdo   | UnicodeSyntaxBit -- the forall symbol, arrow symbols, etc-  | UnboxedTuplesBit -- (# and #)-  | UnboxedSumsBit -- (# and #)+  | UnboxedParensBit -- (# and #)   | DatatypeContextsBit   | MonadComprehensionsBit   | TransformComprehensionsBit@@ -2740,8 +2807,9 @@  {-# INLINE mkParserOpts #-} mkParserOpts-  :: EnumSet WarningFlag        -- ^ warnings flags enabled-  -> EnumSet LangExt.Extension  -- ^ permitted language extensions enabled+  :: 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@@ -2753,11 +2821,12 @@    -> ParserOpts -- ^ Given exactly the information needed, set up the 'ParserOpts'-mkParserOpts warningFlags extensionFlags+mkParserOpts extensionFlags diag_opts supported   safeImports isHaddock rawTokStream usePosPrags =     ParserOpts {-      pWarningFlags = warningFlags-    , pExtsBitmap   = safeHaskellBit .|. langExtBits .|. optBits+      pDiagOpts      = diag_opts+    , pExtsBitmap    = safeHaskellBit .|. langExtBits .|. optBits+    , pSupportedExts = supported     }   where     safeHaskellBit = SafeHaskellBit `setBitIf` safeImports@@ -2777,8 +2846,7 @@       .|. RecursiveDoBit              `xoptBit` LangExt.RecursiveDo       .|. QualifiedDoBit              `xoptBit` LangExt.QualifiedDo       .|. UnicodeSyntaxBit            `xoptBit` LangExt.UnicodeSyntax-      .|. UnboxedTuplesBit            `xoptBit` LangExt.UnboxedTuples-      .|. UnboxedSumsBit              `xoptBit` LangExt.UnboxedSums+      .|. UnboxedParensBit            `orXoptsBit` [LangExt.UnboxedTuples, LangExt.UnboxedSums]       .|. DatatypeContextsBit         `xoptBit` LangExt.DatatypeContexts       .|. TransformComprehensionsBit  `xoptBit` LangExt.TransformListComp       .|. MonadComprehensionsBit      `xoptBit` LangExt.MonadComprehensions@@ -2814,10 +2882,18 @@     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)@@ -2830,11 +2906,11 @@   PState {       buffer        = buf,       options       = options,-      errors        = emptyBag,-      warnings      = emptyBag,-      tab_first     = Nothing,+      errors        = emptyMessages,+      warnings      = emptyMessages,+      tab_first     = Strict.Nothing,       tab_count     = 0,-      last_tk       = Nothing,+      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,@@ -2849,8 +2925,8 @@       alr_context = [],       alr_expecting_ocurly = Nothing,       alr_justClosedExplicitLetBlock = False,-      eof_pos = Nothing,-      header_comments = Nothing,+      eof_pos = Strict.Nothing,+      header_comments = Strict.Nothing,       comment_q = [],       hdk_comments = nilOL     }@@ -2878,15 +2954,15 @@   --   to the accumulator and parsing continues. This allows GHC to report   --   more than one parse error per file.   ---  addError :: PsError -> m ()+  addError :: MsgEnvelope PsMessage -> m ()    -- | Add a warning to the accumulator.-  --   Use 'getMessages' to get the accumulated warnings.-  addWarning :: WarningFlag -> PsWarning -> m ()+  --   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 :: PsError -> m a+  addFatalError :: MsgEnvelope PsMessage -> m a    -- | Check if a given flag is currently set in the bitmap.   getBit :: ExtBits -> m Bool@@ -2902,12 +2978,13 @@  instance MonadP P where   addError err-   = P $ \s -> POk s { errors = err `consBag` errors s} ()+   = P $ \s -> POk s { errors = err `addMessage` errors s} () -  addWarning option w-   = P $ \s -> if warnopt option (options s)-                  then POk (s { warnings = w `consBag` warnings s }) ()-                  else POk 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@@ -2932,7 +3009,7 @@       POk s {          header_comments = header_comments',          comment_q = comment_q'-       } (EpaCommentsBalanced (fromMaybe [] header_comments') (reverse newAnns))+       } (EpaCommentsBalanced (Strict.fromMaybe [] header_comments') newAnns)  getCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments getCommentsFor (RealSrcSpan l _) = allocateCommentsP l@@ -2946,13 +3023,18 @@ getFinalCommentsFor (RealSrcSpan l _) = allocateFinalCommentsP l getFinalCommentsFor _ = return emptyComments -getEofPos :: P (Maybe (RealSrcSpan, RealSrcSpan))+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' = if isJust tf then tf else Just srcspan+       let tf' = tf <|> Strict.Just srcspan            tc' = tc + 1            s' = if warnopt Opt_WarnTabs o                 then s{tab_first = tf', tab_count = tc'}@@ -2961,20 +3043,24 @@  -- | 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+getPsErrorMessages :: PState -> Messages PsMessage+getPsErrorMessages 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 =+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-               Nothing -> ws-               Just tf -> PsWarnTab (RealSrcSpan tf Nothing) (tab_count p)-                           `consBag` ws+        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]@@ -3021,26 +3107,23 @@   -> 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+  -> MsgEnvelope PsMessage+srcParseErr options buf len loc = mkPlainErrorMsgEnvelope loc (PsErrParse token details)   where    token = lexemeToString (offsetBytes (-len) buf) len-   pattern = decodePrevNChars 8 buf+   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]+   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@@ -3057,7 +3140,7 @@   loc <- getRealSrcLoc   (AI end buf) <- getInput   reportLexError loc (psRealLoc end) buf-    (\k -> PsError (PsErrLexer e k) [])+    (\k srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrLexer e k)  -- ----------------------------------------------------------------------------- -- This is the top-level function: called from the parser each time a@@ -3097,6 +3180,7 @@                      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)@@ -3172,8 +3256,9 @@              -- 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+                 do addPsMessage+                      (mkSrcSpanPs thisLoc)+                      (PsWarnTransitionalLayout TransLayout_Where)                     setALRContext ls                     setNextToken t                     -- Note that we use lastLoc, as we may need to close@@ -3182,8 +3267,9 @@              -- 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+                 do addPsMessage+                      (mkSrcSpanPs thisLoc)+                      (PsWarnTransitionalLayout TransLayout_Pipe)                     setALRContext ls                     setNextToken t                     -- Note that we use lastLoc, as we may need to close@@ -3306,7 +3392,7 @@         return (L span ITeof)     AlexError (AI loc2 buf) ->         reportLexError (psRealLoc loc1) (psRealLoc loc2) buf-          (\k -> PsError (PsErrLexer LexError k) [])+          (\k srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrLexer LexError k)     AlexSkip inp2 _ -> do         setInput inp2         lexToken@@ -3320,7 +3406,11 @@         if (isComment lt') then setLastComment lt else setLastTk lt         return lt -reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> (LexErrKind -> SrcSpan -> PsError) -> P a+reportLexError :: RealSrcLoc+               -> RealSrcLoc+               -> StringBuffer+               -> (LexErrKind -> SrcSpan -> MsgEnvelope PsMessage)+               -> P a reportLexError loc1 loc2 buf f   | atEnd buf = failLocMsgP loc1 loc2 (f LexErrKind_EOF)   | otherwise =@@ -3332,8 +3422,7 @@ 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+    new_exts  =   xunset UsePosPragsBit  -- parse LINE/COLUMN pragmas as tokens                 $ xset RawTokenStreamBit -- include comments                 $ pExtsBitmap opts     opts'     = opts { pExtsBitmap = new_exts }@@ -3353,7 +3442,7 @@                                  ("include", lex_string_prag ITinclude_prag)])  ignoredPrags = Map.fromList (map ignored pragmas)-               where ignored opt = (opt, nested_comment lexToken)+               where ignored opt = (opt, nested_comment)                      impls = ["hugs", "nhc98", "jhc", "yhc", "catch", "derive"]                      options_pragmas = map ("options_" ++) impls                      -- CFILES is a hugs-only thing.@@ -3362,14 +3451,15 @@ oneWordPrags = Map.fromList [      ("rules", rulePrag),      ("inline",-         strtoken (\s -> (ITinline_prag (SourceText s) Inline FunLike))),+         strtoken (\s -> (ITinline_prag (SourceText s) (Inline (SourceText s)) FunLike))),      ("inlinable",-         strtoken (\s -> (ITinline_prag (SourceText s) Inlinable FunLike))),+         strtoken (\s -> (ITinline_prag (SourceText s) (Inlinable (SourceText s)) FunLike))),      ("inlineable",-         strtoken (\s -> (ITinline_prag (SourceText s) Inlinable FunLike))),+         strtoken (\s -> (ITinline_prag (SourceText s) (Inlinable (SourceText s)) FunLike))),                                     -- Spelling variant      ("notinline",-         strtoken (\s -> (ITinline_prag (SourceText s) NoInline FunLike))),+         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))),@@ -3390,9 +3480,9 @@  twoWordPrags = Map.fromList [      ("inline conlike",-         strtoken (\s -> (ITinline_prag (SourceText s) Inline ConLike))),+         strtoken (\s -> (ITinline_prag (SourceText s) (Inline (SourceText s)) ConLike))),      ("notinline conlike",-         strtoken (\s -> (ITinline_prag (SourceText s) NoInline ConLike))),+         strtoken (\s -> (ITinline_prag (SourceText s) (NoInline (SourceText s)) ConLike))),      ("specialize inline",          strtoken (\s -> (ITspec_inline_prag (SourceText s) True))),      ("specialize notinline",@@ -3464,13 +3554,13 @@     comment_q' = before ++ after     newAnns = middle   in-    (comment_q', newAnns)+    (comment_q', reverse newAnns)  allocatePriorComments   :: RealSrcSpan   -> [LEpaComment]-  -> Maybe [LEpaComment]-  -> (Maybe [LEpaComment], [LEpaComment], [LEpaComment])+  -> Strict.Maybe [LEpaComment]+  -> (Strict.Maybe [LEpaComment], [LEpaComment], [LEpaComment]) allocatePriorComments ss comment_q mheader_comments =   let     cmp (L l _) = anchor l <= ss@@ -3479,33 +3569,26 @@     comment_q'= after   in     case mheader_comments of-      Nothing -> (Just newAnns, comment_q', [])-      Just _ -> (mheader_comments, comment_q', newAnns)+      Strict.Nothing -> (Strict.Just (reverse newAnns), comment_q', [])+      Strict.Just _ -> (mheader_comments, comment_q', reverse 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)+  -> 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 (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 (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]@@ -3515,12 +3598,9 @@ -- ---------------------------------------------------------------------  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+isComment (ITlineComment  _ _) = True+isComment (ITblockComment _ _) = True+isComment (ITdocComment   _ _) = True+isComment (ITdocOptions   _ _) = True+isComment _                    = False }
compiler/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 "GhclibHsVersions.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   }
compiler/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 -}
compiler/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
compiler/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   }
compiler/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"
compiler/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"
compiler/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"
compiler/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"
compiler/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
compiler/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"
compiler/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
compiler/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
compiler/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"
− compiler/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"-
compiler/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 "GhclibHsVersions.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,
compiler/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"
compiler/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"
compiler/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.
compiler/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-
compiler/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 {
compiler/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 "rts/storage/ClosureTypes.h"-#include "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
+ compiler/GHC/Runtime/Interpreter.hs view
@@ -0,0 +1,752 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}++-- | Interacting with the iserv interpreter, whether it is running on an+-- external process or in the current process.+--+module GHC.Runtime.Interpreter+  ( module GHC.Runtime.Interpreter.Types++  -- * High-level interface to the interpreter+  , BCOOpts (..)+  , evalStmt, EvalStatus_(..), EvalStatus, EvalResult(..), EvalExpr(..)+  , resumeStmt+  , abandonStmt+  , evalIO+  , evalString+  , evalStringToIOString+  , mallocData+  , createBCOs+  , addSptEntry+  , mkCostCentres+  , costCentreStackInfo+  , newBreakArray+  , storeBreakpoint+  , breakpointStatus+  , getBreakpointVar+  , getClosure+  , getModBreaks+  , seqHValue+  , interpreterDynamic+  , interpreterProfiled++  -- * The object-code linker+  , initObjLinker+  , lookupSymbol+  , lookupClosure+  , loadDLL+  , loadArchive+  , loadObj+  , unloadObj+  , addLibrarySearchPath+  , removeLibrarySearchPath+  , resolveObjs+  , findSystemLibrary++  -- * Lower-level API using messages+  , interpCmd, Message(..), withIServ, withIServ_+  , stopInterp+  , iservCall, readIServ, writeIServ+  , purgeLookupSymbolCache+  , freeHValueRefs+  , mkFinalizedHValue+  , wormhole, wormholeRef+  , fromEvalResult+  ) where++import GHC.Prelude++import GHC.IO (catchException)++import GHC.Runtime.Interpreter.Types+import GHCi.Message+import GHCi.RemoteTypes+import GHCi.ResolvedBCO+import GHCi.BreakArray (BreakArray)+import GHC.Types.BreakInfo (BreakInfo(..))+import GHC.ByteCode.Types++import GHC.Linker.Types++import GHC.Data.Maybe+import GHC.Data.FastString++import GHC.Types.Unique+import GHC.Types.SrcLoc+import GHC.Types.Unique.FM+import GHC.Types.Basic++import GHC.Utils.Panic+import GHC.Utils.Exception as Ex+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+import GHC.Platform.Ways+#endif++import Control.Concurrent+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Catch as MC (mask, onException)+import Data.Binary+import Data.Binary.Put+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as LB+import Data.Array ((!))+import Data.IORef+import Foreign hiding (void)+import qualified GHC.Exts.Heap as Heap+import GHC.Stack.CCS (CostCentre,CostCentreStack)+import System.Exit+import GHC.IO.Handle.Types (Handle)+#if defined(mingw32_HOST_OS)+import Foreign.C+import GHC.IO.Handle.FD (fdToHandle)+#else+import System.Posix as Posix+#endif+import System.Directory+import System.Process+import GHC.Conc (pseq, par)++{- Note [Remote GHCi]+   ~~~~~~~~~~~~~~~~~~+When the flag -fexternal-interpreter is given to GHC, interpreted code+is run in a separate process called iserv, and we communicate with the+external process over a pipe using Binary-encoded messages.++Motivation+~~~~~~~~~~++When the interpreted code is running in a separate process, it can+use a different "way", e.g. profiled or dynamic.  This means++- compiling Template Haskell code with -prof does not require+  building the code without -prof first++- when GHC itself is profiled, it can interpret unprofiled code,+  and the same applies to dynamic linking.++- An unprofiled GHCi can load and run profiled code, which means it+  can use the stack-trace functionality provided by profiling without+  taking the performance hit on the compiler that profiling would+  entail.++For other reasons see remote-GHCi on the wiki.++Implementation Overview+~~~~~~~~~~~~~~~~~~~~~~~++The main pieces are:++- libraries/ghci, containing:+  - types for talking about remote values (GHCi.RemoteTypes)+  - the message protocol (GHCi.Message),+  - implementation of the messages (GHCi.Run)+  - implementation of Template Haskell (GHCi.TH)+  - a few other things needed to run interpreted code++- top-level iserv directory, containing the codefor the external+  server.  This is a fairly simple wrapper, most of the functionality+  is provided by modules in libraries/ghci.++- This module which provides the interface to the server used+  by the rest of GHC.++GHC works with and without -fexternal-interpreter.  With the flag, all+interpreted code is run by the iserv binary.  Without the flag,+interpreted code is run in the same process as GHC.++Things that do not work with -fexternal-interpreter+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++dynCompileExpr cannot work, because we have no way to run code of an+unknown type in the remote process.  This API fails with an error+message if it is used with -fexternal-interpreter.++Other Notes on Remote GHCi+~~~~~~~~~~~~~~~~~~~~~~~~~~+  * This wiki page has an implementation overview:+    https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/external-interpreter+  * Note [External GHCi pointers] in "GHC.Runtime.Interpreter"+  * Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs+-}+++-- | Run a command in the interpreter's context.  With+-- @-fexternal-interpreter@, the command is serialized and sent to an+-- external iserv process, and the response is deserialized (hence the+-- @Binary@ constraint).  With @-fno-external-interpreter@ we execute+-- the command directly here.+interpCmd :: Binary a => Interp -> Message a -> IO a+interpCmd interp msg = case interpInstance interp of+#if defined(HAVE_INTERNAL_INTERPRETER)+  InternalInterp     -> run msg -- Just run it directly+#endif+  ExternalInterp c i -> withIServ_ c i $ \iserv ->+    uninterruptibleMask_ $ -- Note [uninterruptibleMask_]+      iservCall iserv msg+++-- 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+-- communication.  A ^C will be delivered to the iserv process (because+-- signals get sent to the whole process group) which will interrupt+-- the running computation and return an EvalException result.++-- | Grab a lock on the 'IServ' and do something with it.+-- Overloaded because this is used from TcM as well as IO.+withIServ+  :: (ExceptionMonad m)+  => IServConfig -> IServ -> (IServInstance -> m (IServInstance, a)) -> m a+withIServ conf (IServ mIServState) action =+  MC.mask $ \restore -> do+    state <- liftIO $ takeMVar mIServState++    iserv <- case state of+      -- start the external iserv process if we haven't done so yet+      IServPending ->+         liftIO (spawnIServ conf)+           `MC.onException` (liftIO $ putMVar mIServState state)++      IServRunning inst -> return inst+++    let iserv'  = iserv{ iservPendingFrees = [] }++    (iserv'',a) <- (do+      -- free any ForeignHValues that have been garbage collected.+      liftIO $ when (not (null (iservPendingFrees iserv))) $+        iservCall iserv (FreeHValueRefs (iservPendingFrees iserv))+      -- run the inner action+      restore $ action iserv')+          `MC.onException` (liftIO $ putMVar mIServState (IServRunning iserv'))+    liftIO $ putMVar mIServState (IServRunning iserv'')+    return a++withIServ_+  :: (MonadIO m, ExceptionMonad m)+  => IServConfig -> IServ -> (IServInstance -> m a) -> m a+withIServ_ conf iserv action = withIServ conf iserv $ \inst ->+   (inst,) <$> action inst++-- -----------------------------------------------------------------------------+-- Wrappers around messages++-- | Execute an action of type @IO [a]@, returning 'ForeignHValue's for+-- each of the results.+evalStmt+  :: Interp+  -> EvalOpts+  -> EvalExpr ForeignHValue+  -> IO (EvalStatus_ [ForeignHValue] [HValueRef])+evalStmt interp opts foreign_expr = do+  status <- withExpr foreign_expr $ \expr ->+    interpCmd interp (EvalStmt opts expr)+  handleEvalStatus interp status+ where+  withExpr :: EvalExpr ForeignHValue -> (EvalExpr HValueRef -> IO a) -> IO a+  withExpr (EvalThis fhv) cont =+    withForeignRef fhv $ \hvref -> cont (EvalThis hvref)+  withExpr (EvalApp fl fr) cont =+    withExpr fl $ \fl' ->+    withExpr fr $ \fr' ->+    cont (EvalApp fl' fr')++resumeStmt+  :: Interp+  -> EvalOpts+  -> ForeignRef (ResumeContext [HValueRef])+  -> IO (EvalStatus_ [ForeignHValue] [HValueRef])+resumeStmt interp opts resume_ctxt = do+  status <- withForeignRef resume_ctxt $ \rhv ->+    interpCmd interp (ResumeStmt opts rhv)+  handleEvalStatus interp status++abandonStmt :: Interp -> ForeignRef (ResumeContext [HValueRef]) -> IO ()+abandonStmt interp resume_ctxt =+  withForeignRef resume_ctxt $ \rhv ->+    interpCmd interp (AbandonStmt rhv)++handleEvalStatus+  :: Interp+  -> EvalStatus [HValueRef]+  -> IO (EvalStatus_ [ForeignHValue] [HValueRef])+handleEvalStatus interp status =+  case status of+    EvalBreak a b c d e f -> return (EvalBreak a b c d e f)+    EvalComplete alloc res ->+      EvalComplete alloc <$> addFinalizer res+ where+  addFinalizer (EvalException e) = return (EvalException e)+  addFinalizer (EvalSuccess rs)  =+    EvalSuccess <$> mapM (mkFinalizedHValue interp) rs++-- | Execute an action of type @IO ()@+evalIO :: Interp -> ForeignHValue -> IO ()+evalIO interp fhv =+  liftIO $ withForeignRef fhv $ \fhv ->+    interpCmd interp (EvalIO fhv) >>= fromEvalResult++-- | Execute an action of type @IO String@+evalString :: Interp -> ForeignHValue -> IO String+evalString interp fhv =+  liftIO $ withForeignRef fhv $ \fhv ->+    interpCmd interp (EvalString fhv) >>= fromEvalResult++-- | Execute an action of type @String -> IO String@+evalStringToIOString :: Interp -> ForeignHValue -> String -> IO String+evalStringToIOString interp fhv str =+  liftIO $ withForeignRef fhv $ \fhv ->+    interpCmd interp (EvalStringToString fhv str) >>= fromEvalResult+++-- | Allocate and store the given bytes in memory, returning a pointer+-- to the memory in the remote process.+mallocData :: Interp -> ByteString -> IO (RemotePtr ())+mallocData interp bs = interpCmd interp (MallocData bs)++mkCostCentres :: Interp -> String -> [(String,String)] -> IO [RemotePtr CostCentre]+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 -> 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+         then void $ evaluate puts+         else bracket_ (setNumCapabilities n_jobs)+                       (setNumCapabilities old_caps)+                       (void $ evaluate puts)+      interpCmd interp (CreateBCOs puts)+ where+  puts = parMap doChunk (chunkList 100 rbcos)++  -- make sure we force the whole lazy ByteString+  doChunk c = pseq (LB.length bs) bs+    where bs = runPut (put c)++  -- We don't have the parallel package, so roll our own simple parMap+  parMap _ [] = []+  parMap f (x:xs) = fx `par` (fxs `pseq` (fx : fxs))+    where fx = f x; fxs = parMap f xs++addSptEntry :: Interp -> Fingerprint -> ForeignHValue -> IO ()+addSptEntry interp fpr ref =+  withForeignRef ref $ \val ->+    interpCmd interp (AddSptEntry fpr val)++costCentreStackInfo :: Interp -> RemotePtr CostCentreStack -> IO [String]+costCentreStackInfo interp ccs =+  interpCmd interp (CostCentreStackInfo ccs)++newBreakArray :: Interp -> Int -> IO (ForeignRef BreakArray)+newBreakArray interp size = do+  breakArray <- interpCmd interp (NewBreakArray size)+  mkFinalizedHValue interp breakArray++storeBreakpoint :: Interp -> ForeignRef BreakArray -> Int -> Int -> IO ()+storeBreakpoint interp ref ix cnt = do                               -- #19157+  withForeignRef ref $ \breakarray ->+    interpCmd interp (SetupBreakpoint breakarray ix cnt)++breakpointStatus :: Interp -> ForeignRef BreakArray -> Int -> IO Bool+breakpointStatus interp ref ix =+  withForeignRef ref $ \breakarray ->+    interpCmd interp (BreakpointStatus breakarray ix)++getBreakpointVar :: Interp -> ForeignHValue -> Int -> IO (Maybe ForeignHValue)+getBreakpointVar interp ref ix =+  withForeignRef ref $ \apStack -> do+    mb <- interpCmd interp (GetBreakpointVar apStack ix)+    mapM (mkFinalizedHValue interp) mb++getClosure :: Interp -> ForeignHValue -> IO (Heap.GenClosure ForeignHValue)+getClosure interp ref =+  withForeignRef ref $ \hval -> do+    mb <- interpCmd interp (GetClosure hval)+    mapM (mkFinalizedHValue interp) mb++-- | Send a Seq message to the iserv process to force a value      #2950+seqHValue :: Interp -> UnitEnv -> ForeignHValue -> IO (EvalResult ())+seqHValue interp unit_env ref =+  withForeignRef ref $ \hval -> do+    status <- interpCmd interp (Seq hval)+    handleSeqHValueStatus interp unit_env status++-- | Process the result of a Seq or ResumeSeq message.             #2950+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 (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 " +++            (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 unit_env status+    (EvalComplete _ r) -> return r+  where+    getSeqBpSpan :: Maybe BreakInfo -> SrcSpan+    -- Just case: Stopped at a breakpoint, extract SrcSpan information+    -- from the breakpoint.+    getSeqBpSpan (Just BreakInfo{..}) =+      (modBreaks_locs (breaks breakInfo_module)) ! breakInfo_number+    -- Nothing case - should not occur!+    -- Reason: Setting of flags in libraries/ghci/GHCi/Run.hs:evalOptsSeq+    getSeqBpSpan Nothing = mkGeneralSrcSpan (fsLit "<unknown>")+    breaks mod = getModBreaks $ expectJust "getSeqBpSpan" $+      lookupHpt (ue_hpt unit_env) (moduleName mod)+++-- -----------------------------------------------------------------------------+-- Interface to the object-code linker++initObjLinker :: Interp -> IO ()+initObjLinker interp = interpCmd interp InitLinker++lookupSymbol :: Interp -> FastString -> IO (Maybe (Ptr ()))+lookupSymbol interp str = case interpInstance interp of+#if defined(HAVE_INTERNAL_INTERPRETER)+  InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str))+#endif++  ExternalInterp c i -> withIServ c i $ \iserv -> do+    -- Profiling of GHCi showed a lot of time and allocation spent+    -- making cross-process LookupSymbol calls, so I added a GHC-side+    -- cache which sped things up quite a lot.  We have to be careful+    -- to purge this cache when unloading code though.+    let cache = iservLookupSymbolCache iserv+    case lookupUFM cache str of+      Just p -> return (iserv, Just p)+      Nothing -> do+        m <- uninterruptibleMask_ $+                 iservCall iserv (LookupSymbol (unpackFS str))+        case m of+          Nothing -> return (iserv, Nothing)+          Just r -> do+            let p      = fromRemotePtr r+                cache' = addToUFM cache str p+                iserv' = iserv {iservLookupSymbolCache = cache'}+            return (iserv', Just p)++lookupClosure :: Interp -> String -> IO (Maybe HValueRef)+lookupClosure interp str =+  interpCmd interp (LookupClosure str)++purgeLookupSymbolCache :: Interp -> IO ()+purgeLookupSymbolCache interp = case interpInstance interp of+#if defined(HAVE_INTERNAL_INTERPRETER)+  InternalInterp -> pure ()+#endif+  ExternalInterp _ (IServ mstate) ->+    modifyMVar_ mstate $ \state -> pure $ case state of+      IServPending       -> state+      IServRunning iserv -> IServRunning+        (iserv { iservLookupSymbolCache = emptyUFM })+++-- | loadDLL loads a dynamic library using the OS's native linker+-- (i.e. dlopen() on Unix, LoadLibrary() on Windows).  It takes either+-- an absolute pathname to the file, or a relative filename+-- (e.g. "libfoo.so" or "foo.dll").  In the latter case, loadDLL+-- searches the standard locations for the appropriate library.+--+-- Returns:+--+-- Nothing      => success+-- Just err_msg => failure+loadDLL :: Interp -> String -> IO (Maybe String)+loadDLL interp str = interpCmd interp (LoadDLL str)++loadArchive :: Interp -> String -> IO ()+loadArchive interp path = do+  path' <- canonicalizePath path -- Note [loadObj and relative paths]+  interpCmd interp (LoadArchive path')++loadObj :: Interp -> String -> IO ()+loadObj interp path = do+  path' <- canonicalizePath path -- Note [loadObj and relative paths]+  interpCmd interp (LoadObj path')++unloadObj :: Interp -> String -> IO ()+unloadObj interp path = do+  path' <- canonicalizePath path -- Note [loadObj and relative paths]+  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.++addLibrarySearchPath :: Interp -> String -> IO (Ptr ())+addLibrarySearchPath interp str =+  fromRemotePtr <$> interpCmd interp (AddLibrarySearchPath str)++removeLibrarySearchPath :: Interp -> Ptr () -> IO Bool+removeLibrarySearchPath interp p =+  interpCmd interp (RemoveLibrarySearchPath (toRemotePtr p))++resolveObjs :: Interp -> IO SuccessFlag+resolveObjs interp = successIf <$> interpCmd interp ResolveObjs++findSystemLibrary :: Interp -> String -> IO (Maybe String)+findSystemLibrary interp str = interpCmd interp (FindSystemLibrary str)+++-- -----------------------------------------------------------------------------+-- Raw calls and messages++-- | Send a 'Message' and receive the response from the iserv process+iservCall :: Binary a => IServInstance -> Message a -> IO a+iservCall iserv msg =+  remoteCall (iservPipe iserv) msg+    `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+    `catchException` \(e :: SomeException) -> handleIServFailure iserv e++-- | Send a value to the iserv process+writeIServ :: IServInstance -> Put -> IO ()+writeIServ iserv put =+  writePipe (iservPipe iserv) put+    `catchException` \(e :: SomeException) -> handleIServFailure iserv e++handleIServFailure :: IServInstance -> SomeException -> IO a+handleIServFailure iserv e = do+  let proc = iservProcess iserv+  ex <- getProcessExitCode proc+  case ex of+    Just (ExitFailure n) ->+      throwIO (InstallationError ("ghc-iserv terminated (" ++ show n ++ ")"))+    _ -> do+      terminateProcess proc+      _ <- waitForProcess proc+      throw e++-- | Spawn an external interpreter+spawnIServ :: IServConfig -> IO IServInstance+spawnIServ conf = do+  iservConfTrace conf+  let createProc = fromMaybe (\cp -> do { (_,_,_,ph) <- createProcess cp+                                        ; return ph })+                             (iservConfHook conf)+  (ph, rh, wh) <- runWithPipes createProc (iservConfProgram conf)+                                          (iservConfOpts    conf)+  lo_ref <- newIORef Nothing+  return $ IServInstance+    { iservPipe              = Pipe { pipeRead = rh, pipeWrite = wh, pipeLeftovers = lo_ref }+    , iservProcess           = ph+    , iservLookupSymbolCache = emptyUFM+    , iservPendingFrees      = []+    }++-- | Stop the interpreter+stopInterp :: Interp -> IO ()+stopInterp interp = case interpInstance interp of+#if defined(HAVE_INTERNAL_INTERPRETER)+    InternalInterp -> pure ()+#endif+    ExternalInterp _ (IServ mstate) ->+      MC.mask $ \_restore -> modifyMVar_ mstate $ \state -> do+        case state of+          IServPending    -> pure state -- already stopped+          IServRunning i  -> do+            ex <- getProcessExitCode (iservProcess i)+            if isJust ex+               then pure ()+               else iservCall i Shutdown+            pure IServPending++runWithPipes :: (CreateProcess -> IO ProcessHandle)+             -> FilePath -> [String] -> IO (ProcessHandle, Handle, Handle)+#if defined(mingw32_HOST_OS)+foreign import ccall "io.h _close"+   c__close :: CInt -> IO CInt++foreign import ccall unsafe "io.h _get_osfhandle"+   _get_osfhandle :: CInt -> IO CInt++runWithPipes createProc prog opts = do+    (rfd1, wfd1) <- createPipeFd -- we read on rfd1+    (rfd2, wfd2) <- createPipeFd -- we write on wfd2+    wh_client    <- _get_osfhandle wfd1+    rh_client    <- _get_osfhandle rfd2+    let args = show wh_client : show rh_client : opts+    ph <- createProc (proc prog args)+    rh <- mkHandle rfd1+    wh <- mkHandle wfd2+    return (ph, rh, wh)+      where mkHandle :: CInt -> IO Handle+            mkHandle fd = (fdToHandle fd) `Ex.onException` (c__close fd)++#else+runWithPipes createProc prog opts = do+    (rfd1, wfd1) <- Posix.createPipe -- we read on rfd1+    (rfd2, wfd2) <- Posix.createPipe -- we write on wfd2+    setFdOption rfd1 CloseOnExec True+    setFdOption wfd2 CloseOnExec True+    let args = show wfd1 : show rfd2 : opts+    ph <- createProc (proc prog args)+    closeFd wfd1+    closeFd rfd2+    rh <- fdToHandle rfd1+    wh <- fdToHandle wfd2+    return (ph, rh, wh)+#endif++-- -----------------------------------------------------------------------------+{- Note [External GHCi pointers]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We have the following ways to reference things in GHCi:++HValue+------++HValue is a direct reference to a value in the local heap.  Obviously+we cannot use this to refer to things in the external process.+++RemoteRef+---------++RemoteRef is a StablePtr to a heap-resident value.  When+-fexternal-interpreter is used, this value resides in the external+process's heap.  RemoteRefs are mostly used to send pointers in+messages between GHC and iserv.++A RemoteRef must be explicitly freed when no longer required, using+freeHValueRefs, or by attaching a finalizer with mkForeignHValue.++To get from a RemoteRef to an HValue you can use 'wormholeRef', which+fails with an error message if -fexternal-interpreter is in use.++ForeignRef+----------++A ForeignRef is a RemoteRef with a finalizer that will free the+'RemoteRef' when it is garbage collected.  We mostly use ForeignHValue+on the GHC side.++The finalizer adds the RemoteRef to the iservPendingFrees list in the+IServ record.  The next call to interpCmd will free any RemoteRefs in+the list.  It was done this way rather than calling interpCmd directly,+because I didn't want to have arbitrary threads calling interpCmd.  In+principle it would probably be ok, but it seems less hairy this way.+-}++-- | Creates a 'ForeignRef' that will automatically release the+-- 'RemoteRef' when it is no longer referenced.+mkFinalizedHValue :: Interp -> RemoteRef a -> IO (ForeignRef a)+mkFinalizedHValue interp rref = do+   let hvref = toHValueRef rref++   free <- case interpInstance interp of+#if defined(HAVE_INTERNAL_INTERPRETER)+      InternalInterp             -> return (freeRemoteRef hvref)+#endif+      ExternalInterp _ (IServ i) -> return $ modifyMVar_ i $ \state ->+       case state of+         IServPending {}   -> pure state -- already shut down+         IServRunning inst -> do+            let !inst' = inst {iservPendingFrees = hvref:iservPendingFrees inst}+            pure (IServRunning inst')++   mkForeignRef rref free+++freeHValueRefs :: Interp -> [HValueRef] -> IO ()+freeHValueRefs _ [] = return ()+freeHValueRefs interp refs = interpCmd interp (FreeHValueRefs refs)++-- | Convert a 'ForeignRef' to the value it references directly.  This+-- only works when the interpreter is running in the same process as+-- the compiler, so it fails when @-fexternal-interpreter@ is on.+wormhole :: Interp -> ForeignRef a -> IO a+wormhole interp r = wormholeRef interp (unsafeForeignRefToRemoteRef r)++-- | Convert an 'RemoteRef' to the value it references directly.  This+-- only works when the interpreter is running in the same process as+-- the compiler, so it fails when @-fexternal-interpreter@ is on.+wormholeRef :: Interp -> RemoteRef a -> IO a+wormholeRef interp _r = case interpInstance interp of+#if defined(HAVE_INTERNAL_INTERPRETER)+  InternalInterp -> localRef _r+#endif+  ExternalInterp {}+    -> throwIO (InstallationError "this operation requires -fno-external-interpreter")++-- -----------------------------------------------------------------------------+-- Misc utils++fromEvalResult :: EvalResult a -> IO a+fromEvalResult (EvalException e) = throwIO (fromSerializableException e)+fromEvalResult (EvalSuccess a) = return a++getModBreaks :: HomeModInfo -> ModBreaks+getModBreaks hmi+  | Just linkable <- hm_linkable hmi,+    [cbc] <- mapMaybe onlyBCOs $ linkableUnlinked linkable+  = fromMaybe emptyModBreaks (bc_breaks cbc)+  | otherwise+  = emptyModBreaks -- probably object code+  where+    -- The linkable may have 'DotO's as well; only consider BCOs. See #20570.+    onlyBCOs :: Unlinked -> Maybe CompiledByteCode+    onlyBCOs (BCOs cbc _) = Just cbc+    onlyBCOs _            = Nothing++-- | Interpreter uses Profiling way+interpreterProfiled :: Interp -> Bool+interpreterProfiled interp = case interpInstance interp of+#if defined(HAVE_INTERNAL_INTERPRETER)+  InternalInterp     -> hostIsProfiled+#endif+  ExternalInterp c _ -> iservConfProfiled c++-- | Interpreter uses Dynamic way+interpreterDynamic :: Interp -> Bool+interpreterDynamic interp = case interpInstance interp of+#if defined(HAVE_INTERNAL_INTERPRETER)+  InternalInterp     -> hostIsDynamic+#endif+  ExternalInterp c _ -> iservConfDynamic c
compiler/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
+ compiler/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
compiler/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 "GhclibHsVersions.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
+ compiler/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
compiler/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 "GhclibHsVersions.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
compiler/GHC/SysTools/BaseDir.hs view
@@ -17,11 +17,9 @@   , tryFindTopDir   ) where -#include "GhclibHsVersions.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
compiler/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
compiler/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
compiler/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
+ compiler/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
+ compiler/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
+ compiler/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
+ compiler/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
compiler/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 "GhclibHsVersions.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)
compiler/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
compiler/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 "GhclibHsVersions.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
compiler/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 "GhclibHsVersions.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
compiler/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 "GhclibHsVersions.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" ]
+ compiler/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
+ compiler/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"
compiler/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 "GhclibHsVersions.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]
compiler/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+
compiler/GHC/Types/Avail.hs view
@@ -1,11 +1,9 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE DeriveDataTypeable #-} -- -- (c) The University of Glasgow -- -#include "GhclibHsVersions.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
compiler/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
+ compiler/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+  }
compiler/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
compiler/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
compiler/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 "GhclibHsVersions.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
compiler/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)
compiler/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
compiler/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
+ compiler/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
+ compiler/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
compiler/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
compiler/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 "GhclibHsVersions.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
compiler/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 "GhclibHsVersions.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
compiler/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 "GhclibHsVersions.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)
compiler/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
compiler/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 "GhclibHsVersions.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.
compiler/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
compiler/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 "GhclibHsVersions.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
compiler/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 "GhclibHsVersions.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+
compiler/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  {- ************************************************************************
compiler/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 "GhclibHsVersions.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
compiler/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 "GhclibHsVersions.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
compiler/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 "GhclibHsVersions.h"  import GHC.Prelude
+ compiler/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)++
compiler/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 "GhclibHsVersions.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
compiler/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
compiler/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.-
compiler/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
compiler/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 =
compiler/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
compiler/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
compiler/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--
compiler/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]
compiler/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 "GhclibHsVersions.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
compiler/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
compiler/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
compiler/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 "GhclibHsVersions.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
compiler/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
+ compiler/GHC/Types/Unique/SDFM.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ApplicativeDo #-}+{-# OPTIONS_GHC -Wall #-}++-- | Like a 'UniqDFM', but maintains equivalence classes of keys sharing the+-- same entry. See 'UniqSDFM'.+module GHC.Types.Unique.SDFM (+        -- * Unique-keyed, /shared/, deterministic mappings+        UniqSDFM,++        emptyUSDFM,+        lookupUSDFM,+        equateUSDFM, addToUSDFM,+        traverseUSDFM+    ) where++import GHC.Prelude++import GHC.Types.Unique+import GHC.Types.Unique.DFM+import GHC.Utils.Outputable++-- | Either @Indirect x@, meaning the value is represented by that of @x@, or+-- an @Entry@ containing containing the actual value it represents.+data Shared key ele+  = Indirect !key+  | Entry !ele++-- | A 'UniqDFM' whose domain is /sets/ of 'Unique's, each of which share a+-- common value of type @ele@.+-- Every such set (\"equivalence class\") has a distinct representative+-- 'Unique'. Supports merging the entries of multiple such sets in a union-find+-- like fashion.+--+-- An accurate model is that of @[(Set key, Maybe ele)]@: A finite mapping from+-- sets of @key@s to possibly absent entries @ele@, where the sets don't overlap.+-- Example:+-- @+--   m = [({u1,u3}, Just ele1), ({u2}, Just ele2), ({u4,u7}, Nothing)]+-- @+-- On this model we support the following main operations:+--+--   * @'lookupUSDFM' m u3 == Just ele1@, @'lookupUSDFM' m u4 == Nothing@,+--     @'lookupUSDFM' m u5 == Nothing@.+--   * @'equateUSDFM' m u1 u3@ is a no-op, but+--     @'equateUSDFM' m u1 u2@ merges @{u1,u3}@ and @{u2}@ to point to+--     @Just ele2@ and returns the old entry of @{u1,u3}@, @Just ele1@.+--   * @'addToUSDFM' m u3 ele4@ sets the entry of @{u1,u3}@ to @Just ele4@.+--+-- As well as a few means for traversal/conversion to list.+newtype UniqSDFM key ele+  = USDFM { unUSDFM :: UniqDFM key (Shared key ele) }++emptyUSDFM :: UniqSDFM key ele+emptyUSDFM = USDFM emptyUDFM++lookupReprAndEntryUSDFM :: Uniquable key => UniqSDFM key ele -> key -> (key, Maybe ele)+lookupReprAndEntryUSDFM (USDFM env) = go+  where+    go x = case lookupUDFM env x of+      Nothing           -> (x, Nothing)+      Just (Indirect y) -> go y+      Just (Entry ele)  -> (x, Just ele)++-- | @lookupSUDFM env x@ looks up an entry for @x@, looking through all+-- 'Indirect's until it finds a shared 'Entry'.+--+-- Examples in terms of the model (see 'UniqSDFM'):+-- >>> lookupUSDFM [({u1,u3}, Just ele1), ({u2}, Just ele2)] u3 == Just ele1+-- >>> lookupUSDFM [({u1,u3}, Just ele1), ({u2}, Just ele2)] u4 == Nothing+-- >>> lookupUSDFM [({u1,u3}, Just ele1), ({u2}, Nothing)] u2 == Nothing+lookupUSDFM :: Uniquable key => UniqSDFM key ele -> key -> Maybe ele+lookupUSDFM usdfm x = snd (lookupReprAndEntryUSDFM usdfm x)++-- | @equateUSDFM env x y@ makes @x@ and @y@ point to the same entry,+-- thereby merging @x@'s class with @y@'s.+-- If both @x@ and @y@ are in the domain of the map, then @y@'s entry will be+-- chosen as the new entry and @x@'s old entry will be returned.+--+-- Examples in terms of the model (see 'UniqSDFM'):+-- >>> equateUSDFM [] u1 u2 == (Nothing, [({u1,u2}, Nothing)])+-- >>> equateUSDFM [({u1,u3}, Just ele1)] u3 u4 == (Nothing, [({u1,u3,u4}, Just ele1)])+-- >>> equateUSDFM [({u1,u3}, Just ele1)] u4 u3 == (Nothing, [({u1,u3,u4}, Just ele1)])+-- >>> equateUSDFM [({u1,u3}, Just ele1), ({u2}, Just ele2)] u3 u2 == (Just ele1, [({u2,u1,u3}, Just ele2)])+equateUSDFM+  :: Uniquable key => UniqSDFM key ele -> key -> key -> (Maybe ele, UniqSDFM key ele)+equateUSDFM usdfm@(USDFM env) x y =+  case (lu x, lu y) of+    ((x', _)    , (y', _))+      | getUnique x' == getUnique y' -> (Nothing, usdfm) -- nothing to do+    ((x', _)    , (y', Nothing))     -> (Nothing, set_indirect y' x')+    ((x', mb_ex), (y', _))           -> (mb_ex,   set_indirect x' y')+  where+    lu = lookupReprAndEntryUSDFM usdfm+    set_indirect a b = USDFM $ addToUDFM env a (Indirect b)++-- | @addToUSDFM env x a@ sets the entry @x@ is associated with to @a@,+-- thereby modifying its whole equivalence class.+--+-- Examples in terms of the model (see 'UniqSDFM'):+-- >>> addToUSDFM [] u1 ele1 == [({u1}, Just ele1)]+-- >>> addToUSDFM [({u1,u3}, Just ele1)] u3 ele2 == [({u1,u3}, Just ele2)]+addToUSDFM :: Uniquable key => UniqSDFM key ele -> key -> ele -> UniqSDFM key ele+addToUSDFM usdfm@(USDFM env) x v =+  USDFM $ addToUDFM env (fst (lookupReprAndEntryUSDFM usdfm x)) (Entry v)++traverseUSDFM :: forall key a b f. Applicative f => (a -> f b) -> UniqSDFM key a -> f (UniqSDFM key b)+traverseUSDFM f = fmap (USDFM . listToUDFM_Directly) . traverse g . udfmToList . unUSDFM+  where+    g :: (Unique, Shared key a) -> f (Unique, Shared key b)+    g (u, Indirect y) = pure (u,Indirect y)+    g (u, Entry a)    = do+        a' <- f a+        pure (u,Entry a')++instance (Outputable key, Outputable ele) => Outputable (Shared key ele) where+  ppr (Indirect x) = ppr x+  ppr (Entry a)    = ppr a++instance (Outputable key, Outputable ele) => Outputable (UniqSDFM key ele) where+  ppr (USDFM env) = ppr env
compiler/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 "GhclibHsVersions.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
compiler/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 "GhclibHsVersions.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 }  -----------------------
compiler/GHC/Types/Var.hs-boot view
@@ -1,3 +1,4 @@+{-# LANGUAGE NoPolyKinds #-} module GHC.Types.Var where  import GHC.Prelude ()
compiler/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.
compiler/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 "GhclibHsVersions.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
compiler/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]
compiler/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.++-}
compiler/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
compiler/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
compiler/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
compiler/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 ]
compiler/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 "GhclibHsVersions.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
compiler/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
compiler/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)+      }
compiler/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
compiler/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
compiler/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)+         }
compiler/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             = []
compiler/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
compiler/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: --
compiler/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
compiler/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
compiler/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
compiler/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
compiler/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 "GhclibHsVersions.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`)
− compiler/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
compiler/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
compiler/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
compiler/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 "GhclibHsVersions.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
compiler/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 "GhclibHsVersions.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
+ compiler/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
compiler/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 "GhclibHsVersions.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).  -}--
compiler/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
compiler/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 "GhclibHsVersions.h"  import GHC.Prelude
compiler/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 "GhclibHsVersions.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)
compiler/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 "GhclibHsVersions.h"  import GHC.Prelude ()
compiler/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
compiler/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
compiler/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 "GhclibHsVersions.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
compiler/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
+ compiler/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')
compiler/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"
compiler/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)
compiler/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 "GhclibHsVersions.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)
compiler/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
compiler/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
compiler/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
+ compiler/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))
− compiler/GhclibHsVersions.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 () }
compiler/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.*'.
compiler/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
compiler/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)
compiler/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 "GhclibHsVersions.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
compiler/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)
compiler/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 "GhclibHsVersions.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
compiler/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)
compiler/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 "GhclibHsVersions.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)
+ compiler/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
compiler/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 ghc_lib_parser_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; }
− compiler/cbits/keepCAFsForGHCi.c 
@@ -1,35 +0,0 @@-#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));--bool keepCAFsForGHCi(void)-{-    bool was_set = keepCAFs;-    setKeepCAFs();-    return was_set;-}--
+ compiler/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-lib-parser.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.0 build-type: Simple name: ghc-lib-parser-version: 9.2.8.20230729+version: 9.4.1.20220807 license: BSD3 license-file: LICENSE category: Development@@ -17,9 +17,9 @@     llvm-targets     llvm-passes extra-source-files:-    ghc-lib/stage0/lib/ghcautoconf.h-    ghc-lib/stage0/lib/ghcplatform.h-    ghc-lib/stage0/lib/GhclibDerivedConstants.h+    ghc-lib/stage0/rts/build/include/ghcautoconf.h+    ghc-lib/stage0/rts/build/include/ghcplatform.h+    ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h     ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl     ghc-lib/stage0/compiler/build/primop-code-size.hs-incl     ghc-lib/stage0/compiler/build/primop-commutable.hs-incl@@ -37,47 +37,45 @@     ghc-lib/stage0/compiler/build/primop-vector-uniques.hs-incl     ghc-lib/stage0/compiler/build/primop-docs.hs-incl     ghc-lib/stage0/compiler/build/GHC/Platform/Constants.hs-    ghc-lib/stage0/compiler/build/GHC/Settings/Config.hs     ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs     ghc-lib/stage0/libraries/ghc-boot/build/GHC/Platform/Host.hs+    ghc-lib/stage0/compiler/build/GHC/Settings/Config.hs     compiler/GHC/Parser.y     compiler/GHC/Parser/Lexer.x-    includes/MachDeps.h-    includes/stg/MachRegs.h-    includes/CodeGen.Platform.hs+    compiler/GHC/Parser/HaddockLex.x+    compiler/GHC/Parser.hs-boot+    rts/include/ghcconfig.h+    compiler/MachRegs.h+    compiler/CodeGen.Platform.h+    compiler/Bytecodes.h+    compiler/ClosureTypes.h+    compiler/FunTypes.h     compiler/Unique.h-    compiler/GhclibHsVersions.h+    compiler/ghc-llvm-version.h source-repository head     type: git     location: git@github.com:digital-asset/ghc-lib.git-flag threaded-rts-  default: True-  manual: True-  description: Pass -DTHREADED_RTS to the C toolchain+ library     default-language:   Haskell2010     exposed: False     include-dirs:-        includes+        rts/include         ghc-lib/stage0/lib         ghc-lib/stage0/compiler/build         compiler-    if flag(threaded-rts)-        ghc-options: -fobject-code -package=ghc-boot-th -optc-DTHREADED_RTS-        cc-options: -DTHREADED_RTS-        cpp-options: -DTHREADED_RTS-    else-        ghc-options: -fobject-code -package=ghc-boot-th-        cpp-options:+    ghc-options: -fobject-code -package=ghc-boot-th -optc-DTHREADED_RTS+    cc-options: -DTHREADED_RTS+    cpp-options:  -DTHREADED_RTS     if !os(windows)         build-depends: unix     else         build-depends: Win32     build-depends:-        base >= 4.14 && < 4.17,-        ghc-prim > 0.2 && < 0.9,-        bytestring >= 0.9 && < 0.12,-        time >= 1.4 && < 1.12,+        base >= 4.15 && < 4.18,+        ghc-prim > 0.2 && < 0.10,+        bytestring >= 0.10 && < 0.12,+        time >= 1.4 && < 1.13,         exceptions == 0.10.*,         parsec,         containers >= 0.5 && < 0.7,@@ -87,7 +85,7 @@         array >= 0.1 && < 0.6,         deepseq >= 1.4 && < 1.5,         pretty == 1.1.*,-        transformers >= 0.5 && < 0.7,+        transformers == 0.5.*,         process >= 1 && < 1.7     build-tool-depends: alex:alex >= 3.1, happy:happy >= 1.19.4     other-extensions:@@ -128,11 +126,11 @@         MonoLocalBinds         NoImplicitPrelude         ScopedTypeVariables+        TypeOperators     c-sources:         libraries/ghc-heap/cbits/HeapPrim.cmm         compiler/cbits/genSym.c         compiler/cbits/cutils.c-        compiler/cbits/keepCAFsForGHCi.c     hs-source-dirs:         ghc-lib/stage0/libraries/ghc-boot/build         ghc-lib/stage0/compiler/build@@ -149,6 +147,7 @@         GHC.BaseDir         GHC.Builtin.Names         GHC.Builtin.PrimOps+        GHC.Builtin.PrimOps.Ids         GHC.Builtin.Types         GHC.Builtin.Types.Prim         GHC.Builtin.Uniques@@ -166,7 +165,6 @@         GHC.Cmm.Switch         GHC.Cmm.Type         GHC.CmmToAsm.CFG.Weight-        GHC.CmmToAsm.Config         GHC.Core         GHC.Core.Class         GHC.Core.Coercion@@ -179,6 +177,7 @@         GHC.Core.InstEnv         GHC.Core.Lint         GHC.Core.Make+        GHC.Core.Map.Expr         GHC.Core.Map.Type         GHC.Core.Multiplicity         GHC.Core.Opt.Arity@@ -189,10 +188,14 @@         GHC.Core.PatSyn         GHC.Core.Ppr         GHC.Core.Predicate+        GHC.Core.Reduction+        GHC.Core.RoughMap+        GHC.Core.Rules         GHC.Core.Seq         GHC.Core.SimpleOpt         GHC.Core.Stats         GHC.Core.Subst+        GHC.Core.Tidy         GHC.Core.TyCo.FVs         GHC.Core.TyCo.Ppr         GHC.Core.TyCo.Rep@@ -209,6 +212,7 @@         GHC.Core.Utils         GHC.CoreToIface         GHC.Data.Bag+        GHC.Data.Bool         GHC.Data.BooleanFormula         GHC.Data.EnumSet         GHC.Data.FastMutInt@@ -223,21 +227,30 @@         GHC.Data.Pair         GHC.Data.ShortText         GHC.Data.SizedSeq+        GHC.Data.SmallArray         GHC.Data.Stream+        GHC.Data.Strict         GHC.Data.StringBuffer         GHC.Data.TrieMap         GHC.Driver.Backend         GHC.Driver.Backpack.Syntax         GHC.Driver.CmdLine         GHC.Driver.Config+        GHC.Driver.Config.Diagnostic+        GHC.Driver.Config.Logger+        GHC.Driver.Config.Parser         GHC.Driver.Env+        GHC.Driver.Env.KnotVars         GHC.Driver.Env.Types         GHC.Driver.Errors+        GHC.Driver.Errors.Ppr+        GHC.Driver.Errors.Types         GHC.Driver.Flags         GHC.Driver.Hooks         GHC.Driver.Monad         GHC.Driver.Phases         GHC.Driver.Pipeline.Monad+        GHC.Driver.Pipeline.Phases         GHC.Driver.Plugins         GHC.Driver.Ppr         GHC.Driver.Session@@ -262,6 +275,7 @@         GHC.Hs.Binds         GHC.Hs.Decls         GHC.Hs.Doc+        GHC.Hs.DocString         GHC.Hs.Dump         GHC.Hs.Expr         GHC.Hs.Extension@@ -271,6 +285,11 @@         GHC.Hs.Pat         GHC.Hs.Type         GHC.Hs.Utils+        GHC.HsToCore.Errors.Ppr+        GHC.HsToCore.Errors.Types+        GHC.HsToCore.Pmc.Ppr+        GHC.HsToCore.Pmc.Solver.Types+        GHC.HsToCore.Pmc.Types         GHC.Iface.Ext.Fields         GHC.Iface.Recomp.Binary         GHC.Iface.Syntax@@ -278,12 +297,15 @@         GHC.LanguageExtensions         GHC.LanguageExtensions.Type         GHC.Lexeme+        GHC.Linker.Static.Utils         GHC.Linker.Types         GHC.Parser         GHC.Parser.Annotation         GHC.Parser.CharClass-        GHC.Parser.Errors+        GHC.Parser.Errors.Basic         GHC.Parser.Errors.Ppr+        GHC.Parser.Errors.Types+        GHC.Parser.HaddockLex         GHC.Parser.Header         GHC.Parser.Lexer         GHC.Parser.PostProcess@@ -302,7 +324,6 @@         GHC.Platform.Reg.Class         GHC.Platform.Regs         GHC.Platform.S390X-        GHC.Platform.SPARC         GHC.Platform.Ways         GHC.Platform.X86         GHC.Platform.X86_64@@ -310,24 +331,33 @@         GHC.Runtime.Context         GHC.Runtime.Eval.Types         GHC.Runtime.Heap.Layout+        GHC.Runtime.Interpreter         GHC.Runtime.Interpreter.Types         GHC.Serialized         GHC.Settings         GHC.Settings.Config         GHC.Settings.Constants+        GHC.Stg.InferTags.TagSig         GHC.Stg.Syntax+        GHC.StgToCmm.Config         GHC.StgToCmm.Types         GHC.SysTools.BaseDir         GHC.SysTools.Terminal         GHC.Tc.Errors.Hole.FitTypes+        GHC.Tc.Errors.Ppr+        GHC.Tc.Errors.Types+        GHC.Tc.Solver.InertSet+        GHC.Tc.Solver.Types         GHC.Tc.Types         GHC.Tc.Types.Constraint         GHC.Tc.Types.Evidence         GHC.Tc.Types.Origin+        GHC.Tc.Types.Rank         GHC.Tc.Utils.TcType         GHC.Types.Annotations         GHC.Types.Avail         GHC.Types.Basic+        GHC.Types.BreakInfo         GHC.Types.CompleteMatch         GHC.Types.CostCentre         GHC.Types.CostCentre.State@@ -339,6 +369,8 @@         GHC.Types.Fixity.Env         GHC.Types.ForeignCall         GHC.Types.ForeignStubs+        GHC.Types.Hint+        GHC.Types.Hint.Ppr         GHC.Types.HpcInfo         GHC.Types.IPE         GHC.Types.Id@@ -353,6 +385,7 @@         GHC.Types.Name.Ppr         GHC.Types.Name.Reader         GHC.Types.Name.Set+        GHC.Types.PkgQual         GHC.Types.RepType         GHC.Types.SafeHaskell         GHC.Types.SourceError@@ -368,6 +401,7 @@         GHC.Types.Unique.DSet         GHC.Types.Unique.FM         GHC.Types.Unique.Map+        GHC.Types.Unique.SDFM         GHC.Types.Unique.Set         GHC.Types.Unique.Supply         GHC.Types.Var@@ -403,6 +437,7 @@         GHC.Utils.Binary.Typeable         GHC.Utils.BufHandle         GHC.Utils.CliOption+        GHC.Utils.Constants         GHC.Utils.Encoding         GHC.Utils.Error         GHC.Utils.Exception@@ -415,17 +450,21 @@         GHC.Utils.Logger         GHC.Utils.Misc         GHC.Utils.Monad+        GHC.Utils.Monad.State.Strict         GHC.Utils.Outputable         GHC.Utils.Panic         GHC.Utils.Panic.Plain         GHC.Utils.Ppr         GHC.Utils.Ppr.Colour         GHC.Utils.TmpFs+        GHC.Utils.Trace         GHC.Version+        GHCi.BinaryArray         GHCi.BreakArray         GHCi.FFI         GHCi.Message         GHCi.RemoteTypes+        GHCi.ResolvedBCO         GHCi.TH.Binary         Language.Haskell.Syntax         Language.Haskell.Syntax.Binds
ghc-lib/stage0/compiler/build/GHC/Platform/Constants.hs view
@@ -131,8 +131,9 @@       pc_LDV_SHIFT :: {-# UNPACK #-} !Int,       pc_ILDV_CREATE_MASK :: !Integer,       pc_ILDV_STATE_CREATE :: !Integer,-      pc_ILDV_STATE_USE :: !Integer-  } deriving (Show,Read,Eq)+      pc_ILDV_STATE_USE :: !Integer,+      pc_USE_INLINE_SRT_FIELD :: !Bool+  } deriving (Show, Read, Eq, Ord)   parseConstantsHeader :: FilePath -> IO PlatformConstants@@ -140,7 +141,8 @@   s <- readFile fp   let def = "#define HS_CONSTANTS \""       find [] xs = xs-      find _  [] = error $ "Couldn't find " ++ def ++ " in " ++ fp+      find _  [] = error $ "GHC couldn't find the RTS constants ("++def++") in " ++ fp ++ ": the RTS package you are trying to use is perhaps for another GHC version" +++                               "(e.g. you are using the wrong package database) or the package database is broken.\n"       find (d:ds) (x:xs)         | d == x    = find ds xs         | otherwise = find def xs@@ -164,6 +166,7 @@      ,v80,v81,v82,v83,v84,v85,v86,v87,v88,v89,v90,v91,v92,v93,v94,v95      ,v96,v97,v98,v99,v100,v101,v102,v103,v104,v105,v106,v107,v108,v109,v110,v111      ,v112,v113,v114,v115,v116,v117,v118,v119,v120,v121,v122,v123,v124,v125,v126,v127+     ,v128      ] -> PlatformConstants             { pc_CONTROL_GROUP_CONST_291 = fromIntegral v0             , pc_STD_HDR_SIZE = fromIntegral v1@@ -293,6 +296,7 @@             , pc_ILDV_CREATE_MASK = v125             , pc_ILDV_STATE_CREATE = v126             , pc_ILDV_STATE_USE = v127+            , pc_USE_INLINE_SRT_FIELD = 0 < v128             }     _ -> error "Invalid platform constants"
ghc-lib/stage0/compiler/build/GHC/Settings/Config.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} module GHC.Settings.Config   ( module GHC.Version   , cBuildPlatformString@@ -22,7 +21,7 @@ cProjectName          = "The Glorious Glasgow Haskell Compilation System"  cBooterVersion        :: String-cBooterVersion        = "8.10.4"+cBooterVersion        = "9.2.2"  cStage                :: String cStage                = show (1 :: Int)
ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl view
@@ -16,6 +16,10 @@ primOpCanFail Word32QuotOp = True primOpCanFail Word32RemOp = True primOpCanFail Word32QuotRemOp = True+primOpCanFail Int64QuotOp = True+primOpCanFail Int64RemOp = True+primOpCanFail Word64QuotOp = True+primOpCanFail Word64RemOp = True primOpCanFail IntQuotOp = True primOpCanFail IntRemOp = True primOpCanFail IntQuotRemOp = True@@ -42,6 +46,7 @@ primOpCanFail CloneMutableArrayOp = True primOpCanFail FreezeArrayOp = True primOpCanFail ThawArrayOp = True+primOpCanFail CasArrayOp = True primOpCanFail ReadSmallArrayOp = True primOpCanFail WriteSmallArrayOp = True primOpCanFail IndexSmallArrayOp = True@@ -51,6 +56,7 @@ primOpCanFail CloneSmallMutableArrayOp = True primOpCanFail FreezeSmallArrayOp = True primOpCanFail ThawSmallArrayOp = True+primOpCanFail CasSmallArrayOp = True primOpCanFail IndexByteArrayOp_Char = True primOpCanFail IndexByteArrayOp_WideChar = True primOpCanFail IndexByteArrayOp_Int = True@@ -151,24 +157,16 @@ primOpCanFail AtomicReadByteArrayOp_Int = True primOpCanFail AtomicWriteByteArrayOp_Int = True primOpCanFail CasByteArrayOp_Int = True+primOpCanFail CasByteArrayOp_Int8 = True+primOpCanFail CasByteArrayOp_Int16 = True+primOpCanFail CasByteArrayOp_Int32 = True+primOpCanFail CasByteArrayOp_Int64 = True primOpCanFail FetchAddByteArrayOp_Int = True primOpCanFail FetchSubByteArrayOp_Int = True primOpCanFail FetchAndByteArrayOp_Int = True primOpCanFail FetchNandByteArrayOp_Int = True primOpCanFail FetchOrByteArrayOp_Int = True primOpCanFail FetchXorByteArrayOp_Int = True-primOpCanFail IndexArrayArrayOp_ByteArray = True-primOpCanFail IndexArrayArrayOp_ArrayArray = True-primOpCanFail ReadArrayArrayOp_ByteArray = True-primOpCanFail ReadArrayArrayOp_MutableByteArray = True-primOpCanFail ReadArrayArrayOp_ArrayArray = True-primOpCanFail ReadArrayArrayOp_MutableArrayArray = True-primOpCanFail WriteArrayArrayOp_ByteArray = True-primOpCanFail WriteArrayArrayOp_MutableByteArray = True-primOpCanFail WriteArrayArrayOp_ArrayArray = True-primOpCanFail WriteArrayArrayOp_MutableArrayArray = True-primOpCanFail CopyArrayArrayOp = True-primOpCanFail CopyMutableArrayArrayOp = True primOpCanFail IndexOffAddrOp_Char = True primOpCanFail IndexOffAddrOp_WideChar = True primOpCanFail IndexOffAddrOp_Int = True@@ -221,6 +219,10 @@ primOpCanFail InterlockedExchange_Word = True primOpCanFail CasAddrOp_Addr = True primOpCanFail CasAddrOp_Word = True+primOpCanFail CasAddrOp_Word8 = True+primOpCanFail CasAddrOp_Word16 = True+primOpCanFail CasAddrOp_Word32 = True+primOpCanFail CasAddrOp_Word64 = True primOpCanFail FetchAddAddrOp_Word = True primOpCanFail FetchSubAddrOp_Word = True primOpCanFail FetchAndAddrOp_Word = True
ghc-lib/stage0/compiler/build/primop-code-size.hs-incl view
@@ -5,6 +5,8 @@ primOpCodeSize Word16ToInt16Op = 0 primOpCodeSize Int32ToWord32Op = 0 primOpCodeSize Word32ToInt32Op = 0+primOpCodeSize Int64ToWord64Op = 0+primOpCodeSize Word64ToInt64Op = 0 primOpCodeSize IntAddCOp = 2 primOpCodeSize IntSubCOp = 2 primOpCodeSize ChrOp = 0
ghc-lib/stage0/compiler/build/primop-commutable.hs-incl view
@@ -21,6 +21,13 @@ commutableOp Word32AndOp = True commutableOp Word32OrOp = True commutableOp Word32XorOp = True+commutableOp Int64AddOp = True+commutableOp Int64MulOp = True+commutableOp Word64AddOp = True+commutableOp Word64MulOp = True+commutableOp Word64AndOp = True+commutableOp Word64OrOp = True+commutableOp Word64XorOp = True commutableOp IntAddOp = True commutableOp IntMulOp = True commutableOp IntMulMayOfloOp = True
ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl view
@@ -126,6 +126,44 @@    | Word32LeOp    | Word32LtOp    | Word32NeOp+   | Int64ToIntOp+   | IntToInt64Op+   | Int64NegOp+   | Int64AddOp+   | Int64SubOp+   | Int64MulOp+   | Int64QuotOp+   | Int64RemOp+   | Int64SllOp+   | Int64SraOp+   | Int64SrlOp+   | Int64ToWord64Op+   | Int64EqOp+   | Int64GeOp+   | Int64GtOp+   | Int64LeOp+   | Int64LtOp+   | Int64NeOp+   | Word64ToWordOp+   | WordToWord64Op+   | Word64AddOp+   | Word64SubOp+   | Word64MulOp+   | Word64QuotOp+   | Word64RemOp+   | Word64AndOp+   | Word64OrOp+   | Word64XorOp+   | Word64NotOp+   | Word64SllOp+   | Word64SrlOp+   | Word64ToInt64Op+   | Word64EqOp+   | Word64GeOp+   | Word64GtOp+   | Word64LeOp+   | Word64LtOp+   | Word64NeOp    | IntAddOp    | IntSubOp    | IntMulOp@@ -288,7 +326,6 @@    | FloatToDoubleOp    | FloatDecode_IntOp    | NewArrayOp-   | SameMutableArrayOp    | ReadArrayOp    | WriteArrayOp    | SizeofArrayOp@@ -304,7 +341,6 @@    | ThawArrayOp    | CasArrayOp    | NewSmallArrayOp-   | SameSmallMutableArrayOp    | ShrinkSmallMutableArrayOp_Char    | ReadSmallArrayOp    | WriteSmallArrayOp@@ -328,7 +364,6 @@    | ByteArrayIsPinnedOp    | ByteArrayContents_Char    | MutableByteArrayContents_Char-   | SameMutableByteArrayOp    | ShrinkMutableByteArrayOp_Char    | ResizeMutableByteArrayOp_Char    | UnsafeFreezeByteArrayOp@@ -435,29 +470,16 @@    | AtomicReadByteArrayOp_Int    | AtomicWriteByteArrayOp_Int    | CasByteArrayOp_Int+   | CasByteArrayOp_Int8+   | CasByteArrayOp_Int16+   | CasByteArrayOp_Int32+   | CasByteArrayOp_Int64    | FetchAddByteArrayOp_Int    | FetchSubByteArrayOp_Int    | FetchAndByteArrayOp_Int    | FetchNandByteArrayOp_Int    | FetchOrByteArrayOp_Int    | FetchXorByteArrayOp_Int-   | NewArrayArrayOp-   | SameMutableArrayArrayOp-   | UnsafeFreezeArrayArrayOp-   | SizeofArrayArrayOp-   | SizeofMutableArrayArrayOp-   | IndexArrayArrayOp_ByteArray-   | IndexArrayArrayOp_ArrayArray-   | ReadArrayArrayOp_ByteArray-   | ReadArrayArrayOp_MutableByteArray-   | ReadArrayArrayOp_ArrayArray-   | ReadArrayArrayOp_MutableArrayArray-   | WriteArrayArrayOp_ByteArray-   | WriteArrayArrayOp_MutableByteArray-   | WriteArrayArrayOp_ArrayArray-   | WriteArrayArrayOp_MutableArrayArray-   | CopyArrayArrayOp-   | CopyMutableArrayArrayOp    | AddrAddOp    | AddrSubOp    | AddrRemOp@@ -521,6 +543,10 @@    | InterlockedExchange_Word    | CasAddrOp_Addr    | CasAddrOp_Word+   | CasAddrOp_Word8+   | CasAddrOp_Word16+   | CasAddrOp_Word32+   | CasAddrOp_Word64    | FetchAddAddrOp_Word    | FetchSubAddrOp_Word    | FetchAndAddrOp_Word@@ -532,7 +558,6 @@    | NewMutVarOp    | ReadMutVarOp    | WriteMutVarOp-   | SameMutVarOp    | AtomicModifyMutVar2Op    | AtomicModifyMutVar_Op    | CasMutVarOp@@ -551,7 +576,6 @@    | ReadTVarOp    | ReadTVarIOOp    | WriteTVarOp-   | SameTVarOp    | NewMVarOp    | TakeMVarOp    | TryTakeMVarOp@@ -559,12 +583,10 @@    | TryPutMVarOp    | ReadMVarOp    | TryReadMVarOp-   | SameMVarOp    | IsEmptyMVarOp-   | NewIOPortrOp+   | NewIOPortOp    | ReadIOPortOp    | WriteIOPortOp-   | SameIOPortOp    | DelayOp    | WaitReadOp    | WaitWriteOp@@ -587,7 +609,6 @@    | DeRefStablePtrOp    | EqStablePtrOp    | MakeStableNameOp-   | EqStableNameOp    | StableNameToIntOp    | CompactNewOp    | CompactResizeOp
ghc-lib/stage0/compiler/build/primop-docs.hs-incl view
@@ -79,7 +79,7 @@   , ("cloneMutableArray#","Given a source array, an offset into the source array, and a number\n   of elements to copy, create a new array with the elements from the\n   source array. The provided array must fully contain the specified\n   range, but this is not checked.")   , ("freezeArray#","Given a source array, an offset into the source array, and a number\n   of elements to copy, create a new array with the elements from the\n   source array. The provided array must fully contain the specified\n   range, but this is not checked.")   , ("thawArray#","Given a source array, an offset into the source array, and a number\n   of elements to copy, create a new array with the elements from the\n   source array. The provided array must fully contain the specified\n   range, but this is not checked.")-  , ("casArray#","Given an array, an offset, the expected old value, and\n    the new value, perform an atomic compare and swap (i.e. write the new\n    value if the current value and the old value are the same pointer).\n    Returns 0 if the swap succeeds and 1 if it fails. Additionally, returns\n    the element at the offset after the operation completes. This means that\n    on a success the new value is returned, and on a failure the actual old\n    value (not the expected one) is returned. Implies a full memory barrier.\n    The use of a pointer equality on a lifted value makes this function harder\n    to use correctly than @casIntArray\\#@. All of the difficulties\n    of using @reallyUnsafePtrEquality\\#@ correctly apply to\n    @casArray\\#@ as well.\n   ")+  , ("casArray#","Given an array, an offset, the expected old value, and\n    the new value, perform an atomic compare and swap (i.e. write the new\n    value if the current value and the old value are the same pointer).\n    Returns 0 if the swap succeeds and 1 if it fails. Additionally, returns\n    the element at the offset after the operation completes. This means that\n    on a success the new value is returned, and on a failure the actual old\n    value (not the expected one) is returned. Implies a full memory barrier.\n    The use of a pointer equality on a boxed value makes this function harder\n    to use correctly than @casIntArray\\#@. All of the difficulties\n    of using @reallyUnsafePtrEquality\\#@ correctly apply to\n    @casArray\\#@ as well.\n   ")   , ("newSmallArray#","Create a new mutable array with the specified number of elements,\n    in the specified state thread,\n    with each element containing the specified initial value.")   , ("shrinkSmallMutableArray#","Shrink mutable array to new specified size, in\n    the specified state thread. The new size argument must be less than or\n    equal to the current size as reported by @getSizeofSmallMutableArray\\#@.")   , ("readSmallArray#","Read from specified index of mutable array. Result is not yet evaluated.")@@ -212,18 +212,16 @@   , ("atomicReadIntArray#","Given an array and an offset in machine words, read an element. The\n    index is assumed to be in bounds. Implies a full memory barrier.")   , ("atomicWriteIntArray#","Given an array and an offset in machine words, write an element. The\n    index is assumed to be in bounds. Implies a full memory barrier.")   , ("casIntArray#","Given an array, an offset in machine words, the expected old value, and\n    the new value, perform an atomic compare and swap i.e. write the new\n    value if the current value matches the provided old value. Returns\n    the value of the element before the operation. Implies a full memory\n    barrier.")+  , ("casInt8Array#","Given an array, an offset in bytes, the expected old value, and\n    the new value, perform an atomic compare and swap i.e. write the new\n    value if the current value matches the provided old value. Returns\n    the value of the element before the operation. Implies a full memory\n    barrier.")+  , ("casInt16Array#","Given an array, an offset in 16 bit units, the expected old value, and\n    the new value, perform an atomic compare and swap i.e. write the new\n    value if the current value matches the provided old value. Returns\n    the value of the element before the operation. Implies a full memory\n    barrier.")+  , ("casInt32Array#","Given an array, an offset in 32 bit units, the expected old value, and\n    the new value, perform an atomic compare and swap i.e. write the new\n    value if the current value matches the provided old value. Returns\n    the value of the element before the operation. Implies a full memory\n    barrier.")+  , ("casInt64Array#","Given an array, an offset in 64 bit units, the expected old value, and\n    the new value, perform an atomic compare and swap i.e. write the new\n    value if the current value matches the provided old value. Returns\n    the value of the element before the operation. Implies a full memory\n    barrier.")   , ("fetchAddIntArray#","Given an array, and offset in machine words, and a value to add,\n    atomically add the value to the element. Returns the value of the\n    element before the operation. Implies a full memory barrier.")   , ("fetchSubIntArray#","Given an array, and offset in machine words, and a value to subtract,\n    atomically subtract the value from the element. Returns the value of\n    the element before the operation. Implies a full memory barrier.")   , ("fetchAndIntArray#","Given an array, and offset in machine words, and a value to AND,\n    atomically AND the value into the element. Returns the value of the\n    element before the operation. Implies a full memory barrier.")   , ("fetchNandIntArray#","Given an array, and offset in machine words, and a value to NAND,\n    atomically NAND the value into the element. Returns the value of the\n    element before the operation. Implies a full memory barrier.")   , ("fetchOrIntArray#","Given an array, and offset in machine words, and a value to OR,\n    atomically OR the value into the element. Returns the value of the\n    element before the operation. Implies a full memory barrier.")   , ("fetchXorIntArray#","Given an array, and offset in machine words, and a value to XOR,\n    atomically XOR the value into the element. Returns the value of the\n    element before the operation. Implies a full memory barrier.")-  , ("newArrayArray#","Create a new mutable array of arrays with the specified number of elements,\n    in the specified state thread, with each element recursively referring to the\n    newly created array.")-  , ("unsafeFreezeArrayArray#","Make a mutable array of arrays immutable, without copying.")-  , ("sizeofArrayArray#","Return the number of elements in the array.")-  , ("sizeofMutableArrayArray#","Return the number of elements in the array.")-  , ("copyArrayArray#","Copy a range of the ArrayArray\\# to the specified region in the MutableArrayArray\\#.\n   Both arrays must fully contain the specified ranges, but this is not checked.\n   The two arrays must not be the same array in different states, but this is not checked either.")-  , ("copyMutableArrayArray#","Copy a range of the first MutableArrayArray# to the specified region in the second\n   MutableArrayArray#.\n   Both arrays must fully contain the specified ranges, but this is not checked.\n   The regions are allowed to overlap, although this is only possible when the same\n   array is provided as both the source and the destination.\n   ")   , ("Addr#"," An arbitrary machine address assumed to point outside\n         the garbage-collected heap. ")   , ("nullAddr#"," The null address. ")   , ("minusAddr#","Result is meaningless if two @Addr\\#@s are so far apart that their\n         difference doesn't fit in an @Int\\#@.")@@ -238,6 +236,10 @@   , ("atomicExchangeWordAddr#","The atomic exchange operation. Atomically exchanges the value at the address\n    with the given value. Returns the old value. Implies a read barrier.")   , ("atomicCasAddrAddr#"," Compare and swap on a word-sized memory location.\n\n     Use as: \\s -> atomicCasAddrAddr# location expected desired s\n\n     This version always returns the old value read. This follows the normal\n     protocol for CAS operations (and matches the underlying instruction on\n     most architectures).\n\n     Implies a full memory barrier.")   , ("atomicCasWordAddr#"," Compare and swap on a word-sized and aligned memory location.\n\n     Use as: \\s -> atomicCasWordAddr# location expected desired s\n\n     This version always returns the old value read. This follows the normal\n     protocol for CAS operations (and matches the underlying instruction on\n     most architectures).\n\n     Implies a full memory barrier.")+  , ("atomicCasWord8Addr#"," Compare and swap on a 8 bit-sized and aligned memory location.\n\n     Use as: \\s -> atomicCasWordAddr8# location expected desired s\n\n     This version always returns the old value read. This follows the normal\n     protocol for CAS operations (and matches the underlying instruction on\n     most architectures).\n\n     Implies a full memory barrier.")+  , ("atomicCasWord16Addr#"," Compare and swap on a 16 bit-sized and aligned memory location.\n\n     Use as: \\s -> atomicCasWordAddr16# location expected desired s\n\n     This version always returns the old value read. This follows the normal\n     protocol for CAS operations (and matches the underlying instruction on\n     most architectures).\n\n     Implies a full memory barrier.")+  , ("atomicCasWord32Addr#"," Compare and swap on a 32 bit-sized and aligned memory location.\n\n     Use as: \\s -> atomicCasWordAddr32# location expected desired s\n\n     This version always returns the old value read. This follows the normal\n     protocol for CAS operations (and matches the underlying instruction on\n     most architectures).\n\n     Implies a full memory barrier.")+  , ("atomicCasWord64Addr#"," Compare and swap on a 64 bit-sized and aligned memory location.\n\n     Use as: \\s -> atomicCasWordAddr64# location expected desired s\n\n     This version always returns the old value read. This follows the normal\n     protocol for CAS operations (and matches the underlying instruction on\n     most architectures).\n\n     Implies a full memory barrier.")   , ("fetchAddWordAddr#","Given an address, and a value to add,\n    atomically add the value to the element. Returns the value of the\n    element before the operation. Implies a full memory barrier.")   , ("fetchSubWordAddr#","Given an address, and a value to subtract,\n    atomically subtract the value from the element. Returns the value of\n    the element before the operation. Implies a full memory barrier.")   , ("fetchAndWordAddr#","Given an address, and a value to AND,\n    atomically AND the value into the element. Returns the value of the\n    element before the operation. Implies a full memory barrier.")@@ -252,9 +254,10 @@   , ("writeMutVar#","Write contents of @MutVar\\#@.")   , ("atomicModifyMutVar2#"," Modify the contents of a @MutVar\\#@, returning the previous\n     contents and the result of applying the given function to the\n     previous contents. Note that this isn't strictly\n     speaking the correct type for this function; it should really be\n     @MutVar\\# s a -> (a -> (a,b)) -> State\\# s -> (\\# State\\# s, a, (a, b) \\#)@,\n     but we don't know about pairs here. ")   , ("atomicModifyMutVar_#"," Modify the contents of a @MutVar\\#@, returning the previous\n     contents and the result of applying the given function to the\n     previous contents. ")+  , ("casMutVar#"," Compare-and-swap: perform a pointer equality test between\n     the first value passed to this function and the value\n     stored inside the @MutVar\\#@. If the pointers are equal,\n     replace the stored value with the second value passed to this\n     function, otherwise do nothing.\n     Returns the final value stored inside the @MutVar\\#@.\n     The @Int\\#@ indicates whether a swap took place,\n     with @1\\#@ meaning that we didn't swap, and @0\\#@\n     that we did.\n     Implies a full memory barrier.\n     Because the comparison is done on the level of pointers,\n     all of the difficulties of using\n     @reallyUnsafePtrEquality\\#@ correctly apply to\n     @casMutVar\\#@ as well.\n   ")   , ("newTVar#","Create a new @TVar\\#@ holding a specified initial value.")-  , ("readTVar#","Read contents of @TVar\\#@.  Result is not yet evaluated.")-  , ("readTVarIO#","Read contents of @TVar\\#@ outside an STM transaction")+  , ("readTVar#","Read contents of @TVar\\#@ inside an STM transaction,\n    i.e. within a call to @atomically\\#@.\n    Does not force evaluation of the result.")+  , ("readTVarIO#","Read contents of @TVar\\#@ outside an STM transaction.\n   Does not force evaluation of the result.")   , ("writeTVar#","Write contents of @TVar\\#@.")   , ("MVar#"," A shared mutable variable (/not/ the same as a @MutVar\\#@!).\n        (Note: in a non-concurrent implementation, @(MVar\\# a)@ can be\n        represented by @(MutVar\\# (Maybe a))@.) ")   , ("newMVar#","Create new @MVar\\#@; initially empty.")@@ -267,8 +270,8 @@   , ("isEmptyMVar#","Return 1 if @MVar\\#@ is empty; 0 otherwise.")   , ("IOPort#"," A shared I/O port is almost the same as a @MVar\\#@!).\n        The main difference is that IOPort has no deadlock detection or\n        deadlock breaking code that forcibly releases the lock. ")   , ("newIOPort#","Create new @IOPort\\#@; initially empty.")-  , ("readIOPort#","If @IOPort\\#@ is empty, block until it becomes full.\n   Then remove and return its contents, and set it empty.")-  , ("writeIOPort#","If @IOPort\\#@ is full, immediately return with integer 0.\n    Otherwise, store value arg as @IOPort\\#@'s new contents,\n    and return with integer 1. ")+  , ("readIOPort#","If @IOPort\\#@ is empty, block until it becomes full.\n   Then remove and return its contents, and set it empty.\n   Throws an @IOPortException@ if another thread is already\n   waiting to read this @IOPort\\#@.")+  , ("writeIOPort#","If @IOPort\\#@ is full, immediately return with integer 0,\n    throwing an @IOPortException@.\n    Otherwise, store value arg as @IOPort\\#@'s new contents,\n    and return with integer 1. ")   , ("delay#","Sleep specified number of microseconds.")   , ("waitRead#","Block until input is available on specified file descriptor.")   , ("waitWrite#","Block until output is possible on specified file descriptor.")@@ -291,7 +294,7 @@   , ("compactSize#"," Return the total capacity (in bytes) of all the compact blocks\n     in the CNF. ")   , ("reallyUnsafePtrEquality#"," Returns @1\\#@ if the given pointers are equal and @0\\#@ otherwise. ")   , ("numSparks#"," Returns the number of sparks in the local spark pool. ")-  , ("keepAlive#"," \\tt{keepAlive# x s k} keeps the value \\tt{x} alive during the execution\n     of the computation \\tt{k}. ")+  , ("keepAlive#"," \\tt{keepAlive# x s k} keeps the value \\tt{x} alive during the execution\n     of the computation \\tt{k}.\n\n     Note that the result type here isn't quite as unrestricted as the\n     polymorphic type might suggest; ticket \\#21868 for details. ")   , ("BCO"," Primitive bytecode type. ")   , ("addrToAny#"," Convert an @Addr\\#@ to a followable Any type. ")   , ("anyToAddr#"," Retrieve the address of any Haskell value. This is\n     essentially an @unsafeCoerce\\#@, but if implemented as such\n     the core lint pass complains and fails to compile.\n     As a primop, it is opaque to core/stg, and only appears\n     in cmm (where the copy propagation pass will get rid of it).\n     Note that \"a\" must be a value, not a thunk! It's too late\n     for strictness analysis to enforce this, so you're on your\n     own to guarantee this. Also note that @Addr\\#@ is not a GC\n     pointer - up to you to guarantee that it does not become\n     a dangling pointer immediately after you get it.")@@ -302,10 +305,9 @@   , ("getCurrentCCS#"," Returns the current @CostCentreStack@ (value is @NULL@ if\n     not profiling).  Takes a dummy argument which can be used to\n     avoid the call to @getCurrentCCS\\#@ being floated out by the\n     simplifier, which would result in an uninformative stack\n     (\"CAF\"). ")   , ("clearCCS#"," Run the supplied IO action with an empty CCS.  For example, this\n     is used by the interpreter to run an interpreted computation\n     without the call stack showing that it was invoked from GHC. ")   , ("whereFrom#"," Returns the @InfoProvEnt @ for the info table of the given object\n     (value is @NULL@ if the table does not exist or there is no information\n     about the closure).")-  , ("FUN","The builtin function type, written in infix form as @a # m -> b@.\n   Values of this type are functions taking inputs of type @a@ and\n   producing outputs of type @b@. The multiplicity of the input is\n   @m@.\n\n   Note that @FUN m a b@ permits levity-polymorphism in both @a@ and\n   @b@, so that types like @Int\\# -> Int\\#@ can still be well-kinded.\n  ")+  , ("FUN","The builtin function type, written in infix form as @a # m -> b@.\n   Values of this type are functions taking inputs of type @a@ and\n   producing outputs of type @b@. The multiplicity of the input is\n   @m@.\n\n   Note that @FUN m a b@ permits representation polymorphism in both\n   @a@ and @b@, so that types like @Int\\# -> Int\\#@ can still be\n   well-kinded.\n  ")   , ("realWorld#"," The token used in the implementation of the IO monad as a state monad.\n     It does not pass any information at runtime.\n     See also @GHC.Magic.runRW\\#@. ")   , ("void#"," This is an alias for the unboxed unit tuple constructor.\n     In earlier versions of GHC, @void\\#@ was a value\n     of the primitive type @Void\\#@, which is now defined to be @(\\# \\#)@.\n   ")-  , ("magicDict"," @magicDict@ is a special-purpose placeholder value.\n     It is used internally by modules such as @GHC.TypeNats@ to cast a typeclass\n     dictionary with a single method. It is eliminated by a rule during compilation.\n     For the details, see Note [magicDictId magic] in GHC. ")   , ("Proxy#"," The type constructor @Proxy#@ is used to bear witness to some\n   type variable. It's used when you want to pass around proxy values\n   for doing things like modelling type applications. A @Proxy#@\n   is not only unboxed, it also has a polymorphic kind, and has no\n   runtime representation, being totally free. ")   , ("proxy#"," Witness for an unboxed @Proxy#@ value, which has no runtime\n   representation. ")   , ("seq"," The value of @seq a b@ is bottom if @a@ is bottom, and\n     otherwise equal to @b@. In other words, it evaluates the first\n     argument @a@ to weak head normal form (WHNF). @seq@ is usually\n     introduced to improve performance by avoiding unneeded laziness.\n\n     A note on evaluation order: the expression @seq a b@ does\n     /not/ guarantee that @a@ will be evaluated before @b@.\n     The only guarantee given by @seq@ is that the both @a@\n     and @b@ will be evaluated before @seq@ returns a value.\n     In particular, this means that @b@ may be evaluated before\n     @a@. If you need to guarantee a specific order of evaluation,\n     you must use the function @pseq@ from the \"parallel\" package. ")@@ -314,7 +316,8 @@   , ("traceBinaryEvent#"," Emits an event via the RTS tracing framework.  The contents\n     of the event is the binary object passed as the first argument with\n     the given length passed as the second argument. The event will be\n     emitted to the @.eventlog@ file. ")   , ("traceMarker#"," Emits a marker event via the RTS tracing framework.  The contents\n     of the event is the zero-terminated byte string passed as the first\n     argument.  The event will be emitted either to the @.eventlog@ file,\n     or to stderr, depending on the runtime RTS flags. ")   , ("setThreadAllocationCounter#"," Sets the allocation counter for the current thread to the given value. ")-  , ("coerce"," The function @coerce@ allows you to safely convert between values of\n     types that have the same representation with no run-time overhead. In the\n     simplest case you can use it instead of a newtype constructor, to go from\n     the newtype's concrete type to the abstract type. But it also works in\n     more complicated settings, e.g. converting a list of newtypes to a list of\n     concrete types.\n\n     This function is runtime-representation polymorphic, but the\n     @RuntimeRep@ type argument is marked as @Inferred@, meaning\n     that it is not available for visible type application. This means\n     the typechecker will accept @coerce @Int @Age 42@.\n   ")+  , ("StackSnapshot#"," Haskell representation of a @StgStack*@ that was created (cloned)\n     with a function in @GHC.Stack.CloneStack@. Please check the\n     documentation in this module for more detailed explanations. ")+  , ("coerce"," The function @coerce@ allows you to safely convert between values of\n     types that have the same representation with no run-time overhead. In the\n     simplest case you can use it instead of a newtype constructor, to go from\n     the newtype's concrete type to the abstract type. But it also works in\n     more complicated settings, e.g. converting a list of newtypes to a list of\n     concrete types.\n\n     This function is representation-polymorphic, but the\n     @RuntimeRep@ type argument is marked as @Inferred@, meaning\n     that it is not available for visible type application. This means\n     the typechecker will accept @coerce @Int @Age 42@.\n   ")   , ("broadcastInt8X16#"," Broadcast a scalar to all elements of a vector. ")   , ("broadcastInt16X8#"," Broadcast a scalar to all elements of a vector. ")   , ("broadcastInt32X4#"," Broadcast a scalar to all elements of a vector. ")
ghc-lib/stage0/compiler/build/primop-has-side-effects.hs-incl view
@@ -98,24 +98,16 @@ primOpHasSideEffects AtomicReadByteArrayOp_Int = True primOpHasSideEffects AtomicWriteByteArrayOp_Int = True primOpHasSideEffects CasByteArrayOp_Int = True+primOpHasSideEffects CasByteArrayOp_Int8 = True+primOpHasSideEffects CasByteArrayOp_Int16 = True+primOpHasSideEffects CasByteArrayOp_Int32 = True+primOpHasSideEffects CasByteArrayOp_Int64 = True primOpHasSideEffects FetchAddByteArrayOp_Int = True primOpHasSideEffects FetchSubByteArrayOp_Int = True primOpHasSideEffects FetchAndByteArrayOp_Int = True primOpHasSideEffects FetchNandByteArrayOp_Int = True primOpHasSideEffects FetchOrByteArrayOp_Int = True primOpHasSideEffects FetchXorByteArrayOp_Int = True-primOpHasSideEffects NewArrayArrayOp = True-primOpHasSideEffects UnsafeFreezeArrayArrayOp = True-primOpHasSideEffects ReadArrayArrayOp_ByteArray = True-primOpHasSideEffects ReadArrayArrayOp_MutableByteArray = True-primOpHasSideEffects ReadArrayArrayOp_ArrayArray = True-primOpHasSideEffects ReadArrayArrayOp_MutableArrayArray = True-primOpHasSideEffects WriteArrayArrayOp_ByteArray = True-primOpHasSideEffects WriteArrayArrayOp_MutableByteArray = True-primOpHasSideEffects WriteArrayArrayOp_ArrayArray = True-primOpHasSideEffects WriteArrayArrayOp_MutableArrayArray = True-primOpHasSideEffects CopyArrayArrayOp = True-primOpHasSideEffects CopyMutableArrayArrayOp = True primOpHasSideEffects ReadOffAddrOp_Char = True primOpHasSideEffects ReadOffAddrOp_WideChar = True primOpHasSideEffects ReadOffAddrOp_Int = True@@ -152,6 +144,10 @@ primOpHasSideEffects InterlockedExchange_Word = True primOpHasSideEffects CasAddrOp_Addr = True primOpHasSideEffects CasAddrOp_Word = True+primOpHasSideEffects CasAddrOp_Word8 = True+primOpHasSideEffects CasAddrOp_Word16 = True+primOpHasSideEffects CasAddrOp_Word32 = True+primOpHasSideEffects CasAddrOp_Word64 = True primOpHasSideEffects FetchAddAddrOp_Word = True primOpHasSideEffects FetchSubAddrOp_Word = True primOpHasSideEffects FetchAndAddrOp_Word = True@@ -188,7 +184,7 @@ primOpHasSideEffects ReadMVarOp = True primOpHasSideEffects TryReadMVarOp = True primOpHasSideEffects IsEmptyMVarOp = True-primOpHasSideEffects NewIOPortrOp = True+primOpHasSideEffects NewIOPortOp = True primOpHasSideEffects ReadIOPortOp = True primOpHasSideEffects WriteIOPortOp = True primOpHasSideEffects DelayOp = True
ghc-lib/stage0/compiler/build/primop-list.hs-incl view
@@ -125,6 +125,44 @@    , Word32LeOp    , Word32LtOp    , Word32NeOp+   , Int64ToIntOp+   , IntToInt64Op+   , Int64NegOp+   , Int64AddOp+   , Int64SubOp+   , Int64MulOp+   , Int64QuotOp+   , Int64RemOp+   , Int64SllOp+   , Int64SraOp+   , Int64SrlOp+   , Int64ToWord64Op+   , Int64EqOp+   , Int64GeOp+   , Int64GtOp+   , Int64LeOp+   , Int64LtOp+   , Int64NeOp+   , Word64ToWordOp+   , WordToWord64Op+   , Word64AddOp+   , Word64SubOp+   , Word64MulOp+   , Word64QuotOp+   , Word64RemOp+   , Word64AndOp+   , Word64OrOp+   , Word64XorOp+   , Word64NotOp+   , Word64SllOp+   , Word64SrlOp+   , Word64ToInt64Op+   , Word64EqOp+   , Word64GeOp+   , Word64GtOp+   , Word64LeOp+   , Word64LtOp+   , Word64NeOp    , IntAddOp    , IntSubOp    , IntMulOp@@ -287,7 +325,6 @@    , FloatToDoubleOp    , FloatDecode_IntOp    , NewArrayOp-   , SameMutableArrayOp    , ReadArrayOp    , WriteArrayOp    , SizeofArrayOp@@ -303,7 +340,6 @@    , ThawArrayOp    , CasArrayOp    , NewSmallArrayOp-   , SameSmallMutableArrayOp    , ShrinkSmallMutableArrayOp_Char    , ReadSmallArrayOp    , WriteSmallArrayOp@@ -327,7 +363,6 @@    , ByteArrayIsPinnedOp    , ByteArrayContents_Char    , MutableByteArrayContents_Char-   , SameMutableByteArrayOp    , ShrinkMutableByteArrayOp_Char    , ResizeMutableByteArrayOp_Char    , UnsafeFreezeByteArrayOp@@ -434,29 +469,16 @@    , AtomicReadByteArrayOp_Int    , AtomicWriteByteArrayOp_Int    , CasByteArrayOp_Int+   , CasByteArrayOp_Int8+   , CasByteArrayOp_Int16+   , CasByteArrayOp_Int32+   , CasByteArrayOp_Int64    , FetchAddByteArrayOp_Int    , FetchSubByteArrayOp_Int    , FetchAndByteArrayOp_Int    , FetchNandByteArrayOp_Int    , FetchOrByteArrayOp_Int    , FetchXorByteArrayOp_Int-   , NewArrayArrayOp-   , SameMutableArrayArrayOp-   , UnsafeFreezeArrayArrayOp-   , SizeofArrayArrayOp-   , SizeofMutableArrayArrayOp-   , IndexArrayArrayOp_ByteArray-   , IndexArrayArrayOp_ArrayArray-   , ReadArrayArrayOp_ByteArray-   , ReadArrayArrayOp_MutableByteArray-   , ReadArrayArrayOp_ArrayArray-   , ReadArrayArrayOp_MutableArrayArray-   , WriteArrayArrayOp_ByteArray-   , WriteArrayArrayOp_MutableByteArray-   , WriteArrayArrayOp_ArrayArray-   , WriteArrayArrayOp_MutableArrayArray-   , CopyArrayArrayOp-   , CopyMutableArrayArrayOp    , AddrAddOp    , AddrSubOp    , AddrRemOp@@ -520,6 +542,10 @@    , InterlockedExchange_Word    , CasAddrOp_Addr    , CasAddrOp_Word+   , CasAddrOp_Word8+   , CasAddrOp_Word16+   , CasAddrOp_Word32+   , CasAddrOp_Word64    , FetchAddAddrOp_Word    , FetchSubAddrOp_Word    , FetchAndAddrOp_Word@@ -531,7 +557,6 @@    , NewMutVarOp    , ReadMutVarOp    , WriteMutVarOp-   , SameMutVarOp    , AtomicModifyMutVar2Op    , AtomicModifyMutVar_Op    , CasMutVarOp@@ -550,7 +575,6 @@    , ReadTVarOp    , ReadTVarIOOp    , WriteTVarOp-   , SameTVarOp    , NewMVarOp    , TakeMVarOp    , TryTakeMVarOp@@ -558,12 +582,10 @@    , TryPutMVarOp    , ReadMVarOp    , TryReadMVarOp-   , SameMVarOp    , IsEmptyMVarOp-   , NewIOPortrOp+   , NewIOPortOp    , ReadIOPortOp    , WriteIOPortOp-   , SameIOPortOp    , DelayOp    , WaitReadOp    , WaitWriteOp@@ -586,7 +608,6 @@    , DeRefStablePtrOp    , EqStablePtrOp    , MakeStableNameOp-   , EqStableNameOp    , StableNameToIntOp    , CompactNewOp    , CompactResizeOp
ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl view
@@ -27,9 +27,6 @@ primOpOutOfLine ByteArrayIsPinnedOp = True primOpOutOfLine ShrinkMutableByteArrayOp_Char = True primOpOutOfLine ResizeMutableByteArrayOp_Char = True-primOpOutOfLine NewArrayArrayOp = True-primOpOutOfLine CopyArrayArrayOp = True-primOpOutOfLine CopyMutableArrayArrayOp = True primOpOutOfLine NewMutVarOp = True primOpOutOfLine AtomicModifyMutVar2Op = True primOpOutOfLine AtomicModifyMutVar_Op = True@@ -57,7 +54,7 @@ primOpOutOfLine ReadMVarOp = True primOpOutOfLine TryReadMVarOp = True primOpOutOfLine IsEmptyMVarOp = True-primOpOutOfLine NewIOPortrOp = True+primOpOutOfLine NewIOPortOp = True primOpOutOfLine ReadIOPortOp = True primOpOutOfLine WriteIOPortOp = True primOpOutOfLine DelayOp = True
ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl view
@@ -125,1159 +125,1180 @@ primOpInfo Word32LeOp = mkCompare (fsLit "leWord32#") word32PrimTy primOpInfo Word32LtOp = mkCompare (fsLit "ltWord32#") word32PrimTy primOpInfo Word32NeOp = mkCompare (fsLit "neWord32#") word32PrimTy-primOpInfo IntAddOp = mkGenPrimOp (fsLit "+#")  [] [intPrimTy, intPrimTy] (intPrimTy)-primOpInfo IntSubOp = mkGenPrimOp (fsLit "-#")  [] [intPrimTy, intPrimTy] (intPrimTy)-primOpInfo IntMulOp = mkGenPrimOp (fsLit "*#")  [] [intPrimTy, intPrimTy] (intPrimTy)-primOpInfo IntMul2Op = mkGenPrimOp (fsLit "timesInt2#")  [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy]))-primOpInfo IntMulMayOfloOp = mkGenPrimOp (fsLit "mulIntMayOflo#")  [] [intPrimTy, intPrimTy] (intPrimTy)-primOpInfo IntQuotOp = mkGenPrimOp (fsLit "quotInt#")  [] [intPrimTy, intPrimTy] (intPrimTy)-primOpInfo IntRemOp = mkGenPrimOp (fsLit "remInt#")  [] [intPrimTy, intPrimTy] (intPrimTy)-primOpInfo IntQuotRemOp = mkGenPrimOp (fsLit "quotRemInt#")  [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))-primOpInfo IntAndOp = mkGenPrimOp (fsLit "andI#")  [] [intPrimTy, intPrimTy] (intPrimTy)-primOpInfo IntOrOp = mkGenPrimOp (fsLit "orI#")  [] [intPrimTy, intPrimTy] (intPrimTy)-primOpInfo IntXorOp = mkGenPrimOp (fsLit "xorI#")  [] [intPrimTy, intPrimTy] (intPrimTy)-primOpInfo IntNotOp = mkGenPrimOp (fsLit "notI#")  [] [intPrimTy] (intPrimTy)-primOpInfo IntNegOp = mkGenPrimOp (fsLit "negateInt#")  [] [intPrimTy] (intPrimTy)-primOpInfo IntAddCOp = mkGenPrimOp (fsLit "addIntC#")  [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))-primOpInfo IntSubCOp = mkGenPrimOp (fsLit "subIntC#")  [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))-primOpInfo IntGtOp = mkCompare (fsLit ">#") intPrimTy-primOpInfo IntGeOp = mkCompare (fsLit ">=#") intPrimTy-primOpInfo IntEqOp = mkCompare (fsLit "==#") intPrimTy-primOpInfo IntNeOp = mkCompare (fsLit "/=#") intPrimTy-primOpInfo IntLtOp = mkCompare (fsLit "<#") intPrimTy-primOpInfo IntLeOp = mkCompare (fsLit "<=#") intPrimTy-primOpInfo ChrOp = mkGenPrimOp (fsLit "chr#")  [] [intPrimTy] (charPrimTy)-primOpInfo IntToWordOp = mkGenPrimOp (fsLit "int2Word#")  [] [intPrimTy] (wordPrimTy)-primOpInfo IntToFloatOp = mkGenPrimOp (fsLit "int2Float#")  [] [intPrimTy] (floatPrimTy)-primOpInfo IntToDoubleOp = mkGenPrimOp (fsLit "int2Double#")  [] [intPrimTy] (doublePrimTy)-primOpInfo WordToFloatOp = mkGenPrimOp (fsLit "word2Float#")  [] [wordPrimTy] (floatPrimTy)-primOpInfo WordToDoubleOp = mkGenPrimOp (fsLit "word2Double#")  [] [wordPrimTy] (doublePrimTy)-primOpInfo IntSllOp = mkGenPrimOp (fsLit "uncheckedIShiftL#")  [] [intPrimTy, intPrimTy] (intPrimTy)-primOpInfo IntSraOp = mkGenPrimOp (fsLit "uncheckedIShiftRA#")  [] [intPrimTy, intPrimTy] (intPrimTy)-primOpInfo IntSrlOp = mkGenPrimOp (fsLit "uncheckedIShiftRL#")  [] [intPrimTy, intPrimTy] (intPrimTy)-primOpInfo WordAddOp = mkGenPrimOp (fsLit "plusWord#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)-primOpInfo WordAddCOp = mkGenPrimOp (fsLit "addWordC#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, intPrimTy]))-primOpInfo WordSubCOp = mkGenPrimOp (fsLit "subWordC#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, intPrimTy]))-primOpInfo WordAdd2Op = mkGenPrimOp (fsLit "plusWord2#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))-primOpInfo WordSubOp = mkGenPrimOp (fsLit "minusWord#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)-primOpInfo WordMulOp = mkGenPrimOp (fsLit "timesWord#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)-primOpInfo WordMul2Op = mkGenPrimOp (fsLit "timesWord2#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))-primOpInfo WordQuotOp = mkGenPrimOp (fsLit "quotWord#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)-primOpInfo WordRemOp = mkGenPrimOp (fsLit "remWord#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)-primOpInfo WordQuotRemOp = mkGenPrimOp (fsLit "quotRemWord#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))-primOpInfo WordQuotRem2Op = mkGenPrimOp (fsLit "quotRemWord2#")  [] [wordPrimTy, wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))-primOpInfo WordAndOp = mkGenPrimOp (fsLit "and#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)-primOpInfo WordOrOp = mkGenPrimOp (fsLit "or#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)-primOpInfo WordXorOp = mkGenPrimOp (fsLit "xor#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)-primOpInfo WordNotOp = mkGenPrimOp (fsLit "not#")  [] [wordPrimTy] (wordPrimTy)-primOpInfo WordSllOp = mkGenPrimOp (fsLit "uncheckedShiftL#")  [] [wordPrimTy, intPrimTy] (wordPrimTy)-primOpInfo WordSrlOp = mkGenPrimOp (fsLit "uncheckedShiftRL#")  [] [wordPrimTy, intPrimTy] (wordPrimTy)-primOpInfo WordToIntOp = mkGenPrimOp (fsLit "word2Int#")  [] [wordPrimTy] (intPrimTy)-primOpInfo WordGtOp = mkCompare (fsLit "gtWord#") wordPrimTy-primOpInfo WordGeOp = mkCompare (fsLit "geWord#") wordPrimTy-primOpInfo WordEqOp = mkCompare (fsLit "eqWord#") wordPrimTy-primOpInfo WordNeOp = mkCompare (fsLit "neWord#") wordPrimTy-primOpInfo WordLtOp = mkCompare (fsLit "ltWord#") wordPrimTy-primOpInfo WordLeOp = mkCompare (fsLit "leWord#") wordPrimTy-primOpInfo PopCnt8Op = mkGenPrimOp (fsLit "popCnt8#")  [] [wordPrimTy] (wordPrimTy)-primOpInfo PopCnt16Op = mkGenPrimOp (fsLit "popCnt16#")  [] [wordPrimTy] (wordPrimTy)-primOpInfo PopCnt32Op = mkGenPrimOp (fsLit "popCnt32#")  [] [wordPrimTy] (wordPrimTy)-primOpInfo PopCnt64Op = mkGenPrimOp (fsLit "popCnt64#")  [] [wordPrimTy] (wordPrimTy)-primOpInfo PopCntOp = mkGenPrimOp (fsLit "popCnt#")  [] [wordPrimTy] (wordPrimTy)-primOpInfo Pdep8Op = mkGenPrimOp (fsLit "pdep8#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)-primOpInfo Pdep16Op = mkGenPrimOp (fsLit "pdep16#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)-primOpInfo Pdep32Op = mkGenPrimOp (fsLit "pdep32#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)-primOpInfo Pdep64Op = mkGenPrimOp (fsLit "pdep64#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)-primOpInfo PdepOp = mkGenPrimOp (fsLit "pdep#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)-primOpInfo Pext8Op = mkGenPrimOp (fsLit "pext8#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)-primOpInfo Pext16Op = mkGenPrimOp (fsLit "pext16#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)-primOpInfo Pext32Op = mkGenPrimOp (fsLit "pext32#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)-primOpInfo Pext64Op = mkGenPrimOp (fsLit "pext64#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)-primOpInfo PextOp = mkGenPrimOp (fsLit "pext#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)-primOpInfo Clz8Op = mkGenPrimOp (fsLit "clz8#")  [] [wordPrimTy] (wordPrimTy)-primOpInfo Clz16Op = mkGenPrimOp (fsLit "clz16#")  [] [wordPrimTy] (wordPrimTy)-primOpInfo Clz32Op = mkGenPrimOp (fsLit "clz32#")  [] [wordPrimTy] (wordPrimTy)-primOpInfo Clz64Op = mkGenPrimOp (fsLit "clz64#")  [] [wordPrimTy] (wordPrimTy)-primOpInfo ClzOp = mkGenPrimOp (fsLit "clz#")  [] [wordPrimTy] (wordPrimTy)-primOpInfo Ctz8Op = mkGenPrimOp (fsLit "ctz8#")  [] [wordPrimTy] (wordPrimTy)-primOpInfo Ctz16Op = mkGenPrimOp (fsLit "ctz16#")  [] [wordPrimTy] (wordPrimTy)-primOpInfo Ctz32Op = mkGenPrimOp (fsLit "ctz32#")  [] [wordPrimTy] (wordPrimTy)-primOpInfo Ctz64Op = mkGenPrimOp (fsLit "ctz64#")  [] [wordPrimTy] (wordPrimTy)-primOpInfo CtzOp = mkGenPrimOp (fsLit "ctz#")  [] [wordPrimTy] (wordPrimTy)-primOpInfo BSwap16Op = mkGenPrimOp (fsLit "byteSwap16#")  [] [wordPrimTy] (wordPrimTy)-primOpInfo BSwap32Op = mkGenPrimOp (fsLit "byteSwap32#")  [] [wordPrimTy] (wordPrimTy)-primOpInfo BSwap64Op = mkGenPrimOp (fsLit "byteSwap64#")  [] [wordPrimTy] (wordPrimTy)-primOpInfo BSwapOp = mkGenPrimOp (fsLit "byteSwap#")  [] [wordPrimTy] (wordPrimTy)-primOpInfo BRev8Op = mkGenPrimOp (fsLit "bitReverse8#")  [] [wordPrimTy] (wordPrimTy)-primOpInfo BRev16Op = mkGenPrimOp (fsLit "bitReverse16#")  [] [wordPrimTy] (wordPrimTy)-primOpInfo BRev32Op = mkGenPrimOp (fsLit "bitReverse32#")  [] [wordPrimTy] (wordPrimTy)-primOpInfo BRev64Op = mkGenPrimOp (fsLit "bitReverse64#")  [] [wordPrimTy] (wordPrimTy)-primOpInfo BRevOp = mkGenPrimOp (fsLit "bitReverse#")  [] [wordPrimTy] (wordPrimTy)-primOpInfo Narrow8IntOp = mkGenPrimOp (fsLit "narrow8Int#")  [] [intPrimTy] (intPrimTy)-primOpInfo Narrow16IntOp = mkGenPrimOp (fsLit "narrow16Int#")  [] [intPrimTy] (intPrimTy)-primOpInfo Narrow32IntOp = mkGenPrimOp (fsLit "narrow32Int#")  [] [intPrimTy] (intPrimTy)-primOpInfo Narrow8WordOp = mkGenPrimOp (fsLit "narrow8Word#")  [] [wordPrimTy] (wordPrimTy)-primOpInfo Narrow16WordOp = mkGenPrimOp (fsLit "narrow16Word#")  [] [wordPrimTy] (wordPrimTy)-primOpInfo Narrow32WordOp = mkGenPrimOp (fsLit "narrow32Word#")  [] [wordPrimTy] (wordPrimTy)-primOpInfo DoubleGtOp = mkCompare (fsLit ">##") doublePrimTy-primOpInfo DoubleGeOp = mkCompare (fsLit ">=##") doublePrimTy-primOpInfo DoubleEqOp = mkCompare (fsLit "==##") doublePrimTy-primOpInfo DoubleNeOp = mkCompare (fsLit "/=##") doublePrimTy-primOpInfo DoubleLtOp = mkCompare (fsLit "<##") doublePrimTy-primOpInfo DoubleLeOp = mkCompare (fsLit "<=##") doublePrimTy-primOpInfo DoubleAddOp = mkGenPrimOp (fsLit "+##")  [] [doublePrimTy, doublePrimTy] (doublePrimTy)-primOpInfo DoubleSubOp = mkGenPrimOp (fsLit "-##")  [] [doublePrimTy, doublePrimTy] (doublePrimTy)-primOpInfo DoubleMulOp = mkGenPrimOp (fsLit "*##")  [] [doublePrimTy, doublePrimTy] (doublePrimTy)-primOpInfo DoubleDivOp = mkGenPrimOp (fsLit "/##")  [] [doublePrimTy, doublePrimTy] (doublePrimTy)-primOpInfo DoubleNegOp = mkGenPrimOp (fsLit "negateDouble#")  [] [doublePrimTy] (doublePrimTy)-primOpInfo DoubleFabsOp = mkGenPrimOp (fsLit "fabsDouble#")  [] [doublePrimTy] (doublePrimTy)-primOpInfo DoubleToIntOp = mkGenPrimOp (fsLit "double2Int#")  [] [doublePrimTy] (intPrimTy)-primOpInfo DoubleToFloatOp = mkGenPrimOp (fsLit "double2Float#")  [] [doublePrimTy] (floatPrimTy)-primOpInfo DoubleExpOp = mkGenPrimOp (fsLit "expDouble#")  [] [doublePrimTy] (doublePrimTy)-primOpInfo DoubleExpM1Op = mkGenPrimOp (fsLit "expm1Double#")  [] [doublePrimTy] (doublePrimTy)-primOpInfo DoubleLogOp = mkGenPrimOp (fsLit "logDouble#")  [] [doublePrimTy] (doublePrimTy)-primOpInfo DoubleLog1POp = mkGenPrimOp (fsLit "log1pDouble#")  [] [doublePrimTy] (doublePrimTy)-primOpInfo DoubleSqrtOp = mkGenPrimOp (fsLit "sqrtDouble#")  [] [doublePrimTy] (doublePrimTy)-primOpInfo DoubleSinOp = mkGenPrimOp (fsLit "sinDouble#")  [] [doublePrimTy] (doublePrimTy)-primOpInfo DoubleCosOp = mkGenPrimOp (fsLit "cosDouble#")  [] [doublePrimTy] (doublePrimTy)-primOpInfo DoubleTanOp = mkGenPrimOp (fsLit "tanDouble#")  [] [doublePrimTy] (doublePrimTy)-primOpInfo DoubleAsinOp = mkGenPrimOp (fsLit "asinDouble#")  [] [doublePrimTy] (doublePrimTy)-primOpInfo DoubleAcosOp = mkGenPrimOp (fsLit "acosDouble#")  [] [doublePrimTy] (doublePrimTy)-primOpInfo DoubleAtanOp = mkGenPrimOp (fsLit "atanDouble#")  [] [doublePrimTy] (doublePrimTy)-primOpInfo DoubleSinhOp = mkGenPrimOp (fsLit "sinhDouble#")  [] [doublePrimTy] (doublePrimTy)-primOpInfo DoubleCoshOp = mkGenPrimOp (fsLit "coshDouble#")  [] [doublePrimTy] (doublePrimTy)-primOpInfo DoubleTanhOp = mkGenPrimOp (fsLit "tanhDouble#")  [] [doublePrimTy] (doublePrimTy)-primOpInfo DoubleAsinhOp = mkGenPrimOp (fsLit "asinhDouble#")  [] [doublePrimTy] (doublePrimTy)-primOpInfo DoubleAcoshOp = mkGenPrimOp (fsLit "acoshDouble#")  [] [doublePrimTy] (doublePrimTy)-primOpInfo DoubleAtanhOp = mkGenPrimOp (fsLit "atanhDouble#")  [] [doublePrimTy] (doublePrimTy)-primOpInfo DoublePowerOp = mkGenPrimOp (fsLit "**##")  [] [doublePrimTy, doublePrimTy] (doublePrimTy)-primOpInfo DoubleDecode_2IntOp = mkGenPrimOp (fsLit "decodeDouble_2Int#")  [] [doublePrimTy] ((mkTupleTy Unboxed [intPrimTy, wordPrimTy, wordPrimTy, intPrimTy]))-primOpInfo DoubleDecode_Int64Op = mkGenPrimOp (fsLit "decodeDouble_Int64#")  [] [doublePrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))-primOpInfo FloatGtOp = mkCompare (fsLit "gtFloat#") floatPrimTy-primOpInfo FloatGeOp = mkCompare (fsLit "geFloat#") floatPrimTy-primOpInfo FloatEqOp = mkCompare (fsLit "eqFloat#") floatPrimTy-primOpInfo FloatNeOp = mkCompare (fsLit "neFloat#") floatPrimTy-primOpInfo FloatLtOp = mkCompare (fsLit "ltFloat#") floatPrimTy-primOpInfo FloatLeOp = mkCompare (fsLit "leFloat#") floatPrimTy-primOpInfo FloatAddOp = mkGenPrimOp (fsLit "plusFloat#")  [] [floatPrimTy, floatPrimTy] (floatPrimTy)-primOpInfo FloatSubOp = mkGenPrimOp (fsLit "minusFloat#")  [] [floatPrimTy, floatPrimTy] (floatPrimTy)-primOpInfo FloatMulOp = mkGenPrimOp (fsLit "timesFloat#")  [] [floatPrimTy, floatPrimTy] (floatPrimTy)-primOpInfo FloatDivOp = mkGenPrimOp (fsLit "divideFloat#")  [] [floatPrimTy, floatPrimTy] (floatPrimTy)-primOpInfo FloatNegOp = mkGenPrimOp (fsLit "negateFloat#")  [] [floatPrimTy] (floatPrimTy)-primOpInfo FloatFabsOp = mkGenPrimOp (fsLit "fabsFloat#")  [] [floatPrimTy] (floatPrimTy)-primOpInfo FloatToIntOp = mkGenPrimOp (fsLit "float2Int#")  [] [floatPrimTy] (intPrimTy)-primOpInfo FloatExpOp = mkGenPrimOp (fsLit "expFloat#")  [] [floatPrimTy] (floatPrimTy)-primOpInfo FloatExpM1Op = mkGenPrimOp (fsLit "expm1Float#")  [] [floatPrimTy] (floatPrimTy)-primOpInfo FloatLogOp = mkGenPrimOp (fsLit "logFloat#")  [] [floatPrimTy] (floatPrimTy)-primOpInfo FloatLog1POp = mkGenPrimOp (fsLit "log1pFloat#")  [] [floatPrimTy] (floatPrimTy)-primOpInfo FloatSqrtOp = mkGenPrimOp (fsLit "sqrtFloat#")  [] [floatPrimTy] (floatPrimTy)-primOpInfo FloatSinOp = mkGenPrimOp (fsLit "sinFloat#")  [] [floatPrimTy] (floatPrimTy)-primOpInfo FloatCosOp = mkGenPrimOp (fsLit "cosFloat#")  [] [floatPrimTy] (floatPrimTy)-primOpInfo FloatTanOp = mkGenPrimOp (fsLit "tanFloat#")  [] [floatPrimTy] (floatPrimTy)-primOpInfo FloatAsinOp = mkGenPrimOp (fsLit "asinFloat#")  [] [floatPrimTy] (floatPrimTy)-primOpInfo FloatAcosOp = mkGenPrimOp (fsLit "acosFloat#")  [] [floatPrimTy] (floatPrimTy)-primOpInfo FloatAtanOp = mkGenPrimOp (fsLit "atanFloat#")  [] [floatPrimTy] (floatPrimTy)-primOpInfo FloatSinhOp = mkGenPrimOp (fsLit "sinhFloat#")  [] [floatPrimTy] (floatPrimTy)-primOpInfo FloatCoshOp = mkGenPrimOp (fsLit "coshFloat#")  [] [floatPrimTy] (floatPrimTy)-primOpInfo FloatTanhOp = mkGenPrimOp (fsLit "tanhFloat#")  [] [floatPrimTy] (floatPrimTy)-primOpInfo FloatAsinhOp = mkGenPrimOp (fsLit "asinhFloat#")  [] [floatPrimTy] (floatPrimTy)-primOpInfo FloatAcoshOp = mkGenPrimOp (fsLit "acoshFloat#")  [] [floatPrimTy] (floatPrimTy)-primOpInfo FloatAtanhOp = mkGenPrimOp (fsLit "atanhFloat#")  [] [floatPrimTy] (floatPrimTy)-primOpInfo FloatPowerOp = mkGenPrimOp (fsLit "powerFloat#")  [] [floatPrimTy, floatPrimTy] (floatPrimTy)-primOpInfo FloatToDoubleOp = mkGenPrimOp (fsLit "float2Double#")  [] [floatPrimTy] (doublePrimTy)-primOpInfo FloatDecode_IntOp = mkGenPrimOp (fsLit "decodeFloat_Int#")  [] [floatPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))-primOpInfo NewArrayOp = mkGenPrimOp (fsLit "newArray#")  [alphaTyVar, deltaTyVar] [intPrimTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy]))-primOpInfo SameMutableArrayOp = mkGenPrimOp (fsLit "sameMutableArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, mkMutableArrayPrimTy deltaTy alphaTy] (intPrimTy)-primOpInfo ReadArrayOp = mkGenPrimOp (fsLit "readArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))-primOpInfo WriteArrayOp = mkGenPrimOp (fsLit "writeArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo SizeofArrayOp = mkGenPrimOp (fsLit "sizeofArray#")  [alphaTyVar] [mkArrayPrimTy alphaTy] (intPrimTy)-primOpInfo SizeofMutableArrayOp = mkGenPrimOp (fsLit "sizeofMutableArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy] (intPrimTy)-primOpInfo IndexArrayOp = mkGenPrimOp (fsLit "indexArray#")  [alphaTyVar] [mkArrayPrimTy alphaTy, intPrimTy] ((mkTupleTy Unboxed [alphaTy]))-primOpInfo UnsafeFreezeArrayOp = mkGenPrimOp (fsLit "unsafeFreezeArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayPrimTy alphaTy]))-primOpInfo UnsafeThawArrayOp = mkGenPrimOp (fsLit "unsafeThawArray#")  [alphaTyVar, deltaTyVar] [mkArrayPrimTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy]))-primOpInfo CopyArrayOp = mkGenPrimOp (fsLit "copyArray#")  [alphaTyVar, deltaTyVar] [mkArrayPrimTy alphaTy, intPrimTy, mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo CopyMutableArrayOp = mkGenPrimOp (fsLit "copyMutableArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo CloneArrayOp = mkGenPrimOp (fsLit "cloneArray#")  [alphaTyVar] [mkArrayPrimTy alphaTy, intPrimTy, intPrimTy] (mkArrayPrimTy alphaTy)-primOpInfo CloneMutableArrayOp = mkGenPrimOp (fsLit "cloneMutableArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy]))-primOpInfo FreezeArrayOp = mkGenPrimOp (fsLit "freezeArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayPrimTy alphaTy]))-primOpInfo ThawArrayOp = mkGenPrimOp (fsLit "thawArray#")  [alphaTyVar, deltaTyVar] [mkArrayPrimTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy]))-primOpInfo CasArrayOp = mkGenPrimOp (fsLit "casArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))-primOpInfo NewSmallArrayOp = mkGenPrimOp (fsLit "newSmallArray#")  [alphaTyVar, deltaTyVar] [intPrimTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy]))-primOpInfo SameSmallMutableArrayOp = mkGenPrimOp (fsLit "sameSmallMutableArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy] (intPrimTy)-primOpInfo ShrinkSmallMutableArrayOp_Char = mkGenPrimOp (fsLit "shrinkSmallMutableArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo ReadSmallArrayOp = mkGenPrimOp (fsLit "readSmallArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))-primOpInfo WriteSmallArrayOp = mkGenPrimOp (fsLit "writeSmallArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo SizeofSmallArrayOp = mkGenPrimOp (fsLit "sizeofSmallArray#")  [alphaTyVar] [mkSmallArrayPrimTy alphaTy] (intPrimTy)-primOpInfo SizeofSmallMutableArrayOp = mkGenPrimOp (fsLit "sizeofSmallMutableArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy] (intPrimTy)-primOpInfo GetSizeofSmallMutableArrayOp = mkGenPrimOp (fsLit "getSizeofSmallMutableArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo IndexSmallArrayOp = mkGenPrimOp (fsLit "indexSmallArray#")  [alphaTyVar] [mkSmallArrayPrimTy alphaTy, intPrimTy] ((mkTupleTy Unboxed [alphaTy]))-primOpInfo UnsafeFreezeSmallArrayOp = mkGenPrimOp (fsLit "unsafeFreezeSmallArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallArrayPrimTy alphaTy]))-primOpInfo UnsafeThawSmallArrayOp = mkGenPrimOp (fsLit "unsafeThawSmallArray#")  [alphaTyVar, deltaTyVar] [mkSmallArrayPrimTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy]))-primOpInfo CopySmallArrayOp = mkGenPrimOp (fsLit "copySmallArray#")  [alphaTyVar, deltaTyVar] [mkSmallArrayPrimTy alphaTy, intPrimTy, mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo CopySmallMutableArrayOp = mkGenPrimOp (fsLit "copySmallMutableArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo CloneSmallArrayOp = mkGenPrimOp (fsLit "cloneSmallArray#")  [alphaTyVar] [mkSmallArrayPrimTy alphaTy, intPrimTy, intPrimTy] (mkSmallArrayPrimTy alphaTy)-primOpInfo CloneSmallMutableArrayOp = mkGenPrimOp (fsLit "cloneSmallMutableArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy]))-primOpInfo FreezeSmallArrayOp = mkGenPrimOp (fsLit "freezeSmallArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallArrayPrimTy alphaTy]))-primOpInfo ThawSmallArrayOp = mkGenPrimOp (fsLit "thawSmallArray#")  [alphaTyVar, deltaTyVar] [mkSmallArrayPrimTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy]))-primOpInfo CasSmallArrayOp = mkGenPrimOp (fsLit "casSmallArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))-primOpInfo NewByteArrayOp_Char = mkGenPrimOp (fsLit "newByteArray#")  [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy]))-primOpInfo NewPinnedByteArrayOp_Char = mkGenPrimOp (fsLit "newPinnedByteArray#")  [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy]))-primOpInfo NewAlignedPinnedByteArrayOp_Char = mkGenPrimOp (fsLit "newAlignedPinnedByteArray#")  [deltaTyVar] [intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy]))-primOpInfo MutableByteArrayIsPinnedOp = mkGenPrimOp (fsLit "isMutableByteArrayPinned#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy] (intPrimTy)-primOpInfo ByteArrayIsPinnedOp = mkGenPrimOp (fsLit "isByteArrayPinned#")  [] [byteArrayPrimTy] (intPrimTy)-primOpInfo ByteArrayContents_Char = mkGenPrimOp (fsLit "byteArrayContents#")  [] [byteArrayPrimTy] (addrPrimTy)-primOpInfo MutableByteArrayContents_Char = mkGenPrimOp (fsLit "mutableByteArrayContents#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy] (addrPrimTy)-primOpInfo SameMutableByteArrayOp = mkGenPrimOp (fsLit "sameMutableByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy] (intPrimTy)-primOpInfo ShrinkMutableByteArrayOp_Char = mkGenPrimOp (fsLit "shrinkMutableByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo ResizeMutableByteArrayOp_Char = mkGenPrimOp (fsLit "resizeMutableByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy]))-primOpInfo UnsafeFreezeByteArrayOp = mkGenPrimOp (fsLit "unsafeFreezeByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, byteArrayPrimTy]))-primOpInfo SizeofByteArrayOp = mkGenPrimOp (fsLit "sizeofByteArray#")  [] [byteArrayPrimTy] (intPrimTy)-primOpInfo SizeofMutableByteArrayOp = mkGenPrimOp (fsLit "sizeofMutableByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy] (intPrimTy)-primOpInfo GetSizeofMutableByteArrayOp = mkGenPrimOp (fsLit "getSizeofMutableByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo IndexByteArrayOp_Char = mkGenPrimOp (fsLit "indexCharArray#")  [] [byteArrayPrimTy, intPrimTy] (charPrimTy)-primOpInfo IndexByteArrayOp_WideChar = mkGenPrimOp (fsLit "indexWideCharArray#")  [] [byteArrayPrimTy, intPrimTy] (charPrimTy)-primOpInfo IndexByteArrayOp_Int = mkGenPrimOp (fsLit "indexIntArray#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)-primOpInfo IndexByteArrayOp_Word = mkGenPrimOp (fsLit "indexWordArray#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)-primOpInfo IndexByteArrayOp_Addr = mkGenPrimOp (fsLit "indexAddrArray#")  [] [byteArrayPrimTy, intPrimTy] (addrPrimTy)-primOpInfo IndexByteArrayOp_Float = mkGenPrimOp (fsLit "indexFloatArray#")  [] [byteArrayPrimTy, intPrimTy] (floatPrimTy)-primOpInfo IndexByteArrayOp_Double = mkGenPrimOp (fsLit "indexDoubleArray#")  [] [byteArrayPrimTy, intPrimTy] (doublePrimTy)-primOpInfo IndexByteArrayOp_StablePtr = mkGenPrimOp (fsLit "indexStablePtrArray#")  [alphaTyVar] [byteArrayPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy)-primOpInfo IndexByteArrayOp_Int8 = mkGenPrimOp (fsLit "indexInt8Array#")  [] [byteArrayPrimTy, intPrimTy] (int8PrimTy)-primOpInfo IndexByteArrayOp_Int16 = mkGenPrimOp (fsLit "indexInt16Array#")  [] [byteArrayPrimTy, intPrimTy] (int16PrimTy)-primOpInfo IndexByteArrayOp_Int32 = mkGenPrimOp (fsLit "indexInt32Array#")  [] [byteArrayPrimTy, intPrimTy] (int32PrimTy)-primOpInfo IndexByteArrayOp_Int64 = mkGenPrimOp (fsLit "indexInt64Array#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)-primOpInfo IndexByteArrayOp_Word8 = mkGenPrimOp (fsLit "indexWord8Array#")  [] [byteArrayPrimTy, intPrimTy] (word8PrimTy)-primOpInfo IndexByteArrayOp_Word16 = mkGenPrimOp (fsLit "indexWord16Array#")  [] [byteArrayPrimTy, intPrimTy] (word16PrimTy)-primOpInfo IndexByteArrayOp_Word32 = mkGenPrimOp (fsLit "indexWord32Array#")  [] [byteArrayPrimTy, intPrimTy] (word32PrimTy)-primOpInfo IndexByteArrayOp_Word64 = mkGenPrimOp (fsLit "indexWord64Array#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)-primOpInfo IndexByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "indexWord8ArrayAsChar#")  [] [byteArrayPrimTy, intPrimTy] (charPrimTy)-primOpInfo IndexByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "indexWord8ArrayAsWideChar#")  [] [byteArrayPrimTy, intPrimTy] (charPrimTy)-primOpInfo IndexByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "indexWord8ArrayAsInt#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)-primOpInfo IndexByteArrayOp_Word8AsWord = mkGenPrimOp (fsLit "indexWord8ArrayAsWord#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)-primOpInfo IndexByteArrayOp_Word8AsAddr = mkGenPrimOp (fsLit "indexWord8ArrayAsAddr#")  [] [byteArrayPrimTy, intPrimTy] (addrPrimTy)-primOpInfo IndexByteArrayOp_Word8AsFloat = mkGenPrimOp (fsLit "indexWord8ArrayAsFloat#")  [] [byteArrayPrimTy, intPrimTy] (floatPrimTy)-primOpInfo IndexByteArrayOp_Word8AsDouble = mkGenPrimOp (fsLit "indexWord8ArrayAsDouble#")  [] [byteArrayPrimTy, intPrimTy] (doublePrimTy)-primOpInfo IndexByteArrayOp_Word8AsStablePtr = mkGenPrimOp (fsLit "indexWord8ArrayAsStablePtr#")  [alphaTyVar] [byteArrayPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy)-primOpInfo IndexByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt16#")  [] [byteArrayPrimTy, intPrimTy] (int16PrimTy)-primOpInfo IndexByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt32#")  [] [byteArrayPrimTy, intPrimTy] (int32PrimTy)-primOpInfo IndexByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt64#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)-primOpInfo IndexByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord16#")  [] [byteArrayPrimTy, intPrimTy] (word16PrimTy)-primOpInfo IndexByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord32#")  [] [byteArrayPrimTy, intPrimTy] (word32PrimTy)-primOpInfo IndexByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord64#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)-primOpInfo ReadByteArrayOp_Char = mkGenPrimOp (fsLit "readCharArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))-primOpInfo ReadByteArrayOp_WideChar = mkGenPrimOp (fsLit "readWideCharArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))-primOpInfo ReadByteArrayOp_Int = mkGenPrimOp (fsLit "readIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo ReadByteArrayOp_Word = mkGenPrimOp (fsLit "readWordArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))-primOpInfo ReadByteArrayOp_Addr = mkGenPrimOp (fsLit "readAddrArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))-primOpInfo ReadByteArrayOp_Float = mkGenPrimOp (fsLit "readFloatArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatPrimTy]))-primOpInfo ReadByteArrayOp_Double = mkGenPrimOp (fsLit "readDoubleArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy]))-primOpInfo ReadByteArrayOp_StablePtr = mkGenPrimOp (fsLit "readStablePtrArray#")  [deltaTyVar, alphaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy]))-primOpInfo ReadByteArrayOp_Int8 = mkGenPrimOp (fsLit "readInt8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8PrimTy]))-primOpInfo ReadByteArrayOp_Int16 = mkGenPrimOp (fsLit "readInt16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16PrimTy]))-primOpInfo ReadByteArrayOp_Int32 = mkGenPrimOp (fsLit "readInt32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32PrimTy]))-primOpInfo ReadByteArrayOp_Int64 = mkGenPrimOp (fsLit "readInt64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo ReadByteArrayOp_Word8 = mkGenPrimOp (fsLit "readWord8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8PrimTy]))-primOpInfo ReadByteArrayOp_Word16 = mkGenPrimOp (fsLit "readWord16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16PrimTy]))-primOpInfo ReadByteArrayOp_Word32 = mkGenPrimOp (fsLit "readWord32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32PrimTy]))-primOpInfo ReadByteArrayOp_Word64 = mkGenPrimOp (fsLit "readWord64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))-primOpInfo ReadByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "readWord8ArrayAsChar#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))-primOpInfo ReadByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "readWord8ArrayAsWideChar#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))-primOpInfo ReadByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "readWord8ArrayAsInt#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo ReadByteArrayOp_Word8AsWord = mkGenPrimOp (fsLit "readWord8ArrayAsWord#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))-primOpInfo ReadByteArrayOp_Word8AsAddr = mkGenPrimOp (fsLit "readWord8ArrayAsAddr#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))-primOpInfo ReadByteArrayOp_Word8AsFloat = mkGenPrimOp (fsLit "readWord8ArrayAsFloat#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatPrimTy]))-primOpInfo ReadByteArrayOp_Word8AsDouble = mkGenPrimOp (fsLit "readWord8ArrayAsDouble#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy]))-primOpInfo ReadByteArrayOp_Word8AsStablePtr = mkGenPrimOp (fsLit "readWord8ArrayAsStablePtr#")  [deltaTyVar, alphaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy]))-primOpInfo ReadByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "readWord8ArrayAsInt16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16PrimTy]))-primOpInfo ReadByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "readWord8ArrayAsInt32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32PrimTy]))-primOpInfo ReadByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "readWord8ArrayAsInt64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo ReadByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "readWord8ArrayAsWord16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16PrimTy]))-primOpInfo ReadByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "readWord8ArrayAsWord32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32PrimTy]))-primOpInfo ReadByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "readWord8ArrayAsWord64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))-primOpInfo WriteByteArrayOp_Char = mkGenPrimOp (fsLit "writeCharArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_WideChar = mkGenPrimOp (fsLit "writeWideCharArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Int = mkGenPrimOp (fsLit "writeIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word = mkGenPrimOp (fsLit "writeWordArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Addr = mkGenPrimOp (fsLit "writeAddrArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Float = mkGenPrimOp (fsLit "writeFloatArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Double = mkGenPrimOp (fsLit "writeDoubleArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_StablePtr = mkGenPrimOp (fsLit "writeStablePtrArray#")  [deltaTyVar, alphaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Int8 = mkGenPrimOp (fsLit "writeInt8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Int16 = mkGenPrimOp (fsLit "writeInt16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Int32 = mkGenPrimOp (fsLit "writeInt32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Int64 = mkGenPrimOp (fsLit "writeInt64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word8 = mkGenPrimOp (fsLit "writeWord8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word16 = mkGenPrimOp (fsLit "writeWord16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word32 = mkGenPrimOp (fsLit "writeWord32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word64 = mkGenPrimOp (fsLit "writeWord64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "writeWord8ArrayAsChar#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "writeWord8ArrayAsWideChar#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "writeWord8ArrayAsInt#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word8AsWord = mkGenPrimOp (fsLit "writeWord8ArrayAsWord#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word8AsAddr = mkGenPrimOp (fsLit "writeWord8ArrayAsAddr#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word8AsFloat = mkGenPrimOp (fsLit "writeWord8ArrayAsFloat#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word8AsDouble = mkGenPrimOp (fsLit "writeWord8ArrayAsDouble#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word8AsStablePtr = mkGenPrimOp (fsLit "writeWord8ArrayAsStablePtr#")  [deltaTyVar, alphaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo CompareByteArraysOp = mkGenPrimOp (fsLit "compareByteArrays#")  [] [byteArrayPrimTy, intPrimTy, byteArrayPrimTy, intPrimTy, intPrimTy] (intPrimTy)-primOpInfo CopyByteArrayOp = mkGenPrimOp (fsLit "copyByteArray#")  [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo CopyMutableByteArrayOp = mkGenPrimOp (fsLit "copyMutableByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo CopyByteArrayToAddrOp = mkGenPrimOp (fsLit "copyByteArrayToAddr#")  [deltaTyVar] [byteArrayPrimTy, intPrimTy, addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo CopyMutableByteArrayToAddrOp = mkGenPrimOp (fsLit "copyMutableByteArrayToAddr#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo CopyAddrToByteArrayOp = mkGenPrimOp (fsLit "copyAddrToByteArray#")  [deltaTyVar] [addrPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo SetByteArrayOp = mkGenPrimOp (fsLit "setByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo AtomicReadByteArrayOp_Int = mkGenPrimOp (fsLit "atomicReadIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo AtomicWriteByteArrayOp_Int = mkGenPrimOp (fsLit "atomicWriteIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo CasByteArrayOp_Int = mkGenPrimOp (fsLit "casIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo FetchAddByteArrayOp_Int = mkGenPrimOp (fsLit "fetchAddIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo FetchSubByteArrayOp_Int = mkGenPrimOp (fsLit "fetchSubIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo FetchAndByteArrayOp_Int = mkGenPrimOp (fsLit "fetchAndIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo FetchNandByteArrayOp_Int = mkGenPrimOp (fsLit "fetchNandIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo FetchOrByteArrayOp_Int = mkGenPrimOp (fsLit "fetchOrIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo FetchXorByteArrayOp_Int = mkGenPrimOp (fsLit "fetchXorIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo NewArrayArrayOp = mkGenPrimOp (fsLit "newArrayArray#")  [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayArrayPrimTy deltaTy]))-primOpInfo SameMutableArrayArrayOp = mkGenPrimOp (fsLit "sameMutableArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, mkMutableArrayArrayPrimTy deltaTy] (intPrimTy)-primOpInfo UnsafeFreezeArrayArrayOp = mkGenPrimOp (fsLit "unsafeFreezeArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayArrayPrimTy]))-primOpInfo SizeofArrayArrayOp = mkGenPrimOp (fsLit "sizeofArrayArray#")  [] [mkArrayArrayPrimTy] (intPrimTy)-primOpInfo SizeofMutableArrayArrayOp = mkGenPrimOp (fsLit "sizeofMutableArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy] (intPrimTy)-primOpInfo IndexArrayArrayOp_ByteArray = mkGenPrimOp (fsLit "indexByteArrayArray#")  [] [mkArrayArrayPrimTy, intPrimTy] (byteArrayPrimTy)-primOpInfo IndexArrayArrayOp_ArrayArray = mkGenPrimOp (fsLit "indexArrayArrayArray#")  [] [mkArrayArrayPrimTy, intPrimTy] (mkArrayArrayPrimTy)-primOpInfo ReadArrayArrayOp_ByteArray = mkGenPrimOp (fsLit "readByteArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, byteArrayPrimTy]))-primOpInfo ReadArrayArrayOp_MutableByteArray = mkGenPrimOp (fsLit "readMutableByteArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy]))-primOpInfo ReadArrayArrayOp_ArrayArray = mkGenPrimOp (fsLit "readArrayArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayArrayPrimTy]))-primOpInfo ReadArrayArrayOp_MutableArrayArray = mkGenPrimOp (fsLit "readMutableArrayArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayArrayPrimTy deltaTy]))-primOpInfo WriteArrayArrayOp_ByteArray = mkGenPrimOp (fsLit "writeByteArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, byteArrayPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteArrayArrayOp_MutableByteArray = mkGenPrimOp (fsLit "writeMutableByteArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteArrayArrayOp_ArrayArray = mkGenPrimOp (fsLit "writeArrayArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkArrayArrayPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteArrayArrayOp_MutableArrayArray = mkGenPrimOp (fsLit "writeMutableArrayArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkMutableArrayArrayPrimTy deltaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo CopyArrayArrayOp = mkGenPrimOp (fsLit "copyArrayArray#")  [deltaTyVar] [mkArrayArrayPrimTy, intPrimTy, mkMutableArrayArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo CopyMutableArrayArrayOp = mkGenPrimOp (fsLit "copyMutableArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkMutableArrayArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo AddrAddOp = mkGenPrimOp (fsLit "plusAddr#")  [] [addrPrimTy, intPrimTy] (addrPrimTy)-primOpInfo AddrSubOp = mkGenPrimOp (fsLit "minusAddr#")  [] [addrPrimTy, addrPrimTy] (intPrimTy)-primOpInfo AddrRemOp = mkGenPrimOp (fsLit "remAddr#")  [] [addrPrimTy, intPrimTy] (intPrimTy)-primOpInfo AddrToIntOp = mkGenPrimOp (fsLit "addr2Int#")  [] [addrPrimTy] (intPrimTy)-primOpInfo IntToAddrOp = mkGenPrimOp (fsLit "int2Addr#")  [] [intPrimTy] (addrPrimTy)-primOpInfo AddrGtOp = mkCompare (fsLit "gtAddr#") addrPrimTy-primOpInfo AddrGeOp = mkCompare (fsLit "geAddr#") addrPrimTy-primOpInfo AddrEqOp = mkCompare (fsLit "eqAddr#") addrPrimTy-primOpInfo AddrNeOp = mkCompare (fsLit "neAddr#") addrPrimTy-primOpInfo AddrLtOp = mkCompare (fsLit "ltAddr#") addrPrimTy-primOpInfo AddrLeOp = mkCompare (fsLit "leAddr#") addrPrimTy-primOpInfo IndexOffAddrOp_Char = mkGenPrimOp (fsLit "indexCharOffAddr#")  [] [addrPrimTy, intPrimTy] (charPrimTy)-primOpInfo IndexOffAddrOp_WideChar = mkGenPrimOp (fsLit "indexWideCharOffAddr#")  [] [addrPrimTy, intPrimTy] (charPrimTy)-primOpInfo IndexOffAddrOp_Int = mkGenPrimOp (fsLit "indexIntOffAddr#")  [] [addrPrimTy, intPrimTy] (intPrimTy)-primOpInfo IndexOffAddrOp_Word = mkGenPrimOp (fsLit "indexWordOffAddr#")  [] [addrPrimTy, intPrimTy] (wordPrimTy)-primOpInfo IndexOffAddrOp_Addr = mkGenPrimOp (fsLit "indexAddrOffAddr#")  [] [addrPrimTy, intPrimTy] (addrPrimTy)-primOpInfo IndexOffAddrOp_Float = mkGenPrimOp (fsLit "indexFloatOffAddr#")  [] [addrPrimTy, intPrimTy] (floatPrimTy)-primOpInfo IndexOffAddrOp_Double = mkGenPrimOp (fsLit "indexDoubleOffAddr#")  [] [addrPrimTy, intPrimTy] (doublePrimTy)-primOpInfo IndexOffAddrOp_StablePtr = mkGenPrimOp (fsLit "indexStablePtrOffAddr#")  [alphaTyVar] [addrPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy)-primOpInfo IndexOffAddrOp_Int8 = mkGenPrimOp (fsLit "indexInt8OffAddr#")  [] [addrPrimTy, intPrimTy] (int8PrimTy)-primOpInfo IndexOffAddrOp_Int16 = mkGenPrimOp (fsLit "indexInt16OffAddr#")  [] [addrPrimTy, intPrimTy] (int16PrimTy)-primOpInfo IndexOffAddrOp_Int32 = mkGenPrimOp (fsLit "indexInt32OffAddr#")  [] [addrPrimTy, intPrimTy] (int32PrimTy)-primOpInfo IndexOffAddrOp_Int64 = mkGenPrimOp (fsLit "indexInt64OffAddr#")  [] [addrPrimTy, intPrimTy] (intPrimTy)-primOpInfo IndexOffAddrOp_Word8 = mkGenPrimOp (fsLit "indexWord8OffAddr#")  [] [addrPrimTy, intPrimTy] (word8PrimTy)-primOpInfo IndexOffAddrOp_Word16 = mkGenPrimOp (fsLit "indexWord16OffAddr#")  [] [addrPrimTy, intPrimTy] (word16PrimTy)-primOpInfo IndexOffAddrOp_Word32 = mkGenPrimOp (fsLit "indexWord32OffAddr#")  [] [addrPrimTy, intPrimTy] (word32PrimTy)-primOpInfo IndexOffAddrOp_Word64 = mkGenPrimOp (fsLit "indexWord64OffAddr#")  [] [addrPrimTy, intPrimTy] (wordPrimTy)-primOpInfo ReadOffAddrOp_Char = mkGenPrimOp (fsLit "readCharOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))-primOpInfo ReadOffAddrOp_WideChar = mkGenPrimOp (fsLit "readWideCharOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))-primOpInfo ReadOffAddrOp_Int = mkGenPrimOp (fsLit "readIntOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo ReadOffAddrOp_Word = mkGenPrimOp (fsLit "readWordOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))-primOpInfo ReadOffAddrOp_Addr = mkGenPrimOp (fsLit "readAddrOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))-primOpInfo ReadOffAddrOp_Float = mkGenPrimOp (fsLit "readFloatOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatPrimTy]))-primOpInfo ReadOffAddrOp_Double = mkGenPrimOp (fsLit "readDoubleOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy]))-primOpInfo ReadOffAddrOp_StablePtr = mkGenPrimOp (fsLit "readStablePtrOffAddr#")  [deltaTyVar, alphaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy]))-primOpInfo ReadOffAddrOp_Int8 = mkGenPrimOp (fsLit "readInt8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8PrimTy]))-primOpInfo ReadOffAddrOp_Int16 = mkGenPrimOp (fsLit "readInt16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16PrimTy]))-primOpInfo ReadOffAddrOp_Int32 = mkGenPrimOp (fsLit "readInt32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32PrimTy]))-primOpInfo ReadOffAddrOp_Int64 = mkGenPrimOp (fsLit "readInt64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo ReadOffAddrOp_Word8 = mkGenPrimOp (fsLit "readWord8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8PrimTy]))-primOpInfo ReadOffAddrOp_Word16 = mkGenPrimOp (fsLit "readWord16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16PrimTy]))-primOpInfo ReadOffAddrOp_Word32 = mkGenPrimOp (fsLit "readWord32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32PrimTy]))-primOpInfo ReadOffAddrOp_Word64 = mkGenPrimOp (fsLit "readWord64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))-primOpInfo WriteOffAddrOp_Char = mkGenPrimOp (fsLit "writeCharOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteOffAddrOp_WideChar = mkGenPrimOp (fsLit "writeWideCharOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteOffAddrOp_Int = mkGenPrimOp (fsLit "writeIntOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteOffAddrOp_Word = mkGenPrimOp (fsLit "writeWordOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteOffAddrOp_Addr = mkGenPrimOp (fsLit "writeAddrOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteOffAddrOp_Float = mkGenPrimOp (fsLit "writeFloatOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteOffAddrOp_Double = mkGenPrimOp (fsLit "writeDoubleOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteOffAddrOp_StablePtr = mkGenPrimOp (fsLit "writeStablePtrOffAddr#")  [alphaTyVar, deltaTyVar] [addrPrimTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteOffAddrOp_Int8 = mkGenPrimOp (fsLit "writeInt8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteOffAddrOp_Int16 = mkGenPrimOp (fsLit "writeInt16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteOffAddrOp_Int32 = mkGenPrimOp (fsLit "writeInt32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteOffAddrOp_Int64 = mkGenPrimOp (fsLit "writeInt64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteOffAddrOp_Word8 = mkGenPrimOp (fsLit "writeWord8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteOffAddrOp_Word16 = mkGenPrimOp (fsLit "writeWord16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteOffAddrOp_Word32 = mkGenPrimOp (fsLit "writeWord32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteOffAddrOp_Word64 = mkGenPrimOp (fsLit "writeWord64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo InterlockedExchange_Addr = mkGenPrimOp (fsLit "atomicExchangeAddrAddr#")  [deltaTyVar] [addrPrimTy, addrPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))-primOpInfo InterlockedExchange_Word = mkGenPrimOp (fsLit "atomicExchangeWordAddr#")  [deltaTyVar] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))-primOpInfo CasAddrOp_Addr = mkGenPrimOp (fsLit "atomicCasAddrAddr#")  [deltaTyVar] [addrPrimTy, addrPrimTy, addrPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))-primOpInfo CasAddrOp_Word = mkGenPrimOp (fsLit "atomicCasWordAddr#")  [deltaTyVar] [addrPrimTy, wordPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))-primOpInfo FetchAddAddrOp_Word = mkGenPrimOp (fsLit "fetchAddWordAddr#")  [deltaTyVar] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))-primOpInfo FetchSubAddrOp_Word = mkGenPrimOp (fsLit "fetchSubWordAddr#")  [deltaTyVar] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))-primOpInfo FetchAndAddrOp_Word = mkGenPrimOp (fsLit "fetchAndWordAddr#")  [deltaTyVar] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))-primOpInfo FetchNandAddrOp_Word = mkGenPrimOp (fsLit "fetchNandWordAddr#")  [deltaTyVar] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))-primOpInfo FetchOrAddrOp_Word = mkGenPrimOp (fsLit "fetchOrWordAddr#")  [deltaTyVar] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))-primOpInfo FetchXorAddrOp_Word = mkGenPrimOp (fsLit "fetchXorWordAddr#")  [deltaTyVar] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))-primOpInfo AtomicReadAddrOp_Word = mkGenPrimOp (fsLit "atomicReadWordAddr#")  [deltaTyVar] [addrPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))-primOpInfo AtomicWriteAddrOp_Word = mkGenPrimOp (fsLit "atomicWriteWordAddr#")  [deltaTyVar] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo NewMutVarOp = mkGenPrimOp (fsLit "newMutVar#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutVarPrimTy deltaTy alphaTy]))-primOpInfo ReadMutVarOp = mkGenPrimOp (fsLit "readMutVar#")  [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))-primOpInfo WriteMutVarOp = mkGenPrimOp (fsLit "writeMutVar#")  [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo SameMutVarOp = mkGenPrimOp (fsLit "sameMutVar#")  [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, mkMutVarPrimTy deltaTy alphaTy] (intPrimTy)-primOpInfo AtomicModifyMutVar2Op = mkGenPrimOp (fsLit "atomicModifyMutVar2#")  [deltaTyVar, alphaTyVar, gammaTyVar] [mkMutVarPrimTy deltaTy alphaTy, (mkVisFunTyMany (alphaTy) (gammaTy)), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy, gammaTy]))-primOpInfo AtomicModifyMutVar_Op = mkGenPrimOp (fsLit "atomicModifyMutVar_#")  [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, (mkVisFunTyMany (alphaTy) (alphaTy)), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy, alphaTy]))-primOpInfo CasMutVarOp = mkGenPrimOp (fsLit "casMutVar#")  [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))-primOpInfo CatchOp = mkGenPrimOp (fsLit "catch#")  [alphaTyVar, betaTyVar] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkVisFunTyMany (betaTy) ((mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))-primOpInfo RaiseOp = mkGenPrimOp (fsLit "raise#")  [betaTyVar, runtimeRep1TyVar, openAlphaTyVar] [betaTy] (openAlphaTy)-primOpInfo RaiseIOOp = mkGenPrimOp (fsLit "raiseIO#")  [alphaTyVar, betaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, betaTy]))-primOpInfo MaskAsyncExceptionsOp = mkGenPrimOp (fsLit "maskAsyncExceptions#")  [alphaTyVar] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))-primOpInfo MaskUninterruptibleOp = mkGenPrimOp (fsLit "maskUninterruptible#")  [alphaTyVar] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))-primOpInfo UnmaskAsyncExceptionsOp = mkGenPrimOp (fsLit "unmaskAsyncExceptions#")  [alphaTyVar] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))-primOpInfo MaskStatus = mkGenPrimOp (fsLit "getMaskingState#")  [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))-primOpInfo AtomicallyOp = mkGenPrimOp (fsLit "atomically#")  [alphaTyVar] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))-primOpInfo RetryOp = mkGenPrimOp (fsLit "retry#")  [alphaTyVar] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))-primOpInfo CatchRetryOp = mkGenPrimOp (fsLit "catchRetry#")  [alphaTyVar] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))-primOpInfo CatchSTMOp = mkGenPrimOp (fsLit "catchSTM#")  [alphaTyVar, betaTyVar] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkVisFunTyMany (betaTy) ((mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))-primOpInfo NewTVarOp = mkGenPrimOp (fsLit "newTVar#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkTVarPrimTy deltaTy alphaTy]))-primOpInfo ReadTVarOp = mkGenPrimOp (fsLit "readTVar#")  [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))-primOpInfo ReadTVarIOOp = mkGenPrimOp (fsLit "readTVarIO#")  [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))-primOpInfo WriteTVarOp = mkGenPrimOp (fsLit "writeTVar#")  [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo SameTVarOp = mkGenPrimOp (fsLit "sameTVar#")  [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, mkTVarPrimTy deltaTy alphaTy] (intPrimTy)-primOpInfo NewMVarOp = mkGenPrimOp (fsLit "newMVar#")  [deltaTyVar, alphaTyVar] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMVarPrimTy deltaTy alphaTy]))-primOpInfo TakeMVarOp = mkGenPrimOp (fsLit "takeMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))-primOpInfo TryTakeMVarOp = mkGenPrimOp (fsLit "tryTakeMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))-primOpInfo PutMVarOp = mkGenPrimOp (fsLit "putMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo TryPutMVarOp = mkGenPrimOp (fsLit "tryPutMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo ReadMVarOp = mkGenPrimOp (fsLit "readMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))-primOpInfo TryReadMVarOp = mkGenPrimOp (fsLit "tryReadMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))-primOpInfo SameMVarOp = mkGenPrimOp (fsLit "sameMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkMVarPrimTy deltaTy alphaTy] (intPrimTy)-primOpInfo IsEmptyMVarOp = mkGenPrimOp (fsLit "isEmptyMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo NewIOPortrOp = mkGenPrimOp (fsLit "newIOPort#")  [deltaTyVar, alphaTyVar] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkIOPortPrimTy deltaTy alphaTy]))-primOpInfo ReadIOPortOp = mkGenPrimOp (fsLit "readIOPort#")  [deltaTyVar, alphaTyVar] [mkIOPortPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))-primOpInfo WriteIOPortOp = mkGenPrimOp (fsLit "writeIOPort#")  [deltaTyVar, alphaTyVar] [mkIOPortPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo SameIOPortOp = mkGenPrimOp (fsLit "sameIOPort#")  [deltaTyVar, alphaTyVar] [mkIOPortPrimTy deltaTy alphaTy, mkIOPortPrimTy deltaTy alphaTy] (intPrimTy)-primOpInfo DelayOp = mkGenPrimOp (fsLit "delay#")  [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WaitReadOp = mkGenPrimOp (fsLit "waitRead#")  [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WaitWriteOp = mkGenPrimOp (fsLit "waitWrite#")  [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo ForkOp = mkGenPrimOp (fsLit "fork#")  [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, threadIdPrimTy]))-primOpInfo ForkOnOp = mkGenPrimOp (fsLit "forkOn#")  [alphaTyVar] [intPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, threadIdPrimTy]))-primOpInfo KillThreadOp = mkGenPrimOp (fsLit "killThread#")  [alphaTyVar] [threadIdPrimTy, alphaTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)-primOpInfo YieldOp = mkGenPrimOp (fsLit "yield#")  [] [mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)-primOpInfo MyThreadIdOp = mkGenPrimOp (fsLit "myThreadId#")  [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, threadIdPrimTy]))-primOpInfo LabelThreadOp = mkGenPrimOp (fsLit "labelThread#")  [] [threadIdPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)-primOpInfo IsCurrentThreadBoundOp = mkGenPrimOp (fsLit "isCurrentThreadBound#")  [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))-primOpInfo NoDuplicateOp = mkGenPrimOp (fsLit "noDuplicate#")  [deltaTyVar] [mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo ThreadStatusOp = mkGenPrimOp (fsLit "threadStatus#")  [] [threadIdPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, intPrimTy, intPrimTy]))-primOpInfo MkWeakOp = mkGenPrimOp (fsLit "mkWeak#")  [runtimeRep1TyVar, openAlphaTyVar, betaTyVar, gammaTyVar] [openAlphaTy, betaTy, (mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, gammaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkWeakPrimTy betaTy]))-primOpInfo MkWeakNoFinalizerOp = mkGenPrimOp (fsLit "mkWeakNoFinalizer#")  [runtimeRep1TyVar, openAlphaTyVar, betaTyVar] [openAlphaTy, betaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkWeakPrimTy betaTy]))-primOpInfo AddCFinalizerToWeakOp = mkGenPrimOp (fsLit "addCFinalizerToWeak#")  [betaTyVar] [addrPrimTy, addrPrimTy, intPrimTy, addrPrimTy, mkWeakPrimTy betaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))-primOpInfo DeRefWeakOp = mkGenPrimOp (fsLit "deRefWeak#")  [alphaTyVar] [mkWeakPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, alphaTy]))-primOpInfo FinalizeWeakOp = mkGenPrimOp (fsLit "finalizeWeak#")  [alphaTyVar, betaTyVar] [mkWeakPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, (mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, betaTy])))]))-primOpInfo TouchOp = mkGenPrimOp (fsLit "touch#")  [runtimeRep1TyVar, openAlphaTyVar] [openAlphaTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)-primOpInfo MakeStablePtrOp = mkGenPrimOp (fsLit "makeStablePtr#")  [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkStablePtrPrimTy alphaTy]))-primOpInfo DeRefStablePtrOp = mkGenPrimOp (fsLit "deRefStablePtr#")  [alphaTyVar] [mkStablePtrPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))-primOpInfo EqStablePtrOp = mkGenPrimOp (fsLit "eqStablePtr#")  [alphaTyVar] [mkStablePtrPrimTy alphaTy, mkStablePtrPrimTy alphaTy] (intPrimTy)-primOpInfo MakeStableNameOp = mkGenPrimOp (fsLit "makeStableName#")  [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkStableNamePrimTy alphaTy]))-primOpInfo EqStableNameOp = mkGenPrimOp (fsLit "eqStableName#")  [alphaTyVar, betaTyVar] [mkStableNamePrimTy alphaTy, mkStableNamePrimTy betaTy] (intPrimTy)-primOpInfo StableNameToIntOp = mkGenPrimOp (fsLit "stableNameToInt#")  [alphaTyVar] [mkStableNamePrimTy alphaTy] (intPrimTy)-primOpInfo CompactNewOp = mkGenPrimOp (fsLit "compactNew#")  [] [wordPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, compactPrimTy]))-primOpInfo CompactResizeOp = mkGenPrimOp (fsLit "compactResize#")  [] [compactPrimTy, wordPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)-primOpInfo CompactContainsOp = mkGenPrimOp (fsLit "compactContains#")  [alphaTyVar] [compactPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))-primOpInfo CompactContainsAnyOp = mkGenPrimOp (fsLit "compactContainsAny#")  [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))-primOpInfo CompactGetFirstBlockOp = mkGenPrimOp (fsLit "compactGetFirstBlock#")  [] [compactPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy, wordPrimTy]))-primOpInfo CompactGetNextBlockOp = mkGenPrimOp (fsLit "compactGetNextBlock#")  [] [compactPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy, wordPrimTy]))-primOpInfo CompactAllocateBlockOp = mkGenPrimOp (fsLit "compactAllocateBlock#")  [] [wordPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy]))-primOpInfo CompactFixupPointersOp = mkGenPrimOp (fsLit "compactFixupPointers#")  [] [addrPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, compactPrimTy, addrPrimTy]))-primOpInfo CompactAdd = mkGenPrimOp (fsLit "compactAdd#")  [alphaTyVar] [compactPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))-primOpInfo CompactAddWithSharing = mkGenPrimOp (fsLit "compactAddWithSharing#")  [alphaTyVar] [compactPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))-primOpInfo CompactSize = mkGenPrimOp (fsLit "compactSize#")  [] [compactPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, wordPrimTy]))-primOpInfo ReallyUnsafePtrEqualityOp = mkGenPrimOp (fsLit "reallyUnsafePtrEquality#")  [alphaTyVar] [alphaTy, alphaTy] (intPrimTy)-primOpInfo ParOp = mkGenPrimOp (fsLit "par#")  [alphaTyVar] [alphaTy] (intPrimTy)-primOpInfo SparkOp = mkGenPrimOp (fsLit "spark#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))-primOpInfo SeqOp = mkGenPrimOp (fsLit "seq#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))-primOpInfo GetSparkOp = mkGenPrimOp (fsLit "getSpark#")  [deltaTyVar, alphaTyVar] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))-primOpInfo NumSparks = mkGenPrimOp (fsLit "numSparks#")  [deltaTyVar] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo KeepAliveOp = mkGenPrimOp (fsLit "keepAlive#")  [runtimeRep1TyVar, openAlphaTyVar, runtimeRep2TyVar, openBetaTyVar] [openAlphaTy, mkStatePrimTy realWorldTy, (mkVisFunTyMany (mkStatePrimTy realWorldTy) (openBetaTy))] (openBetaTy)-primOpInfo DataToTagOp = mkGenPrimOp (fsLit "dataToTag#")  [alphaTyVar] [alphaTy] (intPrimTy)-primOpInfo TagToEnumOp = mkGenPrimOp (fsLit "tagToEnum#")  [alphaTyVar] [intPrimTy] (alphaTy)-primOpInfo AddrToAnyOp = mkGenPrimOp (fsLit "addrToAny#")  [alphaTyVar] [addrPrimTy] ((mkTupleTy Unboxed [alphaTy]))-primOpInfo AnyToAddrOp = mkGenPrimOp (fsLit "anyToAddr#")  [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy]))-primOpInfo MkApUpd0_Op = mkGenPrimOp (fsLit "mkApUpd0#")  [alphaTyVar] [bcoPrimTy] ((mkTupleTy Unboxed [alphaTy]))-primOpInfo NewBCOOp = mkGenPrimOp (fsLit "newBCO#")  [alphaTyVar, deltaTyVar] [byteArrayPrimTy, byteArrayPrimTy, mkArrayPrimTy alphaTy, intPrimTy, byteArrayPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, bcoPrimTy]))-primOpInfo UnpackClosureOp = mkGenPrimOp (fsLit "unpackClosure#")  [alphaTyVar, betaTyVar] [alphaTy] ((mkTupleTy Unboxed [addrPrimTy, byteArrayPrimTy, mkArrayPrimTy betaTy]))-primOpInfo ClosureSizeOp = mkGenPrimOp (fsLit "closureSize#")  [alphaTyVar] [alphaTy] (intPrimTy)-primOpInfo GetApStackValOp = mkGenPrimOp (fsLit "getApStackVal#")  [alphaTyVar, betaTyVar] [alphaTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, betaTy]))-primOpInfo GetCCSOfOp = mkGenPrimOp (fsLit "getCCSOf#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))-primOpInfo GetCurrentCCSOp = mkGenPrimOp (fsLit "getCurrentCCS#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))-primOpInfo ClearCCSOp = mkGenPrimOp (fsLit "clearCCS#")  [deltaTyVar, alphaTyVar] [(mkVisFunTyMany (mkStatePrimTy deltaTy) ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))-primOpInfo WhereFromOp = mkGenPrimOp (fsLit "whereFrom#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))-primOpInfo TraceEventOp = mkGenPrimOp (fsLit "traceEvent#")  [deltaTyVar] [addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo TraceEventBinaryOp = mkGenPrimOp (fsLit "traceBinaryEvent#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo TraceMarkerOp = mkGenPrimOp (fsLit "traceMarker#")  [deltaTyVar] [addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo SetThreadAllocationCounter = mkGenPrimOp (fsLit "setThreadAllocationCounter#")  [] [intPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)-primOpInfo (VecBroadcastOp IntVec 16 W8) = mkGenPrimOp (fsLit "broadcastInt8X16#")  [] [int8PrimTy] (int8X16PrimTy)-primOpInfo (VecBroadcastOp IntVec 8 W16) = mkGenPrimOp (fsLit "broadcastInt16X8#")  [] [int16PrimTy] (int16X8PrimTy)-primOpInfo (VecBroadcastOp IntVec 4 W32) = mkGenPrimOp (fsLit "broadcastInt32X4#")  [] [int32PrimTy] (int32X4PrimTy)-primOpInfo (VecBroadcastOp IntVec 2 W64) = mkGenPrimOp (fsLit "broadcastInt64X2#")  [] [intPrimTy] (int64X2PrimTy)-primOpInfo (VecBroadcastOp IntVec 32 W8) = mkGenPrimOp (fsLit "broadcastInt8X32#")  [] [int8PrimTy] (int8X32PrimTy)-primOpInfo (VecBroadcastOp IntVec 16 W16) = mkGenPrimOp (fsLit "broadcastInt16X16#")  [] [int16PrimTy] (int16X16PrimTy)-primOpInfo (VecBroadcastOp IntVec 8 W32) = mkGenPrimOp (fsLit "broadcastInt32X8#")  [] [int32PrimTy] (int32X8PrimTy)-primOpInfo (VecBroadcastOp IntVec 4 W64) = mkGenPrimOp (fsLit "broadcastInt64X4#")  [] [intPrimTy] (int64X4PrimTy)-primOpInfo (VecBroadcastOp IntVec 64 W8) = mkGenPrimOp (fsLit "broadcastInt8X64#")  [] [int8PrimTy] (int8X64PrimTy)-primOpInfo (VecBroadcastOp IntVec 32 W16) = mkGenPrimOp (fsLit "broadcastInt16X32#")  [] [int16PrimTy] (int16X32PrimTy)-primOpInfo (VecBroadcastOp IntVec 16 W32) = mkGenPrimOp (fsLit "broadcastInt32X16#")  [] [int32PrimTy] (int32X16PrimTy)-primOpInfo (VecBroadcastOp IntVec 8 W64) = mkGenPrimOp (fsLit "broadcastInt64X8#")  [] [intPrimTy] (int64X8PrimTy)-primOpInfo (VecBroadcastOp WordVec 16 W8) = mkGenPrimOp (fsLit "broadcastWord8X16#")  [] [wordPrimTy] (word8X16PrimTy)-primOpInfo (VecBroadcastOp WordVec 8 W16) = mkGenPrimOp (fsLit "broadcastWord16X8#")  [] [wordPrimTy] (word16X8PrimTy)-primOpInfo (VecBroadcastOp WordVec 4 W32) = mkGenPrimOp (fsLit "broadcastWord32X4#")  [] [word32PrimTy] (word32X4PrimTy)-primOpInfo (VecBroadcastOp WordVec 2 W64) = mkGenPrimOp (fsLit "broadcastWord64X2#")  [] [wordPrimTy] (word64X2PrimTy)-primOpInfo (VecBroadcastOp WordVec 32 W8) = mkGenPrimOp (fsLit "broadcastWord8X32#")  [] [wordPrimTy] (word8X32PrimTy)-primOpInfo (VecBroadcastOp WordVec 16 W16) = mkGenPrimOp (fsLit "broadcastWord16X16#")  [] [wordPrimTy] (word16X16PrimTy)-primOpInfo (VecBroadcastOp WordVec 8 W32) = mkGenPrimOp (fsLit "broadcastWord32X8#")  [] [word32PrimTy] (word32X8PrimTy)-primOpInfo (VecBroadcastOp WordVec 4 W64) = mkGenPrimOp (fsLit "broadcastWord64X4#")  [] [wordPrimTy] (word64X4PrimTy)-primOpInfo (VecBroadcastOp WordVec 64 W8) = mkGenPrimOp (fsLit "broadcastWord8X64#")  [] [wordPrimTy] (word8X64PrimTy)-primOpInfo (VecBroadcastOp WordVec 32 W16) = mkGenPrimOp (fsLit "broadcastWord16X32#")  [] [wordPrimTy] (word16X32PrimTy)-primOpInfo (VecBroadcastOp WordVec 16 W32) = mkGenPrimOp (fsLit "broadcastWord32X16#")  [] [word32PrimTy] (word32X16PrimTy)-primOpInfo (VecBroadcastOp WordVec 8 W64) = mkGenPrimOp (fsLit "broadcastWord64X8#")  [] [wordPrimTy] (word64X8PrimTy)-primOpInfo (VecBroadcastOp FloatVec 4 W32) = mkGenPrimOp (fsLit "broadcastFloatX4#")  [] [floatPrimTy] (floatX4PrimTy)-primOpInfo (VecBroadcastOp FloatVec 2 W64) = mkGenPrimOp (fsLit "broadcastDoubleX2#")  [] [doublePrimTy] (doubleX2PrimTy)-primOpInfo (VecBroadcastOp FloatVec 8 W32) = mkGenPrimOp (fsLit "broadcastFloatX8#")  [] [floatPrimTy] (floatX8PrimTy)-primOpInfo (VecBroadcastOp FloatVec 4 W64) = mkGenPrimOp (fsLit "broadcastDoubleX4#")  [] [doublePrimTy] (doubleX4PrimTy)-primOpInfo (VecBroadcastOp FloatVec 16 W32) = mkGenPrimOp (fsLit "broadcastFloatX16#")  [] [floatPrimTy] (floatX16PrimTy)-primOpInfo (VecBroadcastOp FloatVec 8 W64) = mkGenPrimOp (fsLit "broadcastDoubleX8#")  [] [doublePrimTy] (doubleX8PrimTy)-primOpInfo (VecPackOp IntVec 16 W8) = mkGenPrimOp (fsLit "packInt8X16#")  [] [(mkTupleTy Unboxed [int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy])] (int8X16PrimTy)-primOpInfo (VecPackOp IntVec 8 W16) = mkGenPrimOp (fsLit "packInt16X8#")  [] [(mkTupleTy Unboxed [int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy])] (int16X8PrimTy)-primOpInfo (VecPackOp IntVec 4 W32) = mkGenPrimOp (fsLit "packInt32X4#")  [] [(mkTupleTy Unboxed [int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy])] (int32X4PrimTy)-primOpInfo (VecPackOp IntVec 2 W64) = mkGenPrimOp (fsLit "packInt64X2#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy])] (int64X2PrimTy)-primOpInfo (VecPackOp IntVec 32 W8) = mkGenPrimOp (fsLit "packInt8X32#")  [] [(mkTupleTy Unboxed [int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy])] (int8X32PrimTy)-primOpInfo (VecPackOp IntVec 16 W16) = mkGenPrimOp (fsLit "packInt16X16#")  [] [(mkTupleTy Unboxed [int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy])] (int16X16PrimTy)-primOpInfo (VecPackOp IntVec 8 W32) = mkGenPrimOp (fsLit "packInt32X8#")  [] [(mkTupleTy Unboxed [int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy])] (int32X8PrimTy)-primOpInfo (VecPackOp IntVec 4 W64) = mkGenPrimOp (fsLit "packInt64X4#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int64X4PrimTy)-primOpInfo (VecPackOp IntVec 64 W8) = mkGenPrimOp (fsLit "packInt8X64#")  [] [(mkTupleTy Unboxed [int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy])] (int8X64PrimTy)-primOpInfo (VecPackOp IntVec 32 W16) = mkGenPrimOp (fsLit "packInt16X32#")  [] [(mkTupleTy Unboxed [int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy])] (int16X32PrimTy)-primOpInfo (VecPackOp IntVec 16 W32) = mkGenPrimOp (fsLit "packInt32X16#")  [] [(mkTupleTy Unboxed [int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy])] (int32X16PrimTy)-primOpInfo (VecPackOp IntVec 8 W64) = mkGenPrimOp (fsLit "packInt64X8#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int64X8PrimTy)-primOpInfo (VecPackOp WordVec 16 W8) = mkGenPrimOp (fsLit "packWord8X16#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word8X16PrimTy)-primOpInfo (VecPackOp WordVec 8 W16) = mkGenPrimOp (fsLit "packWord16X8#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word16X8PrimTy)-primOpInfo (VecPackOp WordVec 4 W32) = mkGenPrimOp (fsLit "packWord32X4#")  [] [(mkTupleTy Unboxed [word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy])] (word32X4PrimTy)-primOpInfo (VecPackOp WordVec 2 W64) = mkGenPrimOp (fsLit "packWord64X2#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy])] (word64X2PrimTy)-primOpInfo (VecPackOp WordVec 32 W8) = mkGenPrimOp (fsLit "packWord8X32#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word8X32PrimTy)-primOpInfo (VecPackOp WordVec 16 W16) = mkGenPrimOp (fsLit "packWord16X16#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word16X16PrimTy)-primOpInfo (VecPackOp WordVec 8 W32) = mkGenPrimOp (fsLit "packWord32X8#")  [] [(mkTupleTy Unboxed [word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy])] (word32X8PrimTy)-primOpInfo (VecPackOp WordVec 4 W64) = mkGenPrimOp (fsLit "packWord64X4#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word64X4PrimTy)-primOpInfo (VecPackOp WordVec 64 W8) = mkGenPrimOp (fsLit "packWord8X64#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word8X64PrimTy)-primOpInfo (VecPackOp WordVec 32 W16) = mkGenPrimOp (fsLit "packWord16X32#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word16X32PrimTy)-primOpInfo (VecPackOp WordVec 16 W32) = mkGenPrimOp (fsLit "packWord32X16#")  [] [(mkTupleTy Unboxed [word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy])] (word32X16PrimTy)-primOpInfo (VecPackOp WordVec 8 W64) = mkGenPrimOp (fsLit "packWord64X8#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word64X8PrimTy)-primOpInfo (VecPackOp FloatVec 4 W32) = mkGenPrimOp (fsLit "packFloatX4#")  [] [(mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])] (floatX4PrimTy)-primOpInfo (VecPackOp FloatVec 2 W64) = mkGenPrimOp (fsLit "packDoubleX2#")  [] [(mkTupleTy Unboxed [doublePrimTy, doublePrimTy])] (doubleX2PrimTy)-primOpInfo (VecPackOp FloatVec 8 W32) = mkGenPrimOp (fsLit "packFloatX8#")  [] [(mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])] (floatX8PrimTy)-primOpInfo (VecPackOp FloatVec 4 W64) = mkGenPrimOp (fsLit "packDoubleX4#")  [] [(mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy])] (doubleX4PrimTy)-primOpInfo (VecPackOp FloatVec 16 W32) = mkGenPrimOp (fsLit "packFloatX16#")  [] [(mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])] (floatX16PrimTy)-primOpInfo (VecPackOp FloatVec 8 W64) = mkGenPrimOp (fsLit "packDoubleX8#")  [] [(mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy])] (doubleX8PrimTy)-primOpInfo (VecUnpackOp IntVec 16 W8) = mkGenPrimOp (fsLit "unpackInt8X16#")  [] [int8X16PrimTy] ((mkTupleTy Unboxed [int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy]))-primOpInfo (VecUnpackOp IntVec 8 W16) = mkGenPrimOp (fsLit "unpackInt16X8#")  [] [int16X8PrimTy] ((mkTupleTy Unboxed [int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy]))-primOpInfo (VecUnpackOp IntVec 4 W32) = mkGenPrimOp (fsLit "unpackInt32X4#")  [] [int32X4PrimTy] ((mkTupleTy Unboxed [int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy]))-primOpInfo (VecUnpackOp IntVec 2 W64) = mkGenPrimOp (fsLit "unpackInt64X2#")  [] [int64X2PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))-primOpInfo (VecUnpackOp IntVec 32 W8) = mkGenPrimOp (fsLit "unpackInt8X32#")  [] [int8X32PrimTy] ((mkTupleTy Unboxed [int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy]))-primOpInfo (VecUnpackOp IntVec 16 W16) = mkGenPrimOp (fsLit "unpackInt16X16#")  [] [int16X16PrimTy] ((mkTupleTy Unboxed [int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy]))-primOpInfo (VecUnpackOp IntVec 8 W32) = mkGenPrimOp (fsLit "unpackInt32X8#")  [] [int32X8PrimTy] ((mkTupleTy Unboxed [int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy]))-primOpInfo (VecUnpackOp IntVec 4 W64) = mkGenPrimOp (fsLit "unpackInt64X4#")  [] [int64X4PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy]))-primOpInfo (VecUnpackOp IntVec 64 W8) = mkGenPrimOp (fsLit "unpackInt8X64#")  [] [int8X64PrimTy] ((mkTupleTy Unboxed [int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy]))-primOpInfo (VecUnpackOp IntVec 32 W16) = mkGenPrimOp (fsLit "unpackInt16X32#")  [] [int16X32PrimTy] ((mkTupleTy Unboxed [int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy]))-primOpInfo (VecUnpackOp IntVec 16 W32) = mkGenPrimOp (fsLit "unpackInt32X16#")  [] [int32X16PrimTy] ((mkTupleTy Unboxed [int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy]))-primOpInfo (VecUnpackOp IntVec 8 W64) = mkGenPrimOp (fsLit "unpackInt64X8#")  [] [int64X8PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))-primOpInfo (VecUnpackOp WordVec 16 W8) = mkGenPrimOp (fsLit "unpackWord8X16#")  [] [word8X16PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))-primOpInfo (VecUnpackOp WordVec 8 W16) = mkGenPrimOp (fsLit "unpackWord16X8#")  [] [word16X8PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))-primOpInfo (VecUnpackOp WordVec 4 W32) = mkGenPrimOp (fsLit "unpackWord32X4#")  [] [word32X4PrimTy] ((mkTupleTy Unboxed [word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy]))-primOpInfo (VecUnpackOp WordVec 2 W64) = mkGenPrimOp (fsLit "unpackWord64X2#")  [] [word64X2PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))-primOpInfo (VecUnpackOp WordVec 32 W8) = mkGenPrimOp (fsLit "unpackWord8X32#")  [] [word8X32PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))-primOpInfo (VecUnpackOp WordVec 16 W16) = mkGenPrimOp (fsLit "unpackWord16X16#")  [] [word16X16PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))-primOpInfo (VecUnpackOp WordVec 8 W32) = mkGenPrimOp (fsLit "unpackWord32X8#")  [] [word32X8PrimTy] ((mkTupleTy Unboxed [word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy]))-primOpInfo (VecUnpackOp WordVec 4 W64) = mkGenPrimOp (fsLit "unpackWord64X4#")  [] [word64X4PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))-primOpInfo (VecUnpackOp WordVec 64 W8) = mkGenPrimOp (fsLit "unpackWord8X64#")  [] [word8X64PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))-primOpInfo (VecUnpackOp WordVec 32 W16) = mkGenPrimOp (fsLit "unpackWord16X32#")  [] [word16X32PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))-primOpInfo (VecUnpackOp WordVec 16 W32) = mkGenPrimOp (fsLit "unpackWord32X16#")  [] [word32X16PrimTy] ((mkTupleTy Unboxed [word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy]))-primOpInfo (VecUnpackOp WordVec 8 W64) = mkGenPrimOp (fsLit "unpackWord64X8#")  [] [word64X8PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))-primOpInfo (VecUnpackOp FloatVec 4 W32) = mkGenPrimOp (fsLit "unpackFloatX4#")  [] [floatX4PrimTy] ((mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy]))-primOpInfo (VecUnpackOp FloatVec 2 W64) = mkGenPrimOp (fsLit "unpackDoubleX2#")  [] [doubleX2PrimTy] ((mkTupleTy Unboxed [doublePrimTy, doublePrimTy]))-primOpInfo (VecUnpackOp FloatVec 8 W32) = mkGenPrimOp (fsLit "unpackFloatX8#")  [] [floatX8PrimTy] ((mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy]))-primOpInfo (VecUnpackOp FloatVec 4 W64) = mkGenPrimOp (fsLit "unpackDoubleX4#")  [] [doubleX4PrimTy] ((mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy]))-primOpInfo (VecUnpackOp FloatVec 16 W32) = mkGenPrimOp (fsLit "unpackFloatX16#")  [] [floatX16PrimTy] ((mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy]))-primOpInfo (VecUnpackOp FloatVec 8 W64) = mkGenPrimOp (fsLit "unpackDoubleX8#")  [] [doubleX8PrimTy] ((mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy]))-primOpInfo (VecInsertOp IntVec 16 W8) = mkGenPrimOp (fsLit "insertInt8X16#")  [] [int8X16PrimTy, int8PrimTy, intPrimTy] (int8X16PrimTy)-primOpInfo (VecInsertOp IntVec 8 W16) = mkGenPrimOp (fsLit "insertInt16X8#")  [] [int16X8PrimTy, int16PrimTy, intPrimTy] (int16X8PrimTy)-primOpInfo (VecInsertOp IntVec 4 W32) = mkGenPrimOp (fsLit "insertInt32X4#")  [] [int32X4PrimTy, int32PrimTy, intPrimTy] (int32X4PrimTy)-primOpInfo (VecInsertOp IntVec 2 W64) = mkGenPrimOp (fsLit "insertInt64X2#")  [] [int64X2PrimTy, intPrimTy, intPrimTy] (int64X2PrimTy)-primOpInfo (VecInsertOp IntVec 32 W8) = mkGenPrimOp (fsLit "insertInt8X32#")  [] [int8X32PrimTy, int8PrimTy, intPrimTy] (int8X32PrimTy)-primOpInfo (VecInsertOp IntVec 16 W16) = mkGenPrimOp (fsLit "insertInt16X16#")  [] [int16X16PrimTy, int16PrimTy, intPrimTy] (int16X16PrimTy)-primOpInfo (VecInsertOp IntVec 8 W32) = mkGenPrimOp (fsLit "insertInt32X8#")  [] [int32X8PrimTy, int32PrimTy, intPrimTy] (int32X8PrimTy)-primOpInfo (VecInsertOp IntVec 4 W64) = mkGenPrimOp (fsLit "insertInt64X4#")  [] [int64X4PrimTy, intPrimTy, intPrimTy] (int64X4PrimTy)-primOpInfo (VecInsertOp IntVec 64 W8) = mkGenPrimOp (fsLit "insertInt8X64#")  [] [int8X64PrimTy, int8PrimTy, intPrimTy] (int8X64PrimTy)-primOpInfo (VecInsertOp IntVec 32 W16) = mkGenPrimOp (fsLit "insertInt16X32#")  [] [int16X32PrimTy, int16PrimTy, intPrimTy] (int16X32PrimTy)-primOpInfo (VecInsertOp IntVec 16 W32) = mkGenPrimOp (fsLit "insertInt32X16#")  [] [int32X16PrimTy, int32PrimTy, intPrimTy] (int32X16PrimTy)-primOpInfo (VecInsertOp IntVec 8 W64) = mkGenPrimOp (fsLit "insertInt64X8#")  [] [int64X8PrimTy, intPrimTy, intPrimTy] (int64X8PrimTy)-primOpInfo (VecInsertOp WordVec 16 W8) = mkGenPrimOp (fsLit "insertWord8X16#")  [] [word8X16PrimTy, wordPrimTy, intPrimTy] (word8X16PrimTy)-primOpInfo (VecInsertOp WordVec 8 W16) = mkGenPrimOp (fsLit "insertWord16X8#")  [] [word16X8PrimTy, wordPrimTy, intPrimTy] (word16X8PrimTy)-primOpInfo (VecInsertOp WordVec 4 W32) = mkGenPrimOp (fsLit "insertWord32X4#")  [] [word32X4PrimTy, word32PrimTy, intPrimTy] (word32X4PrimTy)-primOpInfo (VecInsertOp WordVec 2 W64) = mkGenPrimOp (fsLit "insertWord64X2#")  [] [word64X2PrimTy, wordPrimTy, intPrimTy] (word64X2PrimTy)-primOpInfo (VecInsertOp WordVec 32 W8) = mkGenPrimOp (fsLit "insertWord8X32#")  [] [word8X32PrimTy, wordPrimTy, intPrimTy] (word8X32PrimTy)-primOpInfo (VecInsertOp WordVec 16 W16) = mkGenPrimOp (fsLit "insertWord16X16#")  [] [word16X16PrimTy, wordPrimTy, intPrimTy] (word16X16PrimTy)-primOpInfo (VecInsertOp WordVec 8 W32) = mkGenPrimOp (fsLit "insertWord32X8#")  [] [word32X8PrimTy, word32PrimTy, intPrimTy] (word32X8PrimTy)-primOpInfo (VecInsertOp WordVec 4 W64) = mkGenPrimOp (fsLit "insertWord64X4#")  [] [word64X4PrimTy, wordPrimTy, intPrimTy] (word64X4PrimTy)-primOpInfo (VecInsertOp WordVec 64 W8) = mkGenPrimOp (fsLit "insertWord8X64#")  [] [word8X64PrimTy, wordPrimTy, intPrimTy] (word8X64PrimTy)-primOpInfo (VecInsertOp WordVec 32 W16) = mkGenPrimOp (fsLit "insertWord16X32#")  [] [word16X32PrimTy, wordPrimTy, intPrimTy] (word16X32PrimTy)-primOpInfo (VecInsertOp WordVec 16 W32) = mkGenPrimOp (fsLit "insertWord32X16#")  [] [word32X16PrimTy, word32PrimTy, intPrimTy] (word32X16PrimTy)-primOpInfo (VecInsertOp WordVec 8 W64) = mkGenPrimOp (fsLit "insertWord64X8#")  [] [word64X8PrimTy, wordPrimTy, intPrimTy] (word64X8PrimTy)-primOpInfo (VecInsertOp FloatVec 4 W32) = mkGenPrimOp (fsLit "insertFloatX4#")  [] [floatX4PrimTy, floatPrimTy, intPrimTy] (floatX4PrimTy)-primOpInfo (VecInsertOp FloatVec 2 W64) = mkGenPrimOp (fsLit "insertDoubleX2#")  [] [doubleX2PrimTy, doublePrimTy, intPrimTy] (doubleX2PrimTy)-primOpInfo (VecInsertOp FloatVec 8 W32) = mkGenPrimOp (fsLit "insertFloatX8#")  [] [floatX8PrimTy, floatPrimTy, intPrimTy] (floatX8PrimTy)-primOpInfo (VecInsertOp FloatVec 4 W64) = mkGenPrimOp (fsLit "insertDoubleX4#")  [] [doubleX4PrimTy, doublePrimTy, intPrimTy] (doubleX4PrimTy)-primOpInfo (VecInsertOp FloatVec 16 W32) = mkGenPrimOp (fsLit "insertFloatX16#")  [] [floatX16PrimTy, floatPrimTy, intPrimTy] (floatX16PrimTy)-primOpInfo (VecInsertOp FloatVec 8 W64) = mkGenPrimOp (fsLit "insertDoubleX8#")  [] [doubleX8PrimTy, doublePrimTy, intPrimTy] (doubleX8PrimTy)-primOpInfo (VecAddOp IntVec 16 W8) = mkGenPrimOp (fsLit "plusInt8X16#")  [] [int8X16PrimTy, int8X16PrimTy] (int8X16PrimTy)-primOpInfo (VecAddOp IntVec 8 W16) = mkGenPrimOp (fsLit "plusInt16X8#")  [] [int16X8PrimTy, int16X8PrimTy] (int16X8PrimTy)-primOpInfo (VecAddOp IntVec 4 W32) = mkGenPrimOp (fsLit "plusInt32X4#")  [] [int32X4PrimTy, int32X4PrimTy] (int32X4PrimTy)-primOpInfo (VecAddOp IntVec 2 W64) = mkGenPrimOp (fsLit "plusInt64X2#")  [] [int64X2PrimTy, int64X2PrimTy] (int64X2PrimTy)-primOpInfo (VecAddOp IntVec 32 W8) = mkGenPrimOp (fsLit "plusInt8X32#")  [] [int8X32PrimTy, int8X32PrimTy] (int8X32PrimTy)-primOpInfo (VecAddOp IntVec 16 W16) = mkGenPrimOp (fsLit "plusInt16X16#")  [] [int16X16PrimTy, int16X16PrimTy] (int16X16PrimTy)-primOpInfo (VecAddOp IntVec 8 W32) = mkGenPrimOp (fsLit "plusInt32X8#")  [] [int32X8PrimTy, int32X8PrimTy] (int32X8PrimTy)-primOpInfo (VecAddOp IntVec 4 W64) = mkGenPrimOp (fsLit "plusInt64X4#")  [] [int64X4PrimTy, int64X4PrimTy] (int64X4PrimTy)-primOpInfo (VecAddOp IntVec 64 W8) = mkGenPrimOp (fsLit "plusInt8X64#")  [] [int8X64PrimTy, int8X64PrimTy] (int8X64PrimTy)-primOpInfo (VecAddOp IntVec 32 W16) = mkGenPrimOp (fsLit "plusInt16X32#")  [] [int16X32PrimTy, int16X32PrimTy] (int16X32PrimTy)-primOpInfo (VecAddOp IntVec 16 W32) = mkGenPrimOp (fsLit "plusInt32X16#")  [] [int32X16PrimTy, int32X16PrimTy] (int32X16PrimTy)-primOpInfo (VecAddOp IntVec 8 W64) = mkGenPrimOp (fsLit "plusInt64X8#")  [] [int64X8PrimTy, int64X8PrimTy] (int64X8PrimTy)-primOpInfo (VecAddOp WordVec 16 W8) = mkGenPrimOp (fsLit "plusWord8X16#")  [] [word8X16PrimTy, word8X16PrimTy] (word8X16PrimTy)-primOpInfo (VecAddOp WordVec 8 W16) = mkGenPrimOp (fsLit "plusWord16X8#")  [] [word16X8PrimTy, word16X8PrimTy] (word16X8PrimTy)-primOpInfo (VecAddOp WordVec 4 W32) = mkGenPrimOp (fsLit "plusWord32X4#")  [] [word32X4PrimTy, word32X4PrimTy] (word32X4PrimTy)-primOpInfo (VecAddOp WordVec 2 W64) = mkGenPrimOp (fsLit "plusWord64X2#")  [] [word64X2PrimTy, word64X2PrimTy] (word64X2PrimTy)-primOpInfo (VecAddOp WordVec 32 W8) = mkGenPrimOp (fsLit "plusWord8X32#")  [] [word8X32PrimTy, word8X32PrimTy] (word8X32PrimTy)-primOpInfo (VecAddOp WordVec 16 W16) = mkGenPrimOp (fsLit "plusWord16X16#")  [] [word16X16PrimTy, word16X16PrimTy] (word16X16PrimTy)-primOpInfo (VecAddOp WordVec 8 W32) = mkGenPrimOp (fsLit "plusWord32X8#")  [] [word32X8PrimTy, word32X8PrimTy] (word32X8PrimTy)-primOpInfo (VecAddOp WordVec 4 W64) = mkGenPrimOp (fsLit "plusWord64X4#")  [] [word64X4PrimTy, word64X4PrimTy] (word64X4PrimTy)-primOpInfo (VecAddOp WordVec 64 W8) = mkGenPrimOp (fsLit "plusWord8X64#")  [] [word8X64PrimTy, word8X64PrimTy] (word8X64PrimTy)-primOpInfo (VecAddOp WordVec 32 W16) = mkGenPrimOp (fsLit "plusWord16X32#")  [] [word16X32PrimTy, word16X32PrimTy] (word16X32PrimTy)-primOpInfo (VecAddOp WordVec 16 W32) = mkGenPrimOp (fsLit "plusWord32X16#")  [] [word32X16PrimTy, word32X16PrimTy] (word32X16PrimTy)-primOpInfo (VecAddOp WordVec 8 W64) = mkGenPrimOp (fsLit "plusWord64X8#")  [] [word64X8PrimTy, word64X8PrimTy] (word64X8PrimTy)-primOpInfo (VecAddOp FloatVec 4 W32) = mkGenPrimOp (fsLit "plusFloatX4#")  [] [floatX4PrimTy, floatX4PrimTy] (floatX4PrimTy)-primOpInfo (VecAddOp FloatVec 2 W64) = mkGenPrimOp (fsLit "plusDoubleX2#")  [] [doubleX2PrimTy, doubleX2PrimTy] (doubleX2PrimTy)-primOpInfo (VecAddOp FloatVec 8 W32) = mkGenPrimOp (fsLit "plusFloatX8#")  [] [floatX8PrimTy, floatX8PrimTy] (floatX8PrimTy)-primOpInfo (VecAddOp FloatVec 4 W64) = mkGenPrimOp (fsLit "plusDoubleX4#")  [] [doubleX4PrimTy, doubleX4PrimTy] (doubleX4PrimTy)-primOpInfo (VecAddOp FloatVec 16 W32) = mkGenPrimOp (fsLit "plusFloatX16#")  [] [floatX16PrimTy, floatX16PrimTy] (floatX16PrimTy)-primOpInfo (VecAddOp FloatVec 8 W64) = mkGenPrimOp (fsLit "plusDoubleX8#")  [] [doubleX8PrimTy, doubleX8PrimTy] (doubleX8PrimTy)-primOpInfo (VecSubOp IntVec 16 W8) = mkGenPrimOp (fsLit "minusInt8X16#")  [] [int8X16PrimTy, int8X16PrimTy] (int8X16PrimTy)-primOpInfo (VecSubOp IntVec 8 W16) = mkGenPrimOp (fsLit "minusInt16X8#")  [] [int16X8PrimTy, int16X8PrimTy] (int16X8PrimTy)-primOpInfo (VecSubOp IntVec 4 W32) = mkGenPrimOp (fsLit "minusInt32X4#")  [] [int32X4PrimTy, int32X4PrimTy] (int32X4PrimTy)-primOpInfo (VecSubOp IntVec 2 W64) = mkGenPrimOp (fsLit "minusInt64X2#")  [] [int64X2PrimTy, int64X2PrimTy] (int64X2PrimTy)-primOpInfo (VecSubOp IntVec 32 W8) = mkGenPrimOp (fsLit "minusInt8X32#")  [] [int8X32PrimTy, int8X32PrimTy] (int8X32PrimTy)-primOpInfo (VecSubOp IntVec 16 W16) = mkGenPrimOp (fsLit "minusInt16X16#")  [] [int16X16PrimTy, int16X16PrimTy] (int16X16PrimTy)-primOpInfo (VecSubOp IntVec 8 W32) = mkGenPrimOp (fsLit "minusInt32X8#")  [] [int32X8PrimTy, int32X8PrimTy] (int32X8PrimTy)-primOpInfo (VecSubOp IntVec 4 W64) = mkGenPrimOp (fsLit "minusInt64X4#")  [] [int64X4PrimTy, int64X4PrimTy] (int64X4PrimTy)-primOpInfo (VecSubOp IntVec 64 W8) = mkGenPrimOp (fsLit "minusInt8X64#")  [] [int8X64PrimTy, int8X64PrimTy] (int8X64PrimTy)-primOpInfo (VecSubOp IntVec 32 W16) = mkGenPrimOp (fsLit "minusInt16X32#")  [] [int16X32PrimTy, int16X32PrimTy] (int16X32PrimTy)-primOpInfo (VecSubOp IntVec 16 W32) = mkGenPrimOp (fsLit "minusInt32X16#")  [] [int32X16PrimTy, int32X16PrimTy] (int32X16PrimTy)-primOpInfo (VecSubOp IntVec 8 W64) = mkGenPrimOp (fsLit "minusInt64X8#")  [] [int64X8PrimTy, int64X8PrimTy] (int64X8PrimTy)-primOpInfo (VecSubOp WordVec 16 W8) = mkGenPrimOp (fsLit "minusWord8X16#")  [] [word8X16PrimTy, word8X16PrimTy] (word8X16PrimTy)-primOpInfo (VecSubOp WordVec 8 W16) = mkGenPrimOp (fsLit "minusWord16X8#")  [] [word16X8PrimTy, word16X8PrimTy] (word16X8PrimTy)-primOpInfo (VecSubOp WordVec 4 W32) = mkGenPrimOp (fsLit "minusWord32X4#")  [] [word32X4PrimTy, word32X4PrimTy] (word32X4PrimTy)-primOpInfo (VecSubOp WordVec 2 W64) = mkGenPrimOp (fsLit "minusWord64X2#")  [] [word64X2PrimTy, word64X2PrimTy] (word64X2PrimTy)-primOpInfo (VecSubOp WordVec 32 W8) = mkGenPrimOp (fsLit "minusWord8X32#")  [] [word8X32PrimTy, word8X32PrimTy] (word8X32PrimTy)-primOpInfo (VecSubOp WordVec 16 W16) = mkGenPrimOp (fsLit "minusWord16X16#")  [] [word16X16PrimTy, word16X16PrimTy] (word16X16PrimTy)-primOpInfo (VecSubOp WordVec 8 W32) = mkGenPrimOp (fsLit "minusWord32X8#")  [] [word32X8PrimTy, word32X8PrimTy] (word32X8PrimTy)-primOpInfo (VecSubOp WordVec 4 W64) = mkGenPrimOp (fsLit "minusWord64X4#")  [] [word64X4PrimTy, word64X4PrimTy] (word64X4PrimTy)-primOpInfo (VecSubOp WordVec 64 W8) = mkGenPrimOp (fsLit "minusWord8X64#")  [] [word8X64PrimTy, word8X64PrimTy] (word8X64PrimTy)-primOpInfo (VecSubOp WordVec 32 W16) = mkGenPrimOp (fsLit "minusWord16X32#")  [] [word16X32PrimTy, word16X32PrimTy] (word16X32PrimTy)-primOpInfo (VecSubOp WordVec 16 W32) = mkGenPrimOp (fsLit "minusWord32X16#")  [] [word32X16PrimTy, word32X16PrimTy] (word32X16PrimTy)-primOpInfo (VecSubOp WordVec 8 W64) = mkGenPrimOp (fsLit "minusWord64X8#")  [] [word64X8PrimTy, word64X8PrimTy] (word64X8PrimTy)-primOpInfo (VecSubOp FloatVec 4 W32) = mkGenPrimOp (fsLit "minusFloatX4#")  [] [floatX4PrimTy, floatX4PrimTy] (floatX4PrimTy)-primOpInfo (VecSubOp FloatVec 2 W64) = mkGenPrimOp (fsLit "minusDoubleX2#")  [] [doubleX2PrimTy, doubleX2PrimTy] (doubleX2PrimTy)-primOpInfo (VecSubOp FloatVec 8 W32) = mkGenPrimOp (fsLit "minusFloatX8#")  [] [floatX8PrimTy, floatX8PrimTy] (floatX8PrimTy)-primOpInfo (VecSubOp FloatVec 4 W64) = mkGenPrimOp (fsLit "minusDoubleX4#")  [] [doubleX4PrimTy, doubleX4PrimTy] (doubleX4PrimTy)-primOpInfo (VecSubOp FloatVec 16 W32) = mkGenPrimOp (fsLit "minusFloatX16#")  [] [floatX16PrimTy, floatX16PrimTy] (floatX16PrimTy)-primOpInfo (VecSubOp FloatVec 8 W64) = mkGenPrimOp (fsLit "minusDoubleX8#")  [] [doubleX8PrimTy, doubleX8PrimTy] (doubleX8PrimTy)-primOpInfo (VecMulOp IntVec 16 W8) = mkGenPrimOp (fsLit "timesInt8X16#")  [] [int8X16PrimTy, int8X16PrimTy] (int8X16PrimTy)-primOpInfo (VecMulOp IntVec 8 W16) = mkGenPrimOp (fsLit "timesInt16X8#")  [] [int16X8PrimTy, int16X8PrimTy] (int16X8PrimTy)-primOpInfo (VecMulOp IntVec 4 W32) = mkGenPrimOp (fsLit "timesInt32X4#")  [] [int32X4PrimTy, int32X4PrimTy] (int32X4PrimTy)-primOpInfo (VecMulOp IntVec 2 W64) = mkGenPrimOp (fsLit "timesInt64X2#")  [] [int64X2PrimTy, int64X2PrimTy] (int64X2PrimTy)-primOpInfo (VecMulOp IntVec 32 W8) = mkGenPrimOp (fsLit "timesInt8X32#")  [] [int8X32PrimTy, int8X32PrimTy] (int8X32PrimTy)-primOpInfo (VecMulOp IntVec 16 W16) = mkGenPrimOp (fsLit "timesInt16X16#")  [] [int16X16PrimTy, int16X16PrimTy] (int16X16PrimTy)-primOpInfo (VecMulOp IntVec 8 W32) = mkGenPrimOp (fsLit "timesInt32X8#")  [] [int32X8PrimTy, int32X8PrimTy] (int32X8PrimTy)-primOpInfo (VecMulOp IntVec 4 W64) = mkGenPrimOp (fsLit "timesInt64X4#")  [] [int64X4PrimTy, int64X4PrimTy] (int64X4PrimTy)-primOpInfo (VecMulOp IntVec 64 W8) = mkGenPrimOp (fsLit "timesInt8X64#")  [] [int8X64PrimTy, int8X64PrimTy] (int8X64PrimTy)-primOpInfo (VecMulOp IntVec 32 W16) = mkGenPrimOp (fsLit "timesInt16X32#")  [] [int16X32PrimTy, int16X32PrimTy] (int16X32PrimTy)-primOpInfo (VecMulOp IntVec 16 W32) = mkGenPrimOp (fsLit "timesInt32X16#")  [] [int32X16PrimTy, int32X16PrimTy] (int32X16PrimTy)-primOpInfo (VecMulOp IntVec 8 W64) = mkGenPrimOp (fsLit "timesInt64X8#")  [] [int64X8PrimTy, int64X8PrimTy] (int64X8PrimTy)-primOpInfo (VecMulOp WordVec 16 W8) = mkGenPrimOp (fsLit "timesWord8X16#")  [] [word8X16PrimTy, word8X16PrimTy] (word8X16PrimTy)-primOpInfo (VecMulOp WordVec 8 W16) = mkGenPrimOp (fsLit "timesWord16X8#")  [] [word16X8PrimTy, word16X8PrimTy] (word16X8PrimTy)-primOpInfo (VecMulOp WordVec 4 W32) = mkGenPrimOp (fsLit "timesWord32X4#")  [] [word32X4PrimTy, word32X4PrimTy] (word32X4PrimTy)-primOpInfo (VecMulOp WordVec 2 W64) = mkGenPrimOp (fsLit "timesWord64X2#")  [] [word64X2PrimTy, word64X2PrimTy] (word64X2PrimTy)-primOpInfo (VecMulOp WordVec 32 W8) = mkGenPrimOp (fsLit "timesWord8X32#")  [] [word8X32PrimTy, word8X32PrimTy] (word8X32PrimTy)-primOpInfo (VecMulOp WordVec 16 W16) = mkGenPrimOp (fsLit "timesWord16X16#")  [] [word16X16PrimTy, word16X16PrimTy] (word16X16PrimTy)-primOpInfo (VecMulOp WordVec 8 W32) = mkGenPrimOp (fsLit "timesWord32X8#")  [] [word32X8PrimTy, word32X8PrimTy] (word32X8PrimTy)-primOpInfo (VecMulOp WordVec 4 W64) = mkGenPrimOp (fsLit "timesWord64X4#")  [] [word64X4PrimTy, word64X4PrimTy] (word64X4PrimTy)-primOpInfo (VecMulOp WordVec 64 W8) = mkGenPrimOp (fsLit "timesWord8X64#")  [] [word8X64PrimTy, word8X64PrimTy] (word8X64PrimTy)-primOpInfo (VecMulOp WordVec 32 W16) = mkGenPrimOp (fsLit "timesWord16X32#")  [] [word16X32PrimTy, word16X32PrimTy] (word16X32PrimTy)-primOpInfo (VecMulOp WordVec 16 W32) = mkGenPrimOp (fsLit "timesWord32X16#")  [] [word32X16PrimTy, word32X16PrimTy] (word32X16PrimTy)-primOpInfo (VecMulOp WordVec 8 W64) = mkGenPrimOp (fsLit "timesWord64X8#")  [] [word64X8PrimTy, word64X8PrimTy] (word64X8PrimTy)-primOpInfo (VecMulOp FloatVec 4 W32) = mkGenPrimOp (fsLit "timesFloatX4#")  [] [floatX4PrimTy, floatX4PrimTy] (floatX4PrimTy)-primOpInfo (VecMulOp FloatVec 2 W64) = mkGenPrimOp (fsLit "timesDoubleX2#")  [] [doubleX2PrimTy, doubleX2PrimTy] (doubleX2PrimTy)-primOpInfo (VecMulOp FloatVec 8 W32) = mkGenPrimOp (fsLit "timesFloatX8#")  [] [floatX8PrimTy, floatX8PrimTy] (floatX8PrimTy)-primOpInfo (VecMulOp FloatVec 4 W64) = mkGenPrimOp (fsLit "timesDoubleX4#")  [] [doubleX4PrimTy, doubleX4PrimTy] (doubleX4PrimTy)-primOpInfo (VecMulOp FloatVec 16 W32) = mkGenPrimOp (fsLit "timesFloatX16#")  [] [floatX16PrimTy, floatX16PrimTy] (floatX16PrimTy)-primOpInfo (VecMulOp FloatVec 8 W64) = mkGenPrimOp (fsLit "timesDoubleX8#")  [] [doubleX8PrimTy, doubleX8PrimTy] (doubleX8PrimTy)-primOpInfo (VecDivOp FloatVec 4 W32) = mkGenPrimOp (fsLit "divideFloatX4#")  [] [floatX4PrimTy, floatX4PrimTy] (floatX4PrimTy)-primOpInfo (VecDivOp FloatVec 2 W64) = mkGenPrimOp (fsLit "divideDoubleX2#")  [] [doubleX2PrimTy, doubleX2PrimTy] (doubleX2PrimTy)-primOpInfo (VecDivOp FloatVec 8 W32) = mkGenPrimOp (fsLit "divideFloatX8#")  [] [floatX8PrimTy, floatX8PrimTy] (floatX8PrimTy)-primOpInfo (VecDivOp FloatVec 4 W64) = mkGenPrimOp (fsLit "divideDoubleX4#")  [] [doubleX4PrimTy, doubleX4PrimTy] (doubleX4PrimTy)-primOpInfo (VecDivOp FloatVec 16 W32) = mkGenPrimOp (fsLit "divideFloatX16#")  [] [floatX16PrimTy, floatX16PrimTy] (floatX16PrimTy)-primOpInfo (VecDivOp FloatVec 8 W64) = mkGenPrimOp (fsLit "divideDoubleX8#")  [] [doubleX8PrimTy, doubleX8PrimTy] (doubleX8PrimTy)-primOpInfo (VecQuotOp IntVec 16 W8) = mkGenPrimOp (fsLit "quotInt8X16#")  [] [int8X16PrimTy, int8X16PrimTy] (int8X16PrimTy)-primOpInfo (VecQuotOp IntVec 8 W16) = mkGenPrimOp (fsLit "quotInt16X8#")  [] [int16X8PrimTy, int16X8PrimTy] (int16X8PrimTy)-primOpInfo (VecQuotOp IntVec 4 W32) = mkGenPrimOp (fsLit "quotInt32X4#")  [] [int32X4PrimTy, int32X4PrimTy] (int32X4PrimTy)-primOpInfo (VecQuotOp IntVec 2 W64) = mkGenPrimOp (fsLit "quotInt64X2#")  [] [int64X2PrimTy, int64X2PrimTy] (int64X2PrimTy)-primOpInfo (VecQuotOp IntVec 32 W8) = mkGenPrimOp (fsLit "quotInt8X32#")  [] [int8X32PrimTy, int8X32PrimTy] (int8X32PrimTy)-primOpInfo (VecQuotOp IntVec 16 W16) = mkGenPrimOp (fsLit "quotInt16X16#")  [] [int16X16PrimTy, int16X16PrimTy] (int16X16PrimTy)-primOpInfo (VecQuotOp IntVec 8 W32) = mkGenPrimOp (fsLit "quotInt32X8#")  [] [int32X8PrimTy, int32X8PrimTy] (int32X8PrimTy)-primOpInfo (VecQuotOp IntVec 4 W64) = mkGenPrimOp (fsLit "quotInt64X4#")  [] [int64X4PrimTy, int64X4PrimTy] (int64X4PrimTy)-primOpInfo (VecQuotOp IntVec 64 W8) = mkGenPrimOp (fsLit "quotInt8X64#")  [] [int8X64PrimTy, int8X64PrimTy] (int8X64PrimTy)-primOpInfo (VecQuotOp IntVec 32 W16) = mkGenPrimOp (fsLit "quotInt16X32#")  [] [int16X32PrimTy, int16X32PrimTy] (int16X32PrimTy)-primOpInfo (VecQuotOp IntVec 16 W32) = mkGenPrimOp (fsLit "quotInt32X16#")  [] [int32X16PrimTy, int32X16PrimTy] (int32X16PrimTy)-primOpInfo (VecQuotOp IntVec 8 W64) = mkGenPrimOp (fsLit "quotInt64X8#")  [] [int64X8PrimTy, int64X8PrimTy] (int64X8PrimTy)-primOpInfo (VecQuotOp WordVec 16 W8) = mkGenPrimOp (fsLit "quotWord8X16#")  [] [word8X16PrimTy, word8X16PrimTy] (word8X16PrimTy)-primOpInfo (VecQuotOp WordVec 8 W16) = mkGenPrimOp (fsLit "quotWord16X8#")  [] [word16X8PrimTy, word16X8PrimTy] (word16X8PrimTy)-primOpInfo (VecQuotOp WordVec 4 W32) = mkGenPrimOp (fsLit "quotWord32X4#")  [] [word32X4PrimTy, word32X4PrimTy] (word32X4PrimTy)-primOpInfo (VecQuotOp WordVec 2 W64) = mkGenPrimOp (fsLit "quotWord64X2#")  [] [word64X2PrimTy, word64X2PrimTy] (word64X2PrimTy)-primOpInfo (VecQuotOp WordVec 32 W8) = mkGenPrimOp (fsLit "quotWord8X32#")  [] [word8X32PrimTy, word8X32PrimTy] (word8X32PrimTy)-primOpInfo (VecQuotOp WordVec 16 W16) = mkGenPrimOp (fsLit "quotWord16X16#")  [] [word16X16PrimTy, word16X16PrimTy] (word16X16PrimTy)-primOpInfo (VecQuotOp WordVec 8 W32) = mkGenPrimOp (fsLit "quotWord32X8#")  [] [word32X8PrimTy, word32X8PrimTy] (word32X8PrimTy)-primOpInfo (VecQuotOp WordVec 4 W64) = mkGenPrimOp (fsLit "quotWord64X4#")  [] [word64X4PrimTy, word64X4PrimTy] (word64X4PrimTy)-primOpInfo (VecQuotOp WordVec 64 W8) = mkGenPrimOp (fsLit "quotWord8X64#")  [] [word8X64PrimTy, word8X64PrimTy] (word8X64PrimTy)-primOpInfo (VecQuotOp WordVec 32 W16) = mkGenPrimOp (fsLit "quotWord16X32#")  [] [word16X32PrimTy, word16X32PrimTy] (word16X32PrimTy)-primOpInfo (VecQuotOp WordVec 16 W32) = mkGenPrimOp (fsLit "quotWord32X16#")  [] [word32X16PrimTy, word32X16PrimTy] (word32X16PrimTy)-primOpInfo (VecQuotOp WordVec 8 W64) = mkGenPrimOp (fsLit "quotWord64X8#")  [] [word64X8PrimTy, word64X8PrimTy] (word64X8PrimTy)-primOpInfo (VecRemOp IntVec 16 W8) = mkGenPrimOp (fsLit "remInt8X16#")  [] [int8X16PrimTy, int8X16PrimTy] (int8X16PrimTy)-primOpInfo (VecRemOp IntVec 8 W16) = mkGenPrimOp (fsLit "remInt16X8#")  [] [int16X8PrimTy, int16X8PrimTy] (int16X8PrimTy)-primOpInfo (VecRemOp IntVec 4 W32) = mkGenPrimOp (fsLit "remInt32X4#")  [] [int32X4PrimTy, int32X4PrimTy] (int32X4PrimTy)-primOpInfo (VecRemOp IntVec 2 W64) = mkGenPrimOp (fsLit "remInt64X2#")  [] [int64X2PrimTy, int64X2PrimTy] (int64X2PrimTy)-primOpInfo (VecRemOp IntVec 32 W8) = mkGenPrimOp (fsLit "remInt8X32#")  [] [int8X32PrimTy, int8X32PrimTy] (int8X32PrimTy)-primOpInfo (VecRemOp IntVec 16 W16) = mkGenPrimOp (fsLit "remInt16X16#")  [] [int16X16PrimTy, int16X16PrimTy] (int16X16PrimTy)-primOpInfo (VecRemOp IntVec 8 W32) = mkGenPrimOp (fsLit "remInt32X8#")  [] [int32X8PrimTy, int32X8PrimTy] (int32X8PrimTy)-primOpInfo (VecRemOp IntVec 4 W64) = mkGenPrimOp (fsLit "remInt64X4#")  [] [int64X4PrimTy, int64X4PrimTy] (int64X4PrimTy)-primOpInfo (VecRemOp IntVec 64 W8) = mkGenPrimOp (fsLit "remInt8X64#")  [] [int8X64PrimTy, int8X64PrimTy] (int8X64PrimTy)-primOpInfo (VecRemOp IntVec 32 W16) = mkGenPrimOp (fsLit "remInt16X32#")  [] [int16X32PrimTy, int16X32PrimTy] (int16X32PrimTy)-primOpInfo (VecRemOp IntVec 16 W32) = mkGenPrimOp (fsLit "remInt32X16#")  [] [int32X16PrimTy, int32X16PrimTy] (int32X16PrimTy)-primOpInfo (VecRemOp IntVec 8 W64) = mkGenPrimOp (fsLit "remInt64X8#")  [] [int64X8PrimTy, int64X8PrimTy] (int64X8PrimTy)-primOpInfo (VecRemOp WordVec 16 W8) = mkGenPrimOp (fsLit "remWord8X16#")  [] [word8X16PrimTy, word8X16PrimTy] (word8X16PrimTy)-primOpInfo (VecRemOp WordVec 8 W16) = mkGenPrimOp (fsLit "remWord16X8#")  [] [word16X8PrimTy, word16X8PrimTy] (word16X8PrimTy)-primOpInfo (VecRemOp WordVec 4 W32) = mkGenPrimOp (fsLit "remWord32X4#")  [] [word32X4PrimTy, word32X4PrimTy] (word32X4PrimTy)-primOpInfo (VecRemOp WordVec 2 W64) = mkGenPrimOp (fsLit "remWord64X2#")  [] [word64X2PrimTy, word64X2PrimTy] (word64X2PrimTy)-primOpInfo (VecRemOp WordVec 32 W8) = mkGenPrimOp (fsLit "remWord8X32#")  [] [word8X32PrimTy, word8X32PrimTy] (word8X32PrimTy)-primOpInfo (VecRemOp WordVec 16 W16) = mkGenPrimOp (fsLit "remWord16X16#")  [] [word16X16PrimTy, word16X16PrimTy] (word16X16PrimTy)-primOpInfo (VecRemOp WordVec 8 W32) = mkGenPrimOp (fsLit "remWord32X8#")  [] [word32X8PrimTy, word32X8PrimTy] (word32X8PrimTy)-primOpInfo (VecRemOp WordVec 4 W64) = mkGenPrimOp (fsLit "remWord64X4#")  [] [word64X4PrimTy, word64X4PrimTy] (word64X4PrimTy)-primOpInfo (VecRemOp WordVec 64 W8) = mkGenPrimOp (fsLit "remWord8X64#")  [] [word8X64PrimTy, word8X64PrimTy] (word8X64PrimTy)-primOpInfo (VecRemOp WordVec 32 W16) = mkGenPrimOp (fsLit "remWord16X32#")  [] [word16X32PrimTy, word16X32PrimTy] (word16X32PrimTy)-primOpInfo (VecRemOp WordVec 16 W32) = mkGenPrimOp (fsLit "remWord32X16#")  [] [word32X16PrimTy, word32X16PrimTy] (word32X16PrimTy)-primOpInfo (VecRemOp WordVec 8 W64) = mkGenPrimOp (fsLit "remWord64X8#")  [] [word64X8PrimTy, word64X8PrimTy] (word64X8PrimTy)-primOpInfo (VecNegOp IntVec 16 W8) = mkGenPrimOp (fsLit "negateInt8X16#")  [] [int8X16PrimTy] (int8X16PrimTy)-primOpInfo (VecNegOp IntVec 8 W16) = mkGenPrimOp (fsLit "negateInt16X8#")  [] [int16X8PrimTy] (int16X8PrimTy)-primOpInfo (VecNegOp IntVec 4 W32) = mkGenPrimOp (fsLit "negateInt32X4#")  [] [int32X4PrimTy] (int32X4PrimTy)-primOpInfo (VecNegOp IntVec 2 W64) = mkGenPrimOp (fsLit "negateInt64X2#")  [] [int64X2PrimTy] (int64X2PrimTy)-primOpInfo (VecNegOp IntVec 32 W8) = mkGenPrimOp (fsLit "negateInt8X32#")  [] [int8X32PrimTy] (int8X32PrimTy)-primOpInfo (VecNegOp IntVec 16 W16) = mkGenPrimOp (fsLit "negateInt16X16#")  [] [int16X16PrimTy] (int16X16PrimTy)-primOpInfo (VecNegOp IntVec 8 W32) = mkGenPrimOp (fsLit "negateInt32X8#")  [] [int32X8PrimTy] (int32X8PrimTy)-primOpInfo (VecNegOp IntVec 4 W64) = mkGenPrimOp (fsLit "negateInt64X4#")  [] [int64X4PrimTy] (int64X4PrimTy)-primOpInfo (VecNegOp IntVec 64 W8) = mkGenPrimOp (fsLit "negateInt8X64#")  [] [int8X64PrimTy] (int8X64PrimTy)-primOpInfo (VecNegOp IntVec 32 W16) = mkGenPrimOp (fsLit "negateInt16X32#")  [] [int16X32PrimTy] (int16X32PrimTy)-primOpInfo (VecNegOp IntVec 16 W32) = mkGenPrimOp (fsLit "negateInt32X16#")  [] [int32X16PrimTy] (int32X16PrimTy)-primOpInfo (VecNegOp IntVec 8 W64) = mkGenPrimOp (fsLit "negateInt64X8#")  [] [int64X8PrimTy] (int64X8PrimTy)-primOpInfo (VecNegOp FloatVec 4 W32) = mkGenPrimOp (fsLit "negateFloatX4#")  [] [floatX4PrimTy] (floatX4PrimTy)-primOpInfo (VecNegOp FloatVec 2 W64) = mkGenPrimOp (fsLit "negateDoubleX2#")  [] [doubleX2PrimTy] (doubleX2PrimTy)-primOpInfo (VecNegOp FloatVec 8 W32) = mkGenPrimOp (fsLit "negateFloatX8#")  [] [floatX8PrimTy] (floatX8PrimTy)-primOpInfo (VecNegOp FloatVec 4 W64) = mkGenPrimOp (fsLit "negateDoubleX4#")  [] [doubleX4PrimTy] (doubleX4PrimTy)-primOpInfo (VecNegOp FloatVec 16 W32) = mkGenPrimOp (fsLit "negateFloatX16#")  [] [floatX16PrimTy] (floatX16PrimTy)-primOpInfo (VecNegOp FloatVec 8 W64) = mkGenPrimOp (fsLit "negateDoubleX8#")  [] [doubleX8PrimTy] (doubleX8PrimTy)-primOpInfo (VecIndexByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8X16Array#")  [] [byteArrayPrimTy, intPrimTy] (int8X16PrimTy)-primOpInfo (VecIndexByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16X8Array#")  [] [byteArrayPrimTy, intPrimTy] (int16X8PrimTy)-primOpInfo (VecIndexByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32X4Array#")  [] [byteArrayPrimTy, intPrimTy] (int32X4PrimTy)-primOpInfo (VecIndexByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64X2Array#")  [] [byteArrayPrimTy, intPrimTy] (int64X2PrimTy)-primOpInfo (VecIndexByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8X32Array#")  [] [byteArrayPrimTy, intPrimTy] (int8X32PrimTy)-primOpInfo (VecIndexByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16X16Array#")  [] [byteArrayPrimTy, intPrimTy] (int16X16PrimTy)-primOpInfo (VecIndexByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32X8Array#")  [] [byteArrayPrimTy, intPrimTy] (int32X8PrimTy)-primOpInfo (VecIndexByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64X4Array#")  [] [byteArrayPrimTy, intPrimTy] (int64X4PrimTy)-primOpInfo (VecIndexByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8X64Array#")  [] [byteArrayPrimTy, intPrimTy] (int8X64PrimTy)-primOpInfo (VecIndexByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16X32Array#")  [] [byteArrayPrimTy, intPrimTy] (int16X32PrimTy)-primOpInfo (VecIndexByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32X16Array#")  [] [byteArrayPrimTy, intPrimTy] (int32X16PrimTy)-primOpInfo (VecIndexByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64X8Array#")  [] [byteArrayPrimTy, intPrimTy] (int64X8PrimTy)-primOpInfo (VecIndexByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8X16Array#")  [] [byteArrayPrimTy, intPrimTy] (word8X16PrimTy)-primOpInfo (VecIndexByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16X8Array#")  [] [byteArrayPrimTy, intPrimTy] (word16X8PrimTy)-primOpInfo (VecIndexByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32X4Array#")  [] [byteArrayPrimTy, intPrimTy] (word32X4PrimTy)-primOpInfo (VecIndexByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64X2Array#")  [] [byteArrayPrimTy, intPrimTy] (word64X2PrimTy)-primOpInfo (VecIndexByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8X32Array#")  [] [byteArrayPrimTy, intPrimTy] (word8X32PrimTy)-primOpInfo (VecIndexByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16X16Array#")  [] [byteArrayPrimTy, intPrimTy] (word16X16PrimTy)-primOpInfo (VecIndexByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32X8Array#")  [] [byteArrayPrimTy, intPrimTy] (word32X8PrimTy)-primOpInfo (VecIndexByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64X4Array#")  [] [byteArrayPrimTy, intPrimTy] (word64X4PrimTy)-primOpInfo (VecIndexByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8X64Array#")  [] [byteArrayPrimTy, intPrimTy] (word8X64PrimTy)-primOpInfo (VecIndexByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16X32Array#")  [] [byteArrayPrimTy, intPrimTy] (word16X32PrimTy)-primOpInfo (VecIndexByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32X16Array#")  [] [byteArrayPrimTy, intPrimTy] (word32X16PrimTy)-primOpInfo (VecIndexByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64X8Array#")  [] [byteArrayPrimTy, intPrimTy] (word64X8PrimTy)-primOpInfo (VecIndexByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatX4Array#")  [] [byteArrayPrimTy, intPrimTy] (floatX4PrimTy)-primOpInfo (VecIndexByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleX2Array#")  [] [byteArrayPrimTy, intPrimTy] (doubleX2PrimTy)-primOpInfo (VecIndexByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatX8Array#")  [] [byteArrayPrimTy, intPrimTy] (floatX8PrimTy)-primOpInfo (VecIndexByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleX4Array#")  [] [byteArrayPrimTy, intPrimTy] (doubleX4PrimTy)-primOpInfo (VecIndexByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatX16Array#")  [] [byteArrayPrimTy, intPrimTy] (floatX16PrimTy)-primOpInfo (VecIndexByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleX8Array#")  [] [byteArrayPrimTy, intPrimTy] (doubleX8PrimTy)-primOpInfo (VecReadByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy]))-primOpInfo (VecReadByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy]))-primOpInfo (VecReadByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy]))-primOpInfo (VecReadByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64X2Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy]))-primOpInfo (VecReadByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy]))-primOpInfo (VecReadByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy]))-primOpInfo (VecReadByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy]))-primOpInfo (VecReadByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy]))-primOpInfo (VecReadByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8X64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy]))-primOpInfo (VecReadByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy]))-primOpInfo (VecReadByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy]))-primOpInfo (VecReadByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy]))-primOpInfo (VecReadByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy]))-primOpInfo (VecReadByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy]))-primOpInfo (VecReadByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy]))-primOpInfo (VecReadByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64X2Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy]))-primOpInfo (VecReadByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy]))-primOpInfo (VecReadByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy]))-primOpInfo (VecReadByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy]))-primOpInfo (VecReadByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy]))-primOpInfo (VecReadByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8X64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy]))-primOpInfo (VecReadByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy]))-primOpInfo (VecReadByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy]))-primOpInfo (VecReadByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy]))-primOpInfo (VecReadByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatX4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy]))-primOpInfo (VecReadByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleX2Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy]))-primOpInfo (VecReadByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatX8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy]))-primOpInfo (VecReadByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleX4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy]))-primOpInfo (VecReadByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatX16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy]))-primOpInfo (VecReadByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleX8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy]))-primOpInfo (VecWriteByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64X2Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8X64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64X2Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8X64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatX4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleX2Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatX8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleX4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatX16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleX8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecIndexOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8X16OffAddr#")  [] [addrPrimTy, intPrimTy] (int8X16PrimTy)-primOpInfo (VecIndexOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16X8OffAddr#")  [] [addrPrimTy, intPrimTy] (int16X8PrimTy)-primOpInfo (VecIndexOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32X4OffAddr#")  [] [addrPrimTy, intPrimTy] (int32X4PrimTy)-primOpInfo (VecIndexOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64X2OffAddr#")  [] [addrPrimTy, intPrimTy] (int64X2PrimTy)-primOpInfo (VecIndexOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8X32OffAddr#")  [] [addrPrimTy, intPrimTy] (int8X32PrimTy)-primOpInfo (VecIndexOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16X16OffAddr#")  [] [addrPrimTy, intPrimTy] (int16X16PrimTy)-primOpInfo (VecIndexOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32X8OffAddr#")  [] [addrPrimTy, intPrimTy] (int32X8PrimTy)-primOpInfo (VecIndexOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64X4OffAddr#")  [] [addrPrimTy, intPrimTy] (int64X4PrimTy)-primOpInfo (VecIndexOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8X64OffAddr#")  [] [addrPrimTy, intPrimTy] (int8X64PrimTy)-primOpInfo (VecIndexOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16X32OffAddr#")  [] [addrPrimTy, intPrimTy] (int16X32PrimTy)-primOpInfo (VecIndexOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32X16OffAddr#")  [] [addrPrimTy, intPrimTy] (int32X16PrimTy)-primOpInfo (VecIndexOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64X8OffAddr#")  [] [addrPrimTy, intPrimTy] (int64X8PrimTy)-primOpInfo (VecIndexOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8X16OffAddr#")  [] [addrPrimTy, intPrimTy] (word8X16PrimTy)-primOpInfo (VecIndexOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16X8OffAddr#")  [] [addrPrimTy, intPrimTy] (word16X8PrimTy)-primOpInfo (VecIndexOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32X4OffAddr#")  [] [addrPrimTy, intPrimTy] (word32X4PrimTy)-primOpInfo (VecIndexOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64X2OffAddr#")  [] [addrPrimTy, intPrimTy] (word64X2PrimTy)-primOpInfo (VecIndexOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8X32OffAddr#")  [] [addrPrimTy, intPrimTy] (word8X32PrimTy)-primOpInfo (VecIndexOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16X16OffAddr#")  [] [addrPrimTy, intPrimTy] (word16X16PrimTy)-primOpInfo (VecIndexOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32X8OffAddr#")  [] [addrPrimTy, intPrimTy] (word32X8PrimTy)-primOpInfo (VecIndexOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64X4OffAddr#")  [] [addrPrimTy, intPrimTy] (word64X4PrimTy)-primOpInfo (VecIndexOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8X64OffAddr#")  [] [addrPrimTy, intPrimTy] (word8X64PrimTy)-primOpInfo (VecIndexOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16X32OffAddr#")  [] [addrPrimTy, intPrimTy] (word16X32PrimTy)-primOpInfo (VecIndexOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32X16OffAddr#")  [] [addrPrimTy, intPrimTy] (word32X16PrimTy)-primOpInfo (VecIndexOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64X8OffAddr#")  [] [addrPrimTy, intPrimTy] (word64X8PrimTy)-primOpInfo (VecIndexOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatX4OffAddr#")  [] [addrPrimTy, intPrimTy] (floatX4PrimTy)-primOpInfo (VecIndexOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleX2OffAddr#")  [] [addrPrimTy, intPrimTy] (doubleX2PrimTy)-primOpInfo (VecIndexOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatX8OffAddr#")  [] [addrPrimTy, intPrimTy] (floatX8PrimTy)-primOpInfo (VecIndexOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleX4OffAddr#")  [] [addrPrimTy, intPrimTy] (doubleX4PrimTy)-primOpInfo (VecIndexOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatX16OffAddr#")  [] [addrPrimTy, intPrimTy] (floatX16PrimTy)-primOpInfo (VecIndexOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleX8OffAddr#")  [] [addrPrimTy, intPrimTy] (doubleX8PrimTy)-primOpInfo (VecReadOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy]))-primOpInfo (VecReadOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy]))-primOpInfo (VecReadOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy]))-primOpInfo (VecReadOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64X2OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy]))-primOpInfo (VecReadOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy]))-primOpInfo (VecReadOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy]))-primOpInfo (VecReadOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy]))-primOpInfo (VecReadOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy]))-primOpInfo (VecReadOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8X64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy]))-primOpInfo (VecReadOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy]))-primOpInfo (VecReadOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy]))-primOpInfo (VecReadOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy]))-primOpInfo (VecReadOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy]))-primOpInfo (VecReadOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy]))-primOpInfo (VecReadOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy]))-primOpInfo (VecReadOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64X2OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy]))-primOpInfo (VecReadOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy]))-primOpInfo (VecReadOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy]))-primOpInfo (VecReadOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy]))-primOpInfo (VecReadOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy]))-primOpInfo (VecReadOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8X64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy]))-primOpInfo (VecReadOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy]))-primOpInfo (VecReadOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy]))-primOpInfo (VecReadOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy]))-primOpInfo (VecReadOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatX4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy]))-primOpInfo (VecReadOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleX2OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy]))-primOpInfo (VecReadOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatX8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy]))-primOpInfo (VecReadOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleX4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy]))-primOpInfo (VecReadOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatX16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy]))-primOpInfo (VecReadOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleX8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy]))-primOpInfo (VecWriteOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64X2OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8X64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64X2OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8X64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatX4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleX2OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatX8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleX4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatX16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleX8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecIndexScalarByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8ArrayAsInt8X16#")  [] [byteArrayPrimTy, intPrimTy] (int8X16PrimTy)-primOpInfo (VecIndexScalarByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16ArrayAsInt16X8#")  [] [byteArrayPrimTy, intPrimTy] (int16X8PrimTy)-primOpInfo (VecIndexScalarByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32ArrayAsInt32X4#")  [] [byteArrayPrimTy, intPrimTy] (int32X4PrimTy)-primOpInfo (VecIndexScalarByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64ArrayAsInt64X2#")  [] [byteArrayPrimTy, intPrimTy] (int64X2PrimTy)-primOpInfo (VecIndexScalarByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8ArrayAsInt8X32#")  [] [byteArrayPrimTy, intPrimTy] (int8X32PrimTy)-primOpInfo (VecIndexScalarByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16ArrayAsInt16X16#")  [] [byteArrayPrimTy, intPrimTy] (int16X16PrimTy)-primOpInfo (VecIndexScalarByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32ArrayAsInt32X8#")  [] [byteArrayPrimTy, intPrimTy] (int32X8PrimTy)-primOpInfo (VecIndexScalarByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64ArrayAsInt64X4#")  [] [byteArrayPrimTy, intPrimTy] (int64X4PrimTy)-primOpInfo (VecIndexScalarByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8ArrayAsInt8X64#")  [] [byteArrayPrimTy, intPrimTy] (int8X64PrimTy)-primOpInfo (VecIndexScalarByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16ArrayAsInt16X32#")  [] [byteArrayPrimTy, intPrimTy] (int16X32PrimTy)-primOpInfo (VecIndexScalarByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32ArrayAsInt32X16#")  [] [byteArrayPrimTy, intPrimTy] (int32X16PrimTy)-primOpInfo (VecIndexScalarByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64ArrayAsInt64X8#")  [] [byteArrayPrimTy, intPrimTy] (int64X8PrimTy)-primOpInfo (VecIndexScalarByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8ArrayAsWord8X16#")  [] [byteArrayPrimTy, intPrimTy] (word8X16PrimTy)-primOpInfo (VecIndexScalarByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16ArrayAsWord16X8#")  [] [byteArrayPrimTy, intPrimTy] (word16X8PrimTy)-primOpInfo (VecIndexScalarByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32ArrayAsWord32X4#")  [] [byteArrayPrimTy, intPrimTy] (word32X4PrimTy)-primOpInfo (VecIndexScalarByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64ArrayAsWord64X2#")  [] [byteArrayPrimTy, intPrimTy] (word64X2PrimTy)-primOpInfo (VecIndexScalarByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8ArrayAsWord8X32#")  [] [byteArrayPrimTy, intPrimTy] (word8X32PrimTy)-primOpInfo (VecIndexScalarByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16ArrayAsWord16X16#")  [] [byteArrayPrimTy, intPrimTy] (word16X16PrimTy)-primOpInfo (VecIndexScalarByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32ArrayAsWord32X8#")  [] [byteArrayPrimTy, intPrimTy] (word32X8PrimTy)-primOpInfo (VecIndexScalarByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64ArrayAsWord64X4#")  [] [byteArrayPrimTy, intPrimTy] (word64X4PrimTy)-primOpInfo (VecIndexScalarByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8ArrayAsWord8X64#")  [] [byteArrayPrimTy, intPrimTy] (word8X64PrimTy)-primOpInfo (VecIndexScalarByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16ArrayAsWord16X32#")  [] [byteArrayPrimTy, intPrimTy] (word16X32PrimTy)-primOpInfo (VecIndexScalarByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32ArrayAsWord32X16#")  [] [byteArrayPrimTy, intPrimTy] (word32X16PrimTy)-primOpInfo (VecIndexScalarByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64ArrayAsWord64X8#")  [] [byteArrayPrimTy, intPrimTy] (word64X8PrimTy)-primOpInfo (VecIndexScalarByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatArrayAsFloatX4#")  [] [byteArrayPrimTy, intPrimTy] (floatX4PrimTy)-primOpInfo (VecIndexScalarByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleArrayAsDoubleX2#")  [] [byteArrayPrimTy, intPrimTy] (doubleX2PrimTy)-primOpInfo (VecIndexScalarByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatArrayAsFloatX8#")  [] [byteArrayPrimTy, intPrimTy] (floatX8PrimTy)-primOpInfo (VecIndexScalarByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleArrayAsDoubleX4#")  [] [byteArrayPrimTy, intPrimTy] (doubleX4PrimTy)-primOpInfo (VecIndexScalarByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatArrayAsFloatX16#")  [] [byteArrayPrimTy, intPrimTy] (floatX16PrimTy)-primOpInfo (VecIndexScalarByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleArrayAsDoubleX8#")  [] [byteArrayPrimTy, intPrimTy] (doubleX8PrimTy)-primOpInfo (VecReadScalarByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8ArrayAsInt8X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy]))-primOpInfo (VecReadScalarByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16ArrayAsInt16X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy]))-primOpInfo (VecReadScalarByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32ArrayAsInt32X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy]))-primOpInfo (VecReadScalarByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64ArrayAsInt64X2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy]))-primOpInfo (VecReadScalarByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8ArrayAsInt8X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy]))-primOpInfo (VecReadScalarByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16ArrayAsInt16X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy]))-primOpInfo (VecReadScalarByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32ArrayAsInt32X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy]))-primOpInfo (VecReadScalarByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64ArrayAsInt64X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy]))-primOpInfo (VecReadScalarByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8ArrayAsInt8X64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy]))-primOpInfo (VecReadScalarByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16ArrayAsInt16X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy]))-primOpInfo (VecReadScalarByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32ArrayAsInt32X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy]))-primOpInfo (VecReadScalarByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64ArrayAsInt64X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy]))-primOpInfo (VecReadScalarByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8ArrayAsWord8X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy]))-primOpInfo (VecReadScalarByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16ArrayAsWord16X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy]))-primOpInfo (VecReadScalarByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32ArrayAsWord32X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy]))-primOpInfo (VecReadScalarByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64ArrayAsWord64X2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy]))-primOpInfo (VecReadScalarByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8ArrayAsWord8X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy]))-primOpInfo (VecReadScalarByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16ArrayAsWord16X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy]))-primOpInfo (VecReadScalarByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32ArrayAsWord32X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy]))-primOpInfo (VecReadScalarByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64ArrayAsWord64X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy]))-primOpInfo (VecReadScalarByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8ArrayAsWord8X64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy]))-primOpInfo (VecReadScalarByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16ArrayAsWord16X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy]))-primOpInfo (VecReadScalarByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32ArrayAsWord32X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy]))-primOpInfo (VecReadScalarByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64ArrayAsWord64X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy]))-primOpInfo (VecReadScalarByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatArrayAsFloatX4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy]))-primOpInfo (VecReadScalarByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleArrayAsDoubleX2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy]))-primOpInfo (VecReadScalarByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatArrayAsFloatX8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy]))-primOpInfo (VecReadScalarByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleArrayAsDoubleX4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy]))-primOpInfo (VecReadScalarByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatArrayAsFloatX16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy]))-primOpInfo (VecReadScalarByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleArrayAsDoubleX8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy]))-primOpInfo (VecWriteScalarByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8ArrayAsInt8X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16ArrayAsInt16X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32ArrayAsInt32X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64ArrayAsInt64X2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8ArrayAsInt8X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16ArrayAsInt16X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32ArrayAsInt32X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64ArrayAsInt64X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8ArrayAsInt8X64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16ArrayAsInt16X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32ArrayAsInt32X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64ArrayAsInt64X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8ArrayAsWord8X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16ArrayAsWord16X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32ArrayAsWord32X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64ArrayAsWord64X2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8ArrayAsWord8X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16ArrayAsWord16X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32ArrayAsWord32X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64ArrayAsWord64X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8ArrayAsWord8X64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16ArrayAsWord16X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32ArrayAsWord32X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64ArrayAsWord64X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatArrayAsFloatX4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleArrayAsDoubleX2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatArrayAsFloatX8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleArrayAsDoubleX4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatArrayAsFloatX16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleArrayAsDoubleX8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecIndexScalarOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8OffAddrAsInt8X16#")  [] [addrPrimTy, intPrimTy] (int8X16PrimTy)-primOpInfo (VecIndexScalarOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16OffAddrAsInt16X8#")  [] [addrPrimTy, intPrimTy] (int16X8PrimTy)-primOpInfo (VecIndexScalarOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32OffAddrAsInt32X4#")  [] [addrPrimTy, intPrimTy] (int32X4PrimTy)-primOpInfo (VecIndexScalarOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64OffAddrAsInt64X2#")  [] [addrPrimTy, intPrimTy] (int64X2PrimTy)-primOpInfo (VecIndexScalarOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8OffAddrAsInt8X32#")  [] [addrPrimTy, intPrimTy] (int8X32PrimTy)-primOpInfo (VecIndexScalarOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16OffAddrAsInt16X16#")  [] [addrPrimTy, intPrimTy] (int16X16PrimTy)-primOpInfo (VecIndexScalarOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32OffAddrAsInt32X8#")  [] [addrPrimTy, intPrimTy] (int32X8PrimTy)-primOpInfo (VecIndexScalarOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64OffAddrAsInt64X4#")  [] [addrPrimTy, intPrimTy] (int64X4PrimTy)-primOpInfo (VecIndexScalarOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8OffAddrAsInt8X64#")  [] [addrPrimTy, intPrimTy] (int8X64PrimTy)-primOpInfo (VecIndexScalarOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16OffAddrAsInt16X32#")  [] [addrPrimTy, intPrimTy] (int16X32PrimTy)-primOpInfo (VecIndexScalarOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32OffAddrAsInt32X16#")  [] [addrPrimTy, intPrimTy] (int32X16PrimTy)-primOpInfo (VecIndexScalarOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64OffAddrAsInt64X8#")  [] [addrPrimTy, intPrimTy] (int64X8PrimTy)-primOpInfo (VecIndexScalarOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord8X16#")  [] [addrPrimTy, intPrimTy] (word8X16PrimTy)-primOpInfo (VecIndexScalarOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16OffAddrAsWord16X8#")  [] [addrPrimTy, intPrimTy] (word16X8PrimTy)-primOpInfo (VecIndexScalarOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32OffAddrAsWord32X4#")  [] [addrPrimTy, intPrimTy] (word32X4PrimTy)-primOpInfo (VecIndexScalarOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64OffAddrAsWord64X2#")  [] [addrPrimTy, intPrimTy] (word64X2PrimTy)-primOpInfo (VecIndexScalarOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord8X32#")  [] [addrPrimTy, intPrimTy] (word8X32PrimTy)-primOpInfo (VecIndexScalarOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16OffAddrAsWord16X16#")  [] [addrPrimTy, intPrimTy] (word16X16PrimTy)-primOpInfo (VecIndexScalarOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32OffAddrAsWord32X8#")  [] [addrPrimTy, intPrimTy] (word32X8PrimTy)-primOpInfo (VecIndexScalarOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64OffAddrAsWord64X4#")  [] [addrPrimTy, intPrimTy] (word64X4PrimTy)-primOpInfo (VecIndexScalarOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord8X64#")  [] [addrPrimTy, intPrimTy] (word8X64PrimTy)-primOpInfo (VecIndexScalarOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16OffAddrAsWord16X32#")  [] [addrPrimTy, intPrimTy] (word16X32PrimTy)-primOpInfo (VecIndexScalarOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32OffAddrAsWord32X16#")  [] [addrPrimTy, intPrimTy] (word32X16PrimTy)-primOpInfo (VecIndexScalarOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64OffAddrAsWord64X8#")  [] [addrPrimTy, intPrimTy] (word64X8PrimTy)-primOpInfo (VecIndexScalarOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatOffAddrAsFloatX4#")  [] [addrPrimTy, intPrimTy] (floatX4PrimTy)-primOpInfo (VecIndexScalarOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleOffAddrAsDoubleX2#")  [] [addrPrimTy, intPrimTy] (doubleX2PrimTy)-primOpInfo (VecIndexScalarOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatOffAddrAsFloatX8#")  [] [addrPrimTy, intPrimTy] (floatX8PrimTy)-primOpInfo (VecIndexScalarOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleOffAddrAsDoubleX4#")  [] [addrPrimTy, intPrimTy] (doubleX4PrimTy)-primOpInfo (VecIndexScalarOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatOffAddrAsFloatX16#")  [] [addrPrimTy, intPrimTy] (floatX16PrimTy)-primOpInfo (VecIndexScalarOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleOffAddrAsDoubleX8#")  [] [addrPrimTy, intPrimTy] (doubleX8PrimTy)-primOpInfo (VecReadScalarOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8OffAddrAsInt8X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy]))-primOpInfo (VecReadScalarOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16OffAddrAsInt16X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy]))-primOpInfo (VecReadScalarOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32OffAddrAsInt32X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy]))-primOpInfo (VecReadScalarOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64OffAddrAsInt64X2#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy]))-primOpInfo (VecReadScalarOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8OffAddrAsInt8X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy]))-primOpInfo (VecReadScalarOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16OffAddrAsInt16X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy]))-primOpInfo (VecReadScalarOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32OffAddrAsInt32X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy]))-primOpInfo (VecReadScalarOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64OffAddrAsInt64X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy]))-primOpInfo (VecReadScalarOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8OffAddrAsInt8X64#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy]))-primOpInfo (VecReadScalarOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16OffAddrAsInt16X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy]))-primOpInfo (VecReadScalarOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32OffAddrAsInt32X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy]))-primOpInfo (VecReadScalarOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64OffAddrAsInt64X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy]))-primOpInfo (VecReadScalarOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8OffAddrAsWord8X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy]))-primOpInfo (VecReadScalarOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16OffAddrAsWord16X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy]))-primOpInfo (VecReadScalarOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32OffAddrAsWord32X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy]))-primOpInfo (VecReadScalarOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64OffAddrAsWord64X2#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy]))-primOpInfo (VecReadScalarOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8OffAddrAsWord8X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy]))-primOpInfo (VecReadScalarOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16OffAddrAsWord16X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy]))-primOpInfo (VecReadScalarOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32OffAddrAsWord32X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy]))-primOpInfo (VecReadScalarOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64OffAddrAsWord64X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy]))-primOpInfo (VecReadScalarOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8OffAddrAsWord8X64#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy]))-primOpInfo (VecReadScalarOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16OffAddrAsWord16X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy]))-primOpInfo (VecReadScalarOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32OffAddrAsWord32X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy]))-primOpInfo (VecReadScalarOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64OffAddrAsWord64X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy]))-primOpInfo (VecReadScalarOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatOffAddrAsFloatX4#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy]))-primOpInfo (VecReadScalarOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleOffAddrAsDoubleX2#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy]))-primOpInfo (VecReadScalarOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatOffAddrAsFloatX8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy]))-primOpInfo (VecReadScalarOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleOffAddrAsDoubleX4#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy]))-primOpInfo (VecReadScalarOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatOffAddrAsFloatX16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy]))-primOpInfo (VecReadScalarOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleOffAddrAsDoubleX8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy]))-primOpInfo (VecWriteScalarOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8OffAddrAsInt8X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16OffAddrAsInt16X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32OffAddrAsInt32X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64OffAddrAsInt64X2#")  [deltaTyVar] [addrPrimTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8OffAddrAsInt8X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16OffAddrAsInt16X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32OffAddrAsInt32X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64OffAddrAsInt64X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8OffAddrAsInt8X64#")  [deltaTyVar] [addrPrimTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16OffAddrAsInt16X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32OffAddrAsInt32X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64OffAddrAsInt64X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord8X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16OffAddrAsWord16X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32OffAddrAsWord32X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64OffAddrAsWord64X2#")  [deltaTyVar] [addrPrimTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord8X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16OffAddrAsWord16X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32OffAddrAsWord32X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64OffAddrAsWord64X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord8X64#")  [deltaTyVar] [addrPrimTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16OffAddrAsWord16X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32OffAddrAsWord32X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64OffAddrAsWord64X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatOffAddrAsFloatX4#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleOffAddrAsDoubleX2#")  [deltaTyVar] [addrPrimTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatOffAddrAsFloatX8#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleOffAddrAsDoubleX4#")  [deltaTyVar] [addrPrimTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatOffAddrAsFloatX16#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleOffAddrAsDoubleX8#")  [deltaTyVar] [addrPrimTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo PrefetchByteArrayOp3 = mkGenPrimOp (fsLit "prefetchByteArray3#")  [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo PrefetchMutableByteArrayOp3 = mkGenPrimOp (fsLit "prefetchMutableByteArray3#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo PrefetchAddrOp3 = mkGenPrimOp (fsLit "prefetchAddr3#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo PrefetchValueOp3 = mkGenPrimOp (fsLit "prefetchValue3#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo PrefetchByteArrayOp2 = mkGenPrimOp (fsLit "prefetchByteArray2#")  [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo PrefetchMutableByteArrayOp2 = mkGenPrimOp (fsLit "prefetchMutableByteArray2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo PrefetchAddrOp2 = mkGenPrimOp (fsLit "prefetchAddr2#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo PrefetchValueOp2 = mkGenPrimOp (fsLit "prefetchValue2#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo PrefetchByteArrayOp1 = mkGenPrimOp (fsLit "prefetchByteArray1#")  [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo PrefetchMutableByteArrayOp1 = mkGenPrimOp (fsLit "prefetchMutableByteArray1#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo PrefetchAddrOp1 = mkGenPrimOp (fsLit "prefetchAddr1#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo PrefetchValueOp1 = mkGenPrimOp (fsLit "prefetchValue1#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo PrefetchByteArrayOp0 = mkGenPrimOp (fsLit "prefetchByteArray0#")  [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo PrefetchMutableByteArrayOp0 = mkGenPrimOp (fsLit "prefetchMutableByteArray0#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo PrefetchAddrOp0 = mkGenPrimOp (fsLit "prefetchAddr0#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo PrefetchValueOp0 = mkGenPrimOp (fsLit "prefetchValue0#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo Int64ToIntOp = mkGenPrimOp (fsLit "int64ToInt#")  [] [int64PrimTy] (intPrimTy)+primOpInfo IntToInt64Op = mkGenPrimOp (fsLit "intToInt64#")  [] [intPrimTy] (int64PrimTy)+primOpInfo Int64NegOp = mkGenPrimOp (fsLit "negateInt64#")  [] [int64PrimTy] (int64PrimTy)+primOpInfo Int64AddOp = mkGenPrimOp (fsLit "plusInt64#")  [] [int64PrimTy, int64PrimTy] (int64PrimTy)+primOpInfo Int64SubOp = mkGenPrimOp (fsLit "subInt64#")  [] [int64PrimTy, int64PrimTy] (int64PrimTy)+primOpInfo Int64MulOp = mkGenPrimOp (fsLit "timesInt64#")  [] [int64PrimTy, int64PrimTy] (int64PrimTy)+primOpInfo Int64QuotOp = mkGenPrimOp (fsLit "quotInt64#")  [] [int64PrimTy, int64PrimTy] (int64PrimTy)+primOpInfo Int64RemOp = mkGenPrimOp (fsLit "remInt64#")  [] [int64PrimTy, int64PrimTy] (int64PrimTy)+primOpInfo Int64SllOp = mkGenPrimOp (fsLit "uncheckedIShiftL64#")  [] [int64PrimTy, intPrimTy] (int64PrimTy)+primOpInfo Int64SraOp = mkGenPrimOp (fsLit "uncheckedIShiftRA64#")  [] [int64PrimTy, intPrimTy] (int64PrimTy)+primOpInfo Int64SrlOp = mkGenPrimOp (fsLit "uncheckedIShiftRL64#")  [] [int64PrimTy, intPrimTy] (int64PrimTy)+primOpInfo Int64ToWord64Op = mkGenPrimOp (fsLit "int64ToWord64#")  [] [int64PrimTy] (word64PrimTy)+primOpInfo Int64EqOp = mkCompare (fsLit "eqInt64#") int64PrimTy+primOpInfo Int64GeOp = mkCompare (fsLit "geInt64#") int64PrimTy+primOpInfo Int64GtOp = mkCompare (fsLit "gtInt64#") int64PrimTy+primOpInfo Int64LeOp = mkCompare (fsLit "leInt64#") int64PrimTy+primOpInfo Int64LtOp = mkCompare (fsLit "ltInt64#") int64PrimTy+primOpInfo Int64NeOp = mkCompare (fsLit "neInt64#") int64PrimTy+primOpInfo Word64ToWordOp = mkGenPrimOp (fsLit "word64ToWord#")  [] [word64PrimTy] (wordPrimTy)+primOpInfo WordToWord64Op = mkGenPrimOp (fsLit "wordToWord64#")  [] [wordPrimTy] (word64PrimTy)+primOpInfo Word64AddOp = mkGenPrimOp (fsLit "plusWord64#")  [] [word64PrimTy, word64PrimTy] (word64PrimTy)+primOpInfo Word64SubOp = mkGenPrimOp (fsLit "subWord64#")  [] [word64PrimTy, word64PrimTy] (word64PrimTy)+primOpInfo Word64MulOp = mkGenPrimOp (fsLit "timesWord64#")  [] [word64PrimTy, word64PrimTy] (word64PrimTy)+primOpInfo Word64QuotOp = mkGenPrimOp (fsLit "quotWord64#")  [] [word64PrimTy, word64PrimTy] (word64PrimTy)+primOpInfo Word64RemOp = mkGenPrimOp (fsLit "remWord64#")  [] [word64PrimTy, word64PrimTy] (word64PrimTy)+primOpInfo Word64AndOp = mkGenPrimOp (fsLit "and64#")  [] [word64PrimTy, word64PrimTy] (word64PrimTy)+primOpInfo Word64OrOp = mkGenPrimOp (fsLit "or64#")  [] [word64PrimTy, word64PrimTy] (word64PrimTy)+primOpInfo Word64XorOp = mkGenPrimOp (fsLit "xor64#")  [] [word64PrimTy, word64PrimTy] (word64PrimTy)+primOpInfo Word64NotOp = mkGenPrimOp (fsLit "not64#")  [] [word64PrimTy] (word64PrimTy)+primOpInfo Word64SllOp = mkGenPrimOp (fsLit "uncheckedShiftL64#")  [] [word64PrimTy, intPrimTy] (word64PrimTy)+primOpInfo Word64SrlOp = mkGenPrimOp (fsLit "uncheckedShiftRL64#")  [] [word64PrimTy, intPrimTy] (word64PrimTy)+primOpInfo Word64ToInt64Op = mkGenPrimOp (fsLit "word64ToInt64#")  [] [word64PrimTy] (int64PrimTy)+primOpInfo Word64EqOp = mkCompare (fsLit "eqWord64#") word64PrimTy+primOpInfo Word64GeOp = mkCompare (fsLit "geWord64#") word64PrimTy+primOpInfo Word64GtOp = mkCompare (fsLit "gtWord64#") word64PrimTy+primOpInfo Word64LeOp = mkCompare (fsLit "leWord64#") word64PrimTy+primOpInfo Word64LtOp = mkCompare (fsLit "ltWord64#") word64PrimTy+primOpInfo Word64NeOp = mkCompare (fsLit "neWord64#") word64PrimTy+primOpInfo IntAddOp = mkGenPrimOp (fsLit "+#")  [] [intPrimTy, intPrimTy] (intPrimTy)+primOpInfo IntSubOp = mkGenPrimOp (fsLit "-#")  [] [intPrimTy, intPrimTy] (intPrimTy)+primOpInfo IntMulOp = mkGenPrimOp (fsLit "*#")  [] [intPrimTy, intPrimTy] (intPrimTy)+primOpInfo IntMul2Op = mkGenPrimOp (fsLit "timesInt2#")  [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy]))+primOpInfo IntMulMayOfloOp = mkGenPrimOp (fsLit "mulIntMayOflo#")  [] [intPrimTy, intPrimTy] (intPrimTy)+primOpInfo IntQuotOp = mkGenPrimOp (fsLit "quotInt#")  [] [intPrimTy, intPrimTy] (intPrimTy)+primOpInfo IntRemOp = mkGenPrimOp (fsLit "remInt#")  [] [intPrimTy, intPrimTy] (intPrimTy)+primOpInfo IntQuotRemOp = mkGenPrimOp (fsLit "quotRemInt#")  [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))+primOpInfo IntAndOp = mkGenPrimOp (fsLit "andI#")  [] [intPrimTy, intPrimTy] (intPrimTy)+primOpInfo IntOrOp = mkGenPrimOp (fsLit "orI#")  [] [intPrimTy, intPrimTy] (intPrimTy)+primOpInfo IntXorOp = mkGenPrimOp (fsLit "xorI#")  [] [intPrimTy, intPrimTy] (intPrimTy)+primOpInfo IntNotOp = mkGenPrimOp (fsLit "notI#")  [] [intPrimTy] (intPrimTy)+primOpInfo IntNegOp = mkGenPrimOp (fsLit "negateInt#")  [] [intPrimTy] (intPrimTy)+primOpInfo IntAddCOp = mkGenPrimOp (fsLit "addIntC#")  [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))+primOpInfo IntSubCOp = mkGenPrimOp (fsLit "subIntC#")  [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))+primOpInfo IntGtOp = mkCompare (fsLit ">#") intPrimTy+primOpInfo IntGeOp = mkCompare (fsLit ">=#") intPrimTy+primOpInfo IntEqOp = mkCompare (fsLit "==#") intPrimTy+primOpInfo IntNeOp = mkCompare (fsLit "/=#") intPrimTy+primOpInfo IntLtOp = mkCompare (fsLit "<#") intPrimTy+primOpInfo IntLeOp = mkCompare (fsLit "<=#") intPrimTy+primOpInfo ChrOp = mkGenPrimOp (fsLit "chr#")  [] [intPrimTy] (charPrimTy)+primOpInfo IntToWordOp = mkGenPrimOp (fsLit "int2Word#")  [] [intPrimTy] (wordPrimTy)+primOpInfo IntToFloatOp = mkGenPrimOp (fsLit "int2Float#")  [] [intPrimTy] (floatPrimTy)+primOpInfo IntToDoubleOp = mkGenPrimOp (fsLit "int2Double#")  [] [intPrimTy] (doublePrimTy)+primOpInfo WordToFloatOp = mkGenPrimOp (fsLit "word2Float#")  [] [wordPrimTy] (floatPrimTy)+primOpInfo WordToDoubleOp = mkGenPrimOp (fsLit "word2Double#")  [] [wordPrimTy] (doublePrimTy)+primOpInfo IntSllOp = mkGenPrimOp (fsLit "uncheckedIShiftL#")  [] [intPrimTy, intPrimTy] (intPrimTy)+primOpInfo IntSraOp = mkGenPrimOp (fsLit "uncheckedIShiftRA#")  [] [intPrimTy, intPrimTy] (intPrimTy)+primOpInfo IntSrlOp = mkGenPrimOp (fsLit "uncheckedIShiftRL#")  [] [intPrimTy, intPrimTy] (intPrimTy)+primOpInfo WordAddOp = mkGenPrimOp (fsLit "plusWord#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)+primOpInfo WordAddCOp = mkGenPrimOp (fsLit "addWordC#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, intPrimTy]))+primOpInfo WordSubCOp = mkGenPrimOp (fsLit "subWordC#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, intPrimTy]))+primOpInfo WordAdd2Op = mkGenPrimOp (fsLit "plusWord2#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))+primOpInfo WordSubOp = mkGenPrimOp (fsLit "minusWord#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)+primOpInfo WordMulOp = mkGenPrimOp (fsLit "timesWord#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)+primOpInfo WordMul2Op = mkGenPrimOp (fsLit "timesWord2#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))+primOpInfo WordQuotOp = mkGenPrimOp (fsLit "quotWord#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)+primOpInfo WordRemOp = mkGenPrimOp (fsLit "remWord#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)+primOpInfo WordQuotRemOp = mkGenPrimOp (fsLit "quotRemWord#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))+primOpInfo WordQuotRem2Op = mkGenPrimOp (fsLit "quotRemWord2#")  [] [wordPrimTy, wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))+primOpInfo WordAndOp = mkGenPrimOp (fsLit "and#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)+primOpInfo WordOrOp = mkGenPrimOp (fsLit "or#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)+primOpInfo WordXorOp = mkGenPrimOp (fsLit "xor#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)+primOpInfo WordNotOp = mkGenPrimOp (fsLit "not#")  [] [wordPrimTy] (wordPrimTy)+primOpInfo WordSllOp = mkGenPrimOp (fsLit "uncheckedShiftL#")  [] [wordPrimTy, intPrimTy] (wordPrimTy)+primOpInfo WordSrlOp = mkGenPrimOp (fsLit "uncheckedShiftRL#")  [] [wordPrimTy, intPrimTy] (wordPrimTy)+primOpInfo WordToIntOp = mkGenPrimOp (fsLit "word2Int#")  [] [wordPrimTy] (intPrimTy)+primOpInfo WordGtOp = mkCompare (fsLit "gtWord#") wordPrimTy+primOpInfo WordGeOp = mkCompare (fsLit "geWord#") wordPrimTy+primOpInfo WordEqOp = mkCompare (fsLit "eqWord#") wordPrimTy+primOpInfo WordNeOp = mkCompare (fsLit "neWord#") wordPrimTy+primOpInfo WordLtOp = mkCompare (fsLit "ltWord#") wordPrimTy+primOpInfo WordLeOp = mkCompare (fsLit "leWord#") wordPrimTy+primOpInfo PopCnt8Op = mkGenPrimOp (fsLit "popCnt8#")  [] [wordPrimTy] (wordPrimTy)+primOpInfo PopCnt16Op = mkGenPrimOp (fsLit "popCnt16#")  [] [wordPrimTy] (wordPrimTy)+primOpInfo PopCnt32Op = mkGenPrimOp (fsLit "popCnt32#")  [] [wordPrimTy] (wordPrimTy)+primOpInfo PopCnt64Op = mkGenPrimOp (fsLit "popCnt64#")  [] [word64PrimTy] (wordPrimTy)+primOpInfo PopCntOp = mkGenPrimOp (fsLit "popCnt#")  [] [wordPrimTy] (wordPrimTy)+primOpInfo Pdep8Op = mkGenPrimOp (fsLit "pdep8#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)+primOpInfo Pdep16Op = mkGenPrimOp (fsLit "pdep16#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)+primOpInfo Pdep32Op = mkGenPrimOp (fsLit "pdep32#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)+primOpInfo Pdep64Op = mkGenPrimOp (fsLit "pdep64#")  [] [word64PrimTy, word64PrimTy] (word64PrimTy)+primOpInfo PdepOp = mkGenPrimOp (fsLit "pdep#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)+primOpInfo Pext8Op = mkGenPrimOp (fsLit "pext8#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)+primOpInfo Pext16Op = mkGenPrimOp (fsLit "pext16#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)+primOpInfo Pext32Op = mkGenPrimOp (fsLit "pext32#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)+primOpInfo Pext64Op = mkGenPrimOp (fsLit "pext64#")  [] [word64PrimTy, word64PrimTy] (word64PrimTy)+primOpInfo PextOp = mkGenPrimOp (fsLit "pext#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)+primOpInfo Clz8Op = mkGenPrimOp (fsLit "clz8#")  [] [wordPrimTy] (wordPrimTy)+primOpInfo Clz16Op = mkGenPrimOp (fsLit "clz16#")  [] [wordPrimTy] (wordPrimTy)+primOpInfo Clz32Op = mkGenPrimOp (fsLit "clz32#")  [] [wordPrimTy] (wordPrimTy)+primOpInfo Clz64Op = mkGenPrimOp (fsLit "clz64#")  [] [word64PrimTy] (wordPrimTy)+primOpInfo ClzOp = mkGenPrimOp (fsLit "clz#")  [] [wordPrimTy] (wordPrimTy)+primOpInfo Ctz8Op = mkGenPrimOp (fsLit "ctz8#")  [] [wordPrimTy] (wordPrimTy)+primOpInfo Ctz16Op = mkGenPrimOp (fsLit "ctz16#")  [] [wordPrimTy] (wordPrimTy)+primOpInfo Ctz32Op = mkGenPrimOp (fsLit "ctz32#")  [] [wordPrimTy] (wordPrimTy)+primOpInfo Ctz64Op = mkGenPrimOp (fsLit "ctz64#")  [] [word64PrimTy] (wordPrimTy)+primOpInfo CtzOp = mkGenPrimOp (fsLit "ctz#")  [] [wordPrimTy] (wordPrimTy)+primOpInfo BSwap16Op = mkGenPrimOp (fsLit "byteSwap16#")  [] [wordPrimTy] (wordPrimTy)+primOpInfo BSwap32Op = mkGenPrimOp (fsLit "byteSwap32#")  [] [wordPrimTy] (wordPrimTy)+primOpInfo BSwap64Op = mkGenPrimOp (fsLit "byteSwap64#")  [] [word64PrimTy] (word64PrimTy)+primOpInfo BSwapOp = mkGenPrimOp (fsLit "byteSwap#")  [] [wordPrimTy] (wordPrimTy)+primOpInfo BRev8Op = mkGenPrimOp (fsLit "bitReverse8#")  [] [wordPrimTy] (wordPrimTy)+primOpInfo BRev16Op = mkGenPrimOp (fsLit "bitReverse16#")  [] [wordPrimTy] (wordPrimTy)+primOpInfo BRev32Op = mkGenPrimOp (fsLit "bitReverse32#")  [] [wordPrimTy] (wordPrimTy)+primOpInfo BRev64Op = mkGenPrimOp (fsLit "bitReverse64#")  [] [word64PrimTy] (word64PrimTy)+primOpInfo BRevOp = mkGenPrimOp (fsLit "bitReverse#")  [] [wordPrimTy] (wordPrimTy)+primOpInfo Narrow8IntOp = mkGenPrimOp (fsLit "narrow8Int#")  [] [intPrimTy] (intPrimTy)+primOpInfo Narrow16IntOp = mkGenPrimOp (fsLit "narrow16Int#")  [] [intPrimTy] (intPrimTy)+primOpInfo Narrow32IntOp = mkGenPrimOp (fsLit "narrow32Int#")  [] [intPrimTy] (intPrimTy)+primOpInfo Narrow8WordOp = mkGenPrimOp (fsLit "narrow8Word#")  [] [wordPrimTy] (wordPrimTy)+primOpInfo Narrow16WordOp = mkGenPrimOp (fsLit "narrow16Word#")  [] [wordPrimTy] (wordPrimTy)+primOpInfo Narrow32WordOp = mkGenPrimOp (fsLit "narrow32Word#")  [] [wordPrimTy] (wordPrimTy)+primOpInfo DoubleGtOp = mkCompare (fsLit ">##") doublePrimTy+primOpInfo DoubleGeOp = mkCompare (fsLit ">=##") doublePrimTy+primOpInfo DoubleEqOp = mkCompare (fsLit "==##") doublePrimTy+primOpInfo DoubleNeOp = mkCompare (fsLit "/=##") doublePrimTy+primOpInfo DoubleLtOp = mkCompare (fsLit "<##") doublePrimTy+primOpInfo DoubleLeOp = mkCompare (fsLit "<=##") doublePrimTy+primOpInfo DoubleAddOp = mkGenPrimOp (fsLit "+##")  [] [doublePrimTy, doublePrimTy] (doublePrimTy)+primOpInfo DoubleSubOp = mkGenPrimOp (fsLit "-##")  [] [doublePrimTy, doublePrimTy] (doublePrimTy)+primOpInfo DoubleMulOp = mkGenPrimOp (fsLit "*##")  [] [doublePrimTy, doublePrimTy] (doublePrimTy)+primOpInfo DoubleDivOp = mkGenPrimOp (fsLit "/##")  [] [doublePrimTy, doublePrimTy] (doublePrimTy)+primOpInfo DoubleNegOp = mkGenPrimOp (fsLit "negateDouble#")  [] [doublePrimTy] (doublePrimTy)+primOpInfo DoubleFabsOp = mkGenPrimOp (fsLit "fabsDouble#")  [] [doublePrimTy] (doublePrimTy)+primOpInfo DoubleToIntOp = mkGenPrimOp (fsLit "double2Int#")  [] [doublePrimTy] (intPrimTy)+primOpInfo DoubleToFloatOp = mkGenPrimOp (fsLit "double2Float#")  [] [doublePrimTy] (floatPrimTy)+primOpInfo DoubleExpOp = mkGenPrimOp (fsLit "expDouble#")  [] [doublePrimTy] (doublePrimTy)+primOpInfo DoubleExpM1Op = mkGenPrimOp (fsLit "expm1Double#")  [] [doublePrimTy] (doublePrimTy)+primOpInfo DoubleLogOp = mkGenPrimOp (fsLit "logDouble#")  [] [doublePrimTy] (doublePrimTy)+primOpInfo DoubleLog1POp = mkGenPrimOp (fsLit "log1pDouble#")  [] [doublePrimTy] (doublePrimTy)+primOpInfo DoubleSqrtOp = mkGenPrimOp (fsLit "sqrtDouble#")  [] [doublePrimTy] (doublePrimTy)+primOpInfo DoubleSinOp = mkGenPrimOp (fsLit "sinDouble#")  [] [doublePrimTy] (doublePrimTy)+primOpInfo DoubleCosOp = mkGenPrimOp (fsLit "cosDouble#")  [] [doublePrimTy] (doublePrimTy)+primOpInfo DoubleTanOp = mkGenPrimOp (fsLit "tanDouble#")  [] [doublePrimTy] (doublePrimTy)+primOpInfo DoubleAsinOp = mkGenPrimOp (fsLit "asinDouble#")  [] [doublePrimTy] (doublePrimTy)+primOpInfo DoubleAcosOp = mkGenPrimOp (fsLit "acosDouble#")  [] [doublePrimTy] (doublePrimTy)+primOpInfo DoubleAtanOp = mkGenPrimOp (fsLit "atanDouble#")  [] [doublePrimTy] (doublePrimTy)+primOpInfo DoubleSinhOp = mkGenPrimOp (fsLit "sinhDouble#")  [] [doublePrimTy] (doublePrimTy)+primOpInfo DoubleCoshOp = mkGenPrimOp (fsLit "coshDouble#")  [] [doublePrimTy] (doublePrimTy)+primOpInfo DoubleTanhOp = mkGenPrimOp (fsLit "tanhDouble#")  [] [doublePrimTy] (doublePrimTy)+primOpInfo DoubleAsinhOp = mkGenPrimOp (fsLit "asinhDouble#")  [] [doublePrimTy] (doublePrimTy)+primOpInfo DoubleAcoshOp = mkGenPrimOp (fsLit "acoshDouble#")  [] [doublePrimTy] (doublePrimTy)+primOpInfo DoubleAtanhOp = mkGenPrimOp (fsLit "atanhDouble#")  [] [doublePrimTy] (doublePrimTy)+primOpInfo DoublePowerOp = mkGenPrimOp (fsLit "**##")  [] [doublePrimTy, doublePrimTy] (doublePrimTy)+primOpInfo DoubleDecode_2IntOp = mkGenPrimOp (fsLit "decodeDouble_2Int#")  [] [doublePrimTy] ((mkTupleTy Unboxed [intPrimTy, wordPrimTy, wordPrimTy, intPrimTy]))+primOpInfo DoubleDecode_Int64Op = mkGenPrimOp (fsLit "decodeDouble_Int64#")  [] [doublePrimTy] ((mkTupleTy Unboxed [int64PrimTy, intPrimTy]))+primOpInfo FloatGtOp = mkCompare (fsLit "gtFloat#") floatPrimTy+primOpInfo FloatGeOp = mkCompare (fsLit "geFloat#") floatPrimTy+primOpInfo FloatEqOp = mkCompare (fsLit "eqFloat#") floatPrimTy+primOpInfo FloatNeOp = mkCompare (fsLit "neFloat#") floatPrimTy+primOpInfo FloatLtOp = mkCompare (fsLit "ltFloat#") floatPrimTy+primOpInfo FloatLeOp = mkCompare (fsLit "leFloat#") floatPrimTy+primOpInfo FloatAddOp = mkGenPrimOp (fsLit "plusFloat#")  [] [floatPrimTy, floatPrimTy] (floatPrimTy)+primOpInfo FloatSubOp = mkGenPrimOp (fsLit "minusFloat#")  [] [floatPrimTy, floatPrimTy] (floatPrimTy)+primOpInfo FloatMulOp = mkGenPrimOp (fsLit "timesFloat#")  [] [floatPrimTy, floatPrimTy] (floatPrimTy)+primOpInfo FloatDivOp = mkGenPrimOp (fsLit "divideFloat#")  [] [floatPrimTy, floatPrimTy] (floatPrimTy)+primOpInfo FloatNegOp = mkGenPrimOp (fsLit "negateFloat#")  [] [floatPrimTy] (floatPrimTy)+primOpInfo FloatFabsOp = mkGenPrimOp (fsLit "fabsFloat#")  [] [floatPrimTy] (floatPrimTy)+primOpInfo FloatToIntOp = mkGenPrimOp (fsLit "float2Int#")  [] [floatPrimTy] (intPrimTy)+primOpInfo FloatExpOp = mkGenPrimOp (fsLit "expFloat#")  [] [floatPrimTy] (floatPrimTy)+primOpInfo FloatExpM1Op = mkGenPrimOp (fsLit "expm1Float#")  [] [floatPrimTy] (floatPrimTy)+primOpInfo FloatLogOp = mkGenPrimOp (fsLit "logFloat#")  [] [floatPrimTy] (floatPrimTy)+primOpInfo FloatLog1POp = mkGenPrimOp (fsLit "log1pFloat#")  [] [floatPrimTy] (floatPrimTy)+primOpInfo FloatSqrtOp = mkGenPrimOp (fsLit "sqrtFloat#")  [] [floatPrimTy] (floatPrimTy)+primOpInfo FloatSinOp = mkGenPrimOp (fsLit "sinFloat#")  [] [floatPrimTy] (floatPrimTy)+primOpInfo FloatCosOp = mkGenPrimOp (fsLit "cosFloat#")  [] [floatPrimTy] (floatPrimTy)+primOpInfo FloatTanOp = mkGenPrimOp (fsLit "tanFloat#")  [] [floatPrimTy] (floatPrimTy)+primOpInfo FloatAsinOp = mkGenPrimOp (fsLit "asinFloat#")  [] [floatPrimTy] (floatPrimTy)+primOpInfo FloatAcosOp = mkGenPrimOp (fsLit "acosFloat#")  [] [floatPrimTy] (floatPrimTy)+primOpInfo FloatAtanOp = mkGenPrimOp (fsLit "atanFloat#")  [] [floatPrimTy] (floatPrimTy)+primOpInfo FloatSinhOp = mkGenPrimOp (fsLit "sinhFloat#")  [] [floatPrimTy] (floatPrimTy)+primOpInfo FloatCoshOp = mkGenPrimOp (fsLit "coshFloat#")  [] [floatPrimTy] (floatPrimTy)+primOpInfo FloatTanhOp = mkGenPrimOp (fsLit "tanhFloat#")  [] [floatPrimTy] (floatPrimTy)+primOpInfo FloatAsinhOp = mkGenPrimOp (fsLit "asinhFloat#")  [] [floatPrimTy] (floatPrimTy)+primOpInfo FloatAcoshOp = mkGenPrimOp (fsLit "acoshFloat#")  [] [floatPrimTy] (floatPrimTy)+primOpInfo FloatAtanhOp = mkGenPrimOp (fsLit "atanhFloat#")  [] [floatPrimTy] (floatPrimTy)+primOpInfo FloatPowerOp = mkGenPrimOp (fsLit "powerFloat#")  [] [floatPrimTy, floatPrimTy] (floatPrimTy)+primOpInfo FloatToDoubleOp = mkGenPrimOp (fsLit "float2Double#")  [] [floatPrimTy] (doublePrimTy)+primOpInfo FloatDecode_IntOp = mkGenPrimOp (fsLit "decodeFloat_Int#")  [] [floatPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))+primOpInfo NewArrayOp = mkGenPrimOp (fsLit "newArray#")  [levity1TyVarInf, levPolyAlphaTyVarSpec, deltaTyVarSpec] [intPrimTy, levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy levPolyAlphaTy]))+primOpInfo ReadArrayOp = mkGenPrimOp (fsLit "readArray#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, levPolyAlphaTy]))+primOpInfo WriteArrayOp = mkGenPrimOp (fsLit "writeArray#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, levPolyAlphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo SizeofArrayOp = mkGenPrimOp (fsLit "sizeofArray#")  [levity1TyVarInf, levPolyAlphaTyVarSpec] [mkArrayPrimTy levPolyAlphaTy] (intPrimTy)+primOpInfo SizeofMutableArrayOp = mkGenPrimOp (fsLit "sizeofMutableArray#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMutableArrayPrimTy deltaTy levPolyAlphaTy] (intPrimTy)+primOpInfo IndexArrayOp = mkGenPrimOp (fsLit "indexArray#")  [levity1TyVarInf, levPolyAlphaTyVarSpec] [mkArrayPrimTy levPolyAlphaTy, intPrimTy] ((mkTupleTy Unboxed [levPolyAlphaTy]))+primOpInfo UnsafeFreezeArrayOp = mkGenPrimOp (fsLit "unsafeFreezeArray#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMutableArrayPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayPrimTy levPolyAlphaTy]))+primOpInfo UnsafeThawArrayOp = mkGenPrimOp (fsLit "unsafeThawArray#")  [levity1TyVarInf, levPolyAlphaTyVarSpec, deltaTyVarSpec] [mkArrayPrimTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy levPolyAlphaTy]))+primOpInfo CopyArrayOp = mkGenPrimOp (fsLit "copyArray#")  [levity1TyVarInf, levPolyAlphaTyVarSpec, deltaTyVarSpec] [mkArrayPrimTy levPolyAlphaTy, intPrimTy, mkMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CopyMutableArrayOp = mkGenPrimOp (fsLit "copyMutableArray#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, mkMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CloneArrayOp = mkGenPrimOp (fsLit "cloneArray#")  [levity1TyVarInf, levPolyAlphaTyVarSpec] [mkArrayPrimTy levPolyAlphaTy, intPrimTy, intPrimTy] (mkArrayPrimTy levPolyAlphaTy)+primOpInfo CloneMutableArrayOp = mkGenPrimOp (fsLit "cloneMutableArray#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy levPolyAlphaTy]))+primOpInfo FreezeArrayOp = mkGenPrimOp (fsLit "freezeArray#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayPrimTy levPolyAlphaTy]))+primOpInfo ThawArrayOp = mkGenPrimOp (fsLit "thawArray#")  [levity1TyVarInf, levPolyAlphaTyVarSpec, deltaTyVarSpec] [mkArrayPrimTy levPolyAlphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy levPolyAlphaTy]))+primOpInfo CasArrayOp = mkGenPrimOp (fsLit "casArray#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, levPolyAlphaTy, levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, levPolyAlphaTy]))+primOpInfo NewSmallArrayOp = mkGenPrimOp (fsLit "newSmallArray#")  [levity1TyVarInf, levPolyAlphaTyVarSpec, deltaTyVarSpec] [intPrimTy, levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy]))+primOpInfo ShrinkSmallMutableArrayOp_Char = mkGenPrimOp (fsLit "shrinkSmallMutableArray#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo ReadSmallArrayOp = mkGenPrimOp (fsLit "readSmallArray#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, levPolyAlphaTy]))+primOpInfo WriteSmallArrayOp = mkGenPrimOp (fsLit "writeSmallArray#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, levPolyAlphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo SizeofSmallArrayOp = mkGenPrimOp (fsLit "sizeofSmallArray#")  [levity1TyVarInf, levPolyAlphaTyVarSpec] [mkSmallArrayPrimTy levPolyAlphaTy] (intPrimTy)+primOpInfo SizeofSmallMutableArrayOp = mkGenPrimOp (fsLit "sizeofSmallMutableArray#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy] (intPrimTy)+primOpInfo GetSizeofSmallMutableArrayOp = mkGenPrimOp (fsLit "getSizeofSmallMutableArray#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo IndexSmallArrayOp = mkGenPrimOp (fsLit "indexSmallArray#")  [levity1TyVarInf, levPolyAlphaTyVarSpec] [mkSmallArrayPrimTy levPolyAlphaTy, intPrimTy] ((mkTupleTy Unboxed [levPolyAlphaTy]))+primOpInfo UnsafeFreezeSmallArrayOp = mkGenPrimOp (fsLit "unsafeFreezeSmallArray#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallArrayPrimTy levPolyAlphaTy]))+primOpInfo UnsafeThawSmallArrayOp = mkGenPrimOp (fsLit "unsafeThawSmallArray#")  [levity1TyVarInf, levPolyAlphaTyVarSpec, deltaTyVarSpec] [mkSmallArrayPrimTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy]))+primOpInfo CopySmallArrayOp = mkGenPrimOp (fsLit "copySmallArray#")  [levity1TyVarInf, levPolyAlphaTyVarSpec, deltaTyVarSpec] [mkSmallArrayPrimTy levPolyAlphaTy, intPrimTy, mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CopySmallMutableArrayOp = mkGenPrimOp (fsLit "copySmallMutableArray#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CloneSmallArrayOp = mkGenPrimOp (fsLit "cloneSmallArray#")  [levity1TyVarInf, levPolyAlphaTyVarSpec] [mkSmallArrayPrimTy levPolyAlphaTy, intPrimTy, intPrimTy] (mkSmallArrayPrimTy levPolyAlphaTy)+primOpInfo CloneSmallMutableArrayOp = mkGenPrimOp (fsLit "cloneSmallMutableArray#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy]))+primOpInfo FreezeSmallArrayOp = mkGenPrimOp (fsLit "freezeSmallArray#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallArrayPrimTy levPolyAlphaTy]))+primOpInfo ThawSmallArrayOp = mkGenPrimOp (fsLit "thawSmallArray#")  [levity1TyVarInf, levPolyAlphaTyVarSpec, deltaTyVarSpec] [mkSmallArrayPrimTy levPolyAlphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy]))+primOpInfo CasSmallArrayOp = mkGenPrimOp (fsLit "casSmallArray#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, levPolyAlphaTy, levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, levPolyAlphaTy]))+primOpInfo NewByteArrayOp_Char = mkGenPrimOp (fsLit "newByteArray#")  [deltaTyVarSpec] [intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy]))+primOpInfo NewPinnedByteArrayOp_Char = mkGenPrimOp (fsLit "newPinnedByteArray#")  [deltaTyVarSpec] [intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy]))+primOpInfo NewAlignedPinnedByteArrayOp_Char = mkGenPrimOp (fsLit "newAlignedPinnedByteArray#")  [deltaTyVarSpec] [intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy]))+primOpInfo MutableByteArrayIsPinnedOp = mkGenPrimOp (fsLit "isMutableByteArrayPinned#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy] (intPrimTy)+primOpInfo ByteArrayIsPinnedOp = mkGenPrimOp (fsLit "isByteArrayPinned#")  [] [byteArrayPrimTy] (intPrimTy)+primOpInfo ByteArrayContents_Char = mkGenPrimOp (fsLit "byteArrayContents#")  [] [byteArrayPrimTy] (addrPrimTy)+primOpInfo MutableByteArrayContents_Char = mkGenPrimOp (fsLit "mutableByteArrayContents#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy] (addrPrimTy)+primOpInfo ShrinkMutableByteArrayOp_Char = mkGenPrimOp (fsLit "shrinkMutableByteArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo ResizeMutableByteArrayOp_Char = mkGenPrimOp (fsLit "resizeMutableByteArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy]))+primOpInfo UnsafeFreezeByteArrayOp = mkGenPrimOp (fsLit "unsafeFreezeByteArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, byteArrayPrimTy]))+primOpInfo SizeofByteArrayOp = mkGenPrimOp (fsLit "sizeofByteArray#")  [] [byteArrayPrimTy] (intPrimTy)+primOpInfo SizeofMutableByteArrayOp = mkGenPrimOp (fsLit "sizeofMutableByteArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy] (intPrimTy)+primOpInfo GetSizeofMutableByteArrayOp = mkGenPrimOp (fsLit "getSizeofMutableByteArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo IndexByteArrayOp_Char = mkGenPrimOp (fsLit "indexCharArray#")  [] [byteArrayPrimTy, intPrimTy] (charPrimTy)+primOpInfo IndexByteArrayOp_WideChar = mkGenPrimOp (fsLit "indexWideCharArray#")  [] [byteArrayPrimTy, intPrimTy] (charPrimTy)+primOpInfo IndexByteArrayOp_Int = mkGenPrimOp (fsLit "indexIntArray#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexByteArrayOp_Word = mkGenPrimOp (fsLit "indexWordArray#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)+primOpInfo IndexByteArrayOp_Addr = mkGenPrimOp (fsLit "indexAddrArray#")  [] [byteArrayPrimTy, intPrimTy] (addrPrimTy)+primOpInfo IndexByteArrayOp_Float = mkGenPrimOp (fsLit "indexFloatArray#")  [] [byteArrayPrimTy, intPrimTy] (floatPrimTy)+primOpInfo IndexByteArrayOp_Double = mkGenPrimOp (fsLit "indexDoubleArray#")  [] [byteArrayPrimTy, intPrimTy] (doublePrimTy)+primOpInfo IndexByteArrayOp_StablePtr = mkGenPrimOp (fsLit "indexStablePtrArray#")  [alphaTyVarSpec] [byteArrayPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy)+primOpInfo IndexByteArrayOp_Int8 = mkGenPrimOp (fsLit "indexInt8Array#")  [] [byteArrayPrimTy, intPrimTy] (int8PrimTy)+primOpInfo IndexByteArrayOp_Int16 = mkGenPrimOp (fsLit "indexInt16Array#")  [] [byteArrayPrimTy, intPrimTy] (int16PrimTy)+primOpInfo IndexByteArrayOp_Int32 = mkGenPrimOp (fsLit "indexInt32Array#")  [] [byteArrayPrimTy, intPrimTy] (int32PrimTy)+primOpInfo IndexByteArrayOp_Int64 = mkGenPrimOp (fsLit "indexInt64Array#")  [] [byteArrayPrimTy, intPrimTy] (int64PrimTy)+primOpInfo IndexByteArrayOp_Word8 = mkGenPrimOp (fsLit "indexWord8Array#")  [] [byteArrayPrimTy, intPrimTy] (word8PrimTy)+primOpInfo IndexByteArrayOp_Word16 = mkGenPrimOp (fsLit "indexWord16Array#")  [] [byteArrayPrimTy, intPrimTy] (word16PrimTy)+primOpInfo IndexByteArrayOp_Word32 = mkGenPrimOp (fsLit "indexWord32Array#")  [] [byteArrayPrimTy, intPrimTy] (word32PrimTy)+primOpInfo IndexByteArrayOp_Word64 = mkGenPrimOp (fsLit "indexWord64Array#")  [] [byteArrayPrimTy, intPrimTy] (word64PrimTy)+primOpInfo IndexByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "indexWord8ArrayAsChar#")  [] [byteArrayPrimTy, intPrimTy] (charPrimTy)+primOpInfo IndexByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "indexWord8ArrayAsWideChar#")  [] [byteArrayPrimTy, intPrimTy] (charPrimTy)+primOpInfo IndexByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "indexWord8ArrayAsInt#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexByteArrayOp_Word8AsWord = mkGenPrimOp (fsLit "indexWord8ArrayAsWord#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)+primOpInfo IndexByteArrayOp_Word8AsAddr = mkGenPrimOp (fsLit "indexWord8ArrayAsAddr#")  [] [byteArrayPrimTy, intPrimTy] (addrPrimTy)+primOpInfo IndexByteArrayOp_Word8AsFloat = mkGenPrimOp (fsLit "indexWord8ArrayAsFloat#")  [] [byteArrayPrimTy, intPrimTy] (floatPrimTy)+primOpInfo IndexByteArrayOp_Word8AsDouble = mkGenPrimOp (fsLit "indexWord8ArrayAsDouble#")  [] [byteArrayPrimTy, intPrimTy] (doublePrimTy)+primOpInfo IndexByteArrayOp_Word8AsStablePtr = mkGenPrimOp (fsLit "indexWord8ArrayAsStablePtr#")  [alphaTyVarSpec] [byteArrayPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy)+primOpInfo IndexByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt16#")  [] [byteArrayPrimTy, intPrimTy] (int16PrimTy)+primOpInfo IndexByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt32#")  [] [byteArrayPrimTy, intPrimTy] (int32PrimTy)+primOpInfo IndexByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt64#")  [] [byteArrayPrimTy, intPrimTy] (int64PrimTy)+primOpInfo IndexByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord16#")  [] [byteArrayPrimTy, intPrimTy] (word16PrimTy)+primOpInfo IndexByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord32#")  [] [byteArrayPrimTy, intPrimTy] (word32PrimTy)+primOpInfo IndexByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord64#")  [] [byteArrayPrimTy, intPrimTy] (word64PrimTy)+primOpInfo ReadByteArrayOp_Char = mkGenPrimOp (fsLit "readCharArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))+primOpInfo ReadByteArrayOp_WideChar = mkGenPrimOp (fsLit "readWideCharArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))+primOpInfo ReadByteArrayOp_Int = mkGenPrimOp (fsLit "readIntArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadByteArrayOp_Word = mkGenPrimOp (fsLit "readWordArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo ReadByteArrayOp_Addr = mkGenPrimOp (fsLit "readAddrArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))+primOpInfo ReadByteArrayOp_Float = mkGenPrimOp (fsLit "readFloatArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatPrimTy]))+primOpInfo ReadByteArrayOp_Double = mkGenPrimOp (fsLit "readDoubleArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy]))+primOpInfo ReadByteArrayOp_StablePtr = mkGenPrimOp (fsLit "readStablePtrArray#")  [deltaTyVarSpec, alphaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy]))+primOpInfo ReadByteArrayOp_Int8 = mkGenPrimOp (fsLit "readInt8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8PrimTy]))+primOpInfo ReadByteArrayOp_Int16 = mkGenPrimOp (fsLit "readInt16Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16PrimTy]))+primOpInfo ReadByteArrayOp_Int32 = mkGenPrimOp (fsLit "readInt32Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32PrimTy]))+primOpInfo ReadByteArrayOp_Int64 = mkGenPrimOp (fsLit "readInt64Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64PrimTy]))+primOpInfo ReadByteArrayOp_Word8 = mkGenPrimOp (fsLit "readWord8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8PrimTy]))+primOpInfo ReadByteArrayOp_Word16 = mkGenPrimOp (fsLit "readWord16Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16PrimTy]))+primOpInfo ReadByteArrayOp_Word32 = mkGenPrimOp (fsLit "readWord32Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32PrimTy]))+primOpInfo ReadByteArrayOp_Word64 = mkGenPrimOp (fsLit "readWord64Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64PrimTy]))+primOpInfo ReadByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "readWord8ArrayAsChar#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))+primOpInfo ReadByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "readWord8ArrayAsWideChar#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))+primOpInfo ReadByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "readWord8ArrayAsInt#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadByteArrayOp_Word8AsWord = mkGenPrimOp (fsLit "readWord8ArrayAsWord#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo ReadByteArrayOp_Word8AsAddr = mkGenPrimOp (fsLit "readWord8ArrayAsAddr#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))+primOpInfo ReadByteArrayOp_Word8AsFloat = mkGenPrimOp (fsLit "readWord8ArrayAsFloat#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatPrimTy]))+primOpInfo ReadByteArrayOp_Word8AsDouble = mkGenPrimOp (fsLit "readWord8ArrayAsDouble#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy]))+primOpInfo ReadByteArrayOp_Word8AsStablePtr = mkGenPrimOp (fsLit "readWord8ArrayAsStablePtr#")  [deltaTyVarSpec, alphaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy]))+primOpInfo ReadByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "readWord8ArrayAsInt16#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16PrimTy]))+primOpInfo ReadByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "readWord8ArrayAsInt32#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32PrimTy]))+primOpInfo ReadByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "readWord8ArrayAsInt64#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64PrimTy]))+primOpInfo ReadByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "readWord8ArrayAsWord16#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16PrimTy]))+primOpInfo ReadByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "readWord8ArrayAsWord32#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32PrimTy]))+primOpInfo ReadByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "readWord8ArrayAsWord64#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64PrimTy]))+primOpInfo WriteByteArrayOp_Char = mkGenPrimOp (fsLit "writeCharArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_WideChar = mkGenPrimOp (fsLit "writeWideCharArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Int = mkGenPrimOp (fsLit "writeIntArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word = mkGenPrimOp (fsLit "writeWordArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Addr = mkGenPrimOp (fsLit "writeAddrArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Float = mkGenPrimOp (fsLit "writeFloatArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Double = mkGenPrimOp (fsLit "writeDoubleArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_StablePtr = mkGenPrimOp (fsLit "writeStablePtrArray#")  [deltaTyVarSpec, alphaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Int8 = mkGenPrimOp (fsLit "writeInt8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Int16 = mkGenPrimOp (fsLit "writeInt16Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Int32 = mkGenPrimOp (fsLit "writeInt32Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Int64 = mkGenPrimOp (fsLit "writeInt64Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8 = mkGenPrimOp (fsLit "writeWord8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word16 = mkGenPrimOp (fsLit "writeWord16Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word32 = mkGenPrimOp (fsLit "writeWord32Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word64 = mkGenPrimOp (fsLit "writeWord64Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "writeWord8ArrayAsChar#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "writeWord8ArrayAsWideChar#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "writeWord8ArrayAsInt#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsWord = mkGenPrimOp (fsLit "writeWord8ArrayAsWord#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsAddr = mkGenPrimOp (fsLit "writeWord8ArrayAsAddr#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsFloat = mkGenPrimOp (fsLit "writeWord8ArrayAsFloat#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsDouble = mkGenPrimOp (fsLit "writeWord8ArrayAsDouble#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsStablePtr = mkGenPrimOp (fsLit "writeWord8ArrayAsStablePtr#")  [deltaTyVarSpec, alphaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt16#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt32#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt64#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord16#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord32#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord64#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CompareByteArraysOp = mkGenPrimOp (fsLit "compareByteArrays#")  [] [byteArrayPrimTy, intPrimTy, byteArrayPrimTy, intPrimTy, intPrimTy] (intPrimTy)+primOpInfo CopyByteArrayOp = mkGenPrimOp (fsLit "copyByteArray#")  [deltaTyVarSpec] [byteArrayPrimTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CopyMutableByteArrayOp = mkGenPrimOp (fsLit "copyMutableByteArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CopyByteArrayToAddrOp = mkGenPrimOp (fsLit "copyByteArrayToAddr#")  [deltaTyVarSpec] [byteArrayPrimTy, intPrimTy, addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CopyMutableByteArrayToAddrOp = mkGenPrimOp (fsLit "copyMutableByteArrayToAddr#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CopyAddrToByteArrayOp = mkGenPrimOp (fsLit "copyAddrToByteArray#")  [deltaTyVarSpec] [addrPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo SetByteArrayOp = mkGenPrimOp (fsLit "setByteArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo AtomicReadByteArrayOp_Int = mkGenPrimOp (fsLit "atomicReadIntArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo AtomicWriteByteArrayOp_Int = mkGenPrimOp (fsLit "atomicWriteIntArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CasByteArrayOp_Int = mkGenPrimOp (fsLit "casIntArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo CasByteArrayOp_Int8 = mkGenPrimOp (fsLit "casInt8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8PrimTy, int8PrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8PrimTy]))+primOpInfo CasByteArrayOp_Int16 = mkGenPrimOp (fsLit "casInt16Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16PrimTy, int16PrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16PrimTy]))+primOpInfo CasByteArrayOp_Int32 = mkGenPrimOp (fsLit "casInt32Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32PrimTy, int32PrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32PrimTy]))+primOpInfo CasByteArrayOp_Int64 = mkGenPrimOp (fsLit "casInt64Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64PrimTy, int64PrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64PrimTy]))+primOpInfo FetchAddByteArrayOp_Int = mkGenPrimOp (fsLit "fetchAddIntArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo FetchSubByteArrayOp_Int = mkGenPrimOp (fsLit "fetchSubIntArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo FetchAndByteArrayOp_Int = mkGenPrimOp (fsLit "fetchAndIntArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo FetchNandByteArrayOp_Int = mkGenPrimOp (fsLit "fetchNandIntArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo FetchOrByteArrayOp_Int = mkGenPrimOp (fsLit "fetchOrIntArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo FetchXorByteArrayOp_Int = mkGenPrimOp (fsLit "fetchXorIntArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo AddrAddOp = mkGenPrimOp (fsLit "plusAddr#")  [] [addrPrimTy, intPrimTy] (addrPrimTy)+primOpInfo AddrSubOp = mkGenPrimOp (fsLit "minusAddr#")  [] [addrPrimTy, addrPrimTy] (intPrimTy)+primOpInfo AddrRemOp = mkGenPrimOp (fsLit "remAddr#")  [] [addrPrimTy, intPrimTy] (intPrimTy)+primOpInfo AddrToIntOp = mkGenPrimOp (fsLit "addr2Int#")  [] [addrPrimTy] (intPrimTy)+primOpInfo IntToAddrOp = mkGenPrimOp (fsLit "int2Addr#")  [] [intPrimTy] (addrPrimTy)+primOpInfo AddrGtOp = mkCompare (fsLit "gtAddr#") addrPrimTy+primOpInfo AddrGeOp = mkCompare (fsLit "geAddr#") addrPrimTy+primOpInfo AddrEqOp = mkCompare (fsLit "eqAddr#") addrPrimTy+primOpInfo AddrNeOp = mkCompare (fsLit "neAddr#") addrPrimTy+primOpInfo AddrLtOp = mkCompare (fsLit "ltAddr#") addrPrimTy+primOpInfo AddrLeOp = mkCompare (fsLit "leAddr#") addrPrimTy+primOpInfo IndexOffAddrOp_Char = mkGenPrimOp (fsLit "indexCharOffAddr#")  [] [addrPrimTy, intPrimTy] (charPrimTy)+primOpInfo IndexOffAddrOp_WideChar = mkGenPrimOp (fsLit "indexWideCharOffAddr#")  [] [addrPrimTy, intPrimTy] (charPrimTy)+primOpInfo IndexOffAddrOp_Int = mkGenPrimOp (fsLit "indexIntOffAddr#")  [] [addrPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexOffAddrOp_Word = mkGenPrimOp (fsLit "indexWordOffAddr#")  [] [addrPrimTy, intPrimTy] (wordPrimTy)+primOpInfo IndexOffAddrOp_Addr = mkGenPrimOp (fsLit "indexAddrOffAddr#")  [] [addrPrimTy, intPrimTy] (addrPrimTy)+primOpInfo IndexOffAddrOp_Float = mkGenPrimOp (fsLit "indexFloatOffAddr#")  [] [addrPrimTy, intPrimTy] (floatPrimTy)+primOpInfo IndexOffAddrOp_Double = mkGenPrimOp (fsLit "indexDoubleOffAddr#")  [] [addrPrimTy, intPrimTy] (doublePrimTy)+primOpInfo IndexOffAddrOp_StablePtr = mkGenPrimOp (fsLit "indexStablePtrOffAddr#")  [alphaTyVarSpec] [addrPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy)+primOpInfo IndexOffAddrOp_Int8 = mkGenPrimOp (fsLit "indexInt8OffAddr#")  [] [addrPrimTy, intPrimTy] (int8PrimTy)+primOpInfo IndexOffAddrOp_Int16 = mkGenPrimOp (fsLit "indexInt16OffAddr#")  [] [addrPrimTy, intPrimTy] (int16PrimTy)+primOpInfo IndexOffAddrOp_Int32 = mkGenPrimOp (fsLit "indexInt32OffAddr#")  [] [addrPrimTy, intPrimTy] (int32PrimTy)+primOpInfo IndexOffAddrOp_Int64 = mkGenPrimOp (fsLit "indexInt64OffAddr#")  [] [addrPrimTy, intPrimTy] (int64PrimTy)+primOpInfo IndexOffAddrOp_Word8 = mkGenPrimOp (fsLit "indexWord8OffAddr#")  [] [addrPrimTy, intPrimTy] (word8PrimTy)+primOpInfo IndexOffAddrOp_Word16 = mkGenPrimOp (fsLit "indexWord16OffAddr#")  [] [addrPrimTy, intPrimTy] (word16PrimTy)+primOpInfo IndexOffAddrOp_Word32 = mkGenPrimOp (fsLit "indexWord32OffAddr#")  [] [addrPrimTy, intPrimTy] (word32PrimTy)+primOpInfo IndexOffAddrOp_Word64 = mkGenPrimOp (fsLit "indexWord64OffAddr#")  [] [addrPrimTy, intPrimTy] (word64PrimTy)+primOpInfo ReadOffAddrOp_Char = mkGenPrimOp (fsLit "readCharOffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))+primOpInfo ReadOffAddrOp_WideChar = mkGenPrimOp (fsLit "readWideCharOffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))+primOpInfo ReadOffAddrOp_Int = mkGenPrimOp (fsLit "readIntOffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadOffAddrOp_Word = mkGenPrimOp (fsLit "readWordOffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo ReadOffAddrOp_Addr = mkGenPrimOp (fsLit "readAddrOffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))+primOpInfo ReadOffAddrOp_Float = mkGenPrimOp (fsLit "readFloatOffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatPrimTy]))+primOpInfo ReadOffAddrOp_Double = mkGenPrimOp (fsLit "readDoubleOffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy]))+primOpInfo ReadOffAddrOp_StablePtr = mkGenPrimOp (fsLit "readStablePtrOffAddr#")  [deltaTyVarSpec, alphaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy]))+primOpInfo ReadOffAddrOp_Int8 = mkGenPrimOp (fsLit "readInt8OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8PrimTy]))+primOpInfo ReadOffAddrOp_Int16 = mkGenPrimOp (fsLit "readInt16OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16PrimTy]))+primOpInfo ReadOffAddrOp_Int32 = mkGenPrimOp (fsLit "readInt32OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32PrimTy]))+primOpInfo ReadOffAddrOp_Int64 = mkGenPrimOp (fsLit "readInt64OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64PrimTy]))+primOpInfo ReadOffAddrOp_Word8 = mkGenPrimOp (fsLit "readWord8OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8PrimTy]))+primOpInfo ReadOffAddrOp_Word16 = mkGenPrimOp (fsLit "readWord16OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16PrimTy]))+primOpInfo ReadOffAddrOp_Word32 = mkGenPrimOp (fsLit "readWord32OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32PrimTy]))+primOpInfo ReadOffAddrOp_Word64 = mkGenPrimOp (fsLit "readWord64OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64PrimTy]))+primOpInfo WriteOffAddrOp_Char = mkGenPrimOp (fsLit "writeCharOffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_WideChar = mkGenPrimOp (fsLit "writeWideCharOffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Int = mkGenPrimOp (fsLit "writeIntOffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Word = mkGenPrimOp (fsLit "writeWordOffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Addr = mkGenPrimOp (fsLit "writeAddrOffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Float = mkGenPrimOp (fsLit "writeFloatOffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, floatPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Double = mkGenPrimOp (fsLit "writeDoubleOffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_StablePtr = mkGenPrimOp (fsLit "writeStablePtrOffAddr#")  [alphaTyVarSpec, deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Int8 = mkGenPrimOp (fsLit "writeInt8OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Int16 = mkGenPrimOp (fsLit "writeInt16OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Int32 = mkGenPrimOp (fsLit "writeInt32OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Int64 = mkGenPrimOp (fsLit "writeInt64OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Word8 = mkGenPrimOp (fsLit "writeWord8OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Word16 = mkGenPrimOp (fsLit "writeWord16OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Word32 = mkGenPrimOp (fsLit "writeWord32OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Word64 = mkGenPrimOp (fsLit "writeWord64OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo InterlockedExchange_Addr = mkGenPrimOp (fsLit "atomicExchangeAddrAddr#")  [deltaTyVarSpec] [addrPrimTy, addrPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))+primOpInfo InterlockedExchange_Word = mkGenPrimOp (fsLit "atomicExchangeWordAddr#")  [deltaTyVarSpec] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo CasAddrOp_Addr = mkGenPrimOp (fsLit "atomicCasAddrAddr#")  [deltaTyVarSpec] [addrPrimTy, addrPrimTy, addrPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))+primOpInfo CasAddrOp_Word = mkGenPrimOp (fsLit "atomicCasWordAddr#")  [deltaTyVarSpec] [addrPrimTy, wordPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo CasAddrOp_Word8 = mkGenPrimOp (fsLit "atomicCasWord8Addr#")  [deltaTyVarSpec] [addrPrimTy, word8PrimTy, word8PrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8PrimTy]))+primOpInfo CasAddrOp_Word16 = mkGenPrimOp (fsLit "atomicCasWord16Addr#")  [deltaTyVarSpec] [addrPrimTy, word16PrimTy, word16PrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16PrimTy]))+primOpInfo CasAddrOp_Word32 = mkGenPrimOp (fsLit "atomicCasWord32Addr#")  [deltaTyVarSpec] [addrPrimTy, word32PrimTy, word32PrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32PrimTy]))+primOpInfo CasAddrOp_Word64 = mkGenPrimOp (fsLit "atomicCasWord64Addr#")  [deltaTyVarSpec] [addrPrimTy, word64PrimTy, word64PrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64PrimTy]))+primOpInfo FetchAddAddrOp_Word = mkGenPrimOp (fsLit "fetchAddWordAddr#")  [deltaTyVarSpec] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo FetchSubAddrOp_Word = mkGenPrimOp (fsLit "fetchSubWordAddr#")  [deltaTyVarSpec] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo FetchAndAddrOp_Word = mkGenPrimOp (fsLit "fetchAndWordAddr#")  [deltaTyVarSpec] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo FetchNandAddrOp_Word = mkGenPrimOp (fsLit "fetchNandWordAddr#")  [deltaTyVarSpec] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo FetchOrAddrOp_Word = mkGenPrimOp (fsLit "fetchOrWordAddr#")  [deltaTyVarSpec] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo FetchXorAddrOp_Word = mkGenPrimOp (fsLit "fetchXorWordAddr#")  [deltaTyVarSpec] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo AtomicReadAddrOp_Word = mkGenPrimOp (fsLit "atomicReadWordAddr#")  [deltaTyVarSpec] [addrPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo AtomicWriteAddrOp_Word = mkGenPrimOp (fsLit "atomicWriteWordAddr#")  [deltaTyVarSpec] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo NewMutVarOp = mkGenPrimOp (fsLit "newMutVar#")  [levity1TyVarInf, levPolyAlphaTyVarSpec, deltaTyVarSpec] [levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutVarPrimTy deltaTy levPolyAlphaTy]))+primOpInfo ReadMutVarOp = mkGenPrimOp (fsLit "readMutVar#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMutVarPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, levPolyAlphaTy]))+primOpInfo WriteMutVarOp = mkGenPrimOp (fsLit "writeMutVar#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMutVarPrimTy deltaTy levPolyAlphaTy, levPolyAlphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo AtomicModifyMutVar2Op = mkGenPrimOp (fsLit "atomicModifyMutVar2#")  [deltaTyVarSpec, alphaTyVarSpec, gammaTyVarSpec] [mkMutVarPrimTy deltaTy alphaTy, (mkVisFunTyMany (alphaTy) (gammaTy)), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy, gammaTy]))+primOpInfo AtomicModifyMutVar_Op = mkGenPrimOp (fsLit "atomicModifyMutVar_#")  [deltaTyVarSpec, alphaTyVarSpec] [mkMutVarPrimTy deltaTy alphaTy, (mkVisFunTyMany (alphaTy) (alphaTy)), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy, alphaTy]))+primOpInfo CasMutVarOp = mkGenPrimOp (fsLit "casMutVar#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMutVarPrimTy deltaTy levPolyAlphaTy, levPolyAlphaTy, levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, levPolyAlphaTy]))+primOpInfo CatchOp = mkGenPrimOp (fsLit "catch#")  [runtimeRep1TyVarInf, levity2TyVarInf, openAlphaTyVarSpec, levPolyBetaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openAlphaTy]))), (mkVisFunTyMany (levPolyBetaTy) ((mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openAlphaTy]))))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openAlphaTy]))+primOpInfo RaiseOp = mkGenPrimOp (fsLit "raise#")  [levity1TyVarInf, runtimeRep2TyVarInf, levPolyAlphaTyVarSpec, openBetaTyVarSpec] [levPolyAlphaTy] (openBetaTy)+primOpInfo RaiseIOOp = mkGenPrimOp (fsLit "raiseIO#")  [levity1TyVarInf, runtimeRep2TyVarInf, levPolyAlphaTyVarSpec, openBetaTyVarSpec] [levPolyAlphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openBetaTy]))+primOpInfo MaskAsyncExceptionsOp = mkGenPrimOp (fsLit "maskAsyncExceptions#")  [runtimeRep1TyVarInf, openAlphaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openAlphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openAlphaTy]))+primOpInfo MaskUninterruptibleOp = mkGenPrimOp (fsLit "maskUninterruptible#")  [runtimeRep1TyVarInf, openAlphaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openAlphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openAlphaTy]))+primOpInfo UnmaskAsyncExceptionsOp = mkGenPrimOp (fsLit "unmaskAsyncExceptions#")  [runtimeRep1TyVarInf, openAlphaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openAlphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openAlphaTy]))+primOpInfo MaskStatus = mkGenPrimOp (fsLit "getMaskingState#")  [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))+primOpInfo AtomicallyOp = mkGenPrimOp (fsLit "atomically#")  [levity1TyVarInf, levPolyAlphaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, levPolyAlphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, levPolyAlphaTy]))+primOpInfo RetryOp = mkGenPrimOp (fsLit "retry#")  [levity1TyVarInf, levPolyAlphaTyVarSpec] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, levPolyAlphaTy]))+primOpInfo CatchRetryOp = mkGenPrimOp (fsLit "catchRetry#")  [levity1TyVarInf, levPolyAlphaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, levPolyAlphaTy]))), (mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, levPolyAlphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, levPolyAlphaTy]))+primOpInfo CatchSTMOp = mkGenPrimOp (fsLit "catchSTM#")  [levity1TyVarInf, levPolyAlphaTyVarSpec, betaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, levPolyAlphaTy]))), (mkVisFunTyMany (betaTy) ((mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, levPolyAlphaTy]))))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, levPolyAlphaTy]))+primOpInfo NewTVarOp = mkGenPrimOp (fsLit "newTVar#")  [levity1TyVarInf, levPolyAlphaTyVarSpec, deltaTyVarSpec] [levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkTVarPrimTy deltaTy levPolyAlphaTy]))+primOpInfo ReadTVarOp = mkGenPrimOp (fsLit "readTVar#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkTVarPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, levPolyAlphaTy]))+primOpInfo ReadTVarIOOp = mkGenPrimOp (fsLit "readTVarIO#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkTVarPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, levPolyAlphaTy]))+primOpInfo WriteTVarOp = mkGenPrimOp (fsLit "writeTVar#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkTVarPrimTy deltaTy levPolyAlphaTy, levPolyAlphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo NewMVarOp = mkGenPrimOp (fsLit "newMVar#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMVarPrimTy deltaTy levPolyAlphaTy]))+primOpInfo TakeMVarOp = mkGenPrimOp (fsLit "takeMVar#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMVarPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, levPolyAlphaTy]))+primOpInfo TryTakeMVarOp = mkGenPrimOp (fsLit "tryTakeMVar#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMVarPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, levPolyAlphaTy]))+primOpInfo PutMVarOp = mkGenPrimOp (fsLit "putMVar#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMVarPrimTy deltaTy levPolyAlphaTy, levPolyAlphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo TryPutMVarOp = mkGenPrimOp (fsLit "tryPutMVar#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMVarPrimTy deltaTy levPolyAlphaTy, levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadMVarOp = mkGenPrimOp (fsLit "readMVar#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMVarPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, levPolyAlphaTy]))+primOpInfo TryReadMVarOp = mkGenPrimOp (fsLit "tryReadMVar#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMVarPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, levPolyAlphaTy]))+primOpInfo IsEmptyMVarOp = mkGenPrimOp (fsLit "isEmptyMVar#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMVarPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo NewIOPortOp = mkGenPrimOp (fsLit "newIOPort#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkIOPortPrimTy deltaTy levPolyAlphaTy]))+primOpInfo ReadIOPortOp = mkGenPrimOp (fsLit "readIOPort#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkIOPortPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, levPolyAlphaTy]))+primOpInfo WriteIOPortOp = mkGenPrimOp (fsLit "writeIOPort#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkIOPortPrimTy deltaTy levPolyAlphaTy, levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo DelayOp = mkGenPrimOp (fsLit "delay#")  [deltaTyVarSpec] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WaitReadOp = mkGenPrimOp (fsLit "waitRead#")  [deltaTyVarSpec] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WaitWriteOp = mkGenPrimOp (fsLit "waitWrite#")  [deltaTyVarSpec] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo ForkOp = mkGenPrimOp (fsLit "fork#")  [runtimeRep1TyVarInf, openAlphaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openAlphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, threadIdPrimTy]))+primOpInfo ForkOnOp = mkGenPrimOp (fsLit "forkOn#")  [runtimeRep1TyVarInf, openAlphaTyVarSpec] [intPrimTy, (mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openAlphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, threadIdPrimTy]))+primOpInfo KillThreadOp = mkGenPrimOp (fsLit "killThread#")  [alphaTyVarSpec] [threadIdPrimTy, alphaTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)+primOpInfo YieldOp = mkGenPrimOp (fsLit "yield#")  [] [mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)+primOpInfo MyThreadIdOp = mkGenPrimOp (fsLit "myThreadId#")  [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, threadIdPrimTy]))+primOpInfo LabelThreadOp = mkGenPrimOp (fsLit "labelThread#")  [] [threadIdPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)+primOpInfo IsCurrentThreadBoundOp = mkGenPrimOp (fsLit "isCurrentThreadBound#")  [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))+primOpInfo NoDuplicateOp = mkGenPrimOp (fsLit "noDuplicate#")  [deltaTyVarSpec] [mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo ThreadStatusOp = mkGenPrimOp (fsLit "threadStatus#")  [] [threadIdPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, intPrimTy, intPrimTy]))+primOpInfo MkWeakOp = mkGenPrimOp (fsLit "mkWeak#")  [levity1TyVarInf, levity2TyVarInf, levPolyAlphaTyVarSpec, levPolyBetaTyVarSpec, gammaTyVarSpec] [levPolyAlphaTy, levPolyBetaTy, (mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, gammaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkWeakPrimTy levPolyBetaTy]))+primOpInfo MkWeakNoFinalizerOp = mkGenPrimOp (fsLit "mkWeakNoFinalizer#")  [levity1TyVarInf, levity2TyVarInf, levPolyAlphaTyVarSpec, levPolyBetaTyVarSpec] [levPolyAlphaTy, levPolyBetaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkWeakPrimTy levPolyBetaTy]))+primOpInfo AddCFinalizerToWeakOp = mkGenPrimOp (fsLit "addCFinalizerToWeak#")  [levity2TyVarInf, levPolyBetaTyVarSpec] [addrPrimTy, addrPrimTy, intPrimTy, addrPrimTy, mkWeakPrimTy levPolyBetaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))+primOpInfo DeRefWeakOp = mkGenPrimOp (fsLit "deRefWeak#")  [levity1TyVarInf, levPolyAlphaTyVarSpec] [mkWeakPrimTy levPolyAlphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, levPolyAlphaTy]))+primOpInfo FinalizeWeakOp = mkGenPrimOp (fsLit "finalizeWeak#")  [levity1TyVarInf, levPolyAlphaTyVarSpec, betaTyVarSpec] [mkWeakPrimTy levPolyAlphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, (mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, betaTy])))]))+primOpInfo TouchOp = mkGenPrimOp (fsLit "touch#")  [levity1TyVarInf, levPolyAlphaTyVarSpec] [levPolyAlphaTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)+primOpInfo MakeStablePtrOp = mkGenPrimOp (fsLit "makeStablePtr#")  [levity1TyVarInf, levPolyAlphaTyVarSpec] [levPolyAlphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkStablePtrPrimTy levPolyAlphaTy]))+primOpInfo DeRefStablePtrOp = mkGenPrimOp (fsLit "deRefStablePtr#")  [levity1TyVarInf, levPolyAlphaTyVarSpec] [mkStablePtrPrimTy levPolyAlphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, levPolyAlphaTy]))+primOpInfo EqStablePtrOp = mkGenPrimOp (fsLit "eqStablePtr#")  [levity1TyVarInf, levPolyAlphaTyVarSpec] [mkStablePtrPrimTy levPolyAlphaTy, mkStablePtrPrimTy levPolyAlphaTy] (intPrimTy)+primOpInfo MakeStableNameOp = mkGenPrimOp (fsLit "makeStableName#")  [levity1TyVarInf, levPolyAlphaTyVarSpec] [levPolyAlphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkStableNamePrimTy levPolyAlphaTy]))+primOpInfo StableNameToIntOp = mkGenPrimOp (fsLit "stableNameToInt#")  [levity1TyVarInf, levPolyAlphaTyVarSpec] [mkStableNamePrimTy levPolyAlphaTy] (intPrimTy)+primOpInfo CompactNewOp = mkGenPrimOp (fsLit "compactNew#")  [] [wordPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, compactPrimTy]))+primOpInfo CompactResizeOp = mkGenPrimOp (fsLit "compactResize#")  [] [compactPrimTy, wordPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)+primOpInfo CompactContainsOp = mkGenPrimOp (fsLit "compactContains#")  [alphaTyVarSpec] [compactPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))+primOpInfo CompactContainsAnyOp = mkGenPrimOp (fsLit "compactContainsAny#")  [alphaTyVarSpec] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))+primOpInfo CompactGetFirstBlockOp = mkGenPrimOp (fsLit "compactGetFirstBlock#")  [] [compactPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy, wordPrimTy]))+primOpInfo CompactGetNextBlockOp = mkGenPrimOp (fsLit "compactGetNextBlock#")  [] [compactPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy, wordPrimTy]))+primOpInfo CompactAllocateBlockOp = mkGenPrimOp (fsLit "compactAllocateBlock#")  [] [wordPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy]))+primOpInfo CompactFixupPointersOp = mkGenPrimOp (fsLit "compactFixupPointers#")  [] [addrPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, compactPrimTy, addrPrimTy]))+primOpInfo CompactAdd = mkGenPrimOp (fsLit "compactAdd#")  [alphaTyVarSpec] [compactPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo CompactAddWithSharing = mkGenPrimOp (fsLit "compactAddWithSharing#")  [alphaTyVarSpec] [compactPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo CompactSize = mkGenPrimOp (fsLit "compactSize#")  [] [compactPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, wordPrimTy]))+primOpInfo ReallyUnsafePtrEqualityOp = mkGenPrimOp (fsLit "reallyUnsafePtrEquality#")  [levity1TyVarInf, levity2TyVarInf, levPolyAlphaTyVarSpec, levPolyBetaTyVarSpec] [levPolyAlphaTy, levPolyBetaTy] (intPrimTy)+primOpInfo ParOp = mkGenPrimOp (fsLit "par#")  [alphaTyVarSpec] [alphaTy] (intPrimTy)+primOpInfo SparkOp = mkGenPrimOp (fsLit "spark#")  [alphaTyVarSpec, deltaTyVarSpec] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))+primOpInfo SeqOp = mkGenPrimOp (fsLit "seq#")  [alphaTyVarSpec, deltaTyVarSpec] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))+primOpInfo GetSparkOp = mkGenPrimOp (fsLit "getSpark#")  [deltaTyVarSpec, alphaTyVarSpec] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))+primOpInfo NumSparks = mkGenPrimOp (fsLit "numSparks#")  [deltaTyVarSpec] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo KeepAliveOp = mkGenPrimOp (fsLit "keepAlive#")  [levity1TyVarInf, runtimeRep2TyVarInf, levPolyAlphaTyVarSpec, openBetaTyVarSpec] [levPolyAlphaTy, mkStatePrimTy realWorldTy, (mkVisFunTyMany (mkStatePrimTy realWorldTy) (openBetaTy))] (openBetaTy)+primOpInfo DataToTagOp = mkGenPrimOp (fsLit "dataToTag#")  [alphaTyVarSpec] [alphaTy] (intPrimTy)+primOpInfo TagToEnumOp = mkGenPrimOp (fsLit "tagToEnum#")  [alphaTyVarSpec] [intPrimTy] (alphaTy)+primOpInfo AddrToAnyOp = mkGenPrimOp (fsLit "addrToAny#")  [alphaTyVarSpec] [addrPrimTy] ((mkTupleTy Unboxed [alphaTy]))+primOpInfo AnyToAddrOp = mkGenPrimOp (fsLit "anyToAddr#")  [alphaTyVarSpec] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy]))+primOpInfo MkApUpd0_Op = mkGenPrimOp (fsLit "mkApUpd0#")  [alphaTyVarSpec] [bcoPrimTy] ((mkTupleTy Unboxed [alphaTy]))+primOpInfo NewBCOOp = mkGenPrimOp (fsLit "newBCO#")  [alphaTyVarSpec, deltaTyVarSpec] [byteArrayPrimTy, byteArrayPrimTy, mkArrayPrimTy alphaTy, intPrimTy, byteArrayPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, bcoPrimTy]))+primOpInfo UnpackClosureOp = mkGenPrimOp (fsLit "unpackClosure#")  [alphaTyVarSpec, betaTyVarSpec] [alphaTy] ((mkTupleTy Unboxed [addrPrimTy, byteArrayPrimTy, mkArrayPrimTy betaTy]))+primOpInfo ClosureSizeOp = mkGenPrimOp (fsLit "closureSize#")  [alphaTyVarSpec] [alphaTy] (intPrimTy)+primOpInfo GetApStackValOp = mkGenPrimOp (fsLit "getApStackVal#")  [alphaTyVarSpec, betaTyVarSpec] [alphaTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, betaTy]))+primOpInfo GetCCSOfOp = mkGenPrimOp (fsLit "getCCSOf#")  [alphaTyVarSpec, deltaTyVarSpec] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))+primOpInfo GetCurrentCCSOp = mkGenPrimOp (fsLit "getCurrentCCS#")  [alphaTyVarSpec, deltaTyVarSpec] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))+primOpInfo ClearCCSOp = mkGenPrimOp (fsLit "clearCCS#")  [deltaTyVarSpec, alphaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy deltaTy) ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))+primOpInfo WhereFromOp = mkGenPrimOp (fsLit "whereFrom#")  [alphaTyVarSpec, deltaTyVarSpec] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))+primOpInfo TraceEventOp = mkGenPrimOp (fsLit "traceEvent#")  [deltaTyVarSpec] [addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo TraceEventBinaryOp = mkGenPrimOp (fsLit "traceBinaryEvent#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo TraceMarkerOp = mkGenPrimOp (fsLit "traceMarker#")  [deltaTyVarSpec] [addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo SetThreadAllocationCounter = mkGenPrimOp (fsLit "setThreadAllocationCounter#")  [] [int64PrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)+primOpInfo (VecBroadcastOp IntVec 16 W8) = mkGenPrimOp (fsLit "broadcastInt8X16#")  [] [int8PrimTy] (int8X16PrimTy)+primOpInfo (VecBroadcastOp IntVec 8 W16) = mkGenPrimOp (fsLit "broadcastInt16X8#")  [] [int16PrimTy] (int16X8PrimTy)+primOpInfo (VecBroadcastOp IntVec 4 W32) = mkGenPrimOp (fsLit "broadcastInt32X4#")  [] [int32PrimTy] (int32X4PrimTy)+primOpInfo (VecBroadcastOp IntVec 2 W64) = mkGenPrimOp (fsLit "broadcastInt64X2#")  [] [int64PrimTy] (int64X2PrimTy)+primOpInfo (VecBroadcastOp IntVec 32 W8) = mkGenPrimOp (fsLit "broadcastInt8X32#")  [] [int8PrimTy] (int8X32PrimTy)+primOpInfo (VecBroadcastOp IntVec 16 W16) = mkGenPrimOp (fsLit "broadcastInt16X16#")  [] [int16PrimTy] (int16X16PrimTy)+primOpInfo (VecBroadcastOp IntVec 8 W32) = mkGenPrimOp (fsLit "broadcastInt32X8#")  [] [int32PrimTy] (int32X8PrimTy)+primOpInfo (VecBroadcastOp IntVec 4 W64) = mkGenPrimOp (fsLit "broadcastInt64X4#")  [] [int64PrimTy] (int64X4PrimTy)+primOpInfo (VecBroadcastOp IntVec 64 W8) = mkGenPrimOp (fsLit "broadcastInt8X64#")  [] [int8PrimTy] (int8X64PrimTy)+primOpInfo (VecBroadcastOp IntVec 32 W16) = mkGenPrimOp (fsLit "broadcastInt16X32#")  [] [int16PrimTy] (int16X32PrimTy)+primOpInfo (VecBroadcastOp IntVec 16 W32) = mkGenPrimOp (fsLit "broadcastInt32X16#")  [] [int32PrimTy] (int32X16PrimTy)+primOpInfo (VecBroadcastOp IntVec 8 W64) = mkGenPrimOp (fsLit "broadcastInt64X8#")  [] [int64PrimTy] (int64X8PrimTy)+primOpInfo (VecBroadcastOp WordVec 16 W8) = mkGenPrimOp (fsLit "broadcastWord8X16#")  [] [wordPrimTy] (word8X16PrimTy)+primOpInfo (VecBroadcastOp WordVec 8 W16) = mkGenPrimOp (fsLit "broadcastWord16X8#")  [] [wordPrimTy] (word16X8PrimTy)+primOpInfo (VecBroadcastOp WordVec 4 W32) = mkGenPrimOp (fsLit "broadcastWord32X4#")  [] [word32PrimTy] (word32X4PrimTy)+primOpInfo (VecBroadcastOp WordVec 2 W64) = mkGenPrimOp (fsLit "broadcastWord64X2#")  [] [word64PrimTy] (word64X2PrimTy)+primOpInfo (VecBroadcastOp WordVec 32 W8) = mkGenPrimOp (fsLit "broadcastWord8X32#")  [] [wordPrimTy] (word8X32PrimTy)+primOpInfo (VecBroadcastOp WordVec 16 W16) = mkGenPrimOp (fsLit "broadcastWord16X16#")  [] [wordPrimTy] (word16X16PrimTy)+primOpInfo (VecBroadcastOp WordVec 8 W32) = mkGenPrimOp (fsLit "broadcastWord32X8#")  [] [word32PrimTy] (word32X8PrimTy)+primOpInfo (VecBroadcastOp WordVec 4 W64) = mkGenPrimOp (fsLit "broadcastWord64X4#")  [] [word64PrimTy] (word64X4PrimTy)+primOpInfo (VecBroadcastOp WordVec 64 W8) = mkGenPrimOp (fsLit "broadcastWord8X64#")  [] [wordPrimTy] (word8X64PrimTy)+primOpInfo (VecBroadcastOp WordVec 32 W16) = mkGenPrimOp (fsLit "broadcastWord16X32#")  [] [wordPrimTy] (word16X32PrimTy)+primOpInfo (VecBroadcastOp WordVec 16 W32) = mkGenPrimOp (fsLit "broadcastWord32X16#")  [] [word32PrimTy] (word32X16PrimTy)+primOpInfo (VecBroadcastOp WordVec 8 W64) = mkGenPrimOp (fsLit "broadcastWord64X8#")  [] [word64PrimTy] (word64X8PrimTy)+primOpInfo (VecBroadcastOp FloatVec 4 W32) = mkGenPrimOp (fsLit "broadcastFloatX4#")  [] [floatPrimTy] (floatX4PrimTy)+primOpInfo (VecBroadcastOp FloatVec 2 W64) = mkGenPrimOp (fsLit "broadcastDoubleX2#")  [] [doublePrimTy] (doubleX2PrimTy)+primOpInfo (VecBroadcastOp FloatVec 8 W32) = mkGenPrimOp (fsLit "broadcastFloatX8#")  [] [floatPrimTy] (floatX8PrimTy)+primOpInfo (VecBroadcastOp FloatVec 4 W64) = mkGenPrimOp (fsLit "broadcastDoubleX4#")  [] [doublePrimTy] (doubleX4PrimTy)+primOpInfo (VecBroadcastOp FloatVec 16 W32) = mkGenPrimOp (fsLit "broadcastFloatX16#")  [] [floatPrimTy] (floatX16PrimTy)+primOpInfo (VecBroadcastOp FloatVec 8 W64) = mkGenPrimOp (fsLit "broadcastDoubleX8#")  [] [doublePrimTy] (doubleX8PrimTy)+primOpInfo (VecPackOp IntVec 16 W8) = mkGenPrimOp (fsLit "packInt8X16#")  [] [(mkTupleTy Unboxed [int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy])] (int8X16PrimTy)+primOpInfo (VecPackOp IntVec 8 W16) = mkGenPrimOp (fsLit "packInt16X8#")  [] [(mkTupleTy Unboxed [int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy])] (int16X8PrimTy)+primOpInfo (VecPackOp IntVec 4 W32) = mkGenPrimOp (fsLit "packInt32X4#")  [] [(mkTupleTy Unboxed [int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy])] (int32X4PrimTy)+primOpInfo (VecPackOp IntVec 2 W64) = mkGenPrimOp (fsLit "packInt64X2#")  [] [(mkTupleTy Unboxed [int64PrimTy, int64PrimTy])] (int64X2PrimTy)+primOpInfo (VecPackOp IntVec 32 W8) = mkGenPrimOp (fsLit "packInt8X32#")  [] [(mkTupleTy Unboxed [int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy])] (int8X32PrimTy)+primOpInfo (VecPackOp IntVec 16 W16) = mkGenPrimOp (fsLit "packInt16X16#")  [] [(mkTupleTy Unboxed [int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy])] (int16X16PrimTy)+primOpInfo (VecPackOp IntVec 8 W32) = mkGenPrimOp (fsLit "packInt32X8#")  [] [(mkTupleTy Unboxed [int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy])] (int32X8PrimTy)+primOpInfo (VecPackOp IntVec 4 W64) = mkGenPrimOp (fsLit "packInt64X4#")  [] [(mkTupleTy Unboxed [int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy])] (int64X4PrimTy)+primOpInfo (VecPackOp IntVec 64 W8) = mkGenPrimOp (fsLit "packInt8X64#")  [] [(mkTupleTy Unboxed [int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy])] (int8X64PrimTy)+primOpInfo (VecPackOp IntVec 32 W16) = mkGenPrimOp (fsLit "packInt16X32#")  [] [(mkTupleTy Unboxed [int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy])] (int16X32PrimTy)+primOpInfo (VecPackOp IntVec 16 W32) = mkGenPrimOp (fsLit "packInt32X16#")  [] [(mkTupleTy Unboxed [int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy])] (int32X16PrimTy)+primOpInfo (VecPackOp IntVec 8 W64) = mkGenPrimOp (fsLit "packInt64X8#")  [] [(mkTupleTy Unboxed [int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy])] (int64X8PrimTy)+primOpInfo (VecPackOp WordVec 16 W8) = mkGenPrimOp (fsLit "packWord8X16#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word8X16PrimTy)+primOpInfo (VecPackOp WordVec 8 W16) = mkGenPrimOp (fsLit "packWord16X8#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word16X8PrimTy)+primOpInfo (VecPackOp WordVec 4 W32) = mkGenPrimOp (fsLit "packWord32X4#")  [] [(mkTupleTy Unboxed [word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy])] (word32X4PrimTy)+primOpInfo (VecPackOp WordVec 2 W64) = mkGenPrimOp (fsLit "packWord64X2#")  [] [(mkTupleTy Unboxed [word64PrimTy, word64PrimTy])] (word64X2PrimTy)+primOpInfo (VecPackOp WordVec 32 W8) = mkGenPrimOp (fsLit "packWord8X32#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word8X32PrimTy)+primOpInfo (VecPackOp WordVec 16 W16) = mkGenPrimOp (fsLit "packWord16X16#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word16X16PrimTy)+primOpInfo (VecPackOp WordVec 8 W32) = mkGenPrimOp (fsLit "packWord32X8#")  [] [(mkTupleTy Unboxed [word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy])] (word32X8PrimTy)+primOpInfo (VecPackOp WordVec 4 W64) = mkGenPrimOp (fsLit "packWord64X4#")  [] [(mkTupleTy Unboxed [word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy])] (word64X4PrimTy)+primOpInfo (VecPackOp WordVec 64 W8) = mkGenPrimOp (fsLit "packWord8X64#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word8X64PrimTy)+primOpInfo (VecPackOp WordVec 32 W16) = mkGenPrimOp (fsLit "packWord16X32#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word16X32PrimTy)+primOpInfo (VecPackOp WordVec 16 W32) = mkGenPrimOp (fsLit "packWord32X16#")  [] [(mkTupleTy Unboxed [word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy])] (word32X16PrimTy)+primOpInfo (VecPackOp WordVec 8 W64) = mkGenPrimOp (fsLit "packWord64X8#")  [] [(mkTupleTy Unboxed [word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy])] (word64X8PrimTy)+primOpInfo (VecPackOp FloatVec 4 W32) = mkGenPrimOp (fsLit "packFloatX4#")  [] [(mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])] (floatX4PrimTy)+primOpInfo (VecPackOp FloatVec 2 W64) = mkGenPrimOp (fsLit "packDoubleX2#")  [] [(mkTupleTy Unboxed [doublePrimTy, doublePrimTy])] (doubleX2PrimTy)+primOpInfo (VecPackOp FloatVec 8 W32) = mkGenPrimOp (fsLit "packFloatX8#")  [] [(mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])] (floatX8PrimTy)+primOpInfo (VecPackOp FloatVec 4 W64) = mkGenPrimOp (fsLit "packDoubleX4#")  [] [(mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy])] (doubleX4PrimTy)+primOpInfo (VecPackOp FloatVec 16 W32) = mkGenPrimOp (fsLit "packFloatX16#")  [] [(mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])] (floatX16PrimTy)+primOpInfo (VecPackOp FloatVec 8 W64) = mkGenPrimOp (fsLit "packDoubleX8#")  [] [(mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy])] (doubleX8PrimTy)+primOpInfo (VecUnpackOp IntVec 16 W8) = mkGenPrimOp (fsLit "unpackInt8X16#")  [] [int8X16PrimTy] ((mkTupleTy Unboxed [int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy]))+primOpInfo (VecUnpackOp IntVec 8 W16) = mkGenPrimOp (fsLit "unpackInt16X8#")  [] [int16X8PrimTy] ((mkTupleTy Unboxed [int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy]))+primOpInfo (VecUnpackOp IntVec 4 W32) = mkGenPrimOp (fsLit "unpackInt32X4#")  [] [int32X4PrimTy] ((mkTupleTy Unboxed [int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy]))+primOpInfo (VecUnpackOp IntVec 2 W64) = mkGenPrimOp (fsLit "unpackInt64X2#")  [] [int64X2PrimTy] ((mkTupleTy Unboxed [int64PrimTy, int64PrimTy]))+primOpInfo (VecUnpackOp IntVec 32 W8) = mkGenPrimOp (fsLit "unpackInt8X32#")  [] [int8X32PrimTy] ((mkTupleTy Unboxed [int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy]))+primOpInfo (VecUnpackOp IntVec 16 W16) = mkGenPrimOp (fsLit "unpackInt16X16#")  [] [int16X16PrimTy] ((mkTupleTy Unboxed [int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy]))+primOpInfo (VecUnpackOp IntVec 8 W32) = mkGenPrimOp (fsLit "unpackInt32X8#")  [] [int32X8PrimTy] ((mkTupleTy Unboxed [int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy]))+primOpInfo (VecUnpackOp IntVec 4 W64) = mkGenPrimOp (fsLit "unpackInt64X4#")  [] [int64X4PrimTy] ((mkTupleTy Unboxed [int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy]))+primOpInfo (VecUnpackOp IntVec 64 W8) = mkGenPrimOp (fsLit "unpackInt8X64#")  [] [int8X64PrimTy] ((mkTupleTy Unboxed [int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy]))+primOpInfo (VecUnpackOp IntVec 32 W16) = mkGenPrimOp (fsLit "unpackInt16X32#")  [] [int16X32PrimTy] ((mkTupleTy Unboxed [int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy]))+primOpInfo (VecUnpackOp IntVec 16 W32) = mkGenPrimOp (fsLit "unpackInt32X16#")  [] [int32X16PrimTy] ((mkTupleTy Unboxed [int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy]))+primOpInfo (VecUnpackOp IntVec 8 W64) = mkGenPrimOp (fsLit "unpackInt64X8#")  [] [int64X8PrimTy] ((mkTupleTy Unboxed [int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy]))+primOpInfo (VecUnpackOp WordVec 16 W8) = mkGenPrimOp (fsLit "unpackWord8X16#")  [] [word8X16PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))+primOpInfo (VecUnpackOp WordVec 8 W16) = mkGenPrimOp (fsLit "unpackWord16X8#")  [] [word16X8PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))+primOpInfo (VecUnpackOp WordVec 4 W32) = mkGenPrimOp (fsLit "unpackWord32X4#")  [] [word32X4PrimTy] ((mkTupleTy Unboxed [word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy]))+primOpInfo (VecUnpackOp WordVec 2 W64) = mkGenPrimOp (fsLit "unpackWord64X2#")  [] [word64X2PrimTy] ((mkTupleTy Unboxed [word64PrimTy, word64PrimTy]))+primOpInfo (VecUnpackOp WordVec 32 W8) = mkGenPrimOp (fsLit "unpackWord8X32#")  [] [word8X32PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))+primOpInfo (VecUnpackOp WordVec 16 W16) = mkGenPrimOp (fsLit "unpackWord16X16#")  [] [word16X16PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))+primOpInfo (VecUnpackOp WordVec 8 W32) = mkGenPrimOp (fsLit "unpackWord32X8#")  [] [word32X8PrimTy] ((mkTupleTy Unboxed [word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy]))+primOpInfo (VecUnpackOp WordVec 4 W64) = mkGenPrimOp (fsLit "unpackWord64X4#")  [] [word64X4PrimTy] ((mkTupleTy Unboxed [word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy]))+primOpInfo (VecUnpackOp WordVec 64 W8) = mkGenPrimOp (fsLit "unpackWord8X64#")  [] [word8X64PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))+primOpInfo (VecUnpackOp WordVec 32 W16) = mkGenPrimOp (fsLit "unpackWord16X32#")  [] [word16X32PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))+primOpInfo (VecUnpackOp WordVec 16 W32) = mkGenPrimOp (fsLit "unpackWord32X16#")  [] [word32X16PrimTy] ((mkTupleTy Unboxed [word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy]))+primOpInfo (VecUnpackOp WordVec 8 W64) = mkGenPrimOp (fsLit "unpackWord64X8#")  [] [word64X8PrimTy] ((mkTupleTy Unboxed [word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy]))+primOpInfo (VecUnpackOp FloatVec 4 W32) = mkGenPrimOp (fsLit "unpackFloatX4#")  [] [floatX4PrimTy] ((mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy]))+primOpInfo (VecUnpackOp FloatVec 2 W64) = mkGenPrimOp (fsLit "unpackDoubleX2#")  [] [doubleX2PrimTy] ((mkTupleTy Unboxed [doublePrimTy, doublePrimTy]))+primOpInfo (VecUnpackOp FloatVec 8 W32) = mkGenPrimOp (fsLit "unpackFloatX8#")  [] [floatX8PrimTy] ((mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy]))+primOpInfo (VecUnpackOp FloatVec 4 W64) = mkGenPrimOp (fsLit "unpackDoubleX4#")  [] [doubleX4PrimTy] ((mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy]))+primOpInfo (VecUnpackOp FloatVec 16 W32) = mkGenPrimOp (fsLit "unpackFloatX16#")  [] [floatX16PrimTy] ((mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy]))+primOpInfo (VecUnpackOp FloatVec 8 W64) = mkGenPrimOp (fsLit "unpackDoubleX8#")  [] [doubleX8PrimTy] ((mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy]))+primOpInfo (VecInsertOp IntVec 16 W8) = mkGenPrimOp (fsLit "insertInt8X16#")  [] [int8X16PrimTy, int8PrimTy, intPrimTy] (int8X16PrimTy)+primOpInfo (VecInsertOp IntVec 8 W16) = mkGenPrimOp (fsLit "insertInt16X8#")  [] [int16X8PrimTy, int16PrimTy, intPrimTy] (int16X8PrimTy)+primOpInfo (VecInsertOp IntVec 4 W32) = mkGenPrimOp (fsLit "insertInt32X4#")  [] [int32X4PrimTy, int32PrimTy, intPrimTy] (int32X4PrimTy)+primOpInfo (VecInsertOp IntVec 2 W64) = mkGenPrimOp (fsLit "insertInt64X2#")  [] [int64X2PrimTy, int64PrimTy, intPrimTy] (int64X2PrimTy)+primOpInfo (VecInsertOp IntVec 32 W8) = mkGenPrimOp (fsLit "insertInt8X32#")  [] [int8X32PrimTy, int8PrimTy, intPrimTy] (int8X32PrimTy)+primOpInfo (VecInsertOp IntVec 16 W16) = mkGenPrimOp (fsLit "insertInt16X16#")  [] [int16X16PrimTy, int16PrimTy, intPrimTy] (int16X16PrimTy)+primOpInfo (VecInsertOp IntVec 8 W32) = mkGenPrimOp (fsLit "insertInt32X8#")  [] [int32X8PrimTy, int32PrimTy, intPrimTy] (int32X8PrimTy)+primOpInfo (VecInsertOp IntVec 4 W64) = mkGenPrimOp (fsLit "insertInt64X4#")  [] [int64X4PrimTy, int64PrimTy, intPrimTy] (int64X4PrimTy)+primOpInfo (VecInsertOp IntVec 64 W8) = mkGenPrimOp (fsLit "insertInt8X64#")  [] [int8X64PrimTy, int8PrimTy, intPrimTy] (int8X64PrimTy)+primOpInfo (VecInsertOp IntVec 32 W16) = mkGenPrimOp (fsLit "insertInt16X32#")  [] [int16X32PrimTy, int16PrimTy, intPrimTy] (int16X32PrimTy)+primOpInfo (VecInsertOp IntVec 16 W32) = mkGenPrimOp (fsLit "insertInt32X16#")  [] [int32X16PrimTy, int32PrimTy, intPrimTy] (int32X16PrimTy)+primOpInfo (VecInsertOp IntVec 8 W64) = mkGenPrimOp (fsLit "insertInt64X8#")  [] [int64X8PrimTy, int64PrimTy, intPrimTy] (int64X8PrimTy)+primOpInfo (VecInsertOp WordVec 16 W8) = mkGenPrimOp (fsLit "insertWord8X16#")  [] [word8X16PrimTy, wordPrimTy, intPrimTy] (word8X16PrimTy)+primOpInfo (VecInsertOp WordVec 8 W16) = mkGenPrimOp (fsLit "insertWord16X8#")  [] [word16X8PrimTy, wordPrimTy, intPrimTy] (word16X8PrimTy)+primOpInfo (VecInsertOp WordVec 4 W32) = mkGenPrimOp (fsLit "insertWord32X4#")  [] [word32X4PrimTy, word32PrimTy, intPrimTy] (word32X4PrimTy)+primOpInfo (VecInsertOp WordVec 2 W64) = mkGenPrimOp (fsLit "insertWord64X2#")  [] [word64X2PrimTy, word64PrimTy, intPrimTy] (word64X2PrimTy)+primOpInfo (VecInsertOp WordVec 32 W8) = mkGenPrimOp (fsLit "insertWord8X32#")  [] [word8X32PrimTy, wordPrimTy, intPrimTy] (word8X32PrimTy)+primOpInfo (VecInsertOp WordVec 16 W16) = mkGenPrimOp (fsLit "insertWord16X16#")  [] [word16X16PrimTy, wordPrimTy, intPrimTy] (word16X16PrimTy)+primOpInfo (VecInsertOp WordVec 8 W32) = mkGenPrimOp (fsLit "insertWord32X8#")  [] [word32X8PrimTy, word32PrimTy, intPrimTy] (word32X8PrimTy)+primOpInfo (VecInsertOp WordVec 4 W64) = mkGenPrimOp (fsLit "insertWord64X4#")  [] [word64X4PrimTy, word64PrimTy, intPrimTy] (word64X4PrimTy)+primOpInfo (VecInsertOp WordVec 64 W8) = mkGenPrimOp (fsLit "insertWord8X64#")  [] [word8X64PrimTy, wordPrimTy, intPrimTy] (word8X64PrimTy)+primOpInfo (VecInsertOp WordVec 32 W16) = mkGenPrimOp (fsLit "insertWord16X32#")  [] [word16X32PrimTy, wordPrimTy, intPrimTy] (word16X32PrimTy)+primOpInfo (VecInsertOp WordVec 16 W32) = mkGenPrimOp (fsLit "insertWord32X16#")  [] [word32X16PrimTy, word32PrimTy, intPrimTy] (word32X16PrimTy)+primOpInfo (VecInsertOp WordVec 8 W64) = mkGenPrimOp (fsLit "insertWord64X8#")  [] [word64X8PrimTy, word64PrimTy, intPrimTy] (word64X8PrimTy)+primOpInfo (VecInsertOp FloatVec 4 W32) = mkGenPrimOp (fsLit "insertFloatX4#")  [] [floatX4PrimTy, floatPrimTy, intPrimTy] (floatX4PrimTy)+primOpInfo (VecInsertOp FloatVec 2 W64) = mkGenPrimOp (fsLit "insertDoubleX2#")  [] [doubleX2PrimTy, doublePrimTy, intPrimTy] (doubleX2PrimTy)+primOpInfo (VecInsertOp FloatVec 8 W32) = mkGenPrimOp (fsLit "insertFloatX8#")  [] [floatX8PrimTy, floatPrimTy, intPrimTy] (floatX8PrimTy)+primOpInfo (VecInsertOp FloatVec 4 W64) = mkGenPrimOp (fsLit "insertDoubleX4#")  [] [doubleX4PrimTy, doublePrimTy, intPrimTy] (doubleX4PrimTy)+primOpInfo (VecInsertOp FloatVec 16 W32) = mkGenPrimOp (fsLit "insertFloatX16#")  [] [floatX16PrimTy, floatPrimTy, intPrimTy] (floatX16PrimTy)+primOpInfo (VecInsertOp FloatVec 8 W64) = mkGenPrimOp (fsLit "insertDoubleX8#")  [] [doubleX8PrimTy, doublePrimTy, intPrimTy] (doubleX8PrimTy)+primOpInfo (VecAddOp IntVec 16 W8) = mkGenPrimOp (fsLit "plusInt8X16#")  [] [int8X16PrimTy, int8X16PrimTy] (int8X16PrimTy)+primOpInfo (VecAddOp IntVec 8 W16) = mkGenPrimOp (fsLit "plusInt16X8#")  [] [int16X8PrimTy, int16X8PrimTy] (int16X8PrimTy)+primOpInfo (VecAddOp IntVec 4 W32) = mkGenPrimOp (fsLit "plusInt32X4#")  [] [int32X4PrimTy, int32X4PrimTy] (int32X4PrimTy)+primOpInfo (VecAddOp IntVec 2 W64) = mkGenPrimOp (fsLit "plusInt64X2#")  [] [int64X2PrimTy, int64X2PrimTy] (int64X2PrimTy)+primOpInfo (VecAddOp IntVec 32 W8) = mkGenPrimOp (fsLit "plusInt8X32#")  [] [int8X32PrimTy, int8X32PrimTy] (int8X32PrimTy)+primOpInfo (VecAddOp IntVec 16 W16) = mkGenPrimOp (fsLit "plusInt16X16#")  [] [int16X16PrimTy, int16X16PrimTy] (int16X16PrimTy)+primOpInfo (VecAddOp IntVec 8 W32) = mkGenPrimOp (fsLit "plusInt32X8#")  [] [int32X8PrimTy, int32X8PrimTy] (int32X8PrimTy)+primOpInfo (VecAddOp IntVec 4 W64) = mkGenPrimOp (fsLit "plusInt64X4#")  [] [int64X4PrimTy, int64X4PrimTy] (int64X4PrimTy)+primOpInfo (VecAddOp IntVec 64 W8) = mkGenPrimOp (fsLit "plusInt8X64#")  [] [int8X64PrimTy, int8X64PrimTy] (int8X64PrimTy)+primOpInfo (VecAddOp IntVec 32 W16) = mkGenPrimOp (fsLit "plusInt16X32#")  [] [int16X32PrimTy, int16X32PrimTy] (int16X32PrimTy)+primOpInfo (VecAddOp IntVec 16 W32) = mkGenPrimOp (fsLit "plusInt32X16#")  [] [int32X16PrimTy, int32X16PrimTy] (int32X16PrimTy)+primOpInfo (VecAddOp IntVec 8 W64) = mkGenPrimOp (fsLit "plusInt64X8#")  [] [int64X8PrimTy, int64X8PrimTy] (int64X8PrimTy)+primOpInfo (VecAddOp WordVec 16 W8) = mkGenPrimOp (fsLit "plusWord8X16#")  [] [word8X16PrimTy, word8X16PrimTy] (word8X16PrimTy)+primOpInfo (VecAddOp WordVec 8 W16) = mkGenPrimOp (fsLit "plusWord16X8#")  [] [word16X8PrimTy, word16X8PrimTy] (word16X8PrimTy)+primOpInfo (VecAddOp WordVec 4 W32) = mkGenPrimOp (fsLit "plusWord32X4#")  [] [word32X4PrimTy, word32X4PrimTy] (word32X4PrimTy)+primOpInfo (VecAddOp WordVec 2 W64) = mkGenPrimOp (fsLit "plusWord64X2#")  [] [word64X2PrimTy, word64X2PrimTy] (word64X2PrimTy)+primOpInfo (VecAddOp WordVec 32 W8) = mkGenPrimOp (fsLit "plusWord8X32#")  [] [word8X32PrimTy, word8X32PrimTy] (word8X32PrimTy)+primOpInfo (VecAddOp WordVec 16 W16) = mkGenPrimOp (fsLit "plusWord16X16#")  [] [word16X16PrimTy, word16X16PrimTy] (word16X16PrimTy)+primOpInfo (VecAddOp WordVec 8 W32) = mkGenPrimOp (fsLit "plusWord32X8#")  [] [word32X8PrimTy, word32X8PrimTy] (word32X8PrimTy)+primOpInfo (VecAddOp WordVec 4 W64) = mkGenPrimOp (fsLit "plusWord64X4#")  [] [word64X4PrimTy, word64X4PrimTy] (word64X4PrimTy)+primOpInfo (VecAddOp WordVec 64 W8) = mkGenPrimOp (fsLit "plusWord8X64#")  [] [word8X64PrimTy, word8X64PrimTy] (word8X64PrimTy)+primOpInfo (VecAddOp WordVec 32 W16) = mkGenPrimOp (fsLit "plusWord16X32#")  [] [word16X32PrimTy, word16X32PrimTy] (word16X32PrimTy)+primOpInfo (VecAddOp WordVec 16 W32) = mkGenPrimOp (fsLit "plusWord32X16#")  [] [word32X16PrimTy, word32X16PrimTy] (word32X16PrimTy)+primOpInfo (VecAddOp WordVec 8 W64) = mkGenPrimOp (fsLit "plusWord64X8#")  [] [word64X8PrimTy, word64X8PrimTy] (word64X8PrimTy)+primOpInfo (VecAddOp FloatVec 4 W32) = mkGenPrimOp (fsLit "plusFloatX4#")  [] [floatX4PrimTy, floatX4PrimTy] (floatX4PrimTy)+primOpInfo (VecAddOp FloatVec 2 W64) = mkGenPrimOp (fsLit "plusDoubleX2#")  [] [doubleX2PrimTy, doubleX2PrimTy] (doubleX2PrimTy)+primOpInfo (VecAddOp FloatVec 8 W32) = mkGenPrimOp (fsLit "plusFloatX8#")  [] [floatX8PrimTy, floatX8PrimTy] (floatX8PrimTy)+primOpInfo (VecAddOp FloatVec 4 W64) = mkGenPrimOp (fsLit "plusDoubleX4#")  [] [doubleX4PrimTy, doubleX4PrimTy] (doubleX4PrimTy)+primOpInfo (VecAddOp FloatVec 16 W32) = mkGenPrimOp (fsLit "plusFloatX16#")  [] [floatX16PrimTy, floatX16PrimTy] (floatX16PrimTy)+primOpInfo (VecAddOp FloatVec 8 W64) = mkGenPrimOp (fsLit "plusDoubleX8#")  [] [doubleX8PrimTy, doubleX8PrimTy] (doubleX8PrimTy)+primOpInfo (VecSubOp IntVec 16 W8) = mkGenPrimOp (fsLit "minusInt8X16#")  [] [int8X16PrimTy, int8X16PrimTy] (int8X16PrimTy)+primOpInfo (VecSubOp IntVec 8 W16) = mkGenPrimOp (fsLit "minusInt16X8#")  [] [int16X8PrimTy, int16X8PrimTy] (int16X8PrimTy)+primOpInfo (VecSubOp IntVec 4 W32) = mkGenPrimOp (fsLit "minusInt32X4#")  [] [int32X4PrimTy, int32X4PrimTy] (int32X4PrimTy)+primOpInfo (VecSubOp IntVec 2 W64) = mkGenPrimOp (fsLit "minusInt64X2#")  [] [int64X2PrimTy, int64X2PrimTy] (int64X2PrimTy)+primOpInfo (VecSubOp IntVec 32 W8) = mkGenPrimOp (fsLit "minusInt8X32#")  [] [int8X32PrimTy, int8X32PrimTy] (int8X32PrimTy)+primOpInfo (VecSubOp IntVec 16 W16) = mkGenPrimOp (fsLit "minusInt16X16#")  [] [int16X16PrimTy, int16X16PrimTy] (int16X16PrimTy)+primOpInfo (VecSubOp IntVec 8 W32) = mkGenPrimOp (fsLit "minusInt32X8#")  [] [int32X8PrimTy, int32X8PrimTy] (int32X8PrimTy)+primOpInfo (VecSubOp IntVec 4 W64) = mkGenPrimOp (fsLit "minusInt64X4#")  [] [int64X4PrimTy, int64X4PrimTy] (int64X4PrimTy)+primOpInfo (VecSubOp IntVec 64 W8) = mkGenPrimOp (fsLit "minusInt8X64#")  [] [int8X64PrimTy, int8X64PrimTy] (int8X64PrimTy)+primOpInfo (VecSubOp IntVec 32 W16) = mkGenPrimOp (fsLit "minusInt16X32#")  [] [int16X32PrimTy, int16X32PrimTy] (int16X32PrimTy)+primOpInfo (VecSubOp IntVec 16 W32) = mkGenPrimOp (fsLit "minusInt32X16#")  [] [int32X16PrimTy, int32X16PrimTy] (int32X16PrimTy)+primOpInfo (VecSubOp IntVec 8 W64) = mkGenPrimOp (fsLit "minusInt64X8#")  [] [int64X8PrimTy, int64X8PrimTy] (int64X8PrimTy)+primOpInfo (VecSubOp WordVec 16 W8) = mkGenPrimOp (fsLit "minusWord8X16#")  [] [word8X16PrimTy, word8X16PrimTy] (word8X16PrimTy)+primOpInfo (VecSubOp WordVec 8 W16) = mkGenPrimOp (fsLit "minusWord16X8#")  [] [word16X8PrimTy, word16X8PrimTy] (word16X8PrimTy)+primOpInfo (VecSubOp WordVec 4 W32) = mkGenPrimOp (fsLit "minusWord32X4#")  [] [word32X4PrimTy, word32X4PrimTy] (word32X4PrimTy)+primOpInfo (VecSubOp WordVec 2 W64) = mkGenPrimOp (fsLit "minusWord64X2#")  [] [word64X2PrimTy, word64X2PrimTy] (word64X2PrimTy)+primOpInfo (VecSubOp WordVec 32 W8) = mkGenPrimOp (fsLit "minusWord8X32#")  [] [word8X32PrimTy, word8X32PrimTy] (word8X32PrimTy)+primOpInfo (VecSubOp WordVec 16 W16) = mkGenPrimOp (fsLit "minusWord16X16#")  [] [word16X16PrimTy, word16X16PrimTy] (word16X16PrimTy)+primOpInfo (VecSubOp WordVec 8 W32) = mkGenPrimOp (fsLit "minusWord32X8#")  [] [word32X8PrimTy, word32X8PrimTy] (word32X8PrimTy)+primOpInfo (VecSubOp WordVec 4 W64) = mkGenPrimOp (fsLit "minusWord64X4#")  [] [word64X4PrimTy, word64X4PrimTy] (word64X4PrimTy)+primOpInfo (VecSubOp WordVec 64 W8) = mkGenPrimOp (fsLit "minusWord8X64#")  [] [word8X64PrimTy, word8X64PrimTy] (word8X64PrimTy)+primOpInfo (VecSubOp WordVec 32 W16) = mkGenPrimOp (fsLit "minusWord16X32#")  [] [word16X32PrimTy, word16X32PrimTy] (word16X32PrimTy)+primOpInfo (VecSubOp WordVec 16 W32) = mkGenPrimOp (fsLit "minusWord32X16#")  [] [word32X16PrimTy, word32X16PrimTy] (word32X16PrimTy)+primOpInfo (VecSubOp WordVec 8 W64) = mkGenPrimOp (fsLit "minusWord64X8#")  [] [word64X8PrimTy, word64X8PrimTy] (word64X8PrimTy)+primOpInfo (VecSubOp FloatVec 4 W32) = mkGenPrimOp (fsLit "minusFloatX4#")  [] [floatX4PrimTy, floatX4PrimTy] (floatX4PrimTy)+primOpInfo (VecSubOp FloatVec 2 W64) = mkGenPrimOp (fsLit "minusDoubleX2#")  [] [doubleX2PrimTy, doubleX2PrimTy] (doubleX2PrimTy)+primOpInfo (VecSubOp FloatVec 8 W32) = mkGenPrimOp (fsLit "minusFloatX8#")  [] [floatX8PrimTy, floatX8PrimTy] (floatX8PrimTy)+primOpInfo (VecSubOp FloatVec 4 W64) = mkGenPrimOp (fsLit "minusDoubleX4#")  [] [doubleX4PrimTy, doubleX4PrimTy] (doubleX4PrimTy)+primOpInfo (VecSubOp FloatVec 16 W32) = mkGenPrimOp (fsLit "minusFloatX16#")  [] [floatX16PrimTy, floatX16PrimTy] (floatX16PrimTy)+primOpInfo (VecSubOp FloatVec 8 W64) = mkGenPrimOp (fsLit "minusDoubleX8#")  [] [doubleX8PrimTy, doubleX8PrimTy] (doubleX8PrimTy)+primOpInfo (VecMulOp IntVec 16 W8) = mkGenPrimOp (fsLit "timesInt8X16#")  [] [int8X16PrimTy, int8X16PrimTy] (int8X16PrimTy)+primOpInfo (VecMulOp IntVec 8 W16) = mkGenPrimOp (fsLit "timesInt16X8#")  [] [int16X8PrimTy, int16X8PrimTy] (int16X8PrimTy)+primOpInfo (VecMulOp IntVec 4 W32) = mkGenPrimOp (fsLit "timesInt32X4#")  [] [int32X4PrimTy, int32X4PrimTy] (int32X4PrimTy)+primOpInfo (VecMulOp IntVec 2 W64) = mkGenPrimOp (fsLit "timesInt64X2#")  [] [int64X2PrimTy, int64X2PrimTy] (int64X2PrimTy)+primOpInfo (VecMulOp IntVec 32 W8) = mkGenPrimOp (fsLit "timesInt8X32#")  [] [int8X32PrimTy, int8X32PrimTy] (int8X32PrimTy)+primOpInfo (VecMulOp IntVec 16 W16) = mkGenPrimOp (fsLit "timesInt16X16#")  [] [int16X16PrimTy, int16X16PrimTy] (int16X16PrimTy)+primOpInfo (VecMulOp IntVec 8 W32) = mkGenPrimOp (fsLit "timesInt32X8#")  [] [int32X8PrimTy, int32X8PrimTy] (int32X8PrimTy)+primOpInfo (VecMulOp IntVec 4 W64) = mkGenPrimOp (fsLit "timesInt64X4#")  [] [int64X4PrimTy, int64X4PrimTy] (int64X4PrimTy)+primOpInfo (VecMulOp IntVec 64 W8) = mkGenPrimOp (fsLit "timesInt8X64#")  [] [int8X64PrimTy, int8X64PrimTy] (int8X64PrimTy)+primOpInfo (VecMulOp IntVec 32 W16) = mkGenPrimOp (fsLit "timesInt16X32#")  [] [int16X32PrimTy, int16X32PrimTy] (int16X32PrimTy)+primOpInfo (VecMulOp IntVec 16 W32) = mkGenPrimOp (fsLit "timesInt32X16#")  [] [int32X16PrimTy, int32X16PrimTy] (int32X16PrimTy)+primOpInfo (VecMulOp IntVec 8 W64) = mkGenPrimOp (fsLit "timesInt64X8#")  [] [int64X8PrimTy, int64X8PrimTy] (int64X8PrimTy)+primOpInfo (VecMulOp WordVec 16 W8) = mkGenPrimOp (fsLit "timesWord8X16#")  [] [word8X16PrimTy, word8X16PrimTy] (word8X16PrimTy)+primOpInfo (VecMulOp WordVec 8 W16) = mkGenPrimOp (fsLit "timesWord16X8#")  [] [word16X8PrimTy, word16X8PrimTy] (word16X8PrimTy)+primOpInfo (VecMulOp WordVec 4 W32) = mkGenPrimOp (fsLit "timesWord32X4#")  [] [word32X4PrimTy, word32X4PrimTy] (word32X4PrimTy)+primOpInfo (VecMulOp WordVec 2 W64) = mkGenPrimOp (fsLit "timesWord64X2#")  [] [word64X2PrimTy, word64X2PrimTy] (word64X2PrimTy)+primOpInfo (VecMulOp WordVec 32 W8) = mkGenPrimOp (fsLit "timesWord8X32#")  [] [word8X32PrimTy, word8X32PrimTy] (word8X32PrimTy)+primOpInfo (VecMulOp WordVec 16 W16) = mkGenPrimOp (fsLit "timesWord16X16#")  [] [word16X16PrimTy, word16X16PrimTy] (word16X16PrimTy)+primOpInfo (VecMulOp WordVec 8 W32) = mkGenPrimOp (fsLit "timesWord32X8#")  [] [word32X8PrimTy, word32X8PrimTy] (word32X8PrimTy)+primOpInfo (VecMulOp WordVec 4 W64) = mkGenPrimOp (fsLit "timesWord64X4#")  [] [word64X4PrimTy, word64X4PrimTy] (word64X4PrimTy)+primOpInfo (VecMulOp WordVec 64 W8) = mkGenPrimOp (fsLit "timesWord8X64#")  [] [word8X64PrimTy, word8X64PrimTy] (word8X64PrimTy)+primOpInfo (VecMulOp WordVec 32 W16) = mkGenPrimOp (fsLit "timesWord16X32#")  [] [word16X32PrimTy, word16X32PrimTy] (word16X32PrimTy)+primOpInfo (VecMulOp WordVec 16 W32) = mkGenPrimOp (fsLit "timesWord32X16#")  [] [word32X16PrimTy, word32X16PrimTy] (word32X16PrimTy)+primOpInfo (VecMulOp WordVec 8 W64) = mkGenPrimOp (fsLit "timesWord64X8#")  [] [word64X8PrimTy, word64X8PrimTy] (word64X8PrimTy)+primOpInfo (VecMulOp FloatVec 4 W32) = mkGenPrimOp (fsLit "timesFloatX4#")  [] [floatX4PrimTy, floatX4PrimTy] (floatX4PrimTy)+primOpInfo (VecMulOp FloatVec 2 W64) = mkGenPrimOp (fsLit "timesDoubleX2#")  [] [doubleX2PrimTy, doubleX2PrimTy] (doubleX2PrimTy)+primOpInfo (VecMulOp FloatVec 8 W32) = mkGenPrimOp (fsLit "timesFloatX8#")  [] [floatX8PrimTy, floatX8PrimTy] (floatX8PrimTy)+primOpInfo (VecMulOp FloatVec 4 W64) = mkGenPrimOp (fsLit "timesDoubleX4#")  [] [doubleX4PrimTy, doubleX4PrimTy] (doubleX4PrimTy)+primOpInfo (VecMulOp FloatVec 16 W32) = mkGenPrimOp (fsLit "timesFloatX16#")  [] [floatX16PrimTy, floatX16PrimTy] (floatX16PrimTy)+primOpInfo (VecMulOp FloatVec 8 W64) = mkGenPrimOp (fsLit "timesDoubleX8#")  [] [doubleX8PrimTy, doubleX8PrimTy] (doubleX8PrimTy)+primOpInfo (VecDivOp FloatVec 4 W32) = mkGenPrimOp (fsLit "divideFloatX4#")  [] [floatX4PrimTy, floatX4PrimTy] (floatX4PrimTy)+primOpInfo (VecDivOp FloatVec 2 W64) = mkGenPrimOp (fsLit "divideDoubleX2#")  [] [doubleX2PrimTy, doubleX2PrimTy] (doubleX2PrimTy)+primOpInfo (VecDivOp FloatVec 8 W32) = mkGenPrimOp (fsLit "divideFloatX8#")  [] [floatX8PrimTy, floatX8PrimTy] (floatX8PrimTy)+primOpInfo (VecDivOp FloatVec 4 W64) = mkGenPrimOp (fsLit "divideDoubleX4#")  [] [doubleX4PrimTy, doubleX4PrimTy] (doubleX4PrimTy)+primOpInfo (VecDivOp FloatVec 16 W32) = mkGenPrimOp (fsLit "divideFloatX16#")  [] [floatX16PrimTy, floatX16PrimTy] (floatX16PrimTy)+primOpInfo (VecDivOp FloatVec 8 W64) = mkGenPrimOp (fsLit "divideDoubleX8#")  [] [doubleX8PrimTy, doubleX8PrimTy] (doubleX8PrimTy)+primOpInfo (VecQuotOp IntVec 16 W8) = mkGenPrimOp (fsLit "quotInt8X16#")  [] [int8X16PrimTy, int8X16PrimTy] (int8X16PrimTy)+primOpInfo (VecQuotOp IntVec 8 W16) = mkGenPrimOp (fsLit "quotInt16X8#")  [] [int16X8PrimTy, int16X8PrimTy] (int16X8PrimTy)+primOpInfo (VecQuotOp IntVec 4 W32) = mkGenPrimOp (fsLit "quotInt32X4#")  [] [int32X4PrimTy, int32X4PrimTy] (int32X4PrimTy)+primOpInfo (VecQuotOp IntVec 2 W64) = mkGenPrimOp (fsLit "quotInt64X2#")  [] [int64X2PrimTy, int64X2PrimTy] (int64X2PrimTy)+primOpInfo (VecQuotOp IntVec 32 W8) = mkGenPrimOp (fsLit "quotInt8X32#")  [] [int8X32PrimTy, int8X32PrimTy] (int8X32PrimTy)+primOpInfo (VecQuotOp IntVec 16 W16) = mkGenPrimOp (fsLit "quotInt16X16#")  [] [int16X16PrimTy, int16X16PrimTy] (int16X16PrimTy)+primOpInfo (VecQuotOp IntVec 8 W32) = mkGenPrimOp (fsLit "quotInt32X8#")  [] [int32X8PrimTy, int32X8PrimTy] (int32X8PrimTy)+primOpInfo (VecQuotOp IntVec 4 W64) = mkGenPrimOp (fsLit "quotInt64X4#")  [] [int64X4PrimTy, int64X4PrimTy] (int64X4PrimTy)+primOpInfo (VecQuotOp IntVec 64 W8) = mkGenPrimOp (fsLit "quotInt8X64#")  [] [int8X64PrimTy, int8X64PrimTy] (int8X64PrimTy)+primOpInfo (VecQuotOp IntVec 32 W16) = mkGenPrimOp (fsLit "quotInt16X32#")  [] [int16X32PrimTy, int16X32PrimTy] (int16X32PrimTy)+primOpInfo (VecQuotOp IntVec 16 W32) = mkGenPrimOp (fsLit "quotInt32X16#")  [] [int32X16PrimTy, int32X16PrimTy] (int32X16PrimTy)+primOpInfo (VecQuotOp IntVec 8 W64) = mkGenPrimOp (fsLit "quotInt64X8#")  [] [int64X8PrimTy, int64X8PrimTy] (int64X8PrimTy)+primOpInfo (VecQuotOp WordVec 16 W8) = mkGenPrimOp (fsLit "quotWord8X16#")  [] [word8X16PrimTy, word8X16PrimTy] (word8X16PrimTy)+primOpInfo (VecQuotOp WordVec 8 W16) = mkGenPrimOp (fsLit "quotWord16X8#")  [] [word16X8PrimTy, word16X8PrimTy] (word16X8PrimTy)+primOpInfo (VecQuotOp WordVec 4 W32) = mkGenPrimOp (fsLit "quotWord32X4#")  [] [word32X4PrimTy, word32X4PrimTy] (word32X4PrimTy)+primOpInfo (VecQuotOp WordVec 2 W64) = mkGenPrimOp (fsLit "quotWord64X2#")  [] [word64X2PrimTy, word64X2PrimTy] (word64X2PrimTy)+primOpInfo (VecQuotOp WordVec 32 W8) = mkGenPrimOp (fsLit "quotWord8X32#")  [] [word8X32PrimTy, word8X32PrimTy] (word8X32PrimTy)+primOpInfo (VecQuotOp WordVec 16 W16) = mkGenPrimOp (fsLit "quotWord16X16#")  [] [word16X16PrimTy, word16X16PrimTy] (word16X16PrimTy)+primOpInfo (VecQuotOp WordVec 8 W32) = mkGenPrimOp (fsLit "quotWord32X8#")  [] [word32X8PrimTy, word32X8PrimTy] (word32X8PrimTy)+primOpInfo (VecQuotOp WordVec 4 W64) = mkGenPrimOp (fsLit "quotWord64X4#")  [] [word64X4PrimTy, word64X4PrimTy] (word64X4PrimTy)+primOpInfo (VecQuotOp WordVec 64 W8) = mkGenPrimOp (fsLit "quotWord8X64#")  [] [word8X64PrimTy, word8X64PrimTy] (word8X64PrimTy)+primOpInfo (VecQuotOp WordVec 32 W16) = mkGenPrimOp (fsLit "quotWord16X32#")  [] [word16X32PrimTy, word16X32PrimTy] (word16X32PrimTy)+primOpInfo (VecQuotOp WordVec 16 W32) = mkGenPrimOp (fsLit "quotWord32X16#")  [] [word32X16PrimTy, word32X16PrimTy] (word32X16PrimTy)+primOpInfo (VecQuotOp WordVec 8 W64) = mkGenPrimOp (fsLit "quotWord64X8#")  [] [word64X8PrimTy, word64X8PrimTy] (word64X8PrimTy)+primOpInfo (VecRemOp IntVec 16 W8) = mkGenPrimOp (fsLit "remInt8X16#")  [] [int8X16PrimTy, int8X16PrimTy] (int8X16PrimTy)+primOpInfo (VecRemOp IntVec 8 W16) = mkGenPrimOp (fsLit "remInt16X8#")  [] [int16X8PrimTy, int16X8PrimTy] (int16X8PrimTy)+primOpInfo (VecRemOp IntVec 4 W32) = mkGenPrimOp (fsLit "remInt32X4#")  [] [int32X4PrimTy, int32X4PrimTy] (int32X4PrimTy)+primOpInfo (VecRemOp IntVec 2 W64) = mkGenPrimOp (fsLit "remInt64X2#")  [] [int64X2PrimTy, int64X2PrimTy] (int64X2PrimTy)+primOpInfo (VecRemOp IntVec 32 W8) = mkGenPrimOp (fsLit "remInt8X32#")  [] [int8X32PrimTy, int8X32PrimTy] (int8X32PrimTy)+primOpInfo (VecRemOp IntVec 16 W16) = mkGenPrimOp (fsLit "remInt16X16#")  [] [int16X16PrimTy, int16X16PrimTy] (int16X16PrimTy)+primOpInfo (VecRemOp IntVec 8 W32) = mkGenPrimOp (fsLit "remInt32X8#")  [] [int32X8PrimTy, int32X8PrimTy] (int32X8PrimTy)+primOpInfo (VecRemOp IntVec 4 W64) = mkGenPrimOp (fsLit "remInt64X4#")  [] [int64X4PrimTy, int64X4PrimTy] (int64X4PrimTy)+primOpInfo (VecRemOp IntVec 64 W8) = mkGenPrimOp (fsLit "remInt8X64#")  [] [int8X64PrimTy, int8X64PrimTy] (int8X64PrimTy)+primOpInfo (VecRemOp IntVec 32 W16) = mkGenPrimOp (fsLit "remInt16X32#")  [] [int16X32PrimTy, int16X32PrimTy] (int16X32PrimTy)+primOpInfo (VecRemOp IntVec 16 W32) = mkGenPrimOp (fsLit "remInt32X16#")  [] [int32X16PrimTy, int32X16PrimTy] (int32X16PrimTy)+primOpInfo (VecRemOp IntVec 8 W64) = mkGenPrimOp (fsLit "remInt64X8#")  [] [int64X8PrimTy, int64X8PrimTy] (int64X8PrimTy)+primOpInfo (VecRemOp WordVec 16 W8) = mkGenPrimOp (fsLit "remWord8X16#")  [] [word8X16PrimTy, word8X16PrimTy] (word8X16PrimTy)+primOpInfo (VecRemOp WordVec 8 W16) = mkGenPrimOp (fsLit "remWord16X8#")  [] [word16X8PrimTy, word16X8PrimTy] (word16X8PrimTy)+primOpInfo (VecRemOp WordVec 4 W32) = mkGenPrimOp (fsLit "remWord32X4#")  [] [word32X4PrimTy, word32X4PrimTy] (word32X4PrimTy)+primOpInfo (VecRemOp WordVec 2 W64) = mkGenPrimOp (fsLit "remWord64X2#")  [] [word64X2PrimTy, word64X2PrimTy] (word64X2PrimTy)+primOpInfo (VecRemOp WordVec 32 W8) = mkGenPrimOp (fsLit "remWord8X32#")  [] [word8X32PrimTy, word8X32PrimTy] (word8X32PrimTy)+primOpInfo (VecRemOp WordVec 16 W16) = mkGenPrimOp (fsLit "remWord16X16#")  [] [word16X16PrimTy, word16X16PrimTy] (word16X16PrimTy)+primOpInfo (VecRemOp WordVec 8 W32) = mkGenPrimOp (fsLit "remWord32X8#")  [] [word32X8PrimTy, word32X8PrimTy] (word32X8PrimTy)+primOpInfo (VecRemOp WordVec 4 W64) = mkGenPrimOp (fsLit "remWord64X4#")  [] [word64X4PrimTy, word64X4PrimTy] (word64X4PrimTy)+primOpInfo (VecRemOp WordVec 64 W8) = mkGenPrimOp (fsLit "remWord8X64#")  [] [word8X64PrimTy, word8X64PrimTy] (word8X64PrimTy)+primOpInfo (VecRemOp WordVec 32 W16) = mkGenPrimOp (fsLit "remWord16X32#")  [] [word16X32PrimTy, word16X32PrimTy] (word16X32PrimTy)+primOpInfo (VecRemOp WordVec 16 W32) = mkGenPrimOp (fsLit "remWord32X16#")  [] [word32X16PrimTy, word32X16PrimTy] (word32X16PrimTy)+primOpInfo (VecRemOp WordVec 8 W64) = mkGenPrimOp (fsLit "remWord64X8#")  [] [word64X8PrimTy, word64X8PrimTy] (word64X8PrimTy)+primOpInfo (VecNegOp IntVec 16 W8) = mkGenPrimOp (fsLit "negateInt8X16#")  [] [int8X16PrimTy] (int8X16PrimTy)+primOpInfo (VecNegOp IntVec 8 W16) = mkGenPrimOp (fsLit "negateInt16X8#")  [] [int16X8PrimTy] (int16X8PrimTy)+primOpInfo (VecNegOp IntVec 4 W32) = mkGenPrimOp (fsLit "negateInt32X4#")  [] [int32X4PrimTy] (int32X4PrimTy)+primOpInfo (VecNegOp IntVec 2 W64) = mkGenPrimOp (fsLit "negateInt64X2#")  [] [int64X2PrimTy] (int64X2PrimTy)+primOpInfo (VecNegOp IntVec 32 W8) = mkGenPrimOp (fsLit "negateInt8X32#")  [] [int8X32PrimTy] (int8X32PrimTy)+primOpInfo (VecNegOp IntVec 16 W16) = mkGenPrimOp (fsLit "negateInt16X16#")  [] [int16X16PrimTy] (int16X16PrimTy)+primOpInfo (VecNegOp IntVec 8 W32) = mkGenPrimOp (fsLit "negateInt32X8#")  [] [int32X8PrimTy] (int32X8PrimTy)+primOpInfo (VecNegOp IntVec 4 W64) = mkGenPrimOp (fsLit "negateInt64X4#")  [] [int64X4PrimTy] (int64X4PrimTy)+primOpInfo (VecNegOp IntVec 64 W8) = mkGenPrimOp (fsLit "negateInt8X64#")  [] [int8X64PrimTy] (int8X64PrimTy)+primOpInfo (VecNegOp IntVec 32 W16) = mkGenPrimOp (fsLit "negateInt16X32#")  [] [int16X32PrimTy] (int16X32PrimTy)+primOpInfo (VecNegOp IntVec 16 W32) = mkGenPrimOp (fsLit "negateInt32X16#")  [] [int32X16PrimTy] (int32X16PrimTy)+primOpInfo (VecNegOp IntVec 8 W64) = mkGenPrimOp (fsLit "negateInt64X8#")  [] [int64X8PrimTy] (int64X8PrimTy)+primOpInfo (VecNegOp FloatVec 4 W32) = mkGenPrimOp (fsLit "negateFloatX4#")  [] [floatX4PrimTy] (floatX4PrimTy)+primOpInfo (VecNegOp FloatVec 2 W64) = mkGenPrimOp (fsLit "negateDoubleX2#")  [] [doubleX2PrimTy] (doubleX2PrimTy)+primOpInfo (VecNegOp FloatVec 8 W32) = mkGenPrimOp (fsLit "negateFloatX8#")  [] [floatX8PrimTy] (floatX8PrimTy)+primOpInfo (VecNegOp FloatVec 4 W64) = mkGenPrimOp (fsLit "negateDoubleX4#")  [] [doubleX4PrimTy] (doubleX4PrimTy)+primOpInfo (VecNegOp FloatVec 16 W32) = mkGenPrimOp (fsLit "negateFloatX16#")  [] [floatX16PrimTy] (floatX16PrimTy)+primOpInfo (VecNegOp FloatVec 8 W64) = mkGenPrimOp (fsLit "negateDoubleX8#")  [] [doubleX8PrimTy] (doubleX8PrimTy)+primOpInfo (VecIndexByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8X16Array#")  [] [byteArrayPrimTy, intPrimTy] (int8X16PrimTy)+primOpInfo (VecIndexByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16X8Array#")  [] [byteArrayPrimTy, intPrimTy] (int16X8PrimTy)+primOpInfo (VecIndexByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32X4Array#")  [] [byteArrayPrimTy, intPrimTy] (int32X4PrimTy)+primOpInfo (VecIndexByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64X2Array#")  [] [byteArrayPrimTy, intPrimTy] (int64X2PrimTy)+primOpInfo (VecIndexByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8X32Array#")  [] [byteArrayPrimTy, intPrimTy] (int8X32PrimTy)+primOpInfo (VecIndexByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16X16Array#")  [] [byteArrayPrimTy, intPrimTy] (int16X16PrimTy)+primOpInfo (VecIndexByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32X8Array#")  [] [byteArrayPrimTy, intPrimTy] (int32X8PrimTy)+primOpInfo (VecIndexByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64X4Array#")  [] [byteArrayPrimTy, intPrimTy] (int64X4PrimTy)+primOpInfo (VecIndexByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8X64Array#")  [] [byteArrayPrimTy, intPrimTy] (int8X64PrimTy)+primOpInfo (VecIndexByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16X32Array#")  [] [byteArrayPrimTy, intPrimTy] (int16X32PrimTy)+primOpInfo (VecIndexByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32X16Array#")  [] [byteArrayPrimTy, intPrimTy] (int32X16PrimTy)+primOpInfo (VecIndexByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64X8Array#")  [] [byteArrayPrimTy, intPrimTy] (int64X8PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8X16Array#")  [] [byteArrayPrimTy, intPrimTy] (word8X16PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16X8Array#")  [] [byteArrayPrimTy, intPrimTy] (word16X8PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32X4Array#")  [] [byteArrayPrimTy, intPrimTy] (word32X4PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64X2Array#")  [] [byteArrayPrimTy, intPrimTy] (word64X2PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8X32Array#")  [] [byteArrayPrimTy, intPrimTy] (word8X32PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16X16Array#")  [] [byteArrayPrimTy, intPrimTy] (word16X16PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32X8Array#")  [] [byteArrayPrimTy, intPrimTy] (word32X8PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64X4Array#")  [] [byteArrayPrimTy, intPrimTy] (word64X4PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8X64Array#")  [] [byteArrayPrimTy, intPrimTy] (word8X64PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16X32Array#")  [] [byteArrayPrimTy, intPrimTy] (word16X32PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32X16Array#")  [] [byteArrayPrimTy, intPrimTy] (word32X16PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64X8Array#")  [] [byteArrayPrimTy, intPrimTy] (word64X8PrimTy)+primOpInfo (VecIndexByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatX4Array#")  [] [byteArrayPrimTy, intPrimTy] (floatX4PrimTy)+primOpInfo (VecIndexByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleX2Array#")  [] [byteArrayPrimTy, intPrimTy] (doubleX2PrimTy)+primOpInfo (VecIndexByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatX8Array#")  [] [byteArrayPrimTy, intPrimTy] (floatX8PrimTy)+primOpInfo (VecIndexByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleX4Array#")  [] [byteArrayPrimTy, intPrimTy] (doubleX4PrimTy)+primOpInfo (VecIndexByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatX16Array#")  [] [byteArrayPrimTy, intPrimTy] (floatX16PrimTy)+primOpInfo (VecIndexByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleX8Array#")  [] [byteArrayPrimTy, intPrimTy] (doubleX8PrimTy)+primOpInfo (VecReadByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8X16Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy]))+primOpInfo (VecReadByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16X8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy]))+primOpInfo (VecReadByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32X4Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy]))+primOpInfo (VecReadByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64X2Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy]))+primOpInfo (VecReadByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8X32Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy]))+primOpInfo (VecReadByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16X16Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy]))+primOpInfo (VecReadByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32X8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy]))+primOpInfo (VecReadByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64X4Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy]))+primOpInfo (VecReadByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8X64Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy]))+primOpInfo (VecReadByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16X32Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy]))+primOpInfo (VecReadByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32X16Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy]))+primOpInfo (VecReadByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64X8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8X16Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16X8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32X4Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64X2Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8X32Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16X16Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32X8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64X4Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8X64Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16X32Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32X16Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64X8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy]))+primOpInfo (VecReadByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatX4Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy]))+primOpInfo (VecReadByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleX2Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy]))+primOpInfo (VecReadByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatX8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy]))+primOpInfo (VecReadByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleX4Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy]))+primOpInfo (VecReadByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatX16Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy]))+primOpInfo (VecReadByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleX8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy]))+primOpInfo (VecWriteByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8X16Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16X8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32X4Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64X2Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8X32Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16X16Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32X8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64X4Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8X64Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16X32Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32X16Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64X8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8X16Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16X8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32X4Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64X2Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8X32Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16X16Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32X8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64X4Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8X64Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16X32Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32X16Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64X8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatX4Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleX2Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatX8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleX4Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatX16Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleX8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecIndexOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8X16OffAddr#")  [] [addrPrimTy, intPrimTy] (int8X16PrimTy)+primOpInfo (VecIndexOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16X8OffAddr#")  [] [addrPrimTy, intPrimTy] (int16X8PrimTy)+primOpInfo (VecIndexOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32X4OffAddr#")  [] [addrPrimTy, intPrimTy] (int32X4PrimTy)+primOpInfo (VecIndexOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64X2OffAddr#")  [] [addrPrimTy, intPrimTy] (int64X2PrimTy)+primOpInfo (VecIndexOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8X32OffAddr#")  [] [addrPrimTy, intPrimTy] (int8X32PrimTy)+primOpInfo (VecIndexOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16X16OffAddr#")  [] [addrPrimTy, intPrimTy] (int16X16PrimTy)+primOpInfo (VecIndexOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32X8OffAddr#")  [] [addrPrimTy, intPrimTy] (int32X8PrimTy)+primOpInfo (VecIndexOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64X4OffAddr#")  [] [addrPrimTy, intPrimTy] (int64X4PrimTy)+primOpInfo (VecIndexOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8X64OffAddr#")  [] [addrPrimTy, intPrimTy] (int8X64PrimTy)+primOpInfo (VecIndexOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16X32OffAddr#")  [] [addrPrimTy, intPrimTy] (int16X32PrimTy)+primOpInfo (VecIndexOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32X16OffAddr#")  [] [addrPrimTy, intPrimTy] (int32X16PrimTy)+primOpInfo (VecIndexOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64X8OffAddr#")  [] [addrPrimTy, intPrimTy] (int64X8PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8X16OffAddr#")  [] [addrPrimTy, intPrimTy] (word8X16PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16X8OffAddr#")  [] [addrPrimTy, intPrimTy] (word16X8PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32X4OffAddr#")  [] [addrPrimTy, intPrimTy] (word32X4PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64X2OffAddr#")  [] [addrPrimTy, intPrimTy] (word64X2PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8X32OffAddr#")  [] [addrPrimTy, intPrimTy] (word8X32PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16X16OffAddr#")  [] [addrPrimTy, intPrimTy] (word16X16PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32X8OffAddr#")  [] [addrPrimTy, intPrimTy] (word32X8PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64X4OffAddr#")  [] [addrPrimTy, intPrimTy] (word64X4PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8X64OffAddr#")  [] [addrPrimTy, intPrimTy] (word8X64PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16X32OffAddr#")  [] [addrPrimTy, intPrimTy] (word16X32PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32X16OffAddr#")  [] [addrPrimTy, intPrimTy] (word32X16PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64X8OffAddr#")  [] [addrPrimTy, intPrimTy] (word64X8PrimTy)+primOpInfo (VecIndexOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatX4OffAddr#")  [] [addrPrimTy, intPrimTy] (floatX4PrimTy)+primOpInfo (VecIndexOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleX2OffAddr#")  [] [addrPrimTy, intPrimTy] (doubleX2PrimTy)+primOpInfo (VecIndexOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatX8OffAddr#")  [] [addrPrimTy, intPrimTy] (floatX8PrimTy)+primOpInfo (VecIndexOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleX4OffAddr#")  [] [addrPrimTy, intPrimTy] (doubleX4PrimTy)+primOpInfo (VecIndexOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatX16OffAddr#")  [] [addrPrimTy, intPrimTy] (floatX16PrimTy)+primOpInfo (VecIndexOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleX8OffAddr#")  [] [addrPrimTy, intPrimTy] (doubleX8PrimTy)+primOpInfo (VecReadOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8X16OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy]))+primOpInfo (VecReadOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16X8OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy]))+primOpInfo (VecReadOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32X4OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy]))+primOpInfo (VecReadOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64X2OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy]))+primOpInfo (VecReadOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8X32OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy]))+primOpInfo (VecReadOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16X16OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy]))+primOpInfo (VecReadOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32X8OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy]))+primOpInfo (VecReadOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64X4OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy]))+primOpInfo (VecReadOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8X64OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy]))+primOpInfo (VecReadOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16X32OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy]))+primOpInfo (VecReadOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32X16OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy]))+primOpInfo (VecReadOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64X8OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8X16OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16X8OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32X4OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64X2OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8X32OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16X16OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32X8OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64X4OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8X64OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16X32OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32X16OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64X8OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy]))+primOpInfo (VecReadOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatX4OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy]))+primOpInfo (VecReadOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleX2OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy]))+primOpInfo (VecReadOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatX8OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy]))+primOpInfo (VecReadOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleX4OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy]))+primOpInfo (VecReadOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatX16OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy]))+primOpInfo (VecReadOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleX8OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy]))+primOpInfo (VecWriteOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8X16OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16X8OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32X4OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64X2OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8X32OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16X16OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32X8OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64X4OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8X64OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16X32OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32X16OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64X8OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8X16OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16X8OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32X4OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64X2OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8X32OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16X16OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32X8OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64X4OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8X64OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16X32OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32X16OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64X8OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatX4OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleX2OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatX8OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleX4OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatX16OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleX8OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8ArrayAsInt8X16#")  [] [byteArrayPrimTy, intPrimTy] (int8X16PrimTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16ArrayAsInt16X8#")  [] [byteArrayPrimTy, intPrimTy] (int16X8PrimTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32ArrayAsInt32X4#")  [] [byteArrayPrimTy, intPrimTy] (int32X4PrimTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64ArrayAsInt64X2#")  [] [byteArrayPrimTy, intPrimTy] (int64X2PrimTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8ArrayAsInt8X32#")  [] [byteArrayPrimTy, intPrimTy] (int8X32PrimTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16ArrayAsInt16X16#")  [] [byteArrayPrimTy, intPrimTy] (int16X16PrimTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32ArrayAsInt32X8#")  [] [byteArrayPrimTy, intPrimTy] (int32X8PrimTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64ArrayAsInt64X4#")  [] [byteArrayPrimTy, intPrimTy] (int64X4PrimTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8ArrayAsInt8X64#")  [] [byteArrayPrimTy, intPrimTy] (int8X64PrimTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16ArrayAsInt16X32#")  [] [byteArrayPrimTy, intPrimTy] (int16X32PrimTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32ArrayAsInt32X16#")  [] [byteArrayPrimTy, intPrimTy] (int32X16PrimTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64ArrayAsInt64X8#")  [] [byteArrayPrimTy, intPrimTy] (int64X8PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8ArrayAsWord8X16#")  [] [byteArrayPrimTy, intPrimTy] (word8X16PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16ArrayAsWord16X8#")  [] [byteArrayPrimTy, intPrimTy] (word16X8PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32ArrayAsWord32X4#")  [] [byteArrayPrimTy, intPrimTy] (word32X4PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64ArrayAsWord64X2#")  [] [byteArrayPrimTy, intPrimTy] (word64X2PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8ArrayAsWord8X32#")  [] [byteArrayPrimTy, intPrimTy] (word8X32PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16ArrayAsWord16X16#")  [] [byteArrayPrimTy, intPrimTy] (word16X16PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32ArrayAsWord32X8#")  [] [byteArrayPrimTy, intPrimTy] (word32X8PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64ArrayAsWord64X4#")  [] [byteArrayPrimTy, intPrimTy] (word64X4PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8ArrayAsWord8X64#")  [] [byteArrayPrimTy, intPrimTy] (word8X64PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16ArrayAsWord16X32#")  [] [byteArrayPrimTy, intPrimTy] (word16X32PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32ArrayAsWord32X16#")  [] [byteArrayPrimTy, intPrimTy] (word32X16PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64ArrayAsWord64X8#")  [] [byteArrayPrimTy, intPrimTy] (word64X8PrimTy)+primOpInfo (VecIndexScalarByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatArrayAsFloatX4#")  [] [byteArrayPrimTy, intPrimTy] (floatX4PrimTy)+primOpInfo (VecIndexScalarByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleArrayAsDoubleX2#")  [] [byteArrayPrimTy, intPrimTy] (doubleX2PrimTy)+primOpInfo (VecIndexScalarByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatArrayAsFloatX8#")  [] [byteArrayPrimTy, intPrimTy] (floatX8PrimTy)+primOpInfo (VecIndexScalarByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleArrayAsDoubleX4#")  [] [byteArrayPrimTy, intPrimTy] (doubleX4PrimTy)+primOpInfo (VecIndexScalarByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatArrayAsFloatX16#")  [] [byteArrayPrimTy, intPrimTy] (floatX16PrimTy)+primOpInfo (VecIndexScalarByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleArrayAsDoubleX8#")  [] [byteArrayPrimTy, intPrimTy] (doubleX8PrimTy)+primOpInfo (VecReadScalarByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8ArrayAsInt8X16#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy]))+primOpInfo (VecReadScalarByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16ArrayAsInt16X8#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy]))+primOpInfo (VecReadScalarByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32ArrayAsInt32X4#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy]))+primOpInfo (VecReadScalarByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64ArrayAsInt64X2#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy]))+primOpInfo (VecReadScalarByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8ArrayAsInt8X32#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy]))+primOpInfo (VecReadScalarByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16ArrayAsInt16X16#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy]))+primOpInfo (VecReadScalarByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32ArrayAsInt32X8#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy]))+primOpInfo (VecReadScalarByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64ArrayAsInt64X4#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy]))+primOpInfo (VecReadScalarByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8ArrayAsInt8X64#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy]))+primOpInfo (VecReadScalarByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16ArrayAsInt16X32#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy]))+primOpInfo (VecReadScalarByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32ArrayAsInt32X16#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy]))+primOpInfo (VecReadScalarByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64ArrayAsInt64X8#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8ArrayAsWord8X16#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16ArrayAsWord16X8#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32ArrayAsWord32X4#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64ArrayAsWord64X2#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8ArrayAsWord8X32#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16ArrayAsWord16X16#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32ArrayAsWord32X8#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64ArrayAsWord64X4#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8ArrayAsWord8X64#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16ArrayAsWord16X32#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32ArrayAsWord32X16#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64ArrayAsWord64X8#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy]))+primOpInfo (VecReadScalarByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatArrayAsFloatX4#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy]))+primOpInfo (VecReadScalarByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleArrayAsDoubleX2#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy]))+primOpInfo (VecReadScalarByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatArrayAsFloatX8#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy]))+primOpInfo (VecReadScalarByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleArrayAsDoubleX4#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy]))+primOpInfo (VecReadScalarByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatArrayAsFloatX16#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy]))+primOpInfo (VecReadScalarByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleArrayAsDoubleX8#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy]))+primOpInfo (VecWriteScalarByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8ArrayAsInt8X16#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16ArrayAsInt16X8#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32ArrayAsInt32X4#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64ArrayAsInt64X2#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8ArrayAsInt8X32#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16ArrayAsInt16X16#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32ArrayAsInt32X8#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64ArrayAsInt64X4#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8ArrayAsInt8X64#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16ArrayAsInt16X32#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32ArrayAsInt32X16#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64ArrayAsInt64X8#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8ArrayAsWord8X16#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16ArrayAsWord16X8#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32ArrayAsWord32X4#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64ArrayAsWord64X2#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8ArrayAsWord8X32#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16ArrayAsWord16X16#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32ArrayAsWord32X8#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64ArrayAsWord64X4#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8ArrayAsWord8X64#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16ArrayAsWord16X32#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32ArrayAsWord32X16#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64ArrayAsWord64X8#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatArrayAsFloatX4#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleArrayAsDoubleX2#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatArrayAsFloatX8#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleArrayAsDoubleX4#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatArrayAsFloatX16#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleArrayAsDoubleX8#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8OffAddrAsInt8X16#")  [] [addrPrimTy, intPrimTy] (int8X16PrimTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16OffAddrAsInt16X8#")  [] [addrPrimTy, intPrimTy] (int16X8PrimTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32OffAddrAsInt32X4#")  [] [addrPrimTy, intPrimTy] (int32X4PrimTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64OffAddrAsInt64X2#")  [] [addrPrimTy, intPrimTy] (int64X2PrimTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8OffAddrAsInt8X32#")  [] [addrPrimTy, intPrimTy] (int8X32PrimTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16OffAddrAsInt16X16#")  [] [addrPrimTy, intPrimTy] (int16X16PrimTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32OffAddrAsInt32X8#")  [] [addrPrimTy, intPrimTy] (int32X8PrimTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64OffAddrAsInt64X4#")  [] [addrPrimTy, intPrimTy] (int64X4PrimTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8OffAddrAsInt8X64#")  [] [addrPrimTy, intPrimTy] (int8X64PrimTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16OffAddrAsInt16X32#")  [] [addrPrimTy, intPrimTy] (int16X32PrimTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32OffAddrAsInt32X16#")  [] [addrPrimTy, intPrimTy] (int32X16PrimTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64OffAddrAsInt64X8#")  [] [addrPrimTy, intPrimTy] (int64X8PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord8X16#")  [] [addrPrimTy, intPrimTy] (word8X16PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16OffAddrAsWord16X8#")  [] [addrPrimTy, intPrimTy] (word16X8PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32OffAddrAsWord32X4#")  [] [addrPrimTy, intPrimTy] (word32X4PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64OffAddrAsWord64X2#")  [] [addrPrimTy, intPrimTy] (word64X2PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord8X32#")  [] [addrPrimTy, intPrimTy] (word8X32PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16OffAddrAsWord16X16#")  [] [addrPrimTy, intPrimTy] (word16X16PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32OffAddrAsWord32X8#")  [] [addrPrimTy, intPrimTy] (word32X8PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64OffAddrAsWord64X4#")  [] [addrPrimTy, intPrimTy] (word64X4PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord8X64#")  [] [addrPrimTy, intPrimTy] (word8X64PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16OffAddrAsWord16X32#")  [] [addrPrimTy, intPrimTy] (word16X32PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32OffAddrAsWord32X16#")  [] [addrPrimTy, intPrimTy] (word32X16PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64OffAddrAsWord64X8#")  [] [addrPrimTy, intPrimTy] (word64X8PrimTy)+primOpInfo (VecIndexScalarOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatOffAddrAsFloatX4#")  [] [addrPrimTy, intPrimTy] (floatX4PrimTy)+primOpInfo (VecIndexScalarOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleOffAddrAsDoubleX2#")  [] [addrPrimTy, intPrimTy] (doubleX2PrimTy)+primOpInfo (VecIndexScalarOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatOffAddrAsFloatX8#")  [] [addrPrimTy, intPrimTy] (floatX8PrimTy)+primOpInfo (VecIndexScalarOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleOffAddrAsDoubleX4#")  [] [addrPrimTy, intPrimTy] (doubleX4PrimTy)+primOpInfo (VecIndexScalarOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatOffAddrAsFloatX16#")  [] [addrPrimTy, intPrimTy] (floatX16PrimTy)+primOpInfo (VecIndexScalarOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleOffAddrAsDoubleX8#")  [] [addrPrimTy, intPrimTy] (doubleX8PrimTy)+primOpInfo (VecReadScalarOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8OffAddrAsInt8X16#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy]))+primOpInfo (VecReadScalarOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16OffAddrAsInt16X8#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy]))+primOpInfo (VecReadScalarOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32OffAddrAsInt32X4#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy]))+primOpInfo (VecReadScalarOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64OffAddrAsInt64X2#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy]))+primOpInfo (VecReadScalarOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8OffAddrAsInt8X32#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy]))+primOpInfo (VecReadScalarOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16OffAddrAsInt16X16#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy]))+primOpInfo (VecReadScalarOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32OffAddrAsInt32X8#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy]))+primOpInfo (VecReadScalarOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64OffAddrAsInt64X4#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy]))+primOpInfo (VecReadScalarOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8OffAddrAsInt8X64#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy]))+primOpInfo (VecReadScalarOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16OffAddrAsInt16X32#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy]))+primOpInfo (VecReadScalarOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32OffAddrAsInt32X16#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy]))+primOpInfo (VecReadScalarOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64OffAddrAsInt64X8#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8OffAddrAsWord8X16#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16OffAddrAsWord16X8#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32OffAddrAsWord32X4#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64OffAddrAsWord64X2#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8OffAddrAsWord8X32#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16OffAddrAsWord16X16#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32OffAddrAsWord32X8#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64OffAddrAsWord64X4#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8OffAddrAsWord8X64#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16OffAddrAsWord16X32#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32OffAddrAsWord32X16#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64OffAddrAsWord64X8#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy]))+primOpInfo (VecReadScalarOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatOffAddrAsFloatX4#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy]))+primOpInfo (VecReadScalarOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleOffAddrAsDoubleX2#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy]))+primOpInfo (VecReadScalarOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatOffAddrAsFloatX8#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy]))+primOpInfo (VecReadScalarOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleOffAddrAsDoubleX4#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy]))+primOpInfo (VecReadScalarOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatOffAddrAsFloatX16#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy]))+primOpInfo (VecReadScalarOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleOffAddrAsDoubleX8#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy]))+primOpInfo (VecWriteScalarOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8OffAddrAsInt8X16#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16OffAddrAsInt16X8#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32OffAddrAsInt32X4#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64OffAddrAsInt64X2#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8OffAddrAsInt8X32#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16OffAddrAsInt16X16#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32OffAddrAsInt32X8#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64OffAddrAsInt64X4#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8OffAddrAsInt8X64#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16OffAddrAsInt16X32#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32OffAddrAsInt32X16#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64OffAddrAsInt64X8#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord8X16#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16OffAddrAsWord16X8#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32OffAddrAsWord32X4#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64OffAddrAsWord64X2#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord8X32#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16OffAddrAsWord16X16#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32OffAddrAsWord32X8#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64OffAddrAsWord64X4#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord8X64#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16OffAddrAsWord16X32#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32OffAddrAsWord32X16#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64OffAddrAsWord64X8#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatOffAddrAsFloatX4#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleOffAddrAsDoubleX2#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatOffAddrAsFloatX8#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleOffAddrAsDoubleX4#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatOffAddrAsFloatX16#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleOffAddrAsDoubleX8#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchByteArrayOp3 = mkGenPrimOp (fsLit "prefetchByteArray3#")  [deltaTyVarSpec] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchMutableByteArrayOp3 = mkGenPrimOp (fsLit "prefetchMutableByteArray3#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchAddrOp3 = mkGenPrimOp (fsLit "prefetchAddr3#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchValueOp3 = mkGenPrimOp (fsLit "prefetchValue3#")  [alphaTyVarSpec, deltaTyVarSpec] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchByteArrayOp2 = mkGenPrimOp (fsLit "prefetchByteArray2#")  [deltaTyVarSpec] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchMutableByteArrayOp2 = mkGenPrimOp (fsLit "prefetchMutableByteArray2#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchAddrOp2 = mkGenPrimOp (fsLit "prefetchAddr2#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchValueOp2 = mkGenPrimOp (fsLit "prefetchValue2#")  [alphaTyVarSpec, deltaTyVarSpec] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchByteArrayOp1 = mkGenPrimOp (fsLit "prefetchByteArray1#")  [deltaTyVarSpec] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchMutableByteArrayOp1 = mkGenPrimOp (fsLit "prefetchMutableByteArray1#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchAddrOp1 = mkGenPrimOp (fsLit "prefetchAddr1#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchValueOp1 = mkGenPrimOp (fsLit "prefetchValue1#")  [alphaTyVarSpec, deltaTyVarSpec] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchByteArrayOp0 = mkGenPrimOp (fsLit "prefetchByteArray0#")  [deltaTyVarSpec] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchMutableByteArrayOp0 = mkGenPrimOp (fsLit "prefetchMutableByteArray0#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchAddrOp0 = mkGenPrimOp (fsLit "prefetchAddr0#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchValueOp0 = mkGenPrimOp (fsLit "prefetchValue0#")  [alphaTyVarSpec, deltaTyVarSpec] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
ghc-lib/stage0/compiler/build/primop-strictness.hs-incl view
@@ -1,19 +1,24 @@-primOpStrictness CatchOp =  \ _arity -> mkClosedStrictSig [ lazyApply1Dmd+primOpStrictness CatchOp =  \ _arity -> mkClosedDmdSig [ lazyApply1Dmd                                                  , lazyApply2Dmd                                                  , topDmd] topDiv -primOpStrictness RaiseOp =  \ _arity -> mkClosedStrictSig [topDmd] botDiv -primOpStrictness RaiseIOOp =  \ _arity -> mkClosedStrictSig [topDmd, topDmd] exnDiv -primOpStrictness MaskAsyncExceptionsOp =  \ _arity -> mkClosedStrictSig [strictOnceApply1Dmd,topDmd] topDiv -primOpStrictness MaskUninterruptibleOp =  \ _arity -> mkClosedStrictSig [strictOnceApply1Dmd,topDmd] topDiv -primOpStrictness UnmaskAsyncExceptionsOp =  \ _arity -> mkClosedStrictSig [strictOnceApply1Dmd,topDmd] topDiv -primOpStrictness AtomicallyOp =  \ _arity -> mkClosedStrictSig [strictManyApply1Dmd,topDmd] topDiv -primOpStrictness RetryOp =  \ _arity -> mkClosedStrictSig [topDmd] botDiv -primOpStrictness CatchRetryOp =  \ _arity -> mkClosedStrictSig [ lazyApply1Dmd+primOpStrictness RaiseOp =  \ _arity -> mkClosedDmdSig [topDmd] botDiv +primOpStrictness RaiseIOOp =  \ _arity -> mkClosedDmdSig [topDmd, topDmd] exnDiv +primOpStrictness MaskAsyncExceptionsOp =  \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv +primOpStrictness MaskUninterruptibleOp =  \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv +primOpStrictness UnmaskAsyncExceptionsOp =  \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv +primOpStrictness AtomicallyOp =  \ _arity -> mkClosedDmdSig [strictManyApply1Dmd,topDmd] topDiv +primOpStrictness RetryOp =  \ _arity -> mkClosedDmdSig [topDmd] botDiv +primOpStrictness CatchRetryOp =  \ _arity -> mkClosedDmdSig [ lazyApply1Dmd                                                  , lazyApply1Dmd                                                  , topDmd ] topDiv -primOpStrictness CatchSTMOp =  \ _arity -> mkClosedStrictSig [ lazyApply1Dmd+primOpStrictness CatchSTMOp =  \ _arity -> mkClosedDmdSig [ lazyApply1Dmd                                                  , lazyApply2Dmd                                                  , topDmd ] topDiv -primOpStrictness KeepAliveOp =  \ _arity -> mkClosedStrictSig [topDmd, topDmd, strictOnceApply1Dmd] topDiv -primOpStrictness DataToTagOp =  \ _arity -> mkClosedStrictSig [evalDmd] topDiv -primOpStrictness _ =  \ arity -> mkClosedStrictSig (replicate arity topDmd) topDiv +primOpStrictness ForkOp =  \ _arity -> mkClosedDmdSig [ lazyApply1Dmd+                                              , topDmd ] topDiv +primOpStrictness ForkOnOp =  \ _arity -> mkClosedDmdSig [ topDmd+                                              , lazyApply1Dmd+                                              , topDmd ] topDiv +primOpStrictness KeepAliveOp =  \ _arity -> mkClosedDmdSig [topDmd, topDmd, strictOnceApply1Dmd] topDiv +primOpStrictness DataToTagOp =  \ _arity -> mkClosedDmdSig [evalDmd] topDiv +primOpStrictness _ =  \ arity -> mkClosedDmdSig (replicate arity topDmd) topDiv
ghc-lib/stage0/compiler/build/primop-tag.hs-incl view
@@ -1,1286 +1,1307 @@ maxPrimOpTag :: Int-maxPrimOpTag = 1283-primOpTag :: PrimOp -> Int-primOpTag CharGtOp = 1-primOpTag CharGeOp = 2-primOpTag CharEqOp = 3-primOpTag CharNeOp = 4-primOpTag CharLtOp = 5-primOpTag CharLeOp = 6-primOpTag OrdOp = 7-primOpTag Int8ToIntOp = 8-primOpTag IntToInt8Op = 9-primOpTag Int8NegOp = 10-primOpTag Int8AddOp = 11-primOpTag Int8SubOp = 12-primOpTag Int8MulOp = 13-primOpTag Int8QuotOp = 14-primOpTag Int8RemOp = 15-primOpTag Int8QuotRemOp = 16-primOpTag Int8SllOp = 17-primOpTag Int8SraOp = 18-primOpTag Int8SrlOp = 19-primOpTag Int8ToWord8Op = 20-primOpTag Int8EqOp = 21-primOpTag Int8GeOp = 22-primOpTag Int8GtOp = 23-primOpTag Int8LeOp = 24-primOpTag Int8LtOp = 25-primOpTag Int8NeOp = 26-primOpTag Word8ToWordOp = 27-primOpTag WordToWord8Op = 28-primOpTag Word8AddOp = 29-primOpTag Word8SubOp = 30-primOpTag Word8MulOp = 31-primOpTag Word8QuotOp = 32-primOpTag Word8RemOp = 33-primOpTag Word8QuotRemOp = 34-primOpTag Word8AndOp = 35-primOpTag Word8OrOp = 36-primOpTag Word8XorOp = 37-primOpTag Word8NotOp = 38-primOpTag Word8SllOp = 39-primOpTag Word8SrlOp = 40-primOpTag Word8ToInt8Op = 41-primOpTag Word8EqOp = 42-primOpTag Word8GeOp = 43-primOpTag Word8GtOp = 44-primOpTag Word8LeOp = 45-primOpTag Word8LtOp = 46-primOpTag Word8NeOp = 47-primOpTag Int16ToIntOp = 48-primOpTag IntToInt16Op = 49-primOpTag Int16NegOp = 50-primOpTag Int16AddOp = 51-primOpTag Int16SubOp = 52-primOpTag Int16MulOp = 53-primOpTag Int16QuotOp = 54-primOpTag Int16RemOp = 55-primOpTag Int16QuotRemOp = 56-primOpTag Int16SllOp = 57-primOpTag Int16SraOp = 58-primOpTag Int16SrlOp = 59-primOpTag Int16ToWord16Op = 60-primOpTag Int16EqOp = 61-primOpTag Int16GeOp = 62-primOpTag Int16GtOp = 63-primOpTag Int16LeOp = 64-primOpTag Int16LtOp = 65-primOpTag Int16NeOp = 66-primOpTag Word16ToWordOp = 67-primOpTag WordToWord16Op = 68-primOpTag Word16AddOp = 69-primOpTag Word16SubOp = 70-primOpTag Word16MulOp = 71-primOpTag Word16QuotOp = 72-primOpTag Word16RemOp = 73-primOpTag Word16QuotRemOp = 74-primOpTag Word16AndOp = 75-primOpTag Word16OrOp = 76-primOpTag Word16XorOp = 77-primOpTag Word16NotOp = 78-primOpTag Word16SllOp = 79-primOpTag Word16SrlOp = 80-primOpTag Word16ToInt16Op = 81-primOpTag Word16EqOp = 82-primOpTag Word16GeOp = 83-primOpTag Word16GtOp = 84-primOpTag Word16LeOp = 85-primOpTag Word16LtOp = 86-primOpTag Word16NeOp = 87-primOpTag Int32ToIntOp = 88-primOpTag IntToInt32Op = 89-primOpTag Int32NegOp = 90-primOpTag Int32AddOp = 91-primOpTag Int32SubOp = 92-primOpTag Int32MulOp = 93-primOpTag Int32QuotOp = 94-primOpTag Int32RemOp = 95-primOpTag Int32QuotRemOp = 96-primOpTag Int32SllOp = 97-primOpTag Int32SraOp = 98-primOpTag Int32SrlOp = 99-primOpTag Int32ToWord32Op = 100-primOpTag Int32EqOp = 101-primOpTag Int32GeOp = 102-primOpTag Int32GtOp = 103-primOpTag Int32LeOp = 104-primOpTag Int32LtOp = 105-primOpTag Int32NeOp = 106-primOpTag Word32ToWordOp = 107-primOpTag WordToWord32Op = 108-primOpTag Word32AddOp = 109-primOpTag Word32SubOp = 110-primOpTag Word32MulOp = 111-primOpTag Word32QuotOp = 112-primOpTag Word32RemOp = 113-primOpTag Word32QuotRemOp = 114-primOpTag Word32AndOp = 115-primOpTag Word32OrOp = 116-primOpTag Word32XorOp = 117-primOpTag Word32NotOp = 118-primOpTag Word32SllOp = 119-primOpTag Word32SrlOp = 120-primOpTag Word32ToInt32Op = 121-primOpTag Word32EqOp = 122-primOpTag Word32GeOp = 123-primOpTag Word32GtOp = 124-primOpTag Word32LeOp = 125-primOpTag Word32LtOp = 126-primOpTag Word32NeOp = 127-primOpTag IntAddOp = 128-primOpTag IntSubOp = 129-primOpTag IntMulOp = 130-primOpTag IntMul2Op = 131-primOpTag IntMulMayOfloOp = 132-primOpTag IntQuotOp = 133-primOpTag IntRemOp = 134-primOpTag IntQuotRemOp = 135-primOpTag IntAndOp = 136-primOpTag IntOrOp = 137-primOpTag IntXorOp = 138-primOpTag IntNotOp = 139-primOpTag IntNegOp = 140-primOpTag IntAddCOp = 141-primOpTag IntSubCOp = 142-primOpTag IntGtOp = 143-primOpTag IntGeOp = 144-primOpTag IntEqOp = 145-primOpTag IntNeOp = 146-primOpTag IntLtOp = 147-primOpTag IntLeOp = 148-primOpTag ChrOp = 149-primOpTag IntToWordOp = 150-primOpTag IntToFloatOp = 151-primOpTag IntToDoubleOp = 152-primOpTag WordToFloatOp = 153-primOpTag WordToDoubleOp = 154-primOpTag IntSllOp = 155-primOpTag IntSraOp = 156-primOpTag IntSrlOp = 157-primOpTag WordAddOp = 158-primOpTag WordAddCOp = 159-primOpTag WordSubCOp = 160-primOpTag WordAdd2Op = 161-primOpTag WordSubOp = 162-primOpTag WordMulOp = 163-primOpTag WordMul2Op = 164-primOpTag WordQuotOp = 165-primOpTag WordRemOp = 166-primOpTag WordQuotRemOp = 167-primOpTag WordQuotRem2Op = 168-primOpTag WordAndOp = 169-primOpTag WordOrOp = 170-primOpTag WordXorOp = 171-primOpTag WordNotOp = 172-primOpTag WordSllOp = 173-primOpTag WordSrlOp = 174-primOpTag WordToIntOp = 175-primOpTag WordGtOp = 176-primOpTag WordGeOp = 177-primOpTag WordEqOp = 178-primOpTag WordNeOp = 179-primOpTag WordLtOp = 180-primOpTag WordLeOp = 181-primOpTag PopCnt8Op = 182-primOpTag PopCnt16Op = 183-primOpTag PopCnt32Op = 184-primOpTag PopCnt64Op = 185-primOpTag PopCntOp = 186-primOpTag Pdep8Op = 187-primOpTag Pdep16Op = 188-primOpTag Pdep32Op = 189-primOpTag Pdep64Op = 190-primOpTag PdepOp = 191-primOpTag Pext8Op = 192-primOpTag Pext16Op = 193-primOpTag Pext32Op = 194-primOpTag Pext64Op = 195-primOpTag PextOp = 196-primOpTag Clz8Op = 197-primOpTag Clz16Op = 198-primOpTag Clz32Op = 199-primOpTag Clz64Op = 200-primOpTag ClzOp = 201-primOpTag Ctz8Op = 202-primOpTag Ctz16Op = 203-primOpTag Ctz32Op = 204-primOpTag Ctz64Op = 205-primOpTag CtzOp = 206-primOpTag BSwap16Op = 207-primOpTag BSwap32Op = 208-primOpTag BSwap64Op = 209-primOpTag BSwapOp = 210-primOpTag BRev8Op = 211-primOpTag BRev16Op = 212-primOpTag BRev32Op = 213-primOpTag BRev64Op = 214-primOpTag BRevOp = 215-primOpTag Narrow8IntOp = 216-primOpTag Narrow16IntOp = 217-primOpTag Narrow32IntOp = 218-primOpTag Narrow8WordOp = 219-primOpTag Narrow16WordOp = 220-primOpTag Narrow32WordOp = 221-primOpTag DoubleGtOp = 222-primOpTag DoubleGeOp = 223-primOpTag DoubleEqOp = 224-primOpTag DoubleNeOp = 225-primOpTag DoubleLtOp = 226-primOpTag DoubleLeOp = 227-primOpTag DoubleAddOp = 228-primOpTag DoubleSubOp = 229-primOpTag DoubleMulOp = 230-primOpTag DoubleDivOp = 231-primOpTag DoubleNegOp = 232-primOpTag DoubleFabsOp = 233-primOpTag DoubleToIntOp = 234-primOpTag DoubleToFloatOp = 235-primOpTag DoubleExpOp = 236-primOpTag DoubleExpM1Op = 237-primOpTag DoubleLogOp = 238-primOpTag DoubleLog1POp = 239-primOpTag DoubleSqrtOp = 240-primOpTag DoubleSinOp = 241-primOpTag DoubleCosOp = 242-primOpTag DoubleTanOp = 243-primOpTag DoubleAsinOp = 244-primOpTag DoubleAcosOp = 245-primOpTag DoubleAtanOp = 246-primOpTag DoubleSinhOp = 247-primOpTag DoubleCoshOp = 248-primOpTag DoubleTanhOp = 249-primOpTag DoubleAsinhOp = 250-primOpTag DoubleAcoshOp = 251-primOpTag DoubleAtanhOp = 252-primOpTag DoublePowerOp = 253-primOpTag DoubleDecode_2IntOp = 254-primOpTag DoubleDecode_Int64Op = 255-primOpTag FloatGtOp = 256-primOpTag FloatGeOp = 257-primOpTag FloatEqOp = 258-primOpTag FloatNeOp = 259-primOpTag FloatLtOp = 260-primOpTag FloatLeOp = 261-primOpTag FloatAddOp = 262-primOpTag FloatSubOp = 263-primOpTag FloatMulOp = 264-primOpTag FloatDivOp = 265-primOpTag FloatNegOp = 266-primOpTag FloatFabsOp = 267-primOpTag FloatToIntOp = 268-primOpTag FloatExpOp = 269-primOpTag FloatExpM1Op = 270-primOpTag FloatLogOp = 271-primOpTag FloatLog1POp = 272-primOpTag FloatSqrtOp = 273-primOpTag FloatSinOp = 274-primOpTag FloatCosOp = 275-primOpTag FloatTanOp = 276-primOpTag FloatAsinOp = 277-primOpTag FloatAcosOp = 278-primOpTag FloatAtanOp = 279-primOpTag FloatSinhOp = 280-primOpTag FloatCoshOp = 281-primOpTag FloatTanhOp = 282-primOpTag FloatAsinhOp = 283-primOpTag FloatAcoshOp = 284-primOpTag FloatAtanhOp = 285-primOpTag FloatPowerOp = 286-primOpTag FloatToDoubleOp = 287-primOpTag FloatDecode_IntOp = 288-primOpTag NewArrayOp = 289-primOpTag SameMutableArrayOp = 290-primOpTag ReadArrayOp = 291-primOpTag WriteArrayOp = 292-primOpTag SizeofArrayOp = 293-primOpTag SizeofMutableArrayOp = 294-primOpTag IndexArrayOp = 295-primOpTag UnsafeFreezeArrayOp = 296-primOpTag UnsafeThawArrayOp = 297-primOpTag CopyArrayOp = 298-primOpTag CopyMutableArrayOp = 299-primOpTag CloneArrayOp = 300-primOpTag CloneMutableArrayOp = 301-primOpTag FreezeArrayOp = 302-primOpTag ThawArrayOp = 303-primOpTag CasArrayOp = 304-primOpTag NewSmallArrayOp = 305-primOpTag SameSmallMutableArrayOp = 306-primOpTag ShrinkSmallMutableArrayOp_Char = 307-primOpTag ReadSmallArrayOp = 308-primOpTag WriteSmallArrayOp = 309-primOpTag SizeofSmallArrayOp = 310-primOpTag SizeofSmallMutableArrayOp = 311-primOpTag GetSizeofSmallMutableArrayOp = 312-primOpTag IndexSmallArrayOp = 313-primOpTag UnsafeFreezeSmallArrayOp = 314-primOpTag UnsafeThawSmallArrayOp = 315-primOpTag CopySmallArrayOp = 316-primOpTag CopySmallMutableArrayOp = 317-primOpTag CloneSmallArrayOp = 318-primOpTag CloneSmallMutableArrayOp = 319-primOpTag FreezeSmallArrayOp = 320-primOpTag ThawSmallArrayOp = 321-primOpTag CasSmallArrayOp = 322-primOpTag NewByteArrayOp_Char = 323-primOpTag NewPinnedByteArrayOp_Char = 324-primOpTag NewAlignedPinnedByteArrayOp_Char = 325-primOpTag MutableByteArrayIsPinnedOp = 326-primOpTag ByteArrayIsPinnedOp = 327-primOpTag ByteArrayContents_Char = 328-primOpTag MutableByteArrayContents_Char = 329-primOpTag SameMutableByteArrayOp = 330-primOpTag ShrinkMutableByteArrayOp_Char = 331-primOpTag ResizeMutableByteArrayOp_Char = 332-primOpTag UnsafeFreezeByteArrayOp = 333-primOpTag SizeofByteArrayOp = 334-primOpTag SizeofMutableByteArrayOp = 335-primOpTag GetSizeofMutableByteArrayOp = 336-primOpTag IndexByteArrayOp_Char = 337-primOpTag IndexByteArrayOp_WideChar = 338-primOpTag IndexByteArrayOp_Int = 339-primOpTag IndexByteArrayOp_Word = 340-primOpTag IndexByteArrayOp_Addr = 341-primOpTag IndexByteArrayOp_Float = 342-primOpTag IndexByteArrayOp_Double = 343-primOpTag IndexByteArrayOp_StablePtr = 344-primOpTag IndexByteArrayOp_Int8 = 345-primOpTag IndexByteArrayOp_Int16 = 346-primOpTag IndexByteArrayOp_Int32 = 347-primOpTag IndexByteArrayOp_Int64 = 348-primOpTag IndexByteArrayOp_Word8 = 349-primOpTag IndexByteArrayOp_Word16 = 350-primOpTag IndexByteArrayOp_Word32 = 351-primOpTag IndexByteArrayOp_Word64 = 352-primOpTag IndexByteArrayOp_Word8AsChar = 353-primOpTag IndexByteArrayOp_Word8AsWideChar = 354-primOpTag IndexByteArrayOp_Word8AsInt = 355-primOpTag IndexByteArrayOp_Word8AsWord = 356-primOpTag IndexByteArrayOp_Word8AsAddr = 357-primOpTag IndexByteArrayOp_Word8AsFloat = 358-primOpTag IndexByteArrayOp_Word8AsDouble = 359-primOpTag IndexByteArrayOp_Word8AsStablePtr = 360-primOpTag IndexByteArrayOp_Word8AsInt16 = 361-primOpTag IndexByteArrayOp_Word8AsInt32 = 362-primOpTag IndexByteArrayOp_Word8AsInt64 = 363-primOpTag IndexByteArrayOp_Word8AsWord16 = 364-primOpTag IndexByteArrayOp_Word8AsWord32 = 365-primOpTag IndexByteArrayOp_Word8AsWord64 = 366-primOpTag ReadByteArrayOp_Char = 367-primOpTag ReadByteArrayOp_WideChar = 368-primOpTag ReadByteArrayOp_Int = 369-primOpTag ReadByteArrayOp_Word = 370-primOpTag ReadByteArrayOp_Addr = 371-primOpTag ReadByteArrayOp_Float = 372-primOpTag ReadByteArrayOp_Double = 373-primOpTag ReadByteArrayOp_StablePtr = 374-primOpTag ReadByteArrayOp_Int8 = 375-primOpTag ReadByteArrayOp_Int16 = 376-primOpTag ReadByteArrayOp_Int32 = 377-primOpTag ReadByteArrayOp_Int64 = 378-primOpTag ReadByteArrayOp_Word8 = 379-primOpTag ReadByteArrayOp_Word16 = 380-primOpTag ReadByteArrayOp_Word32 = 381-primOpTag ReadByteArrayOp_Word64 = 382-primOpTag ReadByteArrayOp_Word8AsChar = 383-primOpTag ReadByteArrayOp_Word8AsWideChar = 384-primOpTag ReadByteArrayOp_Word8AsInt = 385-primOpTag ReadByteArrayOp_Word8AsWord = 386-primOpTag ReadByteArrayOp_Word8AsAddr = 387-primOpTag ReadByteArrayOp_Word8AsFloat = 388-primOpTag ReadByteArrayOp_Word8AsDouble = 389-primOpTag ReadByteArrayOp_Word8AsStablePtr = 390-primOpTag ReadByteArrayOp_Word8AsInt16 = 391-primOpTag ReadByteArrayOp_Word8AsInt32 = 392-primOpTag ReadByteArrayOp_Word8AsInt64 = 393-primOpTag ReadByteArrayOp_Word8AsWord16 = 394-primOpTag ReadByteArrayOp_Word8AsWord32 = 395-primOpTag ReadByteArrayOp_Word8AsWord64 = 396-primOpTag WriteByteArrayOp_Char = 397-primOpTag WriteByteArrayOp_WideChar = 398-primOpTag WriteByteArrayOp_Int = 399-primOpTag WriteByteArrayOp_Word = 400-primOpTag WriteByteArrayOp_Addr = 401-primOpTag WriteByteArrayOp_Float = 402-primOpTag WriteByteArrayOp_Double = 403-primOpTag WriteByteArrayOp_StablePtr = 404-primOpTag WriteByteArrayOp_Int8 = 405-primOpTag WriteByteArrayOp_Int16 = 406-primOpTag WriteByteArrayOp_Int32 = 407-primOpTag WriteByteArrayOp_Int64 = 408-primOpTag WriteByteArrayOp_Word8 = 409-primOpTag WriteByteArrayOp_Word16 = 410-primOpTag WriteByteArrayOp_Word32 = 411-primOpTag WriteByteArrayOp_Word64 = 412-primOpTag WriteByteArrayOp_Word8AsChar = 413-primOpTag WriteByteArrayOp_Word8AsWideChar = 414-primOpTag WriteByteArrayOp_Word8AsInt = 415-primOpTag WriteByteArrayOp_Word8AsWord = 416-primOpTag WriteByteArrayOp_Word8AsAddr = 417-primOpTag WriteByteArrayOp_Word8AsFloat = 418-primOpTag WriteByteArrayOp_Word8AsDouble = 419-primOpTag WriteByteArrayOp_Word8AsStablePtr = 420-primOpTag WriteByteArrayOp_Word8AsInt16 = 421-primOpTag WriteByteArrayOp_Word8AsInt32 = 422-primOpTag WriteByteArrayOp_Word8AsInt64 = 423-primOpTag WriteByteArrayOp_Word8AsWord16 = 424-primOpTag WriteByteArrayOp_Word8AsWord32 = 425-primOpTag WriteByteArrayOp_Word8AsWord64 = 426-primOpTag CompareByteArraysOp = 427-primOpTag CopyByteArrayOp = 428-primOpTag CopyMutableByteArrayOp = 429-primOpTag CopyByteArrayToAddrOp = 430-primOpTag CopyMutableByteArrayToAddrOp = 431-primOpTag CopyAddrToByteArrayOp = 432-primOpTag SetByteArrayOp = 433-primOpTag AtomicReadByteArrayOp_Int = 434-primOpTag AtomicWriteByteArrayOp_Int = 435-primOpTag CasByteArrayOp_Int = 436-primOpTag FetchAddByteArrayOp_Int = 437-primOpTag FetchSubByteArrayOp_Int = 438-primOpTag FetchAndByteArrayOp_Int = 439-primOpTag FetchNandByteArrayOp_Int = 440-primOpTag FetchOrByteArrayOp_Int = 441-primOpTag FetchXorByteArrayOp_Int = 442-primOpTag NewArrayArrayOp = 443-primOpTag SameMutableArrayArrayOp = 444-primOpTag UnsafeFreezeArrayArrayOp = 445-primOpTag SizeofArrayArrayOp = 446-primOpTag SizeofMutableArrayArrayOp = 447-primOpTag IndexArrayArrayOp_ByteArray = 448-primOpTag IndexArrayArrayOp_ArrayArray = 449-primOpTag ReadArrayArrayOp_ByteArray = 450-primOpTag ReadArrayArrayOp_MutableByteArray = 451-primOpTag ReadArrayArrayOp_ArrayArray = 452-primOpTag ReadArrayArrayOp_MutableArrayArray = 453-primOpTag WriteArrayArrayOp_ByteArray = 454-primOpTag WriteArrayArrayOp_MutableByteArray = 455-primOpTag WriteArrayArrayOp_ArrayArray = 456-primOpTag WriteArrayArrayOp_MutableArrayArray = 457-primOpTag CopyArrayArrayOp = 458-primOpTag CopyMutableArrayArrayOp = 459-primOpTag AddrAddOp = 460-primOpTag AddrSubOp = 461-primOpTag AddrRemOp = 462-primOpTag AddrToIntOp = 463-primOpTag IntToAddrOp = 464-primOpTag AddrGtOp = 465-primOpTag AddrGeOp = 466-primOpTag AddrEqOp = 467-primOpTag AddrNeOp = 468-primOpTag AddrLtOp = 469-primOpTag AddrLeOp = 470-primOpTag IndexOffAddrOp_Char = 471-primOpTag IndexOffAddrOp_WideChar = 472-primOpTag IndexOffAddrOp_Int = 473-primOpTag IndexOffAddrOp_Word = 474-primOpTag IndexOffAddrOp_Addr = 475-primOpTag IndexOffAddrOp_Float = 476-primOpTag IndexOffAddrOp_Double = 477-primOpTag IndexOffAddrOp_StablePtr = 478-primOpTag IndexOffAddrOp_Int8 = 479-primOpTag IndexOffAddrOp_Int16 = 480-primOpTag IndexOffAddrOp_Int32 = 481-primOpTag IndexOffAddrOp_Int64 = 482-primOpTag IndexOffAddrOp_Word8 = 483-primOpTag IndexOffAddrOp_Word16 = 484-primOpTag IndexOffAddrOp_Word32 = 485-primOpTag IndexOffAddrOp_Word64 = 486-primOpTag ReadOffAddrOp_Char = 487-primOpTag ReadOffAddrOp_WideChar = 488-primOpTag ReadOffAddrOp_Int = 489-primOpTag ReadOffAddrOp_Word = 490-primOpTag ReadOffAddrOp_Addr = 491-primOpTag ReadOffAddrOp_Float = 492-primOpTag ReadOffAddrOp_Double = 493-primOpTag ReadOffAddrOp_StablePtr = 494-primOpTag ReadOffAddrOp_Int8 = 495-primOpTag ReadOffAddrOp_Int16 = 496-primOpTag ReadOffAddrOp_Int32 = 497-primOpTag ReadOffAddrOp_Int64 = 498-primOpTag ReadOffAddrOp_Word8 = 499-primOpTag ReadOffAddrOp_Word16 = 500-primOpTag ReadOffAddrOp_Word32 = 501-primOpTag ReadOffAddrOp_Word64 = 502-primOpTag WriteOffAddrOp_Char = 503-primOpTag WriteOffAddrOp_WideChar = 504-primOpTag WriteOffAddrOp_Int = 505-primOpTag WriteOffAddrOp_Word = 506-primOpTag WriteOffAddrOp_Addr = 507-primOpTag WriteOffAddrOp_Float = 508-primOpTag WriteOffAddrOp_Double = 509-primOpTag WriteOffAddrOp_StablePtr = 510-primOpTag WriteOffAddrOp_Int8 = 511-primOpTag WriteOffAddrOp_Int16 = 512-primOpTag WriteOffAddrOp_Int32 = 513-primOpTag WriteOffAddrOp_Int64 = 514-primOpTag WriteOffAddrOp_Word8 = 515-primOpTag WriteOffAddrOp_Word16 = 516-primOpTag WriteOffAddrOp_Word32 = 517-primOpTag WriteOffAddrOp_Word64 = 518-primOpTag InterlockedExchange_Addr = 519-primOpTag InterlockedExchange_Word = 520-primOpTag CasAddrOp_Addr = 521-primOpTag CasAddrOp_Word = 522-primOpTag FetchAddAddrOp_Word = 523-primOpTag FetchSubAddrOp_Word = 524-primOpTag FetchAndAddrOp_Word = 525-primOpTag FetchNandAddrOp_Word = 526-primOpTag FetchOrAddrOp_Word = 527-primOpTag FetchXorAddrOp_Word = 528-primOpTag AtomicReadAddrOp_Word = 529-primOpTag AtomicWriteAddrOp_Word = 530-primOpTag NewMutVarOp = 531-primOpTag ReadMutVarOp = 532-primOpTag WriteMutVarOp = 533-primOpTag SameMutVarOp = 534-primOpTag AtomicModifyMutVar2Op = 535-primOpTag AtomicModifyMutVar_Op = 536-primOpTag CasMutVarOp = 537-primOpTag CatchOp = 538-primOpTag RaiseOp = 539-primOpTag RaiseIOOp = 540-primOpTag MaskAsyncExceptionsOp = 541-primOpTag MaskUninterruptibleOp = 542-primOpTag UnmaskAsyncExceptionsOp = 543-primOpTag MaskStatus = 544-primOpTag AtomicallyOp = 545-primOpTag RetryOp = 546-primOpTag CatchRetryOp = 547-primOpTag CatchSTMOp = 548-primOpTag NewTVarOp = 549-primOpTag ReadTVarOp = 550-primOpTag ReadTVarIOOp = 551-primOpTag WriteTVarOp = 552-primOpTag SameTVarOp = 553-primOpTag NewMVarOp = 554-primOpTag TakeMVarOp = 555-primOpTag TryTakeMVarOp = 556-primOpTag PutMVarOp = 557-primOpTag TryPutMVarOp = 558-primOpTag ReadMVarOp = 559-primOpTag TryReadMVarOp = 560-primOpTag SameMVarOp = 561-primOpTag IsEmptyMVarOp = 562-primOpTag NewIOPortrOp = 563-primOpTag ReadIOPortOp = 564-primOpTag WriteIOPortOp = 565-primOpTag SameIOPortOp = 566-primOpTag DelayOp = 567-primOpTag WaitReadOp = 568-primOpTag WaitWriteOp = 569-primOpTag ForkOp = 570-primOpTag ForkOnOp = 571-primOpTag KillThreadOp = 572-primOpTag YieldOp = 573-primOpTag MyThreadIdOp = 574-primOpTag LabelThreadOp = 575-primOpTag IsCurrentThreadBoundOp = 576-primOpTag NoDuplicateOp = 577-primOpTag ThreadStatusOp = 578-primOpTag MkWeakOp = 579-primOpTag MkWeakNoFinalizerOp = 580-primOpTag AddCFinalizerToWeakOp = 581-primOpTag DeRefWeakOp = 582-primOpTag FinalizeWeakOp = 583-primOpTag TouchOp = 584-primOpTag MakeStablePtrOp = 585-primOpTag DeRefStablePtrOp = 586-primOpTag EqStablePtrOp = 587-primOpTag MakeStableNameOp = 588-primOpTag EqStableNameOp = 589-primOpTag StableNameToIntOp = 590-primOpTag CompactNewOp = 591-primOpTag CompactResizeOp = 592-primOpTag CompactContainsOp = 593-primOpTag CompactContainsAnyOp = 594-primOpTag CompactGetFirstBlockOp = 595-primOpTag CompactGetNextBlockOp = 596-primOpTag CompactAllocateBlockOp = 597-primOpTag CompactFixupPointersOp = 598-primOpTag CompactAdd = 599-primOpTag CompactAddWithSharing = 600-primOpTag CompactSize = 601-primOpTag ReallyUnsafePtrEqualityOp = 602-primOpTag ParOp = 603-primOpTag SparkOp = 604-primOpTag SeqOp = 605-primOpTag GetSparkOp = 606-primOpTag NumSparks = 607-primOpTag KeepAliveOp = 608-primOpTag DataToTagOp = 609-primOpTag TagToEnumOp = 610-primOpTag AddrToAnyOp = 611-primOpTag AnyToAddrOp = 612-primOpTag MkApUpd0_Op = 613-primOpTag NewBCOOp = 614-primOpTag UnpackClosureOp = 615-primOpTag ClosureSizeOp = 616-primOpTag GetApStackValOp = 617-primOpTag GetCCSOfOp = 618-primOpTag GetCurrentCCSOp = 619-primOpTag ClearCCSOp = 620-primOpTag WhereFromOp = 621-primOpTag TraceEventOp = 622-primOpTag TraceEventBinaryOp = 623-primOpTag TraceMarkerOp = 624-primOpTag SetThreadAllocationCounter = 625-primOpTag (VecBroadcastOp IntVec 16 W8) = 626-primOpTag (VecBroadcastOp IntVec 8 W16) = 627-primOpTag (VecBroadcastOp IntVec 4 W32) = 628-primOpTag (VecBroadcastOp IntVec 2 W64) = 629-primOpTag (VecBroadcastOp IntVec 32 W8) = 630-primOpTag (VecBroadcastOp IntVec 16 W16) = 631-primOpTag (VecBroadcastOp IntVec 8 W32) = 632-primOpTag (VecBroadcastOp IntVec 4 W64) = 633-primOpTag (VecBroadcastOp IntVec 64 W8) = 634-primOpTag (VecBroadcastOp IntVec 32 W16) = 635-primOpTag (VecBroadcastOp IntVec 16 W32) = 636-primOpTag (VecBroadcastOp IntVec 8 W64) = 637-primOpTag (VecBroadcastOp WordVec 16 W8) = 638-primOpTag (VecBroadcastOp WordVec 8 W16) = 639-primOpTag (VecBroadcastOp WordVec 4 W32) = 640-primOpTag (VecBroadcastOp WordVec 2 W64) = 641-primOpTag (VecBroadcastOp WordVec 32 W8) = 642-primOpTag (VecBroadcastOp WordVec 16 W16) = 643-primOpTag (VecBroadcastOp WordVec 8 W32) = 644-primOpTag (VecBroadcastOp WordVec 4 W64) = 645-primOpTag (VecBroadcastOp WordVec 64 W8) = 646-primOpTag (VecBroadcastOp WordVec 32 W16) = 647-primOpTag (VecBroadcastOp WordVec 16 W32) = 648-primOpTag (VecBroadcastOp WordVec 8 W64) = 649-primOpTag (VecBroadcastOp FloatVec 4 W32) = 650-primOpTag (VecBroadcastOp FloatVec 2 W64) = 651-primOpTag (VecBroadcastOp FloatVec 8 W32) = 652-primOpTag (VecBroadcastOp FloatVec 4 W64) = 653-primOpTag (VecBroadcastOp FloatVec 16 W32) = 654-primOpTag (VecBroadcastOp FloatVec 8 W64) = 655-primOpTag (VecPackOp IntVec 16 W8) = 656-primOpTag (VecPackOp IntVec 8 W16) = 657-primOpTag (VecPackOp IntVec 4 W32) = 658-primOpTag (VecPackOp IntVec 2 W64) = 659-primOpTag (VecPackOp IntVec 32 W8) = 660-primOpTag (VecPackOp IntVec 16 W16) = 661-primOpTag (VecPackOp IntVec 8 W32) = 662-primOpTag (VecPackOp IntVec 4 W64) = 663-primOpTag (VecPackOp IntVec 64 W8) = 664-primOpTag (VecPackOp IntVec 32 W16) = 665-primOpTag (VecPackOp IntVec 16 W32) = 666-primOpTag (VecPackOp IntVec 8 W64) = 667-primOpTag (VecPackOp WordVec 16 W8) = 668-primOpTag (VecPackOp WordVec 8 W16) = 669-primOpTag (VecPackOp WordVec 4 W32) = 670-primOpTag (VecPackOp WordVec 2 W64) = 671-primOpTag (VecPackOp WordVec 32 W8) = 672-primOpTag (VecPackOp WordVec 16 W16) = 673-primOpTag (VecPackOp WordVec 8 W32) = 674-primOpTag (VecPackOp WordVec 4 W64) = 675-primOpTag (VecPackOp WordVec 64 W8) = 676-primOpTag (VecPackOp WordVec 32 W16) = 677-primOpTag (VecPackOp WordVec 16 W32) = 678-primOpTag (VecPackOp WordVec 8 W64) = 679-primOpTag (VecPackOp FloatVec 4 W32) = 680-primOpTag (VecPackOp FloatVec 2 W64) = 681-primOpTag (VecPackOp FloatVec 8 W32) = 682-primOpTag (VecPackOp FloatVec 4 W64) = 683-primOpTag (VecPackOp FloatVec 16 W32) = 684-primOpTag (VecPackOp FloatVec 8 W64) = 685-primOpTag (VecUnpackOp IntVec 16 W8) = 686-primOpTag (VecUnpackOp IntVec 8 W16) = 687-primOpTag (VecUnpackOp IntVec 4 W32) = 688-primOpTag (VecUnpackOp IntVec 2 W64) = 689-primOpTag (VecUnpackOp IntVec 32 W8) = 690-primOpTag (VecUnpackOp IntVec 16 W16) = 691-primOpTag (VecUnpackOp IntVec 8 W32) = 692-primOpTag (VecUnpackOp IntVec 4 W64) = 693-primOpTag (VecUnpackOp IntVec 64 W8) = 694-primOpTag (VecUnpackOp IntVec 32 W16) = 695-primOpTag (VecUnpackOp IntVec 16 W32) = 696-primOpTag (VecUnpackOp IntVec 8 W64) = 697-primOpTag (VecUnpackOp WordVec 16 W8) = 698-primOpTag (VecUnpackOp WordVec 8 W16) = 699-primOpTag (VecUnpackOp WordVec 4 W32) = 700-primOpTag (VecUnpackOp WordVec 2 W64) = 701-primOpTag (VecUnpackOp WordVec 32 W8) = 702-primOpTag (VecUnpackOp WordVec 16 W16) = 703-primOpTag (VecUnpackOp WordVec 8 W32) = 704-primOpTag (VecUnpackOp WordVec 4 W64) = 705-primOpTag (VecUnpackOp WordVec 64 W8) = 706-primOpTag (VecUnpackOp WordVec 32 W16) = 707-primOpTag (VecUnpackOp WordVec 16 W32) = 708-primOpTag (VecUnpackOp WordVec 8 W64) = 709-primOpTag (VecUnpackOp FloatVec 4 W32) = 710-primOpTag (VecUnpackOp FloatVec 2 W64) = 711-primOpTag (VecUnpackOp FloatVec 8 W32) = 712-primOpTag (VecUnpackOp FloatVec 4 W64) = 713-primOpTag (VecUnpackOp FloatVec 16 W32) = 714-primOpTag (VecUnpackOp FloatVec 8 W64) = 715-primOpTag (VecInsertOp IntVec 16 W8) = 716-primOpTag (VecInsertOp IntVec 8 W16) = 717-primOpTag (VecInsertOp IntVec 4 W32) = 718-primOpTag (VecInsertOp IntVec 2 W64) = 719-primOpTag (VecInsertOp IntVec 32 W8) = 720-primOpTag (VecInsertOp IntVec 16 W16) = 721-primOpTag (VecInsertOp IntVec 8 W32) = 722-primOpTag (VecInsertOp IntVec 4 W64) = 723-primOpTag (VecInsertOp IntVec 64 W8) = 724-primOpTag (VecInsertOp IntVec 32 W16) = 725-primOpTag (VecInsertOp IntVec 16 W32) = 726-primOpTag (VecInsertOp IntVec 8 W64) = 727-primOpTag (VecInsertOp WordVec 16 W8) = 728-primOpTag (VecInsertOp WordVec 8 W16) = 729-primOpTag (VecInsertOp WordVec 4 W32) = 730-primOpTag (VecInsertOp WordVec 2 W64) = 731-primOpTag (VecInsertOp WordVec 32 W8) = 732-primOpTag (VecInsertOp WordVec 16 W16) = 733-primOpTag (VecInsertOp WordVec 8 W32) = 734-primOpTag (VecInsertOp WordVec 4 W64) = 735-primOpTag (VecInsertOp WordVec 64 W8) = 736-primOpTag (VecInsertOp WordVec 32 W16) = 737-primOpTag (VecInsertOp WordVec 16 W32) = 738-primOpTag (VecInsertOp WordVec 8 W64) = 739-primOpTag (VecInsertOp FloatVec 4 W32) = 740-primOpTag (VecInsertOp FloatVec 2 W64) = 741-primOpTag (VecInsertOp FloatVec 8 W32) = 742-primOpTag (VecInsertOp FloatVec 4 W64) = 743-primOpTag (VecInsertOp FloatVec 16 W32) = 744-primOpTag (VecInsertOp FloatVec 8 W64) = 745-primOpTag (VecAddOp IntVec 16 W8) = 746-primOpTag (VecAddOp IntVec 8 W16) = 747-primOpTag (VecAddOp IntVec 4 W32) = 748-primOpTag (VecAddOp IntVec 2 W64) = 749-primOpTag (VecAddOp IntVec 32 W8) = 750-primOpTag (VecAddOp IntVec 16 W16) = 751-primOpTag (VecAddOp IntVec 8 W32) = 752-primOpTag (VecAddOp IntVec 4 W64) = 753-primOpTag (VecAddOp IntVec 64 W8) = 754-primOpTag (VecAddOp IntVec 32 W16) = 755-primOpTag (VecAddOp IntVec 16 W32) = 756-primOpTag (VecAddOp IntVec 8 W64) = 757-primOpTag (VecAddOp WordVec 16 W8) = 758-primOpTag (VecAddOp WordVec 8 W16) = 759-primOpTag (VecAddOp WordVec 4 W32) = 760-primOpTag (VecAddOp WordVec 2 W64) = 761-primOpTag (VecAddOp WordVec 32 W8) = 762-primOpTag (VecAddOp WordVec 16 W16) = 763-primOpTag (VecAddOp WordVec 8 W32) = 764-primOpTag (VecAddOp WordVec 4 W64) = 765-primOpTag (VecAddOp WordVec 64 W8) = 766-primOpTag (VecAddOp WordVec 32 W16) = 767-primOpTag (VecAddOp WordVec 16 W32) = 768-primOpTag (VecAddOp WordVec 8 W64) = 769-primOpTag (VecAddOp FloatVec 4 W32) = 770-primOpTag (VecAddOp FloatVec 2 W64) = 771-primOpTag (VecAddOp FloatVec 8 W32) = 772-primOpTag (VecAddOp FloatVec 4 W64) = 773-primOpTag (VecAddOp FloatVec 16 W32) = 774-primOpTag (VecAddOp FloatVec 8 W64) = 775-primOpTag (VecSubOp IntVec 16 W8) = 776-primOpTag (VecSubOp IntVec 8 W16) = 777-primOpTag (VecSubOp IntVec 4 W32) = 778-primOpTag (VecSubOp IntVec 2 W64) = 779-primOpTag (VecSubOp IntVec 32 W8) = 780-primOpTag (VecSubOp IntVec 16 W16) = 781-primOpTag (VecSubOp IntVec 8 W32) = 782-primOpTag (VecSubOp IntVec 4 W64) = 783-primOpTag (VecSubOp IntVec 64 W8) = 784-primOpTag (VecSubOp IntVec 32 W16) = 785-primOpTag (VecSubOp IntVec 16 W32) = 786-primOpTag (VecSubOp IntVec 8 W64) = 787-primOpTag (VecSubOp WordVec 16 W8) = 788-primOpTag (VecSubOp WordVec 8 W16) = 789-primOpTag (VecSubOp WordVec 4 W32) = 790-primOpTag (VecSubOp WordVec 2 W64) = 791-primOpTag (VecSubOp WordVec 32 W8) = 792-primOpTag (VecSubOp WordVec 16 W16) = 793-primOpTag (VecSubOp WordVec 8 W32) = 794-primOpTag (VecSubOp WordVec 4 W64) = 795-primOpTag (VecSubOp WordVec 64 W8) = 796-primOpTag (VecSubOp WordVec 32 W16) = 797-primOpTag (VecSubOp WordVec 16 W32) = 798-primOpTag (VecSubOp WordVec 8 W64) = 799-primOpTag (VecSubOp FloatVec 4 W32) = 800-primOpTag (VecSubOp FloatVec 2 W64) = 801-primOpTag (VecSubOp FloatVec 8 W32) = 802-primOpTag (VecSubOp FloatVec 4 W64) = 803-primOpTag (VecSubOp FloatVec 16 W32) = 804-primOpTag (VecSubOp FloatVec 8 W64) = 805-primOpTag (VecMulOp IntVec 16 W8) = 806-primOpTag (VecMulOp IntVec 8 W16) = 807-primOpTag (VecMulOp IntVec 4 W32) = 808-primOpTag (VecMulOp IntVec 2 W64) = 809-primOpTag (VecMulOp IntVec 32 W8) = 810-primOpTag (VecMulOp IntVec 16 W16) = 811-primOpTag (VecMulOp IntVec 8 W32) = 812-primOpTag (VecMulOp IntVec 4 W64) = 813-primOpTag (VecMulOp IntVec 64 W8) = 814-primOpTag (VecMulOp IntVec 32 W16) = 815-primOpTag (VecMulOp IntVec 16 W32) = 816-primOpTag (VecMulOp IntVec 8 W64) = 817-primOpTag (VecMulOp WordVec 16 W8) = 818-primOpTag (VecMulOp WordVec 8 W16) = 819-primOpTag (VecMulOp WordVec 4 W32) = 820-primOpTag (VecMulOp WordVec 2 W64) = 821-primOpTag (VecMulOp WordVec 32 W8) = 822-primOpTag (VecMulOp WordVec 16 W16) = 823-primOpTag (VecMulOp WordVec 8 W32) = 824-primOpTag (VecMulOp WordVec 4 W64) = 825-primOpTag (VecMulOp WordVec 64 W8) = 826-primOpTag (VecMulOp WordVec 32 W16) = 827-primOpTag (VecMulOp WordVec 16 W32) = 828-primOpTag (VecMulOp WordVec 8 W64) = 829-primOpTag (VecMulOp FloatVec 4 W32) = 830-primOpTag (VecMulOp FloatVec 2 W64) = 831-primOpTag (VecMulOp FloatVec 8 W32) = 832-primOpTag (VecMulOp FloatVec 4 W64) = 833-primOpTag (VecMulOp FloatVec 16 W32) = 834-primOpTag (VecMulOp FloatVec 8 W64) = 835-primOpTag (VecDivOp FloatVec 4 W32) = 836-primOpTag (VecDivOp FloatVec 2 W64) = 837-primOpTag (VecDivOp FloatVec 8 W32) = 838-primOpTag (VecDivOp FloatVec 4 W64) = 839-primOpTag (VecDivOp FloatVec 16 W32) = 840-primOpTag (VecDivOp FloatVec 8 W64) = 841-primOpTag (VecQuotOp IntVec 16 W8) = 842-primOpTag (VecQuotOp IntVec 8 W16) = 843-primOpTag (VecQuotOp IntVec 4 W32) = 844-primOpTag (VecQuotOp IntVec 2 W64) = 845-primOpTag (VecQuotOp IntVec 32 W8) = 846-primOpTag (VecQuotOp IntVec 16 W16) = 847-primOpTag (VecQuotOp IntVec 8 W32) = 848-primOpTag (VecQuotOp IntVec 4 W64) = 849-primOpTag (VecQuotOp IntVec 64 W8) = 850-primOpTag (VecQuotOp IntVec 32 W16) = 851-primOpTag (VecQuotOp IntVec 16 W32) = 852-primOpTag (VecQuotOp IntVec 8 W64) = 853-primOpTag (VecQuotOp WordVec 16 W8) = 854-primOpTag (VecQuotOp WordVec 8 W16) = 855-primOpTag (VecQuotOp WordVec 4 W32) = 856-primOpTag (VecQuotOp WordVec 2 W64) = 857-primOpTag (VecQuotOp WordVec 32 W8) = 858-primOpTag (VecQuotOp WordVec 16 W16) = 859-primOpTag (VecQuotOp WordVec 8 W32) = 860-primOpTag (VecQuotOp WordVec 4 W64) = 861-primOpTag (VecQuotOp WordVec 64 W8) = 862-primOpTag (VecQuotOp WordVec 32 W16) = 863-primOpTag (VecQuotOp WordVec 16 W32) = 864-primOpTag (VecQuotOp WordVec 8 W64) = 865-primOpTag (VecRemOp IntVec 16 W8) = 866-primOpTag (VecRemOp IntVec 8 W16) = 867-primOpTag (VecRemOp IntVec 4 W32) = 868-primOpTag (VecRemOp IntVec 2 W64) = 869-primOpTag (VecRemOp IntVec 32 W8) = 870-primOpTag (VecRemOp IntVec 16 W16) = 871-primOpTag (VecRemOp IntVec 8 W32) = 872-primOpTag (VecRemOp IntVec 4 W64) = 873-primOpTag (VecRemOp IntVec 64 W8) = 874-primOpTag (VecRemOp IntVec 32 W16) = 875-primOpTag (VecRemOp IntVec 16 W32) = 876-primOpTag (VecRemOp IntVec 8 W64) = 877-primOpTag (VecRemOp WordVec 16 W8) = 878-primOpTag (VecRemOp WordVec 8 W16) = 879-primOpTag (VecRemOp WordVec 4 W32) = 880-primOpTag (VecRemOp WordVec 2 W64) = 881-primOpTag (VecRemOp WordVec 32 W8) = 882-primOpTag (VecRemOp WordVec 16 W16) = 883-primOpTag (VecRemOp WordVec 8 W32) = 884-primOpTag (VecRemOp WordVec 4 W64) = 885-primOpTag (VecRemOp WordVec 64 W8) = 886-primOpTag (VecRemOp WordVec 32 W16) = 887-primOpTag (VecRemOp WordVec 16 W32) = 888-primOpTag (VecRemOp WordVec 8 W64) = 889-primOpTag (VecNegOp IntVec 16 W8) = 890-primOpTag (VecNegOp IntVec 8 W16) = 891-primOpTag (VecNegOp IntVec 4 W32) = 892-primOpTag (VecNegOp IntVec 2 W64) = 893-primOpTag (VecNegOp IntVec 32 W8) = 894-primOpTag (VecNegOp IntVec 16 W16) = 895-primOpTag (VecNegOp IntVec 8 W32) = 896-primOpTag (VecNegOp IntVec 4 W64) = 897-primOpTag (VecNegOp IntVec 64 W8) = 898-primOpTag (VecNegOp IntVec 32 W16) = 899-primOpTag (VecNegOp IntVec 16 W32) = 900-primOpTag (VecNegOp IntVec 8 W64) = 901-primOpTag (VecNegOp FloatVec 4 W32) = 902-primOpTag (VecNegOp FloatVec 2 W64) = 903-primOpTag (VecNegOp FloatVec 8 W32) = 904-primOpTag (VecNegOp FloatVec 4 W64) = 905-primOpTag (VecNegOp FloatVec 16 W32) = 906-primOpTag (VecNegOp FloatVec 8 W64) = 907-primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 908-primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 909-primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 910-primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 911-primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 912-primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 913-primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 914-primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 915-primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 916-primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 917-primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 918-primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 919-primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 920-primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 921-primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 922-primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 923-primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 924-primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 925-primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 926-primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 927-primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 928-primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 929-primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 930-primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 931-primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 932-primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 933-primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 934-primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 935-primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 936-primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 937-primOpTag (VecReadByteArrayOp IntVec 16 W8) = 938-primOpTag (VecReadByteArrayOp IntVec 8 W16) = 939-primOpTag (VecReadByteArrayOp IntVec 4 W32) = 940-primOpTag (VecReadByteArrayOp IntVec 2 W64) = 941-primOpTag (VecReadByteArrayOp IntVec 32 W8) = 942-primOpTag (VecReadByteArrayOp IntVec 16 W16) = 943-primOpTag (VecReadByteArrayOp IntVec 8 W32) = 944-primOpTag (VecReadByteArrayOp IntVec 4 W64) = 945-primOpTag (VecReadByteArrayOp IntVec 64 W8) = 946-primOpTag (VecReadByteArrayOp IntVec 32 W16) = 947-primOpTag (VecReadByteArrayOp IntVec 16 W32) = 948-primOpTag (VecReadByteArrayOp IntVec 8 W64) = 949-primOpTag (VecReadByteArrayOp WordVec 16 W8) = 950-primOpTag (VecReadByteArrayOp WordVec 8 W16) = 951-primOpTag (VecReadByteArrayOp WordVec 4 W32) = 952-primOpTag (VecReadByteArrayOp WordVec 2 W64) = 953-primOpTag (VecReadByteArrayOp WordVec 32 W8) = 954-primOpTag (VecReadByteArrayOp WordVec 16 W16) = 955-primOpTag (VecReadByteArrayOp WordVec 8 W32) = 956-primOpTag (VecReadByteArrayOp WordVec 4 W64) = 957-primOpTag (VecReadByteArrayOp WordVec 64 W8) = 958-primOpTag (VecReadByteArrayOp WordVec 32 W16) = 959-primOpTag (VecReadByteArrayOp WordVec 16 W32) = 960-primOpTag (VecReadByteArrayOp WordVec 8 W64) = 961-primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 962-primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 963-primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 964-primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 965-primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 966-primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 967-primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 968-primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 969-primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 970-primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 971-primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 972-primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 973-primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 974-primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 975-primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 976-primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 977-primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 978-primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 979-primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 980-primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 981-primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 982-primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 983-primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 984-primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 985-primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 986-primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 987-primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 988-primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 989-primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 990-primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 991-primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 992-primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 993-primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 994-primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 995-primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 996-primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 997-primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 998-primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 999-primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 1000-primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 1001-primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 1002-primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 1003-primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 1004-primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 1005-primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 1006-primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 1007-primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 1008-primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 1009-primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 1010-primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 1011-primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 1012-primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 1013-primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 1014-primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 1015-primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 1016-primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 1017-primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 1018-primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 1019-primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 1020-primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 1021-primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 1022-primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 1023-primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 1024-primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 1025-primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 1026-primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 1027-primOpTag (VecReadOffAddrOp IntVec 16 W8) = 1028-primOpTag (VecReadOffAddrOp IntVec 8 W16) = 1029-primOpTag (VecReadOffAddrOp IntVec 4 W32) = 1030-primOpTag (VecReadOffAddrOp IntVec 2 W64) = 1031-primOpTag (VecReadOffAddrOp IntVec 32 W8) = 1032-primOpTag (VecReadOffAddrOp IntVec 16 W16) = 1033-primOpTag (VecReadOffAddrOp IntVec 8 W32) = 1034-primOpTag (VecReadOffAddrOp IntVec 4 W64) = 1035-primOpTag (VecReadOffAddrOp IntVec 64 W8) = 1036-primOpTag (VecReadOffAddrOp IntVec 32 W16) = 1037-primOpTag (VecReadOffAddrOp IntVec 16 W32) = 1038-primOpTag (VecReadOffAddrOp IntVec 8 W64) = 1039-primOpTag (VecReadOffAddrOp WordVec 16 W8) = 1040-primOpTag (VecReadOffAddrOp WordVec 8 W16) = 1041-primOpTag (VecReadOffAddrOp WordVec 4 W32) = 1042-primOpTag (VecReadOffAddrOp WordVec 2 W64) = 1043-primOpTag (VecReadOffAddrOp WordVec 32 W8) = 1044-primOpTag (VecReadOffAddrOp WordVec 16 W16) = 1045-primOpTag (VecReadOffAddrOp WordVec 8 W32) = 1046-primOpTag (VecReadOffAddrOp WordVec 4 W64) = 1047-primOpTag (VecReadOffAddrOp WordVec 64 W8) = 1048-primOpTag (VecReadOffAddrOp WordVec 32 W16) = 1049-primOpTag (VecReadOffAddrOp WordVec 16 W32) = 1050-primOpTag (VecReadOffAddrOp WordVec 8 W64) = 1051-primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 1052-primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 1053-primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 1054-primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 1055-primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 1056-primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 1057-primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 1058-primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 1059-primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 1060-primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 1061-primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 1062-primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 1063-primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 1064-primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 1065-primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 1066-primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 1067-primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 1068-primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 1069-primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 1070-primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 1071-primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 1072-primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 1073-primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 1074-primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 1075-primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 1076-primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 1077-primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 1078-primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 1079-primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 1080-primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 1081-primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 1082-primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 1083-primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 1084-primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 1085-primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 1086-primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 1087-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 1088-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 1089-primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 1090-primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1091-primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1092-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1093-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1094-primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1095-primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1096-primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1097-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1098-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1099-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1100-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1101-primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1102-primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1103-primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1104-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1105-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1106-primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1107-primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1108-primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1109-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1110-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1111-primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1112-primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1113-primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1114-primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1115-primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1116-primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1117-primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1118-primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1119-primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1120-primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1121-primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1122-primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1123-primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1124-primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1125-primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1126-primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1127-primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1128-primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1129-primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1130-primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1131-primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1132-primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1133-primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1134-primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1135-primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1136-primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1137-primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1138-primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1139-primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1140-primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1141-primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1142-primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1143-primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1144-primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1145-primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1146-primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1147-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1148-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1149-primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1150-primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1151-primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1152-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1153-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1154-primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1155-primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1156-primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1157-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1158-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1159-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1160-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1161-primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1162-primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1163-primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1164-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1165-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1166-primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1167-primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1168-primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1169-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1170-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1171-primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1172-primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1173-primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1174-primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1175-primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1176-primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1177-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1178-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1179-primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1180-primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1181-primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1182-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1183-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1184-primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1185-primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1186-primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1187-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1188-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1189-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1190-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1191-primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1192-primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1193-primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1194-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1195-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1196-primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1197-primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1198-primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1199-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1200-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1201-primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1202-primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1203-primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1204-primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1205-primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1206-primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1207-primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1208-primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1209-primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1210-primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1211-primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1212-primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1213-primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1214-primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1215-primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1216-primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1217-primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1218-primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1219-primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1220-primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1221-primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1222-primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1223-primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1224-primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1225-primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1226-primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1227-primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1228-primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1229-primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1230-primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1231-primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1232-primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1233-primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1234-primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1235-primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1236-primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1237-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1238-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1239-primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1240-primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1241-primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1242-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1243-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1244-primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1245-primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1246-primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1247-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1248-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1249-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1250-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1251-primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1252-primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1253-primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1254-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1255-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1256-primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1257-primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1258-primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1259-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1260-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1261-primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1262-primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1263-primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1264-primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1265-primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1266-primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1267-primOpTag PrefetchByteArrayOp3 = 1268-primOpTag PrefetchMutableByteArrayOp3 = 1269-primOpTag PrefetchAddrOp3 = 1270-primOpTag PrefetchValueOp3 = 1271-primOpTag PrefetchByteArrayOp2 = 1272-primOpTag PrefetchMutableByteArrayOp2 = 1273-primOpTag PrefetchAddrOp2 = 1274-primOpTag PrefetchValueOp2 = 1275-primOpTag PrefetchByteArrayOp1 = 1276-primOpTag PrefetchMutableByteArrayOp1 = 1277-primOpTag PrefetchAddrOp1 = 1278-primOpTag PrefetchValueOp1 = 1279-primOpTag PrefetchByteArrayOp0 = 1280-primOpTag PrefetchMutableByteArrayOp0 = 1281-primOpTag PrefetchAddrOp0 = 1282-primOpTag PrefetchValueOp0 = 1283+maxPrimOpTag = 1303+primOpTag :: PrimOp -> Int+primOpTag CharGtOp = 0+primOpTag CharGeOp = 1+primOpTag CharEqOp = 2+primOpTag CharNeOp = 3+primOpTag CharLtOp = 4+primOpTag CharLeOp = 5+primOpTag OrdOp = 6+primOpTag Int8ToIntOp = 7+primOpTag IntToInt8Op = 8+primOpTag Int8NegOp = 9+primOpTag Int8AddOp = 10+primOpTag Int8SubOp = 11+primOpTag Int8MulOp = 12+primOpTag Int8QuotOp = 13+primOpTag Int8RemOp = 14+primOpTag Int8QuotRemOp = 15+primOpTag Int8SllOp = 16+primOpTag Int8SraOp = 17+primOpTag Int8SrlOp = 18+primOpTag Int8ToWord8Op = 19+primOpTag Int8EqOp = 20+primOpTag Int8GeOp = 21+primOpTag Int8GtOp = 22+primOpTag Int8LeOp = 23+primOpTag Int8LtOp = 24+primOpTag Int8NeOp = 25+primOpTag Word8ToWordOp = 26+primOpTag WordToWord8Op = 27+primOpTag Word8AddOp = 28+primOpTag Word8SubOp = 29+primOpTag Word8MulOp = 30+primOpTag Word8QuotOp = 31+primOpTag Word8RemOp = 32+primOpTag Word8QuotRemOp = 33+primOpTag Word8AndOp = 34+primOpTag Word8OrOp = 35+primOpTag Word8XorOp = 36+primOpTag Word8NotOp = 37+primOpTag Word8SllOp = 38+primOpTag Word8SrlOp = 39+primOpTag Word8ToInt8Op = 40+primOpTag Word8EqOp = 41+primOpTag Word8GeOp = 42+primOpTag Word8GtOp = 43+primOpTag Word8LeOp = 44+primOpTag Word8LtOp = 45+primOpTag Word8NeOp = 46+primOpTag Int16ToIntOp = 47+primOpTag IntToInt16Op = 48+primOpTag Int16NegOp = 49+primOpTag Int16AddOp = 50+primOpTag Int16SubOp = 51+primOpTag Int16MulOp = 52+primOpTag Int16QuotOp = 53+primOpTag Int16RemOp = 54+primOpTag Int16QuotRemOp = 55+primOpTag Int16SllOp = 56+primOpTag Int16SraOp = 57+primOpTag Int16SrlOp = 58+primOpTag Int16ToWord16Op = 59+primOpTag Int16EqOp = 60+primOpTag Int16GeOp = 61+primOpTag Int16GtOp = 62+primOpTag Int16LeOp = 63+primOpTag Int16LtOp = 64+primOpTag Int16NeOp = 65+primOpTag Word16ToWordOp = 66+primOpTag WordToWord16Op = 67+primOpTag Word16AddOp = 68+primOpTag Word16SubOp = 69+primOpTag Word16MulOp = 70+primOpTag Word16QuotOp = 71+primOpTag Word16RemOp = 72+primOpTag Word16QuotRemOp = 73+primOpTag Word16AndOp = 74+primOpTag Word16OrOp = 75+primOpTag Word16XorOp = 76+primOpTag Word16NotOp = 77+primOpTag Word16SllOp = 78+primOpTag Word16SrlOp = 79+primOpTag Word16ToInt16Op = 80+primOpTag Word16EqOp = 81+primOpTag Word16GeOp = 82+primOpTag Word16GtOp = 83+primOpTag Word16LeOp = 84+primOpTag Word16LtOp = 85+primOpTag Word16NeOp = 86+primOpTag Int32ToIntOp = 87+primOpTag IntToInt32Op = 88+primOpTag Int32NegOp = 89+primOpTag Int32AddOp = 90+primOpTag Int32SubOp = 91+primOpTag Int32MulOp = 92+primOpTag Int32QuotOp = 93+primOpTag Int32RemOp = 94+primOpTag Int32QuotRemOp = 95+primOpTag Int32SllOp = 96+primOpTag Int32SraOp = 97+primOpTag Int32SrlOp = 98+primOpTag Int32ToWord32Op = 99+primOpTag Int32EqOp = 100+primOpTag Int32GeOp = 101+primOpTag Int32GtOp = 102+primOpTag Int32LeOp = 103+primOpTag Int32LtOp = 104+primOpTag Int32NeOp = 105+primOpTag Word32ToWordOp = 106+primOpTag WordToWord32Op = 107+primOpTag Word32AddOp = 108+primOpTag Word32SubOp = 109+primOpTag Word32MulOp = 110+primOpTag Word32QuotOp = 111+primOpTag Word32RemOp = 112+primOpTag Word32QuotRemOp = 113+primOpTag Word32AndOp = 114+primOpTag Word32OrOp = 115+primOpTag Word32XorOp = 116+primOpTag Word32NotOp = 117+primOpTag Word32SllOp = 118+primOpTag Word32SrlOp = 119+primOpTag Word32ToInt32Op = 120+primOpTag Word32EqOp = 121+primOpTag Word32GeOp = 122+primOpTag Word32GtOp = 123+primOpTag Word32LeOp = 124+primOpTag Word32LtOp = 125+primOpTag Word32NeOp = 126+primOpTag Int64ToIntOp = 127+primOpTag IntToInt64Op = 128+primOpTag Int64NegOp = 129+primOpTag Int64AddOp = 130+primOpTag Int64SubOp = 131+primOpTag Int64MulOp = 132+primOpTag Int64QuotOp = 133+primOpTag Int64RemOp = 134+primOpTag Int64SllOp = 135+primOpTag Int64SraOp = 136+primOpTag Int64SrlOp = 137+primOpTag Int64ToWord64Op = 138+primOpTag Int64EqOp = 139+primOpTag Int64GeOp = 140+primOpTag Int64GtOp = 141+primOpTag Int64LeOp = 142+primOpTag Int64LtOp = 143+primOpTag Int64NeOp = 144+primOpTag Word64ToWordOp = 145+primOpTag WordToWord64Op = 146+primOpTag Word64AddOp = 147+primOpTag Word64SubOp = 148+primOpTag Word64MulOp = 149+primOpTag Word64QuotOp = 150+primOpTag Word64RemOp = 151+primOpTag Word64AndOp = 152+primOpTag Word64OrOp = 153+primOpTag Word64XorOp = 154+primOpTag Word64NotOp = 155+primOpTag Word64SllOp = 156+primOpTag Word64SrlOp = 157+primOpTag Word64ToInt64Op = 158+primOpTag Word64EqOp = 159+primOpTag Word64GeOp = 160+primOpTag Word64GtOp = 161+primOpTag Word64LeOp = 162+primOpTag Word64LtOp = 163+primOpTag Word64NeOp = 164+primOpTag IntAddOp = 165+primOpTag IntSubOp = 166+primOpTag IntMulOp = 167+primOpTag IntMul2Op = 168+primOpTag IntMulMayOfloOp = 169+primOpTag IntQuotOp = 170+primOpTag IntRemOp = 171+primOpTag IntQuotRemOp = 172+primOpTag IntAndOp = 173+primOpTag IntOrOp = 174+primOpTag IntXorOp = 175+primOpTag IntNotOp = 176+primOpTag IntNegOp = 177+primOpTag IntAddCOp = 178+primOpTag IntSubCOp = 179+primOpTag IntGtOp = 180+primOpTag IntGeOp = 181+primOpTag IntEqOp = 182+primOpTag IntNeOp = 183+primOpTag IntLtOp = 184+primOpTag IntLeOp = 185+primOpTag ChrOp = 186+primOpTag IntToWordOp = 187+primOpTag IntToFloatOp = 188+primOpTag IntToDoubleOp = 189+primOpTag WordToFloatOp = 190+primOpTag WordToDoubleOp = 191+primOpTag IntSllOp = 192+primOpTag IntSraOp = 193+primOpTag IntSrlOp = 194+primOpTag WordAddOp = 195+primOpTag WordAddCOp = 196+primOpTag WordSubCOp = 197+primOpTag WordAdd2Op = 198+primOpTag WordSubOp = 199+primOpTag WordMulOp = 200+primOpTag WordMul2Op = 201+primOpTag WordQuotOp = 202+primOpTag WordRemOp = 203+primOpTag WordQuotRemOp = 204+primOpTag WordQuotRem2Op = 205+primOpTag WordAndOp = 206+primOpTag WordOrOp = 207+primOpTag WordXorOp = 208+primOpTag WordNotOp = 209+primOpTag WordSllOp = 210+primOpTag WordSrlOp = 211+primOpTag WordToIntOp = 212+primOpTag WordGtOp = 213+primOpTag WordGeOp = 214+primOpTag WordEqOp = 215+primOpTag WordNeOp = 216+primOpTag WordLtOp = 217+primOpTag WordLeOp = 218+primOpTag PopCnt8Op = 219+primOpTag PopCnt16Op = 220+primOpTag PopCnt32Op = 221+primOpTag PopCnt64Op = 222+primOpTag PopCntOp = 223+primOpTag Pdep8Op = 224+primOpTag Pdep16Op = 225+primOpTag Pdep32Op = 226+primOpTag Pdep64Op = 227+primOpTag PdepOp = 228+primOpTag Pext8Op = 229+primOpTag Pext16Op = 230+primOpTag Pext32Op = 231+primOpTag Pext64Op = 232+primOpTag PextOp = 233+primOpTag Clz8Op = 234+primOpTag Clz16Op = 235+primOpTag Clz32Op = 236+primOpTag Clz64Op = 237+primOpTag ClzOp = 238+primOpTag Ctz8Op = 239+primOpTag Ctz16Op = 240+primOpTag Ctz32Op = 241+primOpTag Ctz64Op = 242+primOpTag CtzOp = 243+primOpTag BSwap16Op = 244+primOpTag BSwap32Op = 245+primOpTag BSwap64Op = 246+primOpTag BSwapOp = 247+primOpTag BRev8Op = 248+primOpTag BRev16Op = 249+primOpTag BRev32Op = 250+primOpTag BRev64Op = 251+primOpTag BRevOp = 252+primOpTag Narrow8IntOp = 253+primOpTag Narrow16IntOp = 254+primOpTag Narrow32IntOp = 255+primOpTag Narrow8WordOp = 256+primOpTag Narrow16WordOp = 257+primOpTag Narrow32WordOp = 258+primOpTag DoubleGtOp = 259+primOpTag DoubleGeOp = 260+primOpTag DoubleEqOp = 261+primOpTag DoubleNeOp = 262+primOpTag DoubleLtOp = 263+primOpTag DoubleLeOp = 264+primOpTag DoubleAddOp = 265+primOpTag DoubleSubOp = 266+primOpTag DoubleMulOp = 267+primOpTag DoubleDivOp = 268+primOpTag DoubleNegOp = 269+primOpTag DoubleFabsOp = 270+primOpTag DoubleToIntOp = 271+primOpTag DoubleToFloatOp = 272+primOpTag DoubleExpOp = 273+primOpTag DoubleExpM1Op = 274+primOpTag DoubleLogOp = 275+primOpTag DoubleLog1POp = 276+primOpTag DoubleSqrtOp = 277+primOpTag DoubleSinOp = 278+primOpTag DoubleCosOp = 279+primOpTag DoubleTanOp = 280+primOpTag DoubleAsinOp = 281+primOpTag DoubleAcosOp = 282+primOpTag DoubleAtanOp = 283+primOpTag DoubleSinhOp = 284+primOpTag DoubleCoshOp = 285+primOpTag DoubleTanhOp = 286+primOpTag DoubleAsinhOp = 287+primOpTag DoubleAcoshOp = 288+primOpTag DoubleAtanhOp = 289+primOpTag DoublePowerOp = 290+primOpTag DoubleDecode_2IntOp = 291+primOpTag DoubleDecode_Int64Op = 292+primOpTag FloatGtOp = 293+primOpTag FloatGeOp = 294+primOpTag FloatEqOp = 295+primOpTag FloatNeOp = 296+primOpTag FloatLtOp = 297+primOpTag FloatLeOp = 298+primOpTag FloatAddOp = 299+primOpTag FloatSubOp = 300+primOpTag FloatMulOp = 301+primOpTag FloatDivOp = 302+primOpTag FloatNegOp = 303+primOpTag FloatFabsOp = 304+primOpTag FloatToIntOp = 305+primOpTag FloatExpOp = 306+primOpTag FloatExpM1Op = 307+primOpTag FloatLogOp = 308+primOpTag FloatLog1POp = 309+primOpTag FloatSqrtOp = 310+primOpTag FloatSinOp = 311+primOpTag FloatCosOp = 312+primOpTag FloatTanOp = 313+primOpTag FloatAsinOp = 314+primOpTag FloatAcosOp = 315+primOpTag FloatAtanOp = 316+primOpTag FloatSinhOp = 317+primOpTag FloatCoshOp = 318+primOpTag FloatTanhOp = 319+primOpTag FloatAsinhOp = 320+primOpTag FloatAcoshOp = 321+primOpTag FloatAtanhOp = 322+primOpTag FloatPowerOp = 323+primOpTag FloatToDoubleOp = 324+primOpTag FloatDecode_IntOp = 325+primOpTag NewArrayOp = 326+primOpTag ReadArrayOp = 327+primOpTag WriteArrayOp = 328+primOpTag SizeofArrayOp = 329+primOpTag SizeofMutableArrayOp = 330+primOpTag IndexArrayOp = 331+primOpTag UnsafeFreezeArrayOp = 332+primOpTag UnsafeThawArrayOp = 333+primOpTag CopyArrayOp = 334+primOpTag CopyMutableArrayOp = 335+primOpTag CloneArrayOp = 336+primOpTag CloneMutableArrayOp = 337+primOpTag FreezeArrayOp = 338+primOpTag ThawArrayOp = 339+primOpTag CasArrayOp = 340+primOpTag NewSmallArrayOp = 341+primOpTag ShrinkSmallMutableArrayOp_Char = 342+primOpTag ReadSmallArrayOp = 343+primOpTag WriteSmallArrayOp = 344+primOpTag SizeofSmallArrayOp = 345+primOpTag SizeofSmallMutableArrayOp = 346+primOpTag GetSizeofSmallMutableArrayOp = 347+primOpTag IndexSmallArrayOp = 348+primOpTag UnsafeFreezeSmallArrayOp = 349+primOpTag UnsafeThawSmallArrayOp = 350+primOpTag CopySmallArrayOp = 351+primOpTag CopySmallMutableArrayOp = 352+primOpTag CloneSmallArrayOp = 353+primOpTag CloneSmallMutableArrayOp = 354+primOpTag FreezeSmallArrayOp = 355+primOpTag ThawSmallArrayOp = 356+primOpTag CasSmallArrayOp = 357+primOpTag NewByteArrayOp_Char = 358+primOpTag NewPinnedByteArrayOp_Char = 359+primOpTag NewAlignedPinnedByteArrayOp_Char = 360+primOpTag MutableByteArrayIsPinnedOp = 361+primOpTag ByteArrayIsPinnedOp = 362+primOpTag ByteArrayContents_Char = 363+primOpTag MutableByteArrayContents_Char = 364+primOpTag ShrinkMutableByteArrayOp_Char = 365+primOpTag ResizeMutableByteArrayOp_Char = 366+primOpTag UnsafeFreezeByteArrayOp = 367+primOpTag SizeofByteArrayOp = 368+primOpTag SizeofMutableByteArrayOp = 369+primOpTag GetSizeofMutableByteArrayOp = 370+primOpTag IndexByteArrayOp_Char = 371+primOpTag IndexByteArrayOp_WideChar = 372+primOpTag IndexByteArrayOp_Int = 373+primOpTag IndexByteArrayOp_Word = 374+primOpTag IndexByteArrayOp_Addr = 375+primOpTag IndexByteArrayOp_Float = 376+primOpTag IndexByteArrayOp_Double = 377+primOpTag IndexByteArrayOp_StablePtr = 378+primOpTag IndexByteArrayOp_Int8 = 379+primOpTag IndexByteArrayOp_Int16 = 380+primOpTag IndexByteArrayOp_Int32 = 381+primOpTag IndexByteArrayOp_Int64 = 382+primOpTag IndexByteArrayOp_Word8 = 383+primOpTag IndexByteArrayOp_Word16 = 384+primOpTag IndexByteArrayOp_Word32 = 385+primOpTag IndexByteArrayOp_Word64 = 386+primOpTag IndexByteArrayOp_Word8AsChar = 387+primOpTag IndexByteArrayOp_Word8AsWideChar = 388+primOpTag IndexByteArrayOp_Word8AsInt = 389+primOpTag IndexByteArrayOp_Word8AsWord = 390+primOpTag IndexByteArrayOp_Word8AsAddr = 391+primOpTag IndexByteArrayOp_Word8AsFloat = 392+primOpTag IndexByteArrayOp_Word8AsDouble = 393+primOpTag IndexByteArrayOp_Word8AsStablePtr = 394+primOpTag IndexByteArrayOp_Word8AsInt16 = 395+primOpTag IndexByteArrayOp_Word8AsInt32 = 396+primOpTag IndexByteArrayOp_Word8AsInt64 = 397+primOpTag IndexByteArrayOp_Word8AsWord16 = 398+primOpTag IndexByteArrayOp_Word8AsWord32 = 399+primOpTag IndexByteArrayOp_Word8AsWord64 = 400+primOpTag ReadByteArrayOp_Char = 401+primOpTag ReadByteArrayOp_WideChar = 402+primOpTag ReadByteArrayOp_Int = 403+primOpTag ReadByteArrayOp_Word = 404+primOpTag ReadByteArrayOp_Addr = 405+primOpTag ReadByteArrayOp_Float = 406+primOpTag ReadByteArrayOp_Double = 407+primOpTag ReadByteArrayOp_StablePtr = 408+primOpTag ReadByteArrayOp_Int8 = 409+primOpTag ReadByteArrayOp_Int16 = 410+primOpTag ReadByteArrayOp_Int32 = 411+primOpTag ReadByteArrayOp_Int64 = 412+primOpTag ReadByteArrayOp_Word8 = 413+primOpTag ReadByteArrayOp_Word16 = 414+primOpTag ReadByteArrayOp_Word32 = 415+primOpTag ReadByteArrayOp_Word64 = 416+primOpTag ReadByteArrayOp_Word8AsChar = 417+primOpTag ReadByteArrayOp_Word8AsWideChar = 418+primOpTag ReadByteArrayOp_Word8AsInt = 419+primOpTag ReadByteArrayOp_Word8AsWord = 420+primOpTag ReadByteArrayOp_Word8AsAddr = 421+primOpTag ReadByteArrayOp_Word8AsFloat = 422+primOpTag ReadByteArrayOp_Word8AsDouble = 423+primOpTag ReadByteArrayOp_Word8AsStablePtr = 424+primOpTag ReadByteArrayOp_Word8AsInt16 = 425+primOpTag ReadByteArrayOp_Word8AsInt32 = 426+primOpTag ReadByteArrayOp_Word8AsInt64 = 427+primOpTag ReadByteArrayOp_Word8AsWord16 = 428+primOpTag ReadByteArrayOp_Word8AsWord32 = 429+primOpTag ReadByteArrayOp_Word8AsWord64 = 430+primOpTag WriteByteArrayOp_Char = 431+primOpTag WriteByteArrayOp_WideChar = 432+primOpTag WriteByteArrayOp_Int = 433+primOpTag WriteByteArrayOp_Word = 434+primOpTag WriteByteArrayOp_Addr = 435+primOpTag WriteByteArrayOp_Float = 436+primOpTag WriteByteArrayOp_Double = 437+primOpTag WriteByteArrayOp_StablePtr = 438+primOpTag WriteByteArrayOp_Int8 = 439+primOpTag WriteByteArrayOp_Int16 = 440+primOpTag WriteByteArrayOp_Int32 = 441+primOpTag WriteByteArrayOp_Int64 = 442+primOpTag WriteByteArrayOp_Word8 = 443+primOpTag WriteByteArrayOp_Word16 = 444+primOpTag WriteByteArrayOp_Word32 = 445+primOpTag WriteByteArrayOp_Word64 = 446+primOpTag WriteByteArrayOp_Word8AsChar = 447+primOpTag WriteByteArrayOp_Word8AsWideChar = 448+primOpTag WriteByteArrayOp_Word8AsInt = 449+primOpTag WriteByteArrayOp_Word8AsWord = 450+primOpTag WriteByteArrayOp_Word8AsAddr = 451+primOpTag WriteByteArrayOp_Word8AsFloat = 452+primOpTag WriteByteArrayOp_Word8AsDouble = 453+primOpTag WriteByteArrayOp_Word8AsStablePtr = 454+primOpTag WriteByteArrayOp_Word8AsInt16 = 455+primOpTag WriteByteArrayOp_Word8AsInt32 = 456+primOpTag WriteByteArrayOp_Word8AsInt64 = 457+primOpTag WriteByteArrayOp_Word8AsWord16 = 458+primOpTag WriteByteArrayOp_Word8AsWord32 = 459+primOpTag WriteByteArrayOp_Word8AsWord64 = 460+primOpTag CompareByteArraysOp = 461+primOpTag CopyByteArrayOp = 462+primOpTag CopyMutableByteArrayOp = 463+primOpTag CopyByteArrayToAddrOp = 464+primOpTag CopyMutableByteArrayToAddrOp = 465+primOpTag CopyAddrToByteArrayOp = 466+primOpTag SetByteArrayOp = 467+primOpTag AtomicReadByteArrayOp_Int = 468+primOpTag AtomicWriteByteArrayOp_Int = 469+primOpTag CasByteArrayOp_Int = 470+primOpTag CasByteArrayOp_Int8 = 471+primOpTag CasByteArrayOp_Int16 = 472+primOpTag CasByteArrayOp_Int32 = 473+primOpTag CasByteArrayOp_Int64 = 474+primOpTag FetchAddByteArrayOp_Int = 475+primOpTag FetchSubByteArrayOp_Int = 476+primOpTag FetchAndByteArrayOp_Int = 477+primOpTag FetchNandByteArrayOp_Int = 478+primOpTag FetchOrByteArrayOp_Int = 479+primOpTag FetchXorByteArrayOp_Int = 480+primOpTag AddrAddOp = 481+primOpTag AddrSubOp = 482+primOpTag AddrRemOp = 483+primOpTag AddrToIntOp = 484+primOpTag IntToAddrOp = 485+primOpTag AddrGtOp = 486+primOpTag AddrGeOp = 487+primOpTag AddrEqOp = 488+primOpTag AddrNeOp = 489+primOpTag AddrLtOp = 490+primOpTag AddrLeOp = 491+primOpTag IndexOffAddrOp_Char = 492+primOpTag IndexOffAddrOp_WideChar = 493+primOpTag IndexOffAddrOp_Int = 494+primOpTag IndexOffAddrOp_Word = 495+primOpTag IndexOffAddrOp_Addr = 496+primOpTag IndexOffAddrOp_Float = 497+primOpTag IndexOffAddrOp_Double = 498+primOpTag IndexOffAddrOp_StablePtr = 499+primOpTag IndexOffAddrOp_Int8 = 500+primOpTag IndexOffAddrOp_Int16 = 501+primOpTag IndexOffAddrOp_Int32 = 502+primOpTag IndexOffAddrOp_Int64 = 503+primOpTag IndexOffAddrOp_Word8 = 504+primOpTag IndexOffAddrOp_Word16 = 505+primOpTag IndexOffAddrOp_Word32 = 506+primOpTag IndexOffAddrOp_Word64 = 507+primOpTag ReadOffAddrOp_Char = 508+primOpTag ReadOffAddrOp_WideChar = 509+primOpTag ReadOffAddrOp_Int = 510+primOpTag ReadOffAddrOp_Word = 511+primOpTag ReadOffAddrOp_Addr = 512+primOpTag ReadOffAddrOp_Float = 513+primOpTag ReadOffAddrOp_Double = 514+primOpTag ReadOffAddrOp_StablePtr = 515+primOpTag ReadOffAddrOp_Int8 = 516+primOpTag ReadOffAddrOp_Int16 = 517+primOpTag ReadOffAddrOp_Int32 = 518+primOpTag ReadOffAddrOp_Int64 = 519+primOpTag ReadOffAddrOp_Word8 = 520+primOpTag ReadOffAddrOp_Word16 = 521+primOpTag ReadOffAddrOp_Word32 = 522+primOpTag ReadOffAddrOp_Word64 = 523+primOpTag WriteOffAddrOp_Char = 524+primOpTag WriteOffAddrOp_WideChar = 525+primOpTag WriteOffAddrOp_Int = 526+primOpTag WriteOffAddrOp_Word = 527+primOpTag WriteOffAddrOp_Addr = 528+primOpTag WriteOffAddrOp_Float = 529+primOpTag WriteOffAddrOp_Double = 530+primOpTag WriteOffAddrOp_StablePtr = 531+primOpTag WriteOffAddrOp_Int8 = 532+primOpTag WriteOffAddrOp_Int16 = 533+primOpTag WriteOffAddrOp_Int32 = 534+primOpTag WriteOffAddrOp_Int64 = 535+primOpTag WriteOffAddrOp_Word8 = 536+primOpTag WriteOffAddrOp_Word16 = 537+primOpTag WriteOffAddrOp_Word32 = 538+primOpTag WriteOffAddrOp_Word64 = 539+primOpTag InterlockedExchange_Addr = 540+primOpTag InterlockedExchange_Word = 541+primOpTag CasAddrOp_Addr = 542+primOpTag CasAddrOp_Word = 543+primOpTag CasAddrOp_Word8 = 544+primOpTag CasAddrOp_Word16 = 545+primOpTag CasAddrOp_Word32 = 546+primOpTag CasAddrOp_Word64 = 547+primOpTag FetchAddAddrOp_Word = 548+primOpTag FetchSubAddrOp_Word = 549+primOpTag FetchAndAddrOp_Word = 550+primOpTag FetchNandAddrOp_Word = 551+primOpTag FetchOrAddrOp_Word = 552+primOpTag FetchXorAddrOp_Word = 553+primOpTag AtomicReadAddrOp_Word = 554+primOpTag AtomicWriteAddrOp_Word = 555+primOpTag NewMutVarOp = 556+primOpTag ReadMutVarOp = 557+primOpTag WriteMutVarOp = 558+primOpTag AtomicModifyMutVar2Op = 559+primOpTag AtomicModifyMutVar_Op = 560+primOpTag CasMutVarOp = 561+primOpTag CatchOp = 562+primOpTag RaiseOp = 563+primOpTag RaiseIOOp = 564+primOpTag MaskAsyncExceptionsOp = 565+primOpTag MaskUninterruptibleOp = 566+primOpTag UnmaskAsyncExceptionsOp = 567+primOpTag MaskStatus = 568+primOpTag AtomicallyOp = 569+primOpTag RetryOp = 570+primOpTag CatchRetryOp = 571+primOpTag CatchSTMOp = 572+primOpTag NewTVarOp = 573+primOpTag ReadTVarOp = 574+primOpTag ReadTVarIOOp = 575+primOpTag WriteTVarOp = 576+primOpTag NewMVarOp = 577+primOpTag TakeMVarOp = 578+primOpTag TryTakeMVarOp = 579+primOpTag PutMVarOp = 580+primOpTag TryPutMVarOp = 581+primOpTag ReadMVarOp = 582+primOpTag TryReadMVarOp = 583+primOpTag IsEmptyMVarOp = 584+primOpTag NewIOPortOp = 585+primOpTag ReadIOPortOp = 586+primOpTag WriteIOPortOp = 587+primOpTag DelayOp = 588+primOpTag WaitReadOp = 589+primOpTag WaitWriteOp = 590+primOpTag ForkOp = 591+primOpTag ForkOnOp = 592+primOpTag KillThreadOp = 593+primOpTag YieldOp = 594+primOpTag MyThreadIdOp = 595+primOpTag LabelThreadOp = 596+primOpTag IsCurrentThreadBoundOp = 597+primOpTag NoDuplicateOp = 598+primOpTag ThreadStatusOp = 599+primOpTag MkWeakOp = 600+primOpTag MkWeakNoFinalizerOp = 601+primOpTag AddCFinalizerToWeakOp = 602+primOpTag DeRefWeakOp = 603+primOpTag FinalizeWeakOp = 604+primOpTag TouchOp = 605+primOpTag MakeStablePtrOp = 606+primOpTag DeRefStablePtrOp = 607+primOpTag EqStablePtrOp = 608+primOpTag MakeStableNameOp = 609+primOpTag StableNameToIntOp = 610+primOpTag CompactNewOp = 611+primOpTag CompactResizeOp = 612+primOpTag CompactContainsOp = 613+primOpTag CompactContainsAnyOp = 614+primOpTag CompactGetFirstBlockOp = 615+primOpTag CompactGetNextBlockOp = 616+primOpTag CompactAllocateBlockOp = 617+primOpTag CompactFixupPointersOp = 618+primOpTag CompactAdd = 619+primOpTag CompactAddWithSharing = 620+primOpTag CompactSize = 621+primOpTag ReallyUnsafePtrEqualityOp = 622+primOpTag ParOp = 623+primOpTag SparkOp = 624+primOpTag SeqOp = 625+primOpTag GetSparkOp = 626+primOpTag NumSparks = 627+primOpTag KeepAliveOp = 628+primOpTag DataToTagOp = 629+primOpTag TagToEnumOp = 630+primOpTag AddrToAnyOp = 631+primOpTag AnyToAddrOp = 632+primOpTag MkApUpd0_Op = 633+primOpTag NewBCOOp = 634+primOpTag UnpackClosureOp = 635+primOpTag ClosureSizeOp = 636+primOpTag GetApStackValOp = 637+primOpTag GetCCSOfOp = 638+primOpTag GetCurrentCCSOp = 639+primOpTag ClearCCSOp = 640+primOpTag WhereFromOp = 641+primOpTag TraceEventOp = 642+primOpTag TraceEventBinaryOp = 643+primOpTag TraceMarkerOp = 644+primOpTag SetThreadAllocationCounter = 645+primOpTag (VecBroadcastOp IntVec 16 W8) = 646+primOpTag (VecBroadcastOp IntVec 8 W16) = 647+primOpTag (VecBroadcastOp IntVec 4 W32) = 648+primOpTag (VecBroadcastOp IntVec 2 W64) = 649+primOpTag (VecBroadcastOp IntVec 32 W8) = 650+primOpTag (VecBroadcastOp IntVec 16 W16) = 651+primOpTag (VecBroadcastOp IntVec 8 W32) = 652+primOpTag (VecBroadcastOp IntVec 4 W64) = 653+primOpTag (VecBroadcastOp IntVec 64 W8) = 654+primOpTag (VecBroadcastOp IntVec 32 W16) = 655+primOpTag (VecBroadcastOp IntVec 16 W32) = 656+primOpTag (VecBroadcastOp IntVec 8 W64) = 657+primOpTag (VecBroadcastOp WordVec 16 W8) = 658+primOpTag (VecBroadcastOp WordVec 8 W16) = 659+primOpTag (VecBroadcastOp WordVec 4 W32) = 660+primOpTag (VecBroadcastOp WordVec 2 W64) = 661+primOpTag (VecBroadcastOp WordVec 32 W8) = 662+primOpTag (VecBroadcastOp WordVec 16 W16) = 663+primOpTag (VecBroadcastOp WordVec 8 W32) = 664+primOpTag (VecBroadcastOp WordVec 4 W64) = 665+primOpTag (VecBroadcastOp WordVec 64 W8) = 666+primOpTag (VecBroadcastOp WordVec 32 W16) = 667+primOpTag (VecBroadcastOp WordVec 16 W32) = 668+primOpTag (VecBroadcastOp WordVec 8 W64) = 669+primOpTag (VecBroadcastOp FloatVec 4 W32) = 670+primOpTag (VecBroadcastOp FloatVec 2 W64) = 671+primOpTag (VecBroadcastOp FloatVec 8 W32) = 672+primOpTag (VecBroadcastOp FloatVec 4 W64) = 673+primOpTag (VecBroadcastOp FloatVec 16 W32) = 674+primOpTag (VecBroadcastOp FloatVec 8 W64) = 675+primOpTag (VecPackOp IntVec 16 W8) = 676+primOpTag (VecPackOp IntVec 8 W16) = 677+primOpTag (VecPackOp IntVec 4 W32) = 678+primOpTag (VecPackOp IntVec 2 W64) = 679+primOpTag (VecPackOp IntVec 32 W8) = 680+primOpTag (VecPackOp IntVec 16 W16) = 681+primOpTag (VecPackOp IntVec 8 W32) = 682+primOpTag (VecPackOp IntVec 4 W64) = 683+primOpTag (VecPackOp IntVec 64 W8) = 684+primOpTag (VecPackOp IntVec 32 W16) = 685+primOpTag (VecPackOp IntVec 16 W32) = 686+primOpTag (VecPackOp IntVec 8 W64) = 687+primOpTag (VecPackOp WordVec 16 W8) = 688+primOpTag (VecPackOp WordVec 8 W16) = 689+primOpTag (VecPackOp WordVec 4 W32) = 690+primOpTag (VecPackOp WordVec 2 W64) = 691+primOpTag (VecPackOp WordVec 32 W8) = 692+primOpTag (VecPackOp WordVec 16 W16) = 693+primOpTag (VecPackOp WordVec 8 W32) = 694+primOpTag (VecPackOp WordVec 4 W64) = 695+primOpTag (VecPackOp WordVec 64 W8) = 696+primOpTag (VecPackOp WordVec 32 W16) = 697+primOpTag (VecPackOp WordVec 16 W32) = 698+primOpTag (VecPackOp WordVec 8 W64) = 699+primOpTag (VecPackOp FloatVec 4 W32) = 700+primOpTag (VecPackOp FloatVec 2 W64) = 701+primOpTag (VecPackOp FloatVec 8 W32) = 702+primOpTag (VecPackOp FloatVec 4 W64) = 703+primOpTag (VecPackOp FloatVec 16 W32) = 704+primOpTag (VecPackOp FloatVec 8 W64) = 705+primOpTag (VecUnpackOp IntVec 16 W8) = 706+primOpTag (VecUnpackOp IntVec 8 W16) = 707+primOpTag (VecUnpackOp IntVec 4 W32) = 708+primOpTag (VecUnpackOp IntVec 2 W64) = 709+primOpTag (VecUnpackOp IntVec 32 W8) = 710+primOpTag (VecUnpackOp IntVec 16 W16) = 711+primOpTag (VecUnpackOp IntVec 8 W32) = 712+primOpTag (VecUnpackOp IntVec 4 W64) = 713+primOpTag (VecUnpackOp IntVec 64 W8) = 714+primOpTag (VecUnpackOp IntVec 32 W16) = 715+primOpTag (VecUnpackOp IntVec 16 W32) = 716+primOpTag (VecUnpackOp IntVec 8 W64) = 717+primOpTag (VecUnpackOp WordVec 16 W8) = 718+primOpTag (VecUnpackOp WordVec 8 W16) = 719+primOpTag (VecUnpackOp WordVec 4 W32) = 720+primOpTag (VecUnpackOp WordVec 2 W64) = 721+primOpTag (VecUnpackOp WordVec 32 W8) = 722+primOpTag (VecUnpackOp WordVec 16 W16) = 723+primOpTag (VecUnpackOp WordVec 8 W32) = 724+primOpTag (VecUnpackOp WordVec 4 W64) = 725+primOpTag (VecUnpackOp WordVec 64 W8) = 726+primOpTag (VecUnpackOp WordVec 32 W16) = 727+primOpTag (VecUnpackOp WordVec 16 W32) = 728+primOpTag (VecUnpackOp WordVec 8 W64) = 729+primOpTag (VecUnpackOp FloatVec 4 W32) = 730+primOpTag (VecUnpackOp FloatVec 2 W64) = 731+primOpTag (VecUnpackOp FloatVec 8 W32) = 732+primOpTag (VecUnpackOp FloatVec 4 W64) = 733+primOpTag (VecUnpackOp FloatVec 16 W32) = 734+primOpTag (VecUnpackOp FloatVec 8 W64) = 735+primOpTag (VecInsertOp IntVec 16 W8) = 736+primOpTag (VecInsertOp IntVec 8 W16) = 737+primOpTag (VecInsertOp IntVec 4 W32) = 738+primOpTag (VecInsertOp IntVec 2 W64) = 739+primOpTag (VecInsertOp IntVec 32 W8) = 740+primOpTag (VecInsertOp IntVec 16 W16) = 741+primOpTag (VecInsertOp IntVec 8 W32) = 742+primOpTag (VecInsertOp IntVec 4 W64) = 743+primOpTag (VecInsertOp IntVec 64 W8) = 744+primOpTag (VecInsertOp IntVec 32 W16) = 745+primOpTag (VecInsertOp IntVec 16 W32) = 746+primOpTag (VecInsertOp IntVec 8 W64) = 747+primOpTag (VecInsertOp WordVec 16 W8) = 748+primOpTag (VecInsertOp WordVec 8 W16) = 749+primOpTag (VecInsertOp WordVec 4 W32) = 750+primOpTag (VecInsertOp WordVec 2 W64) = 751+primOpTag (VecInsertOp WordVec 32 W8) = 752+primOpTag (VecInsertOp WordVec 16 W16) = 753+primOpTag (VecInsertOp WordVec 8 W32) = 754+primOpTag (VecInsertOp WordVec 4 W64) = 755+primOpTag (VecInsertOp WordVec 64 W8) = 756+primOpTag (VecInsertOp WordVec 32 W16) = 757+primOpTag (VecInsertOp WordVec 16 W32) = 758+primOpTag (VecInsertOp WordVec 8 W64) = 759+primOpTag (VecInsertOp FloatVec 4 W32) = 760+primOpTag (VecInsertOp FloatVec 2 W64) = 761+primOpTag (VecInsertOp FloatVec 8 W32) = 762+primOpTag (VecInsertOp FloatVec 4 W64) = 763+primOpTag (VecInsertOp FloatVec 16 W32) = 764+primOpTag (VecInsertOp FloatVec 8 W64) = 765+primOpTag (VecAddOp IntVec 16 W8) = 766+primOpTag (VecAddOp IntVec 8 W16) = 767+primOpTag (VecAddOp IntVec 4 W32) = 768+primOpTag (VecAddOp IntVec 2 W64) = 769+primOpTag (VecAddOp IntVec 32 W8) = 770+primOpTag (VecAddOp IntVec 16 W16) = 771+primOpTag (VecAddOp IntVec 8 W32) = 772+primOpTag (VecAddOp IntVec 4 W64) = 773+primOpTag (VecAddOp IntVec 64 W8) = 774+primOpTag (VecAddOp IntVec 32 W16) = 775+primOpTag (VecAddOp IntVec 16 W32) = 776+primOpTag (VecAddOp IntVec 8 W64) = 777+primOpTag (VecAddOp WordVec 16 W8) = 778+primOpTag (VecAddOp WordVec 8 W16) = 779+primOpTag (VecAddOp WordVec 4 W32) = 780+primOpTag (VecAddOp WordVec 2 W64) = 781+primOpTag (VecAddOp WordVec 32 W8) = 782+primOpTag (VecAddOp WordVec 16 W16) = 783+primOpTag (VecAddOp WordVec 8 W32) = 784+primOpTag (VecAddOp WordVec 4 W64) = 785+primOpTag (VecAddOp WordVec 64 W8) = 786+primOpTag (VecAddOp WordVec 32 W16) = 787+primOpTag (VecAddOp WordVec 16 W32) = 788+primOpTag (VecAddOp WordVec 8 W64) = 789+primOpTag (VecAddOp FloatVec 4 W32) = 790+primOpTag (VecAddOp FloatVec 2 W64) = 791+primOpTag (VecAddOp FloatVec 8 W32) = 792+primOpTag (VecAddOp FloatVec 4 W64) = 793+primOpTag (VecAddOp FloatVec 16 W32) = 794+primOpTag (VecAddOp FloatVec 8 W64) = 795+primOpTag (VecSubOp IntVec 16 W8) = 796+primOpTag (VecSubOp IntVec 8 W16) = 797+primOpTag (VecSubOp IntVec 4 W32) = 798+primOpTag (VecSubOp IntVec 2 W64) = 799+primOpTag (VecSubOp IntVec 32 W8) = 800+primOpTag (VecSubOp IntVec 16 W16) = 801+primOpTag (VecSubOp IntVec 8 W32) = 802+primOpTag (VecSubOp IntVec 4 W64) = 803+primOpTag (VecSubOp IntVec 64 W8) = 804+primOpTag (VecSubOp IntVec 32 W16) = 805+primOpTag (VecSubOp IntVec 16 W32) = 806+primOpTag (VecSubOp IntVec 8 W64) = 807+primOpTag (VecSubOp WordVec 16 W8) = 808+primOpTag (VecSubOp WordVec 8 W16) = 809+primOpTag (VecSubOp WordVec 4 W32) = 810+primOpTag (VecSubOp WordVec 2 W64) = 811+primOpTag (VecSubOp WordVec 32 W8) = 812+primOpTag (VecSubOp WordVec 16 W16) = 813+primOpTag (VecSubOp WordVec 8 W32) = 814+primOpTag (VecSubOp WordVec 4 W64) = 815+primOpTag (VecSubOp WordVec 64 W8) = 816+primOpTag (VecSubOp WordVec 32 W16) = 817+primOpTag (VecSubOp WordVec 16 W32) = 818+primOpTag (VecSubOp WordVec 8 W64) = 819+primOpTag (VecSubOp FloatVec 4 W32) = 820+primOpTag (VecSubOp FloatVec 2 W64) = 821+primOpTag (VecSubOp FloatVec 8 W32) = 822+primOpTag (VecSubOp FloatVec 4 W64) = 823+primOpTag (VecSubOp FloatVec 16 W32) = 824+primOpTag (VecSubOp FloatVec 8 W64) = 825+primOpTag (VecMulOp IntVec 16 W8) = 826+primOpTag (VecMulOp IntVec 8 W16) = 827+primOpTag (VecMulOp IntVec 4 W32) = 828+primOpTag (VecMulOp IntVec 2 W64) = 829+primOpTag (VecMulOp IntVec 32 W8) = 830+primOpTag (VecMulOp IntVec 16 W16) = 831+primOpTag (VecMulOp IntVec 8 W32) = 832+primOpTag (VecMulOp IntVec 4 W64) = 833+primOpTag (VecMulOp IntVec 64 W8) = 834+primOpTag (VecMulOp IntVec 32 W16) = 835+primOpTag (VecMulOp IntVec 16 W32) = 836+primOpTag (VecMulOp IntVec 8 W64) = 837+primOpTag (VecMulOp WordVec 16 W8) = 838+primOpTag (VecMulOp WordVec 8 W16) = 839+primOpTag (VecMulOp WordVec 4 W32) = 840+primOpTag (VecMulOp WordVec 2 W64) = 841+primOpTag (VecMulOp WordVec 32 W8) = 842+primOpTag (VecMulOp WordVec 16 W16) = 843+primOpTag (VecMulOp WordVec 8 W32) = 844+primOpTag (VecMulOp WordVec 4 W64) = 845+primOpTag (VecMulOp WordVec 64 W8) = 846+primOpTag (VecMulOp WordVec 32 W16) = 847+primOpTag (VecMulOp WordVec 16 W32) = 848+primOpTag (VecMulOp WordVec 8 W64) = 849+primOpTag (VecMulOp FloatVec 4 W32) = 850+primOpTag (VecMulOp FloatVec 2 W64) = 851+primOpTag (VecMulOp FloatVec 8 W32) = 852+primOpTag (VecMulOp FloatVec 4 W64) = 853+primOpTag (VecMulOp FloatVec 16 W32) = 854+primOpTag (VecMulOp FloatVec 8 W64) = 855+primOpTag (VecDivOp FloatVec 4 W32) = 856+primOpTag (VecDivOp FloatVec 2 W64) = 857+primOpTag (VecDivOp FloatVec 8 W32) = 858+primOpTag (VecDivOp FloatVec 4 W64) = 859+primOpTag (VecDivOp FloatVec 16 W32) = 860+primOpTag (VecDivOp FloatVec 8 W64) = 861+primOpTag (VecQuotOp IntVec 16 W8) = 862+primOpTag (VecQuotOp IntVec 8 W16) = 863+primOpTag (VecQuotOp IntVec 4 W32) = 864+primOpTag (VecQuotOp IntVec 2 W64) = 865+primOpTag (VecQuotOp IntVec 32 W8) = 866+primOpTag (VecQuotOp IntVec 16 W16) = 867+primOpTag (VecQuotOp IntVec 8 W32) = 868+primOpTag (VecQuotOp IntVec 4 W64) = 869+primOpTag (VecQuotOp IntVec 64 W8) = 870+primOpTag (VecQuotOp IntVec 32 W16) = 871+primOpTag (VecQuotOp IntVec 16 W32) = 872+primOpTag (VecQuotOp IntVec 8 W64) = 873+primOpTag (VecQuotOp WordVec 16 W8) = 874+primOpTag (VecQuotOp WordVec 8 W16) = 875+primOpTag (VecQuotOp WordVec 4 W32) = 876+primOpTag (VecQuotOp WordVec 2 W64) = 877+primOpTag (VecQuotOp WordVec 32 W8) = 878+primOpTag (VecQuotOp WordVec 16 W16) = 879+primOpTag (VecQuotOp WordVec 8 W32) = 880+primOpTag (VecQuotOp WordVec 4 W64) = 881+primOpTag (VecQuotOp WordVec 64 W8) = 882+primOpTag (VecQuotOp WordVec 32 W16) = 883+primOpTag (VecQuotOp WordVec 16 W32) = 884+primOpTag (VecQuotOp WordVec 8 W64) = 885+primOpTag (VecRemOp IntVec 16 W8) = 886+primOpTag (VecRemOp IntVec 8 W16) = 887+primOpTag (VecRemOp IntVec 4 W32) = 888+primOpTag (VecRemOp IntVec 2 W64) = 889+primOpTag (VecRemOp IntVec 32 W8) = 890+primOpTag (VecRemOp IntVec 16 W16) = 891+primOpTag (VecRemOp IntVec 8 W32) = 892+primOpTag (VecRemOp IntVec 4 W64) = 893+primOpTag (VecRemOp IntVec 64 W8) = 894+primOpTag (VecRemOp IntVec 32 W16) = 895+primOpTag (VecRemOp IntVec 16 W32) = 896+primOpTag (VecRemOp IntVec 8 W64) = 897+primOpTag (VecRemOp WordVec 16 W8) = 898+primOpTag (VecRemOp WordVec 8 W16) = 899+primOpTag (VecRemOp WordVec 4 W32) = 900+primOpTag (VecRemOp WordVec 2 W64) = 901+primOpTag (VecRemOp WordVec 32 W8) = 902+primOpTag (VecRemOp WordVec 16 W16) = 903+primOpTag (VecRemOp WordVec 8 W32) = 904+primOpTag (VecRemOp WordVec 4 W64) = 905+primOpTag (VecRemOp WordVec 64 W8) = 906+primOpTag (VecRemOp WordVec 32 W16) = 907+primOpTag (VecRemOp WordVec 16 W32) = 908+primOpTag (VecRemOp WordVec 8 W64) = 909+primOpTag (VecNegOp IntVec 16 W8) = 910+primOpTag (VecNegOp IntVec 8 W16) = 911+primOpTag (VecNegOp IntVec 4 W32) = 912+primOpTag (VecNegOp IntVec 2 W64) = 913+primOpTag (VecNegOp IntVec 32 W8) = 914+primOpTag (VecNegOp IntVec 16 W16) = 915+primOpTag (VecNegOp IntVec 8 W32) = 916+primOpTag (VecNegOp IntVec 4 W64) = 917+primOpTag (VecNegOp IntVec 64 W8) = 918+primOpTag (VecNegOp IntVec 32 W16) = 919+primOpTag (VecNegOp IntVec 16 W32) = 920+primOpTag (VecNegOp IntVec 8 W64) = 921+primOpTag (VecNegOp FloatVec 4 W32) = 922+primOpTag (VecNegOp FloatVec 2 W64) = 923+primOpTag (VecNegOp FloatVec 8 W32) = 924+primOpTag (VecNegOp FloatVec 4 W64) = 925+primOpTag (VecNegOp FloatVec 16 W32) = 926+primOpTag (VecNegOp FloatVec 8 W64) = 927+primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 928+primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 929+primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 930+primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 931+primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 932+primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 933+primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 934+primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 935+primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 936+primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 937+primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 938+primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 939+primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 940+primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 941+primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 942+primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 943+primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 944+primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 945+primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 946+primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 947+primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 948+primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 949+primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 950+primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 951+primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 952+primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 953+primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 954+primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 955+primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 956+primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 957+primOpTag (VecReadByteArrayOp IntVec 16 W8) = 958+primOpTag (VecReadByteArrayOp IntVec 8 W16) = 959+primOpTag (VecReadByteArrayOp IntVec 4 W32) = 960+primOpTag (VecReadByteArrayOp IntVec 2 W64) = 961+primOpTag (VecReadByteArrayOp IntVec 32 W8) = 962+primOpTag (VecReadByteArrayOp IntVec 16 W16) = 963+primOpTag (VecReadByteArrayOp IntVec 8 W32) = 964+primOpTag (VecReadByteArrayOp IntVec 4 W64) = 965+primOpTag (VecReadByteArrayOp IntVec 64 W8) = 966+primOpTag (VecReadByteArrayOp IntVec 32 W16) = 967+primOpTag (VecReadByteArrayOp IntVec 16 W32) = 968+primOpTag (VecReadByteArrayOp IntVec 8 W64) = 969+primOpTag (VecReadByteArrayOp WordVec 16 W8) = 970+primOpTag (VecReadByteArrayOp WordVec 8 W16) = 971+primOpTag (VecReadByteArrayOp WordVec 4 W32) = 972+primOpTag (VecReadByteArrayOp WordVec 2 W64) = 973+primOpTag (VecReadByteArrayOp WordVec 32 W8) = 974+primOpTag (VecReadByteArrayOp WordVec 16 W16) = 975+primOpTag (VecReadByteArrayOp WordVec 8 W32) = 976+primOpTag (VecReadByteArrayOp WordVec 4 W64) = 977+primOpTag (VecReadByteArrayOp WordVec 64 W8) = 978+primOpTag (VecReadByteArrayOp WordVec 32 W16) = 979+primOpTag (VecReadByteArrayOp WordVec 16 W32) = 980+primOpTag (VecReadByteArrayOp WordVec 8 W64) = 981+primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 982+primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 983+primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 984+primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 985+primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 986+primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 987+primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 988+primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 989+primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 990+primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 991+primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 992+primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 993+primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 994+primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 995+primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 996+primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 997+primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 998+primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 999+primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 1000+primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 1001+primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 1002+primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 1003+primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 1004+primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 1005+primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 1006+primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 1007+primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 1008+primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 1009+primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 1010+primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 1011+primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 1012+primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 1013+primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 1014+primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 1015+primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 1016+primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 1017+primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 1018+primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 1019+primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 1020+primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 1021+primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 1022+primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 1023+primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 1024+primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 1025+primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 1026+primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 1027+primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 1028+primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 1029+primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 1030+primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 1031+primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 1032+primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 1033+primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 1034+primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 1035+primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 1036+primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 1037+primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 1038+primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 1039+primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 1040+primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 1041+primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 1042+primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 1043+primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 1044+primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 1045+primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 1046+primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 1047+primOpTag (VecReadOffAddrOp IntVec 16 W8) = 1048+primOpTag (VecReadOffAddrOp IntVec 8 W16) = 1049+primOpTag (VecReadOffAddrOp IntVec 4 W32) = 1050+primOpTag (VecReadOffAddrOp IntVec 2 W64) = 1051+primOpTag (VecReadOffAddrOp IntVec 32 W8) = 1052+primOpTag (VecReadOffAddrOp IntVec 16 W16) = 1053+primOpTag (VecReadOffAddrOp IntVec 8 W32) = 1054+primOpTag (VecReadOffAddrOp IntVec 4 W64) = 1055+primOpTag (VecReadOffAddrOp IntVec 64 W8) = 1056+primOpTag (VecReadOffAddrOp IntVec 32 W16) = 1057+primOpTag (VecReadOffAddrOp IntVec 16 W32) = 1058+primOpTag (VecReadOffAddrOp IntVec 8 W64) = 1059+primOpTag (VecReadOffAddrOp WordVec 16 W8) = 1060+primOpTag (VecReadOffAddrOp WordVec 8 W16) = 1061+primOpTag (VecReadOffAddrOp WordVec 4 W32) = 1062+primOpTag (VecReadOffAddrOp WordVec 2 W64) = 1063+primOpTag (VecReadOffAddrOp WordVec 32 W8) = 1064+primOpTag (VecReadOffAddrOp WordVec 16 W16) = 1065+primOpTag (VecReadOffAddrOp WordVec 8 W32) = 1066+primOpTag (VecReadOffAddrOp WordVec 4 W64) = 1067+primOpTag (VecReadOffAddrOp WordVec 64 W8) = 1068+primOpTag (VecReadOffAddrOp WordVec 32 W16) = 1069+primOpTag (VecReadOffAddrOp WordVec 16 W32) = 1070+primOpTag (VecReadOffAddrOp WordVec 8 W64) = 1071+primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 1072+primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 1073+primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 1074+primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 1075+primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 1076+primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 1077+primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 1078+primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 1079+primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 1080+primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 1081+primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 1082+primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 1083+primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 1084+primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 1085+primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 1086+primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 1087+primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 1088+primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 1089+primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 1090+primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 1091+primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 1092+primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 1093+primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 1094+primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 1095+primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 1096+primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 1097+primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 1098+primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 1099+primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 1100+primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 1101+primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 1102+primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 1103+primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 1104+primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 1105+primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 1106+primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 1107+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 1108+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 1109+primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 1110+primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1111+primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1112+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1113+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1114+primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1115+primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1116+primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1117+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1118+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1119+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1120+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1121+primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1122+primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1123+primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1124+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1125+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1126+primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1127+primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1128+primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1129+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1130+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1131+primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1132+primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1133+primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1134+primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1135+primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1136+primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1137+primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1138+primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1139+primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1140+primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1141+primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1142+primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1143+primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1144+primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1145+primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1146+primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1147+primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1148+primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1149+primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1150+primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1151+primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1152+primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1153+primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1154+primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1155+primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1156+primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1157+primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1158+primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1159+primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1160+primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1161+primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1162+primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1163+primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1164+primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1165+primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1166+primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1167+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1168+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1169+primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1170+primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1171+primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1172+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1173+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1174+primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1175+primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1176+primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1177+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1178+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1179+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1180+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1181+primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1182+primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1183+primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1184+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1185+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1186+primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1187+primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1188+primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1189+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1190+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1191+primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1192+primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1193+primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1194+primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1195+primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1196+primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1197+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1198+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1199+primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1200+primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1201+primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1202+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1203+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1204+primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1205+primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1206+primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1207+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1208+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1209+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1210+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1211+primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1212+primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1213+primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1214+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1215+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1216+primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1217+primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1218+primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1219+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1220+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1221+primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1222+primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1223+primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1224+primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1225+primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1226+primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1227+primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1228+primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1229+primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1230+primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1231+primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1232+primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1233+primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1234+primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1235+primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1236+primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1237+primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1238+primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1239+primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1240+primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1241+primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1242+primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1243+primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1244+primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1245+primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1246+primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1247+primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1248+primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1249+primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1250+primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1251+primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1252+primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1253+primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1254+primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1255+primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1256+primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1257+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1258+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1259+primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1260+primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1261+primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1262+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1263+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1264+primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1265+primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1266+primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1267+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1268+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1269+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1270+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1271+primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1272+primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1273+primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1274+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1275+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1276+primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1277+primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1278+primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1279+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1280+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1281+primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1282+primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1283+primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1284+primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1285+primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1286+primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1287+primOpTag PrefetchByteArrayOp3 = 1288+primOpTag PrefetchMutableByteArrayOp3 = 1289+primOpTag PrefetchAddrOp3 = 1290+primOpTag PrefetchValueOp3 = 1291+primOpTag PrefetchByteArrayOp2 = 1292+primOpTag PrefetchMutableByteArrayOp2 = 1293+primOpTag PrefetchAddrOp2 = 1294+primOpTag PrefetchValueOp2 = 1295+primOpTag PrefetchByteArrayOp1 = 1296+primOpTag PrefetchMutableByteArrayOp1 = 1297+primOpTag PrefetchAddrOp1 = 1298+primOpTag PrefetchValueOp1 = 1299+primOpTag PrefetchByteArrayOp0 = 1300+primOpTag PrefetchMutableByteArrayOp0 = 1301+primOpTag PrefetchAddrOp0 = 1302+primOpTag PrefetchValueOp0 = 1303
ghc-lib/stage0/compiler/build/primop-vector-tys.hs-incl view
@@ -3,178 +3,178 @@ int8X16PrimTy :: Type int8X16PrimTy = mkTyConTy int8X16PrimTyCon int8X16PrimTyCon :: TyCon-int8X16PrimTyCon = pcPrimTyCon0 int8X16PrimTyConName (VecRep 16 Int8ElemRep)+int8X16PrimTyCon = pcPrimTyCon0 int8X16PrimTyConName (TyConApp vecRepDataConTyCon [vec16DataConTy, int8ElemRepDataConTy]) int16X8PrimTyConName :: Name int16X8PrimTyConName = mkPrimTc (fsLit "Int16X8#") int16X8PrimTyConKey int16X8PrimTyCon int16X8PrimTy :: Type int16X8PrimTy = mkTyConTy int16X8PrimTyCon int16X8PrimTyCon :: TyCon-int16X8PrimTyCon = pcPrimTyCon0 int16X8PrimTyConName (VecRep 8 Int16ElemRep)+int16X8PrimTyCon = pcPrimTyCon0 int16X8PrimTyConName (TyConApp vecRepDataConTyCon [vec8DataConTy, int16ElemRepDataConTy]) int32X4PrimTyConName :: Name int32X4PrimTyConName = mkPrimTc (fsLit "Int32X4#") int32X4PrimTyConKey int32X4PrimTyCon int32X4PrimTy :: Type int32X4PrimTy = mkTyConTy int32X4PrimTyCon int32X4PrimTyCon :: TyCon-int32X4PrimTyCon = pcPrimTyCon0 int32X4PrimTyConName (VecRep 4 Int32ElemRep)+int32X4PrimTyCon = pcPrimTyCon0 int32X4PrimTyConName (TyConApp vecRepDataConTyCon [vec4DataConTy, int32ElemRepDataConTy]) int64X2PrimTyConName :: Name int64X2PrimTyConName = mkPrimTc (fsLit "Int64X2#") int64X2PrimTyConKey int64X2PrimTyCon int64X2PrimTy :: Type int64X2PrimTy = mkTyConTy int64X2PrimTyCon int64X2PrimTyCon :: TyCon-int64X2PrimTyCon = pcPrimTyCon0 int64X2PrimTyConName (VecRep 2 Int64ElemRep)+int64X2PrimTyCon = pcPrimTyCon0 int64X2PrimTyConName (TyConApp vecRepDataConTyCon [vec2DataConTy, int64ElemRepDataConTy]) int8X32PrimTyConName :: Name int8X32PrimTyConName = mkPrimTc (fsLit "Int8X32#") int8X32PrimTyConKey int8X32PrimTyCon int8X32PrimTy :: Type int8X32PrimTy = mkTyConTy int8X32PrimTyCon int8X32PrimTyCon :: TyCon-int8X32PrimTyCon = pcPrimTyCon0 int8X32PrimTyConName (VecRep 32 Int8ElemRep)+int8X32PrimTyCon = pcPrimTyCon0 int8X32PrimTyConName (TyConApp vecRepDataConTyCon [vec32DataConTy, int8ElemRepDataConTy]) int16X16PrimTyConName :: Name int16X16PrimTyConName = mkPrimTc (fsLit "Int16X16#") int16X16PrimTyConKey int16X16PrimTyCon int16X16PrimTy :: Type int16X16PrimTy = mkTyConTy int16X16PrimTyCon int16X16PrimTyCon :: TyCon-int16X16PrimTyCon = pcPrimTyCon0 int16X16PrimTyConName (VecRep 16 Int16ElemRep)+int16X16PrimTyCon = pcPrimTyCon0 int16X16PrimTyConName (TyConApp vecRepDataConTyCon [vec16DataConTy, int16ElemRepDataConTy]) int32X8PrimTyConName :: Name int32X8PrimTyConName = mkPrimTc (fsLit "Int32X8#") int32X8PrimTyConKey int32X8PrimTyCon int32X8PrimTy :: Type int32X8PrimTy = mkTyConTy int32X8PrimTyCon int32X8PrimTyCon :: TyCon-int32X8PrimTyCon = pcPrimTyCon0 int32X8PrimTyConName (VecRep 8 Int32ElemRep)+int32X8PrimTyCon = pcPrimTyCon0 int32X8PrimTyConName (TyConApp vecRepDataConTyCon [vec8DataConTy, int32ElemRepDataConTy]) int64X4PrimTyConName :: Name int64X4PrimTyConName = mkPrimTc (fsLit "Int64X4#") int64X4PrimTyConKey int64X4PrimTyCon int64X4PrimTy :: Type int64X4PrimTy = mkTyConTy int64X4PrimTyCon int64X4PrimTyCon :: TyCon-int64X4PrimTyCon = pcPrimTyCon0 int64X4PrimTyConName (VecRep 4 Int64ElemRep)+int64X4PrimTyCon = pcPrimTyCon0 int64X4PrimTyConName (TyConApp vecRepDataConTyCon [vec4DataConTy, int64ElemRepDataConTy]) int8X64PrimTyConName :: Name int8X64PrimTyConName = mkPrimTc (fsLit "Int8X64#") int8X64PrimTyConKey int8X64PrimTyCon int8X64PrimTy :: Type int8X64PrimTy = mkTyConTy int8X64PrimTyCon int8X64PrimTyCon :: TyCon-int8X64PrimTyCon = pcPrimTyCon0 int8X64PrimTyConName (VecRep 64 Int8ElemRep)+int8X64PrimTyCon = pcPrimTyCon0 int8X64PrimTyConName (TyConApp vecRepDataConTyCon [vec64DataConTy, int8ElemRepDataConTy]) int16X32PrimTyConName :: Name int16X32PrimTyConName = mkPrimTc (fsLit "Int16X32#") int16X32PrimTyConKey int16X32PrimTyCon int16X32PrimTy :: Type int16X32PrimTy = mkTyConTy int16X32PrimTyCon int16X32PrimTyCon :: TyCon-int16X32PrimTyCon = pcPrimTyCon0 int16X32PrimTyConName (VecRep 32 Int16ElemRep)+int16X32PrimTyCon = pcPrimTyCon0 int16X32PrimTyConName (TyConApp vecRepDataConTyCon [vec32DataConTy, int16ElemRepDataConTy]) int32X16PrimTyConName :: Name int32X16PrimTyConName = mkPrimTc (fsLit "Int32X16#") int32X16PrimTyConKey int32X16PrimTyCon int32X16PrimTy :: Type int32X16PrimTy = mkTyConTy int32X16PrimTyCon int32X16PrimTyCon :: TyCon-int32X16PrimTyCon = pcPrimTyCon0 int32X16PrimTyConName (VecRep 16 Int32ElemRep)+int32X16PrimTyCon = pcPrimTyCon0 int32X16PrimTyConName (TyConApp vecRepDataConTyCon [vec16DataConTy, int32ElemRepDataConTy]) int64X8PrimTyConName :: Name int64X8PrimTyConName = mkPrimTc (fsLit "Int64X8#") int64X8PrimTyConKey int64X8PrimTyCon int64X8PrimTy :: Type int64X8PrimTy = mkTyConTy int64X8PrimTyCon int64X8PrimTyCon :: TyCon-int64X8PrimTyCon = pcPrimTyCon0 int64X8PrimTyConName (VecRep 8 Int64ElemRep)+int64X8PrimTyCon = pcPrimTyCon0 int64X8PrimTyConName (TyConApp vecRepDataConTyCon [vec8DataConTy, int64ElemRepDataConTy]) word8X16PrimTyConName :: Name word8X16PrimTyConName = mkPrimTc (fsLit "Word8X16#") word8X16PrimTyConKey word8X16PrimTyCon word8X16PrimTy :: Type word8X16PrimTy = mkTyConTy word8X16PrimTyCon word8X16PrimTyCon :: TyCon-word8X16PrimTyCon = pcPrimTyCon0 word8X16PrimTyConName (VecRep 16 Word8ElemRep)+word8X16PrimTyCon = pcPrimTyCon0 word8X16PrimTyConName (TyConApp vecRepDataConTyCon [vec16DataConTy, word8ElemRepDataConTy]) word16X8PrimTyConName :: Name word16X8PrimTyConName = mkPrimTc (fsLit "Word16X8#") word16X8PrimTyConKey word16X8PrimTyCon word16X8PrimTy :: Type word16X8PrimTy = mkTyConTy word16X8PrimTyCon word16X8PrimTyCon :: TyCon-word16X8PrimTyCon = pcPrimTyCon0 word16X8PrimTyConName (VecRep 8 Word16ElemRep)+word16X8PrimTyCon = pcPrimTyCon0 word16X8PrimTyConName (TyConApp vecRepDataConTyCon [vec8DataConTy, word16ElemRepDataConTy]) word32X4PrimTyConName :: Name word32X4PrimTyConName = mkPrimTc (fsLit "Word32X4#") word32X4PrimTyConKey word32X4PrimTyCon word32X4PrimTy :: Type word32X4PrimTy = mkTyConTy word32X4PrimTyCon word32X4PrimTyCon :: TyCon-word32X4PrimTyCon = pcPrimTyCon0 word32X4PrimTyConName (VecRep 4 Word32ElemRep)+word32X4PrimTyCon = pcPrimTyCon0 word32X4PrimTyConName (TyConApp vecRepDataConTyCon [vec4DataConTy, word32ElemRepDataConTy]) word64X2PrimTyConName :: Name word64X2PrimTyConName = mkPrimTc (fsLit "Word64X2#") word64X2PrimTyConKey word64X2PrimTyCon word64X2PrimTy :: Type word64X2PrimTy = mkTyConTy word64X2PrimTyCon word64X2PrimTyCon :: TyCon-word64X2PrimTyCon = pcPrimTyCon0 word64X2PrimTyConName (VecRep 2 Word64ElemRep)+word64X2PrimTyCon = pcPrimTyCon0 word64X2PrimTyConName (TyConApp vecRepDataConTyCon [vec2DataConTy, word64ElemRepDataConTy]) word8X32PrimTyConName :: Name word8X32PrimTyConName = mkPrimTc (fsLit "Word8X32#") word8X32PrimTyConKey word8X32PrimTyCon word8X32PrimTy :: Type word8X32PrimTy = mkTyConTy word8X32PrimTyCon word8X32PrimTyCon :: TyCon-word8X32PrimTyCon = pcPrimTyCon0 word8X32PrimTyConName (VecRep 32 Word8ElemRep)+word8X32PrimTyCon = pcPrimTyCon0 word8X32PrimTyConName (TyConApp vecRepDataConTyCon [vec32DataConTy, word8ElemRepDataConTy]) word16X16PrimTyConName :: Name word16X16PrimTyConName = mkPrimTc (fsLit "Word16X16#") word16X16PrimTyConKey word16X16PrimTyCon word16X16PrimTy :: Type word16X16PrimTy = mkTyConTy word16X16PrimTyCon word16X16PrimTyCon :: TyCon-word16X16PrimTyCon = pcPrimTyCon0 word16X16PrimTyConName (VecRep 16 Word16ElemRep)+word16X16PrimTyCon = pcPrimTyCon0 word16X16PrimTyConName (TyConApp vecRepDataConTyCon [vec16DataConTy, word16ElemRepDataConTy]) word32X8PrimTyConName :: Name word32X8PrimTyConName = mkPrimTc (fsLit "Word32X8#") word32X8PrimTyConKey word32X8PrimTyCon word32X8PrimTy :: Type word32X8PrimTy = mkTyConTy word32X8PrimTyCon word32X8PrimTyCon :: TyCon-word32X8PrimTyCon = pcPrimTyCon0 word32X8PrimTyConName (VecRep 8 Word32ElemRep)+word32X8PrimTyCon = pcPrimTyCon0 word32X8PrimTyConName (TyConApp vecRepDataConTyCon [vec8DataConTy, word32ElemRepDataConTy]) word64X4PrimTyConName :: Name word64X4PrimTyConName = mkPrimTc (fsLit "Word64X4#") word64X4PrimTyConKey word64X4PrimTyCon word64X4PrimTy :: Type word64X4PrimTy = mkTyConTy word64X4PrimTyCon word64X4PrimTyCon :: TyCon-word64X4PrimTyCon = pcPrimTyCon0 word64X4PrimTyConName (VecRep 4 Word64ElemRep)+word64X4PrimTyCon = pcPrimTyCon0 word64X4PrimTyConName (TyConApp vecRepDataConTyCon [vec4DataConTy, word64ElemRepDataConTy]) word8X64PrimTyConName :: Name word8X64PrimTyConName = mkPrimTc (fsLit "Word8X64#") word8X64PrimTyConKey word8X64PrimTyCon word8X64PrimTy :: Type word8X64PrimTy = mkTyConTy word8X64PrimTyCon word8X64PrimTyCon :: TyCon-word8X64PrimTyCon = pcPrimTyCon0 word8X64PrimTyConName (VecRep 64 Word8ElemRep)+word8X64PrimTyCon = pcPrimTyCon0 word8X64PrimTyConName (TyConApp vecRepDataConTyCon [vec64DataConTy, word8ElemRepDataConTy]) word16X32PrimTyConName :: Name word16X32PrimTyConName = mkPrimTc (fsLit "Word16X32#") word16X32PrimTyConKey word16X32PrimTyCon word16X32PrimTy :: Type word16X32PrimTy = mkTyConTy word16X32PrimTyCon word16X32PrimTyCon :: TyCon-word16X32PrimTyCon = pcPrimTyCon0 word16X32PrimTyConName (VecRep 32 Word16ElemRep)+word16X32PrimTyCon = pcPrimTyCon0 word16X32PrimTyConName (TyConApp vecRepDataConTyCon [vec32DataConTy, word16ElemRepDataConTy]) word32X16PrimTyConName :: Name word32X16PrimTyConName = mkPrimTc (fsLit "Word32X16#") word32X16PrimTyConKey word32X16PrimTyCon word32X16PrimTy :: Type word32X16PrimTy = mkTyConTy word32X16PrimTyCon word32X16PrimTyCon :: TyCon-word32X16PrimTyCon = pcPrimTyCon0 word32X16PrimTyConName (VecRep 16 Word32ElemRep)+word32X16PrimTyCon = pcPrimTyCon0 word32X16PrimTyConName (TyConApp vecRepDataConTyCon [vec16DataConTy, word32ElemRepDataConTy]) word64X8PrimTyConName :: Name word64X8PrimTyConName = mkPrimTc (fsLit "Word64X8#") word64X8PrimTyConKey word64X8PrimTyCon word64X8PrimTy :: Type word64X8PrimTy = mkTyConTy word64X8PrimTyCon word64X8PrimTyCon :: TyCon-word64X8PrimTyCon = pcPrimTyCon0 word64X8PrimTyConName (VecRep 8 Word64ElemRep)+word64X8PrimTyCon = pcPrimTyCon0 word64X8PrimTyConName (TyConApp vecRepDataConTyCon [vec8DataConTy, word64ElemRepDataConTy]) floatX4PrimTyConName :: Name floatX4PrimTyConName = mkPrimTc (fsLit "FloatX4#") floatX4PrimTyConKey floatX4PrimTyCon floatX4PrimTy :: Type floatX4PrimTy = mkTyConTy floatX4PrimTyCon floatX4PrimTyCon :: TyCon-floatX4PrimTyCon = pcPrimTyCon0 floatX4PrimTyConName (VecRep 4 FloatElemRep)+floatX4PrimTyCon = pcPrimTyCon0 floatX4PrimTyConName (TyConApp vecRepDataConTyCon [vec4DataConTy, floatElemRepDataConTy]) doubleX2PrimTyConName :: Name doubleX2PrimTyConName = mkPrimTc (fsLit "DoubleX2#") doubleX2PrimTyConKey doubleX2PrimTyCon doubleX2PrimTy :: Type doubleX2PrimTy = mkTyConTy doubleX2PrimTyCon doubleX2PrimTyCon :: TyCon-doubleX2PrimTyCon = pcPrimTyCon0 doubleX2PrimTyConName (VecRep 2 DoubleElemRep)+doubleX2PrimTyCon = pcPrimTyCon0 doubleX2PrimTyConName (TyConApp vecRepDataConTyCon [vec2DataConTy, doubleElemRepDataConTy]) floatX8PrimTyConName :: Name floatX8PrimTyConName = mkPrimTc (fsLit "FloatX8#") floatX8PrimTyConKey floatX8PrimTyCon floatX8PrimTy :: Type floatX8PrimTy = mkTyConTy floatX8PrimTyCon floatX8PrimTyCon :: TyCon-floatX8PrimTyCon = pcPrimTyCon0 floatX8PrimTyConName (VecRep 8 FloatElemRep)+floatX8PrimTyCon = pcPrimTyCon0 floatX8PrimTyConName (TyConApp vecRepDataConTyCon [vec8DataConTy, floatElemRepDataConTy]) doubleX4PrimTyConName :: Name doubleX4PrimTyConName = mkPrimTc (fsLit "DoubleX4#") doubleX4PrimTyConKey doubleX4PrimTyCon doubleX4PrimTy :: Type doubleX4PrimTy = mkTyConTy doubleX4PrimTyCon doubleX4PrimTyCon :: TyCon-doubleX4PrimTyCon = pcPrimTyCon0 doubleX4PrimTyConName (VecRep 4 DoubleElemRep)+doubleX4PrimTyCon = pcPrimTyCon0 doubleX4PrimTyConName (TyConApp vecRepDataConTyCon [vec4DataConTy, doubleElemRepDataConTy]) floatX16PrimTyConName :: Name floatX16PrimTyConName = mkPrimTc (fsLit "FloatX16#") floatX16PrimTyConKey floatX16PrimTyCon floatX16PrimTy :: Type floatX16PrimTy = mkTyConTy floatX16PrimTyCon floatX16PrimTyCon :: TyCon-floatX16PrimTyCon = pcPrimTyCon0 floatX16PrimTyConName (VecRep 16 FloatElemRep)+floatX16PrimTyCon = pcPrimTyCon0 floatX16PrimTyConName (TyConApp vecRepDataConTyCon [vec16DataConTy, floatElemRepDataConTy]) doubleX8PrimTyConName :: Name doubleX8PrimTyConName = mkPrimTc (fsLit "DoubleX8#") doubleX8PrimTyConKey doubleX8PrimTyCon doubleX8PrimTy :: Type doubleX8PrimTy = mkTyConTy doubleX8PrimTyCon doubleX8PrimTyCon :: TyCon-doubleX8PrimTyCon = pcPrimTyCon0 doubleX8PrimTyConName (VecRep 8 DoubleElemRep)+doubleX8PrimTyCon = pcPrimTyCon0 doubleX8PrimTyConName (TyConApp vecRepDataConTyCon [vec8DataConTy, doubleElemRepDataConTy])
− ghc-lib/stage0/lib/GhclibDerivedConstants.h 
@@ -1,559 +0,0 @@-/* This file is created automatically.  Do not edit by hand.*/--#define HS_CONSTANTS "291,1,2,4096,252,9,0,8,16,24,32,40,48,56,64,72,80,84,88,92,96,100,104,112,120,128,136,144,152,168,184,200,216,232,248,280,312,344,376,408,440,504,568,632,696,760,824,832,840,848,856,864,872,888,904,-24,-16,-8,24,0,8,48,46,96,72,8,48,8,8,16,8,48,8,16,8,0,56,40,8,16,0,8,8,0,8,0,96,112,16,8,16,0,4,4,24,20,4,15,7,1,-16,255,0,255,7,10,6,6,1,6,6,6,6,6,0,16384,21,1024,8,4,8,8,6,3,30,1152921503533105152,0,1152921504606846976"-#define CONTROL_GROUP_CONST_291 291-#define STD_HDR_SIZE 1-#define PROF_HDR_SIZE 2-#define STACK_DIRTY 1-#define BLOCK_SIZE 4096-#define MBLOCK_SIZE 1048576-#define BLOCKS_PER_MBLOCK 252-#define TICKY_BIN_COUNT 9-#define OFFSET_StgRegTable_rR1 0-#define OFFSET_StgRegTable_rR2 8-#define OFFSET_StgRegTable_rR3 16-#define OFFSET_StgRegTable_rR4 24-#define OFFSET_StgRegTable_rR5 32-#define OFFSET_StgRegTable_rR6 40-#define OFFSET_StgRegTable_rR7 48-#define OFFSET_StgRegTable_rR8 56-#define OFFSET_StgRegTable_rR9 64-#define OFFSET_StgRegTable_rR10 72-#define OFFSET_StgRegTable_rF1 80-#define OFFSET_StgRegTable_rF2 84-#define OFFSET_StgRegTable_rF3 88-#define OFFSET_StgRegTable_rF4 92-#define OFFSET_StgRegTable_rF5 96-#define OFFSET_StgRegTable_rF6 100-#define OFFSET_StgRegTable_rD1 104-#define OFFSET_StgRegTable_rD2 112-#define OFFSET_StgRegTable_rD3 120-#define OFFSET_StgRegTable_rD4 128-#define OFFSET_StgRegTable_rD5 136-#define OFFSET_StgRegTable_rD6 144-#define OFFSET_StgRegTable_rXMM1 152-#define OFFSET_StgRegTable_rXMM2 168-#define OFFSET_StgRegTable_rXMM3 184-#define OFFSET_StgRegTable_rXMM4 200-#define OFFSET_StgRegTable_rXMM5 216-#define OFFSET_StgRegTable_rXMM6 232-#define OFFSET_StgRegTable_rYMM1 248-#define OFFSET_StgRegTable_rYMM2 280-#define OFFSET_StgRegTable_rYMM3 312-#define OFFSET_StgRegTable_rYMM4 344-#define OFFSET_StgRegTable_rYMM5 376-#define OFFSET_StgRegTable_rYMM6 408-#define OFFSET_StgRegTable_rZMM1 440-#define OFFSET_StgRegTable_rZMM2 504-#define OFFSET_StgRegTable_rZMM3 568-#define OFFSET_StgRegTable_rZMM4 632-#define OFFSET_StgRegTable_rZMM5 696-#define OFFSET_StgRegTable_rZMM6 760-#define OFFSET_StgRegTable_rL1 824-#define OFFSET_StgRegTable_rSp 832-#define OFFSET_StgRegTable_rSpLim 840-#define OFFSET_StgRegTable_rHp 848-#define OFFSET_StgRegTable_rHpLim 856-#define OFFSET_StgRegTable_rCCCS 864-#define OFFSET_StgRegTable_rCurrentTSO 872-#define OFFSET_StgRegTable_rCurrentNursery 888-#define OFFSET_StgRegTable_rHpAlloc 904-#define OFFSET_StgRegTable_rRet 912-#define REP_StgRegTable_rRet b64-#define StgRegTable_rRet(__ptr__) REP_StgRegTable_rRet[__ptr__+OFFSET_StgRegTable_rRet]-#define OFFSET_StgRegTable_rNursery 880-#define REP_StgRegTable_rNursery b64-#define StgRegTable_rNursery(__ptr__) REP_StgRegTable_rNursery[__ptr__+OFFSET_StgRegTable_rNursery]-#define OFFSET_stgEagerBlackholeInfo -24-#define OFFSET_stgGCEnter1 -16-#define OFFSET_stgGCFun -8-#define OFFSET_Capability_r 24-#define OFFSET_Capability_lock 1224-#define OFFSET_Capability_no 944-#define REP_Capability_no b32-#define Capability_no(__ptr__) REP_Capability_no[__ptr__+OFFSET_Capability_no]-#define OFFSET_Capability_mut_lists 1016-#define REP_Capability_mut_lists b64-#define Capability_mut_lists(__ptr__) REP_Capability_mut_lists[__ptr__+OFFSET_Capability_mut_lists]-#define OFFSET_Capability_context_switch 1192-#define REP_Capability_context_switch b32-#define Capability_context_switch(__ptr__) REP_Capability_context_switch[__ptr__+OFFSET_Capability_context_switch]-#define OFFSET_Capability_interrupt 1196-#define REP_Capability_interrupt b32-#define Capability_interrupt(__ptr__) REP_Capability_interrupt[__ptr__+OFFSET_Capability_interrupt]-#define OFFSET_Capability_sparks 1328-#define REP_Capability_sparks b64-#define Capability_sparks(__ptr__) REP_Capability_sparks[__ptr__+OFFSET_Capability_sparks]-#define OFFSET_Capability_total_allocated 1200-#define REP_Capability_total_allocated b64-#define Capability_total_allocated(__ptr__) REP_Capability_total_allocated[__ptr__+OFFSET_Capability_total_allocated]-#define OFFSET_Capability_weak_ptr_list_hd 1176-#define REP_Capability_weak_ptr_list_hd b64-#define Capability_weak_ptr_list_hd(__ptr__) REP_Capability_weak_ptr_list_hd[__ptr__+OFFSET_Capability_weak_ptr_list_hd]-#define OFFSET_Capability_weak_ptr_list_tl 1184-#define REP_Capability_weak_ptr_list_tl b64-#define Capability_weak_ptr_list_tl(__ptr__) REP_Capability_weak_ptr_list_tl[__ptr__+OFFSET_Capability_weak_ptr_list_tl]-#define OFFSET_bdescr_start 0-#define REP_bdescr_start b64-#define bdescr_start(__ptr__) REP_bdescr_start[__ptr__+OFFSET_bdescr_start]-#define OFFSET_bdescr_free 8-#define REP_bdescr_free b64-#define bdescr_free(__ptr__) REP_bdescr_free[__ptr__+OFFSET_bdescr_free]-#define OFFSET_bdescr_blocks 48-#define REP_bdescr_blocks b32-#define bdescr_blocks(__ptr__) REP_bdescr_blocks[__ptr__+OFFSET_bdescr_blocks]-#define OFFSET_bdescr_gen_no 40-#define REP_bdescr_gen_no b16-#define bdescr_gen_no(__ptr__) REP_bdescr_gen_no[__ptr__+OFFSET_bdescr_gen_no]-#define OFFSET_bdescr_link 16-#define REP_bdescr_link b64-#define bdescr_link(__ptr__) REP_bdescr_link[__ptr__+OFFSET_bdescr_link]-#define OFFSET_bdescr_flags 46-#define REP_bdescr_flags b16-#define bdescr_flags(__ptr__) REP_bdescr_flags[__ptr__+OFFSET_bdescr_flags]-#define SIZEOF_generation 384-#define OFFSET_generation_n_new_large_words 56-#define REP_generation_n_new_large_words b64-#define generation_n_new_large_words(__ptr__) REP_generation_n_new_large_words[__ptr__+OFFSET_generation_n_new_large_words]-#define OFFSET_generation_weak_ptr_list 112-#define REP_generation_weak_ptr_list b64-#define generation_weak_ptr_list(__ptr__) REP_generation_weak_ptr_list[__ptr__+OFFSET_generation_weak_ptr_list]-#define SIZEOF_CostCentreStack 96-#define OFFSET_CostCentreStack_ccsID 0-#define REP_CostCentreStack_ccsID b64-#define CostCentreStack_ccsID(__ptr__) REP_CostCentreStack_ccsID[__ptr__+OFFSET_CostCentreStack_ccsID]-#define OFFSET_CostCentreStack_mem_alloc 72-#define REP_CostCentreStack_mem_alloc b64-#define CostCentreStack_mem_alloc(__ptr__) REP_CostCentreStack_mem_alloc[__ptr__+OFFSET_CostCentreStack_mem_alloc]-#define OFFSET_CostCentreStack_scc_count 48-#define REP_CostCentreStack_scc_count b64-#define CostCentreStack_scc_count(__ptr__) REP_CostCentreStack_scc_count[__ptr__+OFFSET_CostCentreStack_scc_count]-#define OFFSET_CostCentreStack_prevStack 16-#define REP_CostCentreStack_prevStack b64-#define CostCentreStack_prevStack(__ptr__) REP_CostCentreStack_prevStack[__ptr__+OFFSET_CostCentreStack_prevStack]-#define OFFSET_CostCentre_ccID 0-#define REP_CostCentre_ccID b64-#define CostCentre_ccID(__ptr__) REP_CostCentre_ccID[__ptr__+OFFSET_CostCentre_ccID]-#define OFFSET_CostCentre_link 56-#define REP_CostCentre_link b64-#define CostCentre_link(__ptr__) REP_CostCentre_link[__ptr__+OFFSET_CostCentre_link]-#define OFFSET_StgHeader_info 0-#define REP_StgHeader_info b64-#define StgHeader_info(__ptr__) REP_StgHeader_info[__ptr__+OFFSET_StgHeader_info]-#define OFFSET_StgHeader_ccs 8-#define REP_StgHeader_ccs b64-#define StgHeader_ccs(__ptr__) REP_StgHeader_ccs[__ptr__+OFFSET_StgHeader_ccs]-#define OFFSET_StgHeader_ldvw 16-#define REP_StgHeader_ldvw b64-#define StgHeader_ldvw(__ptr__) REP_StgHeader_ldvw[__ptr__+OFFSET_StgHeader_ldvw]-#define SIZEOF_StgSMPThunkHeader 8-#define OFFSET_StgClosure_payload 0-#define StgClosure_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgClosure_payload + WDS(__ix__)]-#define OFFSET_StgEntCounter_allocs 48-#define REP_StgEntCounter_allocs b64-#define StgEntCounter_allocs(__ptr__) REP_StgEntCounter_allocs[__ptr__+OFFSET_StgEntCounter_allocs]-#define OFFSET_StgEntCounter_allocd 16-#define REP_StgEntCounter_allocd b64-#define StgEntCounter_allocd(__ptr__) REP_StgEntCounter_allocd[__ptr__+OFFSET_StgEntCounter_allocd]-#define OFFSET_StgEntCounter_registeredp 0-#define REP_StgEntCounter_registeredp b64-#define StgEntCounter_registeredp(__ptr__) REP_StgEntCounter_registeredp[__ptr__+OFFSET_StgEntCounter_registeredp]-#define OFFSET_StgEntCounter_link 56-#define REP_StgEntCounter_link b64-#define StgEntCounter_link(__ptr__) REP_StgEntCounter_link[__ptr__+OFFSET_StgEntCounter_link]-#define OFFSET_StgEntCounter_entry_count 40-#define REP_StgEntCounter_entry_count b64-#define StgEntCounter_entry_count(__ptr__) REP_StgEntCounter_entry_count[__ptr__+OFFSET_StgEntCounter_entry_count]-#define SIZEOF_StgUpdateFrame_NoHdr 8-#define SIZEOF_StgUpdateFrame (SIZEOF_StgHeader+8)-#define SIZEOF_StgCatchFrame_NoHdr 16-#define SIZEOF_StgCatchFrame (SIZEOF_StgHeader+16)-#define SIZEOF_StgStopFrame_NoHdr 0-#define SIZEOF_StgStopFrame (SIZEOF_StgHeader+0)-#define SIZEOF_StgMutArrPtrs_NoHdr 16-#define SIZEOF_StgMutArrPtrs (SIZEOF_StgHeader+16)-#define OFFSET_StgMutArrPtrs_ptrs 0-#define REP_StgMutArrPtrs_ptrs b64-#define StgMutArrPtrs_ptrs(__ptr__) REP_StgMutArrPtrs_ptrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgMutArrPtrs_ptrs]-#define OFFSET_StgMutArrPtrs_size 8-#define REP_StgMutArrPtrs_size b64-#define StgMutArrPtrs_size(__ptr__) REP_StgMutArrPtrs_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgMutArrPtrs_size]-#define SIZEOF_StgSmallMutArrPtrs_NoHdr 8-#define SIZEOF_StgSmallMutArrPtrs (SIZEOF_StgHeader+8)-#define OFFSET_StgSmallMutArrPtrs_ptrs 0-#define REP_StgSmallMutArrPtrs_ptrs b64-#define StgSmallMutArrPtrs_ptrs(__ptr__) REP_StgSmallMutArrPtrs_ptrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgSmallMutArrPtrs_ptrs]-#define SIZEOF_StgArrBytes_NoHdr 8-#define SIZEOF_StgArrBytes (SIZEOF_StgHeader+8)-#define OFFSET_StgArrBytes_bytes 0-#define REP_StgArrBytes_bytes b64-#define StgArrBytes_bytes(__ptr__) REP_StgArrBytes_bytes[__ptr__+SIZEOF_StgHeader+OFFSET_StgArrBytes_bytes]-#define OFFSET_StgArrBytes_payload 8-#define StgArrBytes_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgArrBytes_payload + WDS(__ix__)]-#define OFFSET_StgTSO__link 0-#define REP_StgTSO__link b64-#define StgTSO__link(__ptr__) REP_StgTSO__link[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO__link]-#define OFFSET_StgTSO_global_link 8-#define REP_StgTSO_global_link b64-#define StgTSO_global_link(__ptr__) REP_StgTSO_global_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_global_link]-#define OFFSET_StgTSO_what_next 24-#define REP_StgTSO_what_next b16-#define StgTSO_what_next(__ptr__) REP_StgTSO_what_next[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_what_next]-#define OFFSET_StgTSO_why_blocked 26-#define REP_StgTSO_why_blocked b16-#define StgTSO_why_blocked(__ptr__) REP_StgTSO_why_blocked[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_why_blocked]-#define OFFSET_StgTSO_block_info 32-#define REP_StgTSO_block_info b64-#define StgTSO_block_info(__ptr__) REP_StgTSO_block_info[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_block_info]-#define OFFSET_StgTSO_blocked_exceptions 80-#define REP_StgTSO_blocked_exceptions b64-#define StgTSO_blocked_exceptions(__ptr__) REP_StgTSO_blocked_exceptions[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_blocked_exceptions]-#define OFFSET_StgTSO_id 40-#define REP_StgTSO_id b64-#define StgTSO_id(__ptr__) REP_StgTSO_id[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_id]-#define OFFSET_StgTSO_cap 64-#define REP_StgTSO_cap b64-#define StgTSO_cap(__ptr__) REP_StgTSO_cap[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_cap]-#define OFFSET_StgTSO_saved_errno 48-#define REP_StgTSO_saved_errno b32-#define StgTSO_saved_errno(__ptr__) REP_StgTSO_saved_errno[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_saved_errno]-#define OFFSET_StgTSO_trec 72-#define REP_StgTSO_trec b64-#define StgTSO_trec(__ptr__) REP_StgTSO_trec[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_trec]-#define OFFSET_StgTSO_flags 28-#define REP_StgTSO_flags b32-#define StgTSO_flags(__ptr__) REP_StgTSO_flags[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_flags]-#define OFFSET_StgTSO_dirty 52-#define REP_StgTSO_dirty b32-#define StgTSO_dirty(__ptr__) REP_StgTSO_dirty[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_dirty]-#define OFFSET_StgTSO_bq 88-#define REP_StgTSO_bq b64-#define StgTSO_bq(__ptr__) REP_StgTSO_bq[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_bq]-#define OFFSET_StgTSO_alloc_limit 96-#define REP_StgTSO_alloc_limit b64-#define StgTSO_alloc_limit(__ptr__) REP_StgTSO_alloc_limit[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_alloc_limit]-#define OFFSET_StgTSO_cccs 112-#define REP_StgTSO_cccs b64-#define StgTSO_cccs(__ptr__) REP_StgTSO_cccs[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_cccs]-#define OFFSET_StgTSO_stackobj 16-#define REP_StgTSO_stackobj b64-#define StgTSO_stackobj(__ptr__) REP_StgTSO_stackobj[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_stackobj]-#define OFFSET_StgStack_sp 8-#define REP_StgStack_sp b64-#define StgStack_sp(__ptr__) REP_StgStack_sp[__ptr__+SIZEOF_StgHeader+OFFSET_StgStack_sp]-#define OFFSET_StgStack_stack 16-#define OFFSET_StgStack_stack_size 0-#define REP_StgStack_stack_size b32-#define StgStack_stack_size(__ptr__) REP_StgStack_stack_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgStack_stack_size]-#define OFFSET_StgStack_dirty 4-#define REP_StgStack_dirty b8-#define StgStack_dirty(__ptr__) REP_StgStack_dirty[__ptr__+SIZEOF_StgHeader+OFFSET_StgStack_dirty]-#define SIZEOF_StgTSOProfInfo 8-#define OFFSET_StgUpdateFrame_updatee 0-#define REP_StgUpdateFrame_updatee b64-#define StgUpdateFrame_updatee(__ptr__) REP_StgUpdateFrame_updatee[__ptr__+SIZEOF_StgHeader+OFFSET_StgUpdateFrame_updatee]-#define OFFSET_StgCatchFrame_handler 8-#define REP_StgCatchFrame_handler b64-#define StgCatchFrame_handler(__ptr__) REP_StgCatchFrame_handler[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchFrame_handler]-#define OFFSET_StgCatchFrame_exceptions_blocked 0-#define REP_StgCatchFrame_exceptions_blocked b64-#define StgCatchFrame_exceptions_blocked(__ptr__) REP_StgCatchFrame_exceptions_blocked[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchFrame_exceptions_blocked]-#define SIZEOF_StgPAP_NoHdr 16-#define SIZEOF_StgPAP (SIZEOF_StgHeader+16)-#define OFFSET_StgPAP_n_args 4-#define REP_StgPAP_n_args b32-#define StgPAP_n_args(__ptr__) REP_StgPAP_n_args[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_n_args]-#define OFFSET_StgPAP_fun 8-#define REP_StgPAP_fun gcptr-#define StgPAP_fun(__ptr__) REP_StgPAP_fun[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_fun]-#define OFFSET_StgPAP_arity 0-#define REP_StgPAP_arity b32-#define StgPAP_arity(__ptr__) REP_StgPAP_arity[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_arity]-#define OFFSET_StgPAP_payload 16-#define StgPAP_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_payload + WDS(__ix__)]-#define SIZEOF_StgAP_NoThunkHdr 16-#define SIZEOF_StgAP_NoHdr 24-#define SIZEOF_StgAP (SIZEOF_StgHeader+24)-#define OFFSET_StgAP_n_args 12-#define REP_StgAP_n_args b32-#define StgAP_n_args(__ptr__) REP_StgAP_n_args[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_n_args]-#define OFFSET_StgAP_fun 16-#define REP_StgAP_fun gcptr-#define StgAP_fun(__ptr__) REP_StgAP_fun[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_fun]-#define OFFSET_StgAP_payload 24-#define StgAP_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_payload + WDS(__ix__)]-#define SIZEOF_StgAP_STACK_NoThunkHdr 16-#define SIZEOF_StgAP_STACK_NoHdr 24-#define SIZEOF_StgAP_STACK (SIZEOF_StgHeader+24)-#define OFFSET_StgAP_STACK_size 8-#define REP_StgAP_STACK_size b64-#define StgAP_STACK_size(__ptr__) REP_StgAP_STACK_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_STACK_size]-#define OFFSET_StgAP_STACK_fun 16-#define REP_StgAP_STACK_fun gcptr-#define StgAP_STACK_fun(__ptr__) REP_StgAP_STACK_fun[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_STACK_fun]-#define OFFSET_StgAP_STACK_payload 24-#define StgAP_STACK_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_STACK_payload + WDS(__ix__)]-#define SIZEOF_StgSelector_NoThunkHdr 8-#define SIZEOF_StgSelector_NoHdr 16-#define SIZEOF_StgSelector (SIZEOF_StgHeader+16)-#define OFFSET_StgInd_indirectee 0-#define REP_StgInd_indirectee gcptr-#define StgInd_indirectee(__ptr__) REP_StgInd_indirectee[__ptr__+SIZEOF_StgHeader+OFFSET_StgInd_indirectee]-#define SIZEOF_StgMutVar_NoHdr 8-#define SIZEOF_StgMutVar (SIZEOF_StgHeader+8)-#define OFFSET_StgMutVar_var 0-#define REP_StgMutVar_var b64-#define StgMutVar_var(__ptr__) REP_StgMutVar_var[__ptr__+SIZEOF_StgHeader+OFFSET_StgMutVar_var]-#define SIZEOF_StgAtomicallyFrame_NoHdr 16-#define SIZEOF_StgAtomicallyFrame (SIZEOF_StgHeader+16)-#define OFFSET_StgAtomicallyFrame_code 0-#define REP_StgAtomicallyFrame_code b64-#define StgAtomicallyFrame_code(__ptr__) REP_StgAtomicallyFrame_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgAtomicallyFrame_code]-#define OFFSET_StgAtomicallyFrame_result 8-#define REP_StgAtomicallyFrame_result b64-#define StgAtomicallyFrame_result(__ptr__) REP_StgAtomicallyFrame_result[__ptr__+SIZEOF_StgHeader+OFFSET_StgAtomicallyFrame_result]-#define OFFSET_StgTRecHeader_enclosing_trec 0-#define REP_StgTRecHeader_enclosing_trec b64-#define StgTRecHeader_enclosing_trec(__ptr__) REP_StgTRecHeader_enclosing_trec[__ptr__+SIZEOF_StgHeader+OFFSET_StgTRecHeader_enclosing_trec]-#define SIZEOF_StgCatchSTMFrame_NoHdr 16-#define SIZEOF_StgCatchSTMFrame (SIZEOF_StgHeader+16)-#define OFFSET_StgCatchSTMFrame_handler 8-#define REP_StgCatchSTMFrame_handler b64-#define StgCatchSTMFrame_handler(__ptr__) REP_StgCatchSTMFrame_handler[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchSTMFrame_handler]-#define OFFSET_StgCatchSTMFrame_code 0-#define REP_StgCatchSTMFrame_code b64-#define StgCatchSTMFrame_code(__ptr__) REP_StgCatchSTMFrame_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchSTMFrame_code]-#define SIZEOF_StgCatchRetryFrame_NoHdr 24-#define SIZEOF_StgCatchRetryFrame (SIZEOF_StgHeader+24)-#define OFFSET_StgCatchRetryFrame_running_alt_code 0-#define REP_StgCatchRetryFrame_running_alt_code b64-#define StgCatchRetryFrame_running_alt_code(__ptr__) REP_StgCatchRetryFrame_running_alt_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchRetryFrame_running_alt_code]-#define OFFSET_StgCatchRetryFrame_first_code 8-#define REP_StgCatchRetryFrame_first_code b64-#define StgCatchRetryFrame_first_code(__ptr__) REP_StgCatchRetryFrame_first_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchRetryFrame_first_code]-#define OFFSET_StgCatchRetryFrame_alt_code 16-#define REP_StgCatchRetryFrame_alt_code b64-#define StgCatchRetryFrame_alt_code(__ptr__) REP_StgCatchRetryFrame_alt_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchRetryFrame_alt_code]-#define OFFSET_StgTVarWatchQueue_closure 0-#define REP_StgTVarWatchQueue_closure b64-#define StgTVarWatchQueue_closure(__ptr__) REP_StgTVarWatchQueue_closure[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVarWatchQueue_closure]-#define OFFSET_StgTVarWatchQueue_next_queue_entry 8-#define REP_StgTVarWatchQueue_next_queue_entry b64-#define StgTVarWatchQueue_next_queue_entry(__ptr__) REP_StgTVarWatchQueue_next_queue_entry[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVarWatchQueue_next_queue_entry]-#define OFFSET_StgTVarWatchQueue_prev_queue_entry 16-#define REP_StgTVarWatchQueue_prev_queue_entry b64-#define StgTVarWatchQueue_prev_queue_entry(__ptr__) REP_StgTVarWatchQueue_prev_queue_entry[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVarWatchQueue_prev_queue_entry]-#define SIZEOF_StgTVar_NoHdr 24-#define SIZEOF_StgTVar (SIZEOF_StgHeader+24)-#define OFFSET_StgTVar_current_value 0-#define REP_StgTVar_current_value b64-#define StgTVar_current_value(__ptr__) REP_StgTVar_current_value[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVar_current_value]-#define OFFSET_StgTVar_first_watch_queue_entry 8-#define REP_StgTVar_first_watch_queue_entry b64-#define StgTVar_first_watch_queue_entry(__ptr__) REP_StgTVar_first_watch_queue_entry[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVar_first_watch_queue_entry]-#define OFFSET_StgTVar_num_updates 16-#define REP_StgTVar_num_updates b64-#define StgTVar_num_updates(__ptr__) REP_StgTVar_num_updates[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVar_num_updates]-#define SIZEOF_StgWeak_NoHdr 40-#define SIZEOF_StgWeak (SIZEOF_StgHeader+40)-#define OFFSET_StgWeak_link 32-#define REP_StgWeak_link b64-#define StgWeak_link(__ptr__) REP_StgWeak_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_link]-#define OFFSET_StgWeak_key 8-#define REP_StgWeak_key b64-#define StgWeak_key(__ptr__) REP_StgWeak_key[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_key]-#define OFFSET_StgWeak_value 16-#define REP_StgWeak_value b64-#define StgWeak_value(__ptr__) REP_StgWeak_value[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_value]-#define OFFSET_StgWeak_finalizer 24-#define REP_StgWeak_finalizer b64-#define StgWeak_finalizer(__ptr__) REP_StgWeak_finalizer[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_finalizer]-#define OFFSET_StgWeak_cfinalizers 0-#define REP_StgWeak_cfinalizers b64-#define StgWeak_cfinalizers(__ptr__) REP_StgWeak_cfinalizers[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_cfinalizers]-#define SIZEOF_StgCFinalizerList_NoHdr 40-#define SIZEOF_StgCFinalizerList (SIZEOF_StgHeader+40)-#define OFFSET_StgCFinalizerList_link 0-#define REP_StgCFinalizerList_link b64-#define StgCFinalizerList_link(__ptr__) REP_StgCFinalizerList_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_link]-#define OFFSET_StgCFinalizerList_fptr 8-#define REP_StgCFinalizerList_fptr b64-#define StgCFinalizerList_fptr(__ptr__) REP_StgCFinalizerList_fptr[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_fptr]-#define OFFSET_StgCFinalizerList_ptr 16-#define REP_StgCFinalizerList_ptr b64-#define StgCFinalizerList_ptr(__ptr__) REP_StgCFinalizerList_ptr[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_ptr]-#define OFFSET_StgCFinalizerList_eptr 24-#define REP_StgCFinalizerList_eptr b64-#define StgCFinalizerList_eptr(__ptr__) REP_StgCFinalizerList_eptr[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_eptr]-#define OFFSET_StgCFinalizerList_flag 32-#define REP_StgCFinalizerList_flag b64-#define StgCFinalizerList_flag(__ptr__) REP_StgCFinalizerList_flag[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_flag]-#define SIZEOF_StgMVar_NoHdr 24-#define SIZEOF_StgMVar (SIZEOF_StgHeader+24)-#define OFFSET_StgMVar_head 0-#define REP_StgMVar_head b64-#define StgMVar_head(__ptr__) REP_StgMVar_head[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVar_head]-#define OFFSET_StgMVar_tail 8-#define REP_StgMVar_tail b64-#define StgMVar_tail(__ptr__) REP_StgMVar_tail[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVar_tail]-#define OFFSET_StgMVar_value 16-#define REP_StgMVar_value b64-#define StgMVar_value(__ptr__) REP_StgMVar_value[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVar_value]-#define SIZEOF_StgMVarTSOQueue_NoHdr 16-#define SIZEOF_StgMVarTSOQueue (SIZEOF_StgHeader+16)-#define OFFSET_StgMVarTSOQueue_link 0-#define REP_StgMVarTSOQueue_link b64-#define StgMVarTSOQueue_link(__ptr__) REP_StgMVarTSOQueue_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVarTSOQueue_link]-#define OFFSET_StgMVarTSOQueue_tso 8-#define REP_StgMVarTSOQueue_tso b64-#define StgMVarTSOQueue_tso(__ptr__) REP_StgMVarTSOQueue_tso[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVarTSOQueue_tso]-#define SIZEOF_StgBCO_NoHdr 32-#define SIZEOF_StgBCO (SIZEOF_StgHeader+32)-#define OFFSET_StgBCO_instrs 0-#define REP_StgBCO_instrs b64-#define StgBCO_instrs(__ptr__) REP_StgBCO_instrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_instrs]-#define OFFSET_StgBCO_literals 8-#define REP_StgBCO_literals b64-#define StgBCO_literals(__ptr__) REP_StgBCO_literals[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_literals]-#define OFFSET_StgBCO_ptrs 16-#define REP_StgBCO_ptrs b64-#define StgBCO_ptrs(__ptr__) REP_StgBCO_ptrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_ptrs]-#define OFFSET_StgBCO_arity 24-#define REP_StgBCO_arity b32-#define StgBCO_arity(__ptr__) REP_StgBCO_arity[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_arity]-#define OFFSET_StgBCO_size 28-#define REP_StgBCO_size b32-#define StgBCO_size(__ptr__) REP_StgBCO_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_size]-#define OFFSET_StgBCO_bitmap 32-#define StgBCO_bitmap(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_bitmap + WDS(__ix__)]-#define SIZEOF_StgStableName_NoHdr 8-#define SIZEOF_StgStableName (SIZEOF_StgHeader+8)-#define OFFSET_StgStableName_sn 0-#define REP_StgStableName_sn b64-#define StgStableName_sn(__ptr__) REP_StgStableName_sn[__ptr__+SIZEOF_StgHeader+OFFSET_StgStableName_sn]-#define SIZEOF_StgBlockingQueue_NoHdr 32-#define SIZEOF_StgBlockingQueue (SIZEOF_StgHeader+32)-#define OFFSET_StgBlockingQueue_bh 8-#define REP_StgBlockingQueue_bh b64-#define StgBlockingQueue_bh(__ptr__) REP_StgBlockingQueue_bh[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_bh]-#define OFFSET_StgBlockingQueue_owner 16-#define REP_StgBlockingQueue_owner b64-#define StgBlockingQueue_owner(__ptr__) REP_StgBlockingQueue_owner[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_owner]-#define OFFSET_StgBlockingQueue_queue 24-#define REP_StgBlockingQueue_queue b64-#define StgBlockingQueue_queue(__ptr__) REP_StgBlockingQueue_queue[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_queue]-#define OFFSET_StgBlockingQueue_link 0-#define REP_StgBlockingQueue_link b64-#define StgBlockingQueue_link(__ptr__) REP_StgBlockingQueue_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_link]-#define SIZEOF_MessageBlackHole_NoHdr 24-#define SIZEOF_MessageBlackHole (SIZEOF_StgHeader+24)-#define OFFSET_MessageBlackHole_link 0-#define REP_MessageBlackHole_link b64-#define MessageBlackHole_link(__ptr__) REP_MessageBlackHole_link[__ptr__+SIZEOF_StgHeader+OFFSET_MessageBlackHole_link]-#define OFFSET_MessageBlackHole_tso 8-#define REP_MessageBlackHole_tso b64-#define MessageBlackHole_tso(__ptr__) REP_MessageBlackHole_tso[__ptr__+SIZEOF_StgHeader+OFFSET_MessageBlackHole_tso]-#define OFFSET_MessageBlackHole_bh 16-#define REP_MessageBlackHole_bh b64-#define MessageBlackHole_bh(__ptr__) REP_MessageBlackHole_bh[__ptr__+SIZEOF_StgHeader+OFFSET_MessageBlackHole_bh]-#define SIZEOF_StgCompactNFData_NoHdr 72-#define SIZEOF_StgCompactNFData (SIZEOF_StgHeader+72)-#define OFFSET_StgCompactNFData_totalW 0-#define REP_StgCompactNFData_totalW b64-#define StgCompactNFData_totalW(__ptr__) REP_StgCompactNFData_totalW[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_totalW]-#define OFFSET_StgCompactNFData_autoBlockW 8-#define REP_StgCompactNFData_autoBlockW b64-#define StgCompactNFData_autoBlockW(__ptr__) REP_StgCompactNFData_autoBlockW[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_autoBlockW]-#define OFFSET_StgCompactNFData_nursery 32-#define REP_StgCompactNFData_nursery b64-#define StgCompactNFData_nursery(__ptr__) REP_StgCompactNFData_nursery[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_nursery]-#define OFFSET_StgCompactNFData_last 40-#define REP_StgCompactNFData_last b64-#define StgCompactNFData_last(__ptr__) REP_StgCompactNFData_last[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_last]-#define OFFSET_StgCompactNFData_hp 16-#define REP_StgCompactNFData_hp b64-#define StgCompactNFData_hp(__ptr__) REP_StgCompactNFData_hp[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_hp]-#define OFFSET_StgCompactNFData_hpLim 24-#define REP_StgCompactNFData_hpLim b64-#define StgCompactNFData_hpLim(__ptr__) REP_StgCompactNFData_hpLim[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_hpLim]-#define OFFSET_StgCompactNFData_hash 48-#define REP_StgCompactNFData_hash b64-#define StgCompactNFData_hash(__ptr__) REP_StgCompactNFData_hash[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_hash]-#define OFFSET_StgCompactNFData_result 56-#define REP_StgCompactNFData_result b64-#define StgCompactNFData_result(__ptr__) REP_StgCompactNFData_result[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_result]-#define SIZEOF_StgCompactNFDataBlock 24-#define OFFSET_StgCompactNFDataBlock_self 0-#define REP_StgCompactNFDataBlock_self b64-#define StgCompactNFDataBlock_self(__ptr__) REP_StgCompactNFDataBlock_self[__ptr__+OFFSET_StgCompactNFDataBlock_self]-#define OFFSET_StgCompactNFDataBlock_owner 8-#define REP_StgCompactNFDataBlock_owner b64-#define StgCompactNFDataBlock_owner(__ptr__) REP_StgCompactNFDataBlock_owner[__ptr__+OFFSET_StgCompactNFDataBlock_owner]-#define OFFSET_StgCompactNFDataBlock_next 16-#define REP_StgCompactNFDataBlock_next b64-#define StgCompactNFDataBlock_next(__ptr__) REP_StgCompactNFDataBlock_next[__ptr__+OFFSET_StgCompactNFDataBlock_next]-#define OFFSET_RtsFlags_ProfFlags_doHeapProfile 280-#define REP_RtsFlags_ProfFlags_doHeapProfile b32-#define RtsFlags_ProfFlags_doHeapProfile(__ptr__) REP_RtsFlags_ProfFlags_doHeapProfile[__ptr__+OFFSET_RtsFlags_ProfFlags_doHeapProfile]-#define OFFSET_RtsFlags_ProfFlags_showCCSOnException 301-#define REP_RtsFlags_ProfFlags_showCCSOnException b8-#define RtsFlags_ProfFlags_showCCSOnException(__ptr__) REP_RtsFlags_ProfFlags_showCCSOnException[__ptr__+OFFSET_RtsFlags_ProfFlags_showCCSOnException]-#define OFFSET_RtsFlags_DebugFlags_apply 244-#define REP_RtsFlags_DebugFlags_apply b8-#define RtsFlags_DebugFlags_apply(__ptr__) REP_RtsFlags_DebugFlags_apply[__ptr__+OFFSET_RtsFlags_DebugFlags_apply]-#define OFFSET_RtsFlags_DebugFlags_sanity 239-#define REP_RtsFlags_DebugFlags_sanity b8-#define RtsFlags_DebugFlags_sanity(__ptr__) REP_RtsFlags_DebugFlags_sanity[__ptr__+OFFSET_RtsFlags_DebugFlags_sanity]-#define OFFSET_RtsFlags_DebugFlags_weak 234-#define REP_RtsFlags_DebugFlags_weak b8-#define RtsFlags_DebugFlags_weak(__ptr__) REP_RtsFlags_DebugFlags_weak[__ptr__+OFFSET_RtsFlags_DebugFlags_weak]-#define OFFSET_RtsFlags_GcFlags_initialStkSize 16-#define REP_RtsFlags_GcFlags_initialStkSize b32-#define RtsFlags_GcFlags_initialStkSize(__ptr__) REP_RtsFlags_GcFlags_initialStkSize[__ptr__+OFFSET_RtsFlags_GcFlags_initialStkSize]-#define OFFSET_RtsFlags_MiscFlags_tickInterval 200-#define REP_RtsFlags_MiscFlags_tickInterval b64-#define RtsFlags_MiscFlags_tickInterval(__ptr__) REP_RtsFlags_MiscFlags_tickInterval[__ptr__+OFFSET_RtsFlags_MiscFlags_tickInterval]-#define SIZEOF_StgFunInfoExtraFwd 32-#define OFFSET_StgFunInfoExtraFwd_slow_apply 24-#define REP_StgFunInfoExtraFwd_slow_apply b64-#define StgFunInfoExtraFwd_slow_apply(__ptr__) REP_StgFunInfoExtraFwd_slow_apply[__ptr__+OFFSET_StgFunInfoExtraFwd_slow_apply]-#define OFFSET_StgFunInfoExtraFwd_fun_type 0-#define REP_StgFunInfoExtraFwd_fun_type b32-#define StgFunInfoExtraFwd_fun_type(__ptr__) REP_StgFunInfoExtraFwd_fun_type[__ptr__+OFFSET_StgFunInfoExtraFwd_fun_type]-#define OFFSET_StgFunInfoExtraFwd_arity 4-#define REP_StgFunInfoExtraFwd_arity b32-#define StgFunInfoExtraFwd_arity(__ptr__) REP_StgFunInfoExtraFwd_arity[__ptr__+OFFSET_StgFunInfoExtraFwd_arity]-#define OFFSET_StgFunInfoExtraFwd_bitmap 16-#define REP_StgFunInfoExtraFwd_bitmap b64-#define StgFunInfoExtraFwd_bitmap(__ptr__) REP_StgFunInfoExtraFwd_bitmap[__ptr__+OFFSET_StgFunInfoExtraFwd_bitmap]-#define SIZEOF_StgFunInfoExtraRev 24-#define OFFSET_StgFunInfoExtraRev_slow_apply_offset 0-#define REP_StgFunInfoExtraRev_slow_apply_offset b32-#define StgFunInfoExtraRev_slow_apply_offset(__ptr__) REP_StgFunInfoExtraRev_slow_apply_offset[__ptr__+OFFSET_StgFunInfoExtraRev_slow_apply_offset]-#define OFFSET_StgFunInfoExtraRev_fun_type 16-#define REP_StgFunInfoExtraRev_fun_type b32-#define StgFunInfoExtraRev_fun_type(__ptr__) REP_StgFunInfoExtraRev_fun_type[__ptr__+OFFSET_StgFunInfoExtraRev_fun_type]-#define OFFSET_StgFunInfoExtraRev_arity 20-#define REP_StgFunInfoExtraRev_arity b32-#define StgFunInfoExtraRev_arity(__ptr__) REP_StgFunInfoExtraRev_arity[__ptr__+OFFSET_StgFunInfoExtraRev_arity]-#define OFFSET_StgFunInfoExtraRev_bitmap 8-#define REP_StgFunInfoExtraRev_bitmap b64-#define StgFunInfoExtraRev_bitmap(__ptr__) REP_StgFunInfoExtraRev_bitmap[__ptr__+OFFSET_StgFunInfoExtraRev_bitmap]-#define OFFSET_StgFunInfoExtraRev_bitmap_offset 8-#define REP_StgFunInfoExtraRev_bitmap_offset b32-#define StgFunInfoExtraRev_bitmap_offset(__ptr__) REP_StgFunInfoExtraRev_bitmap_offset[__ptr__+OFFSET_StgFunInfoExtraRev_bitmap_offset]-#define OFFSET_StgLargeBitmap_size 0-#define REP_StgLargeBitmap_size b64-#define StgLargeBitmap_size(__ptr__) REP_StgLargeBitmap_size[__ptr__+OFFSET_StgLargeBitmap_size]-#define OFFSET_StgLargeBitmap_bitmap 8-#define SIZEOF_snEntry 24-#define OFFSET_snEntry_sn_obj 16-#define REP_snEntry_sn_obj b64-#define snEntry_sn_obj(__ptr__) REP_snEntry_sn_obj[__ptr__+OFFSET_snEntry_sn_obj]-#define OFFSET_snEntry_addr 0-#define REP_snEntry_addr b64-#define snEntry_addr(__ptr__) REP_snEntry_addr[__ptr__+OFFSET_snEntry_addr]-#define SIZEOF_spEntry 8-#define OFFSET_spEntry_addr 0-#define REP_spEntry_addr b64-#define spEntry_addr(__ptr__) REP_spEntry_addr[__ptr__+OFFSET_spEntry_addr]
− ghc-lib/stage0/lib/ghcautoconf.h 
@@ -1,630 +0,0 @@-#if !defined(__GHCAUTOCONF_H__)-#define __GHCAUTOCONF_H__-/* mk/config.h.  Generated from config.h.in by configure.  */-/* mk/config.h.in.  Generated from configure.ac by autoheader.  */--/* Define if building universal (internal helper macro) */-/* #undef AC_APPLE_UNIVERSAL_BUILD */--/* The alignment of a `char'. */-#define ALIGNMENT_CHAR 1--/* The alignment of a `double'. */-#define ALIGNMENT_DOUBLE 8--/* The alignment of a `float'. */-#define ALIGNMENT_FLOAT 4--/* The alignment of a `int'. */-#define ALIGNMENT_INT 4--/* The alignment of a `int16_t'. */-#define ALIGNMENT_INT16_T 2--/* The alignment of a `int32_t'. */-#define ALIGNMENT_INT32_T 4--/* The alignment of a `int64_t'. */-#define ALIGNMENT_INT64_T 8--/* The alignment of a `int8_t'. */-#define ALIGNMENT_INT8_T 1--/* The alignment of a `long'. */-#define ALIGNMENT_LONG 8--/* The alignment of a `long long'. */-#define ALIGNMENT_LONG_LONG 8--/* The alignment of a `short'. */-#define ALIGNMENT_SHORT 2--/* The alignment of a `uint16_t'. */-#define ALIGNMENT_UINT16_T 2--/* The alignment of a `uint32_t'. */-#define ALIGNMENT_UINT32_T 4--/* The alignment of a `uint64_t'. */-#define ALIGNMENT_UINT64_T 8--/* The alignment of a `uint8_t'. */-#define ALIGNMENT_UINT8_T 1--/* The alignment of a `unsigned char'. */-#define ALIGNMENT_UNSIGNED_CHAR 1--/* The alignment of a `unsigned int'. */-#define ALIGNMENT_UNSIGNED_INT 4--/* The alignment of a `unsigned long'. */-#define ALIGNMENT_UNSIGNED_LONG 8--/* The alignment of a `unsigned long long'. */-#define ALIGNMENT_UNSIGNED_LONG_LONG 8--/* The alignment of a `unsigned short'. */-#define ALIGNMENT_UNSIGNED_SHORT 2--/* The alignment of a `void *'. */-#define ALIGNMENT_VOID_P 8--/* Define (to 1) if C compiler has an LLVM back end */-#define CC_LLVM_BACKEND 1--/* Define to 1 if __thread is supported */-#define CC_SUPPORTS_TLS 1--/* Define to 1 if using 'alloca.c'. */-/* #undef C_ALLOCA */--/* Enable Native I/O manager as default. */-/* #undef DEFAULT_NATIVE_IO_MANAGER */--/* Define to 1 if your processor stores words of floats with the most-   significant byte first */-/* #undef FLOAT_WORDS_BIGENDIAN */--/* Has visibility hidden */-#define HAS_VISIBILITY_HIDDEN 1--/* Define to 1 if you have 'alloca', as a function or macro. */-#define HAVE_ALLOCA 1--/* Define to 1 if <alloca.h> works. */-#define HAVE_ALLOCA_H 1--/* Define to 1 if you have the <bfd.h> header file. */-/* #undef HAVE_BFD_H */--/* Does C compiler support __atomic primitives? */-#define HAVE_C11_ATOMICS 1--/* Define to 1 if you have the `clock_gettime' function. */-#define HAVE_CLOCK_GETTIME 1--/* Define to 1 if you have the `ctime_r' function. */-#define HAVE_CTIME_R 1--/* Define to 1 if you have the <ctype.h> header file. */-#define HAVE_CTYPE_H 1--/* Define to 1 if you have the declaration of `ctime_r', and to 0 if you-   don't. */-#define HAVE_DECL_CTIME_R 1--/* Define to 1 if you have the declaration of `environ', and to 0 if you-   don't. */-#define HAVE_DECL_ENVIRON 0--/* Define to 1 if you have the declaration of `MADV_DONTNEED', and to 0 if you-   don't. */-/* #undef HAVE_DECL_MADV_DONTNEED */--/* Define to 1 if you have the declaration of `MADV_FREE', and to 0 if you-   don't. */-/* #undef HAVE_DECL_MADV_FREE */--/* Define to 1 if you have the declaration of `MAP_NORESERVE', and to 0 if you-   don't. */-/* #undef HAVE_DECL_MAP_NORESERVE */--/* Define to 1 if you have the <dirent.h> header file. */-#define HAVE_DIRENT_H 1--/* Define to 1 if you have the <dlfcn.h> header file. */-#define HAVE_DLFCN_H 1--/* Define to 1 if you have the `dlinfo' function. */-/* #undef HAVE_DLINFO */--/* Define to 1 if you have the <elfutils/libdw.h> header file. */-/* #undef HAVE_ELFUTILS_LIBDW_H */--/* Define to 1 if you have the <errno.h> header file. */-#define HAVE_ERRNO_H 1--/* Define to 1 if you have the `eventfd' function. */-/* #undef HAVE_EVENTFD */--/* Define to 1 if you have the <fcntl.h> header file. */-#define HAVE_FCNTL_H 1--/* Define to 1 if you have the <ffi.h> header file. */-/* #undef HAVE_FFI_H */--/* Define to 1 if you have the `fork' function. */-#define HAVE_FORK 1--/* Define to 1 if you have the `getclock' function. */-/* #undef HAVE_GETCLOCK */--/* Define to 1 if you have the `GetModuleFileName' function. */-/* #undef HAVE_GETMODULEFILENAME */--/* Define to 1 if you have the `getrusage' function. */-#define HAVE_GETRUSAGE 1--/* Define to 1 if you have the `gettimeofday' function. */-#define HAVE_GETTIMEOFDAY 1--/* Define to 1 if you have the <grp.h> header file. */-#define HAVE_GRP_H 1--/* Define to 1 if you have the <inttypes.h> header file. */-#define HAVE_INTTYPES_H 1--/* Define to 1 if you have the `bfd' library (-lbfd). */-/* #undef HAVE_LIBBFD */--/* Define to 1 if you have the `dl' library (-ldl). */-#define HAVE_LIBDL 1--/* Define to 1 if you have the `iberty' library (-liberty). */-/* #undef HAVE_LIBIBERTY */--/* Define to 1 if you need to link with libm */-#define HAVE_LIBM 1--/* Define to 1 if you have libnuma */-#define HAVE_LIBNUMA 0--/* Define to 1 if you have the `pthread' library (-lpthread). */-#define HAVE_LIBPTHREAD 1--/* Define to 1 if you have the `rt' library (-lrt). */-/* #undef HAVE_LIBRT */--/* Define to 1 if you have the <limits.h> header file. */-#define HAVE_LIMITS_H 1--/* Define to 1 if you have the <locale.h> header file. */-#define HAVE_LOCALE_H 1--/* Define to 1 if the system has the type `long long'. */-#define HAVE_LONG_LONG 1--/* Define to 1 if you have the mingwex library. */-/* #undef HAVE_MINGWEX */--/* Define to 1 if you have the <minix/config.h> header file. */-/* #undef HAVE_MINIX_CONFIG_H */--/* Define to 1 if you have the <nlist.h> header file. */-#define HAVE_NLIST_H 1--/* Define to 1 if you have the <numaif.h> header file. */-/* #undef HAVE_NUMAIF_H */--/* Define to 1 if you have the <numa.h> header file. */-/* #undef HAVE_NUMA_H */--/* Define to 1 if we have printf$LDBLStub (Apple Mac OS >= 10.4, PPC). */-#define HAVE_PRINTF_LDBLSTUB 0--/* Define to 1 if you have the `pthread_condattr_setclock' function. */-/* #undef HAVE_PTHREAD_CONDATTR_SETCLOCK */--/* Define to 1 if you have the <pthread.h> header file. */-#define HAVE_PTHREAD_H 1--/* Define to 1 if you have the <pthread_np.h> header file. */-/* #undef HAVE_PTHREAD_NP_H */--/* Define to 1 if you have the glibc version of pthread_setname_np */-/* #undef HAVE_PTHREAD_SETNAME_NP */--/* Define to 1 if you have the Darwin version of pthread_setname_np */-#define HAVE_PTHREAD_SETNAME_NP_DARWIN 1--/* Define to 1 if you have pthread_set_name_np */-/* #undef HAVE_PTHREAD_SET_NAME_NP */--/* Define to 1 if you have the <pwd.h> header file. */-#define HAVE_PWD_H 1--/* Define to 1 if you have the `sched_getaffinity' function. */-/* #undef HAVE_SCHED_GETAFFINITY */--/* Define to 1 if you have the <sched.h> header file. */-#define HAVE_SCHED_H 1--/* Define to 1 if you have the `sched_setaffinity' function. */-/* #undef HAVE_SCHED_SETAFFINITY */--/* Define to 1 if you have the `setitimer' function. */-#define HAVE_SETITIMER 1--/* Define to 1 if you have the `setlocale' function. */-#define HAVE_SETLOCALE 1--/* Define to 1 if you have the `siginterrupt' function. */-#define HAVE_SIGINTERRUPT 1--/* Define to 1 if you have the <signal.h> header file. */-#define HAVE_SIGNAL_H 1--/* Define to 1 if you have the <stdint.h> header file. */-#define HAVE_STDINT_H 1--/* Define to 1 if you have the <stdio.h> header file. */-#define HAVE_STDIO_H 1--/* Define to 1 if you have the <stdlib.h> header file. */-#define HAVE_STDLIB_H 1--/* Define to 1 if you have the <strings.h> header file. */-#define HAVE_STRINGS_H 1--/* Define to 1 if you have the <string.h> header file. */-#define HAVE_STRING_H 1--/* Define to 1 if Apple-style dead-stripping is supported. */-#define HAVE_SUBSECTIONS_VIA_SYMBOLS 1--/* Define to 1 if you have the `sysconf' function. */-#define HAVE_SYSCONF 1--/* Define to 1 if you have libffi. */-/* #undef HAVE_SYSTEM_LIBFFI */--/* Define to 1 if you have the <sys/cpuset.h> header file. */-/* #undef HAVE_SYS_CPUSET_H */--/* Define to 1 if you have the <sys/eventfd.h> header file. */-/* #undef HAVE_SYS_EVENTFD_H */--/* Define to 1 if you have the <sys/mman.h> header file. */-#define HAVE_SYS_MMAN_H 1--/* Define to 1 if you have the <sys/param.h> header file. */-#define HAVE_SYS_PARAM_H 1--/* Define to 1 if you have the <sys/resource.h> header file. */-#define HAVE_SYS_RESOURCE_H 1--/* Define to 1 if you have the <sys/select.h> header file. */-#define HAVE_SYS_SELECT_H 1--/* Define to 1 if you have the <sys/stat.h> header file. */-#define HAVE_SYS_STAT_H 1--/* Define to 1 if you have the <sys/timeb.h> header file. */-#define HAVE_SYS_TIMEB_H 1--/* Define to 1 if you have the <sys/timerfd.h> header file. */-/* #undef HAVE_SYS_TIMERFD_H */--/* Define to 1 if you have the <sys/timers.h> header file. */-/* #undef HAVE_SYS_TIMERS_H */--/* Define to 1 if you have the <sys/times.h> header file. */-#define HAVE_SYS_TIMES_H 1--/* Define to 1 if you have the <sys/time.h> header file. */-#define HAVE_SYS_TIME_H 1--/* Define to 1 if you have the <sys/types.h> header file. */-#define HAVE_SYS_TYPES_H 1--/* Define to 1 if you have the <sys/utsname.h> header file. */-#define HAVE_SYS_UTSNAME_H 1--/* Define to 1 if you have the <sys/wait.h> header file. */-#define HAVE_SYS_WAIT_H 1--/* Define to 1 if you have the <termios.h> header file. */-#define HAVE_TERMIOS_H 1--/* Define to 1 if you have the `timer_settime' function. */-/* #undef HAVE_TIMER_SETTIME */--/* Define to 1 if you have the `times' function. */-#define HAVE_TIMES 1--/* Define to 1 if you have the <time.h> header file. */-#define HAVE_TIME_H 1--/* Define to 1 if you have the <unistd.h> header file. */-#define HAVE_UNISTD_H 1--/* Define to 1 if you have the <utime.h> header file. */-#define HAVE_UTIME_H 1--/* Define to 1 if you have the `vfork' function. */-#define HAVE_VFORK 1--/* Define to 1 if you have the <vfork.h> header file. */-/* #undef HAVE_VFORK_H */--/* Define to 1 if you have the <wchar.h> header file. */-#define HAVE_WCHAR_H 1--/* Define to 1 if you have the <windows.h> header file. */-/* #undef HAVE_WINDOWS_H */--/* Define to 1 if you have the `WinExec' function. */-/* #undef HAVE_WINEXEC */--/* Define to 1 if you have the <winsock.h> header file. */-/* #undef HAVE_WINSOCK_H */--/* Define to 1 if `fork' works. */-#define HAVE_WORKING_FORK 1--/* Define to 1 if `vfork' works. */-#define HAVE_WORKING_VFORK 1--/* Define to 1 if C symbols have a leading underscore added by the compiler.-   */-#define LEADING_UNDERSCORE 1--/* Define to 1 if we need -latomic. */-#define NEED_ATOMIC_LIB 0--/* Define 1 if we need to link code using pthreads with -lpthread */-#define NEED_PTHREAD_LIB 0--/* Define to the address where bug reports for this package should be sent. */-/* #undef PACKAGE_BUGREPORT */--/* Define to the full name of this package. */-/* #undef PACKAGE_NAME */--/* Define to the full name and version of this package. */-/* #undef PACKAGE_STRING */--/* Define to the one symbol short name of this package. */-/* #undef PACKAGE_TARNAME */--/* Define to the home page for this package. */-/* #undef PACKAGE_URL */--/* Define to the version of this package. */-/* #undef PACKAGE_VERSION */--/* Use mmap in the runtime linker */-#define RTS_LINKER_USE_MMAP 1--/* The size of `char', as computed by sizeof. */-#define SIZEOF_CHAR 1--/* The size of `double', as computed by sizeof. */-#define SIZEOF_DOUBLE 8--/* The size of `float', as computed by sizeof. */-#define SIZEOF_FLOAT 4--/* The size of `int', as computed by sizeof. */-#define SIZEOF_INT 4--/* The size of `int16_t', as computed by sizeof. */-#define SIZEOF_INT16_T 2--/* The size of `int32_t', as computed by sizeof. */-#define SIZEOF_INT32_T 4--/* The size of `int64_t', as computed by sizeof. */-#define SIZEOF_INT64_T 8--/* The size of `int8_t', as computed by sizeof. */-#define SIZEOF_INT8_T 1--/* The size of `long', as computed by sizeof. */-#define SIZEOF_LONG 8--/* The size of `long long', as computed by sizeof. */-#define SIZEOF_LONG_LONG 8--/* The size of `short', as computed by sizeof. */-#define SIZEOF_SHORT 2--/* The size of `uint16_t', as computed by sizeof. */-#define SIZEOF_UINT16_T 2--/* The size of `uint32_t', as computed by sizeof. */-#define SIZEOF_UINT32_T 4--/* The size of `uint64_t', as computed by sizeof. */-#define SIZEOF_UINT64_T 8--/* The size of `uint8_t', as computed by sizeof. */-#define SIZEOF_UINT8_T 1--/* The size of `unsigned char', as computed by sizeof. */-#define SIZEOF_UNSIGNED_CHAR 1--/* The size of `unsigned int', as computed by sizeof. */-#define SIZEOF_UNSIGNED_INT 4--/* The size of `unsigned long', as computed by sizeof. */-#define SIZEOF_UNSIGNED_LONG 8--/* The size of `unsigned long long', as computed by sizeof. */-#define SIZEOF_UNSIGNED_LONG_LONG 8--/* The size of `unsigned short', as computed by sizeof. */-#define SIZEOF_UNSIGNED_SHORT 2--/* The size of `void *', as computed by sizeof. */-#define SIZEOF_VOID_P 8--/* If using the C implementation of alloca, define if you know the-   direction of stack growth for your system; otherwise it will be-   automatically deduced at runtime.-	STACK_DIRECTION > 0 => grows toward higher addresses-	STACK_DIRECTION < 0 => grows toward lower addresses-	STACK_DIRECTION = 0 => direction of growth unknown */-/* #undef STACK_DIRECTION */--/* Define to 1 if all of the C90 standard headers exist (not just the ones-   required in a freestanding environment). This macro is provided for-   backward compatibility; new code need not use it. */-#define STDC_HEADERS 1--/* Define to 1 if info tables are laid out next to code */-#define TABLES_NEXT_TO_CODE 1--/* Define to 1 if you can safely include both <sys/time.h> and <time.h>. This-   macro is obsolete. */-#define TIME_WITH_SYS_TIME 1--/* Enable single heap address space support */-#define USE_LARGE_ADDRESS_SPACE 1--/* Set to 1 to use libdw */-#define USE_LIBDW 0--/* Enable extensions on AIX 3, Interix.  */-#ifndef _ALL_SOURCE-# define _ALL_SOURCE 1-#endif-/* Enable general extensions on macOS.  */-#ifndef _DARWIN_C_SOURCE-# define _DARWIN_C_SOURCE 1-#endif-/* Enable general extensions on Solaris.  */-#ifndef __EXTENSIONS__-# define __EXTENSIONS__ 1-#endif-/* Enable GNU extensions on systems that have them.  */-#ifndef _GNU_SOURCE-# define _GNU_SOURCE 1-#endif-/* Enable X/Open compliant socket functions that do not require linking-   with -lxnet on HP-UX 11.11.  */-#ifndef _HPUX_ALT_XOPEN_SOCKET_API-# define _HPUX_ALT_XOPEN_SOCKET_API 1-#endif-/* Identify the host operating system as Minix.-   This macro does not affect the system headers' behavior.-   A future release of Autoconf may stop defining this macro.  */-#ifndef _MINIX-/* # undef _MINIX */-#endif-/* Enable general extensions on NetBSD.-   Enable NetBSD compatibility extensions on Minix.  */-#ifndef _NETBSD_SOURCE-# define _NETBSD_SOURCE 1-#endif-/* Enable OpenBSD compatibility extensions on NetBSD.-   Oddly enough, this does nothing on OpenBSD.  */-#ifndef _OPENBSD_SOURCE-# define _OPENBSD_SOURCE 1-#endif-/* Define to 1 if needed for POSIX-compatible behavior.  */-#ifndef _POSIX_SOURCE-/* # undef _POSIX_SOURCE */-#endif-/* Define to 2 if needed for POSIX-compatible behavior.  */-#ifndef _POSIX_1_SOURCE-/* # undef _POSIX_1_SOURCE */-#endif-/* Enable POSIX-compatible threading on Solaris.  */-#ifndef _POSIX_PTHREAD_SEMANTICS-# define _POSIX_PTHREAD_SEMANTICS 1-#endif-/* Enable extensions specified by ISO/IEC TS 18661-5:2014.  */-#ifndef __STDC_WANT_IEC_60559_ATTRIBS_EXT__-# define __STDC_WANT_IEC_60559_ATTRIBS_EXT__ 1-#endif-/* Enable extensions specified by ISO/IEC TS 18661-1:2014.  */-#ifndef __STDC_WANT_IEC_60559_BFP_EXT__-# define __STDC_WANT_IEC_60559_BFP_EXT__ 1-#endif-/* Enable extensions specified by ISO/IEC TS 18661-2:2015.  */-#ifndef __STDC_WANT_IEC_60559_DFP_EXT__-# define __STDC_WANT_IEC_60559_DFP_EXT__ 1-#endif-/* Enable extensions specified by ISO/IEC TS 18661-4:2015.  */-#ifndef __STDC_WANT_IEC_60559_FUNCS_EXT__-# define __STDC_WANT_IEC_60559_FUNCS_EXT__ 1-#endif-/* Enable extensions specified by ISO/IEC TS 18661-3:2015.  */-#ifndef __STDC_WANT_IEC_60559_TYPES_EXT__-# define __STDC_WANT_IEC_60559_TYPES_EXT__ 1-#endif-/* Enable extensions specified by ISO/IEC TR 24731-2:2010.  */-#ifndef __STDC_WANT_LIB_EXT2__-# define __STDC_WANT_LIB_EXT2__ 1-#endif-/* Enable extensions specified by ISO/IEC 24747:2009.  */-#ifndef __STDC_WANT_MATH_SPEC_FUNCS__-# define __STDC_WANT_MATH_SPEC_FUNCS__ 1-#endif-/* Enable extensions on HP NonStop.  */-#ifndef _TANDEM_SOURCE-# define _TANDEM_SOURCE 1-#endif-/* Enable X/Open extensions.  Define to 500 only if necessary-   to make mbstate_t available.  */-#ifndef _XOPEN_SOURCE-/* # undef _XOPEN_SOURCE */-#endif---/* Define to 1 if we can use timer_create(CLOCK_REALTIME,...) */-/* #undef USE_TIMER_CREATE */--/* Define WORDS_BIGENDIAN to 1 if your processor stores words with the most-   significant byte first (like Motorola and SPARC, unlike Intel). */-#if defined AC_APPLE_UNIVERSAL_BUILD-# if defined __BIG_ENDIAN__-#  define WORDS_BIGENDIAN 1-# endif-#else-# ifndef WORDS_BIGENDIAN-/* #  undef WORDS_BIGENDIAN */-# endif-#endif--/* Number of bits in a file offset, on hosts where this is settable. */-/* #undef _FILE_OFFSET_BITS */--/* Define for large files, on AIX-style hosts. */-/* #undef _LARGE_FILES */--/* ARM pre v6 */-/* #undef arm_HOST_ARCH_PRE_ARMv6 */--/* ARM pre v7 */-/* #undef arm_HOST_ARCH_PRE_ARMv7 */--/* Define to empty if `const' does not conform to ANSI C. */-/* #undef const */--/* Define as a signed integer type capable of holding a process identifier. */-/* #undef pid_t */--/* The maximum supported LLVM version number */-#define sUPPORTED_LLVM_VERSION_MAX (13)--/* The minimum supported LLVM version number */-#define sUPPORTED_LLVM_VERSION_MIN (9)--/* Define to `unsigned int' if <sys/types.h> does not define. */-/* #undef size_t */--/* Define as `fork' if `vfork' does not work. */-/* #undef vfork */-#endif /* __GHCAUTOCONF_H__ */
− ghc-lib/stage0/lib/ghcplatform.h 
@@ -1,28 +0,0 @@-#if !defined(__GHCPLATFORM_H__)-#define __GHCPLATFORM_H__--#define GHC_STAGE 1--#define BuildPlatform_TYPE  x86_64_apple_darwin-#define HostPlatform_TYPE   x86_64_apple_darwin--#define x86_64_apple_darwin_BUILD 1-#define x86_64_apple_darwin_HOST 1--#define x86_64_BUILD_ARCH 1-#define x86_64_HOST_ARCH 1-#define BUILD_ARCH "x86_64"-#define HOST_ARCH "x86_64"--#define darwin_BUILD_OS 1-#define darwin_HOST_OS 1-#define BUILD_OS "darwin"-#define HOST_OS "darwin"--#define apple_BUILD_VENDOR 1-#define apple_HOST_VENDOR 1-#define BUILD_VENDOR "apple"-#define HOST_VENDOR "apple"---#endif /* __GHCPLATFORM_H__ */
ghc-lib/stage0/lib/llvm-targets view
@@ -1,23 +1,23 @@ [("i386-unknown-windows", ("e-m:x-p:32:32-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:32-n8:16:32-a:0:32-S32", "pentium4", "")) ,("i686-unknown-windows", ("e-m:x-p:32:32-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:32-n8:16:32-a:0:32-S32", "pentium4", "")) ,("x86_64-unknown-windows", ("e-m:w-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "x86-64", ""))-,("arm-unknown-linux-gnueabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm7tdmi", "+strict-align"))-,("arm-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))-,("arm-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))-,("armv6-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1136jf-s", "+strict-align"))-,("armv6-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1136jf-s", "+strict-align"))-,("armv6l-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))-,("armv6l-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))-,("armv7-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))-,("armv7-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))-,("armv7a-unknown-linux-gnueabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))-,("armv7a-unknown-linux-musleabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))-,("armv7a-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))-,("armv7a-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))-,("armv7l-unknown-linux-gnueabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))-,("armv7l-unknown-linux-musleabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))-,("armv7l-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))-,("armv7l-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))+,("arm-unknown-linux-gnueabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm7tdmi", "-vfp2 -vfp2sp -vfp3 -vfp3d16 -vfp3d16sp -vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 -fp64 -d32 -neon -sha2 -aes -dotprod -fp16fml -bf16 -mve.fp -fpregs +strict-align"))+,("arm-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+vfp2 +vfp2sp -vfp3 -vfp3d16 -vfp3d16sp -vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 -d32 -neon -sha2 -aes -fp16fml +strict-align"))+,("arm-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+vfp2 +vfp2sp -vfp3 -vfp3d16 -vfp3d16sp -vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 -d32 -neon -sha2 -aes -fp16fml +strict-align"))+,("armv6-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1136jf-s", "+vfp2 +vfp2sp -vfp3 -vfp3d16 -vfp3d16sp -vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 -d32 -neon -sha2 -aes -fp16fml +strict-align"))+,("armv6-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1136jf-s", "+vfp2 +vfp2sp -vfp3 -vfp3d16 -vfp3d16sp -vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 -d32 -neon -sha2 -aes -fp16fml +strict-align"))+,("armv6l-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+vfp2 +vfp2sp -vfp3 -vfp3d16 -vfp3d16sp -vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 -d32 -neon -sha2 -aes -fp16fml +strict-align"))+,("armv6l-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+vfp2 +vfp2sp -vfp3 -vfp3d16 -vfp3d16sp -vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 -d32 -neon -sha2 -aes -fp16fml +strict-align"))+,("armv7-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+vfp2 +vfp2sp +vfp3 +vfp3d16 +vfp3d16sp +vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 +d32 +neon -sha2 -aes -fp16fml"))+,("armv7-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+vfp2 +vfp2sp +vfp3 +vfp3d16 +vfp3d16sp +vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 +d32 +neon -sha2 -aes -fp16fml"))+,("armv7a-unknown-linux-gnueabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+vfp2 +vfp2sp +vfp3 +vfp3d16 +vfp3d16sp +vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 +d32 +neon -sha2 -aes -fp16fml"))+,("armv7a-unknown-linux-musleabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+vfp2 +vfp2sp +vfp3 +vfp3d16 +vfp3d16sp +vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 +d32 +neon -sha2 -aes -fp16fml"))+,("armv7a-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+vfp2 +vfp2sp +vfp3 +vfp3d16 +vfp3d16sp +vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 +d32 +neon -sha2 -aes -fp16fml"))+,("armv7a-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+vfp2 +vfp2sp +vfp3 +vfp3d16 +vfp3d16sp +vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 +d32 +neon -sha2 -aes -fp16fml"))+,("armv7l-unknown-linux-gnueabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+vfp2 +vfp2sp +vfp3 +vfp3d16 +vfp3d16sp +vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 +d32 +neon -sha2 -aes -fp16fml"))+,("armv7l-unknown-linux-musleabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+vfp2 +vfp2sp +vfp3 +vfp3d16 +vfp3d16sp +vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 +d32 +neon -sha2 -aes -fp16fml"))+,("armv7l-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+vfp2 +vfp2sp +vfp3 +vfp3d16 +vfp3d16sp +vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 +d32 +neon -sha2 -aes -fp16fml"))+,("armv7l-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+vfp2 +vfp2sp +vfp3 +vfp3d16 +vfp3d16sp +vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 +d32 +neon -sha2 -aes -fp16fml")) ,("aarch64-unknown-linux-gnu", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon")) ,("aarch64-unknown-linux-musl", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon")) ,("aarch64-unknown-linux", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon"))@@ -31,26 +31,29 @@ ,("x86_64-unknown-linux-musl", ("e-m:e-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "")) ,("x86_64-unknown-linux", ("e-m:e-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "")) ,("x86_64-unknown-linux-android", ("e-m:e-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "+sse4.2 +popcnt +cx16"))-,("armv7-unknown-linux-androideabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+fpregs +vfp2 +vfp2sp +vfp3 +vfp3d16 +vfp3d16sp +vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 +d32 +neon -crypto -fp16fml"))-,("aarch64-unknown-linux-android", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon"))-,("armv7a-unknown-linux-androideabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+fpregs +vfp2 +vfp2sp +vfp3 +vfp3d16 +vfp3d16sp +vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 +d32 +neon -crypto -fp16fml"))-,("powerpc64le-unknown-linux-gnu", ("e-m:e-i64:64-n32:64", "ppc64le", ""))-,("powerpc64le-unknown-linux-musl", ("e-m:e-i64:64-n32:64", "ppc64le", "+secure-plt"))-,("powerpc64le-unknown-linux", ("e-m:e-i64:64-n32:64", "ppc64le", ""))+,("armv7-unknown-linux-androideabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+vfp2 +vfp2sp +vfp3 +vfp3d16 +vfp3d16sp +vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 +d32 +neon -sha2 -aes -fp16fml"))+,("aarch64-unknown-linux-android", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon +outline-atomics"))+,("armv7a-unknown-linux-androideabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+vfp2 +vfp2sp +vfp3 +vfp3d16 +vfp3d16sp +vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 +d32 +neon -sha2 -aes -fp16fml"))+,("powerpc64le-unknown-linux-gnu", ("e-m:e-i64:64-n32:64-S128-v256:256:256-v512:512:512", "ppc64le", ""))+,("powerpc64le-unknown-linux-musl", ("e-m:e-i64:64-n32:64-S128-v256:256:256-v512:512:512", "ppc64le", "+secure-plt"))+,("powerpc64le-unknown-linux", ("e-m:e-i64:64-n32:64-S128-v256:256:256-v512:512:512", "ppc64le", "")) ,("s390x-ibm-linux", ("E-m:e-i1:8:16-i8:8:16-i64:64-f128:64-a:8:16-n32:64", "z10", ""))-,("riscv64-unknown-linux-gnu", ("e-m:e-p:64:64-i64:64-i128:128-n64-S128", "", "+m +a +f +d +c +relax"))-,("riscv64-unknown-linux", ("e-m:e-p:64:64-i64:64-i128:128-n64-S128", "", "+m +a +f +d +c +relax"))-,("i386-apple-darwin", ("e-m:o-p:32:32-p270:32:32-p271:32:32-p272:64:64-f64:32:64-f80:128-n8:16:32-S128", "penryn", ""))-,("x86_64-apple-darwin", ("e-m:o-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "penryn", ""))-,("arm64-apple-darwin", ("e-m:o-i64:64-i128:128-n32:64-S128", "generic", "+v8.3a +fp-armv8 +neon +crc +crypto +fullfp16 +ras +lse +rdm +rcpc +zcm +zcz +sha2 +aes"))-,("armv7-apple-ios", ("e-m:o-p:32:32-Fi8-f64:32:64-v64:32:64-v128:32:128-a:0:32-n32-S32", "generic", ""))+,("riscv64-unknown-linux-gnu", ("e-m:e-p:64:64-i64:64-i128:128-n64-S128", "", "+m +a +f +d +c +relax -save-restore"))+,("riscv64-unknown-linux", ("e-m:e-p:64:64-i64:64-i128:128-n64-S128", "", "+m +a +f +d +c +relax -save-restore"))+,("i386-apple-darwin", ("e-m:o-p:32:32-p270:32:32-p271:32:32-p272:64:64-f64:32:64-f80:128-n8:16:32-S128", "yonah", ""))+,("x86_64-apple-darwin", ("e-m:o-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "core2", ""))+,("arm64-apple-darwin", ("e-m:o-i64:64-i128:128-n32:64-S128", "apple-a7", "+fp-armv8 +neon +crypto +zcm +zcz +sha2 +aes"))+,("armv7-apple-ios", ("e-m:o-p:32:32-Fi8-f64:32:64-v64:32:64-v128:32:128-a:0:32-n32-S32", "generic", "+vfp2 +vfp2sp +vfp3 +vfp3d16 +vfp3d16sp +vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 +d32 +neon -sha2 -aes -fp16fml")) ,("aarch64-apple-ios", ("e-m:o-i64:64-i128:128-n32:64-S128", "apple-a7", "+fp-armv8 +neon +crypto +zcm +zcz +sha2 +aes")) ,("i386-apple-ios", ("e-m:o-p:32:32-p270:32:32-p271:32:32-p272:64:64-f64:32:64-f80:128-n8:16:32-S128", "yonah", "")) ,("x86_64-apple-ios", ("e-m:o-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "core2", ""))-,("amd64-portbld-freebsd", ("e-m:e-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "x86-64", ""))+,("x86_64-portbld-freebsd", ("e-m:e-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "")) ,("x86_64-unknown-freebsd", ("e-m:e-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "")) ,("aarch64-unknown-freebsd", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon"))-,("armv6-unknown-freebsd-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))-,("armv7-unknown-freebsd-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+strict-align"))-,("arm-unknown-nto-qnx-eabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm7tdmi", "+strict-align"))+,("armv6-unknown-freebsd-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+vfp2 +vfp2sp -vfp3 -vfp3d16 -vfp3d16sp -vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 -d32 -neon -sha2 -aes -fp16fml +strict-align"))+,("armv7-unknown-freebsd-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "cortex-a8", "+vfp2 +vfp2sp +vfp3 +vfp3d16 +vfp3d16sp +vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 +d32 +neon -sha2 -aes -fp16fml +strict-align"))+,("aarch64-unknown-netbsd", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon"))+,("x86_64-unknown-openbsd", ("e-m:e-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "x86-64", ""))+,("i386-unknown-openbsd", ("e-m:e-p:32:32-p270:32:32-p271:32:32-p272:64:64-f64:32:64-f80:32-n8:16:32-S128", "i586", ""))+,("arm-unknown-nto-qnx-eabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm7tdmi", "-vfp2 -vfp2sp -vfp3 -vfp3d16 -vfp3d16sp -vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 -fp64 -d32 -neon -sha2 -aes -dotprod -fp16fml -bf16 -mve.fp -fpregs +strict-align")) ]
ghc-lib/stage0/lib/settings view
@@ -1,10 +1,11 @@ [("GCC extra via C opts", "")-,("C compiler command", "cc")+,("C compiler command", "/usr/bin/gcc") ,("C compiler flags", "--target=x86_64-apple-darwin ")+,("C++ compiler command", "/usr/bin/g++") ,("C++ compiler flags", "--target=x86_64-apple-darwin ")-,("C compiler link flags", "--target=x86_64-apple-darwin -Wl,-no_fixup_chains")+,("C compiler link flags", "--target=x86_64-apple-darwin  ") ,("C compiler supports -no-pie", "NO")-,("Haskell CPP command", "cc")+,("Haskell CPP command", "/usr/bin/gcc") ,("Haskell CPP flags", "-E -undef -traditional -Wno-invalid-pp-token -Wno-unicode -Wno-trigraphs") ,("ld command", "ld") ,("ld flags", "")@@ -14,10 +15,11 @@ ,("ld is GNU ld", "NO") ,("Merge objects command", "ld") ,("Merge objects flags", "-r")-,("ar command", "ar")+,("ar command", "/usr/bin/ar") ,("ar flags", "qcls") ,("ar supports at file", "NO")-,("ranlib command", "ranlib")+,("ar supports -L", "NO")+,("ranlib command", "/usr/bin/ranlib") ,("otool command", "otool") ,("install_name_tool command", "install_name_tool") ,("touch command", "touch")@@ -35,11 +37,13 @@ ,("target has .ident directive", "YES") ,("target has subsections via symbols", "YES") ,("target has RTS linker", "YES")+,("target has libm", "YES") ,("Unregisterised", "NO") ,("LLVM target", "x86_64-apple-darwin") ,("LLVM llc command", "llc") ,("LLVM opt command", "opt") ,("LLVM clang command", "clang")+,("Use inplace MinGW toolchain", "NO") ,("Use interpreter", "YES") ,("Support SMP", "YES") ,("RTS ways", "v thr")
ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs view
@@ -3,19 +3,19 @@ import Prelude -- See Note [Why do we import Prelude here?]  cProjectGitCommitId   :: String-cProjectGitCommitId   = "dfa834627a94d98aaeddb0cb3a0cedca934d2814"+cProjectGitCommitId   = "6d01245c458c49ca25c89ec13be3268ab6930a27"  cProjectVersion       :: String-cProjectVersion       = "9.2.8"+cProjectVersion       = "9.4.1"  cProjectVersionInt    :: String-cProjectVersionInt    = "902"+cProjectVersionInt    = "904"  cProjectPatchLevel    :: String-cProjectPatchLevel    = "8"+cProjectPatchLevel    = "1"  cProjectPatchLevel1   :: String-cProjectPatchLevel1   = "8"+cProjectPatchLevel1   = "1"  cProjectPatchLevel2   :: String-cProjectPatchLevel2   = ""+cProjectPatchLevel2   = "0"
+ ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h view
@@ -0,0 +1,559 @@+/* This file is created automatically.  Do not edit by hand.*/++#define HS_CONSTANTS "291,1,2,4096,252,9,0,8,16,24,32,40,48,56,64,72,80,84,88,92,96,100,104,112,120,128,136,144,152,168,184,200,216,232,248,280,312,344,376,408,440,504,568,632,696,760,824,832,840,848,856,864,872,888,904,-24,-16,-8,24,0,8,48,46,96,72,8,48,8,8,16,8,64,8,16,8,0,72,56,8,16,0,8,8,0,8,0,96,112,16,8,16,0,4,4,24,20,4,15,7,1,-16,255,0,255,7,10,6,6,1,6,6,6,6,6,0,16384,21,1024,8,4,8,8,6,3,30,1152921503533105152,0,1152921504606846976,1"+#define CONTROL_GROUP_CONST_291 291+#define STD_HDR_SIZE 1+#define PROF_HDR_SIZE 2+#define STACK_DIRTY 1+#define BLOCK_SIZE 4096+#define MBLOCK_SIZE 1048576+#define BLOCKS_PER_MBLOCK 252+#define TICKY_BIN_COUNT 9+#define OFFSET_StgRegTable_rR1 0+#define OFFSET_StgRegTable_rR2 8+#define OFFSET_StgRegTable_rR3 16+#define OFFSET_StgRegTable_rR4 24+#define OFFSET_StgRegTable_rR5 32+#define OFFSET_StgRegTable_rR6 40+#define OFFSET_StgRegTable_rR7 48+#define OFFSET_StgRegTable_rR8 56+#define OFFSET_StgRegTable_rR9 64+#define OFFSET_StgRegTable_rR10 72+#define OFFSET_StgRegTable_rF1 80+#define OFFSET_StgRegTable_rF2 84+#define OFFSET_StgRegTable_rF3 88+#define OFFSET_StgRegTable_rF4 92+#define OFFSET_StgRegTable_rF5 96+#define OFFSET_StgRegTable_rF6 100+#define OFFSET_StgRegTable_rD1 104+#define OFFSET_StgRegTable_rD2 112+#define OFFSET_StgRegTable_rD3 120+#define OFFSET_StgRegTable_rD4 128+#define OFFSET_StgRegTable_rD5 136+#define OFFSET_StgRegTable_rD6 144+#define OFFSET_StgRegTable_rXMM1 152+#define OFFSET_StgRegTable_rXMM2 168+#define OFFSET_StgRegTable_rXMM3 184+#define OFFSET_StgRegTable_rXMM4 200+#define OFFSET_StgRegTable_rXMM5 216+#define OFFSET_StgRegTable_rXMM6 232+#define OFFSET_StgRegTable_rYMM1 248+#define OFFSET_StgRegTable_rYMM2 280+#define OFFSET_StgRegTable_rYMM3 312+#define OFFSET_StgRegTable_rYMM4 344+#define OFFSET_StgRegTable_rYMM5 376+#define OFFSET_StgRegTable_rYMM6 408+#define OFFSET_StgRegTable_rZMM1 440+#define OFFSET_StgRegTable_rZMM2 504+#define OFFSET_StgRegTable_rZMM3 568+#define OFFSET_StgRegTable_rZMM4 632+#define OFFSET_StgRegTable_rZMM5 696+#define OFFSET_StgRegTable_rZMM6 760+#define OFFSET_StgRegTable_rL1 824+#define OFFSET_StgRegTable_rSp 832+#define OFFSET_StgRegTable_rSpLim 840+#define OFFSET_StgRegTable_rHp 848+#define OFFSET_StgRegTable_rHpLim 856+#define OFFSET_StgRegTable_rCCCS 864+#define OFFSET_StgRegTable_rCurrentTSO 872+#define OFFSET_StgRegTable_rCurrentNursery 888+#define OFFSET_StgRegTable_rHpAlloc 904+#define OFFSET_StgRegTable_rRet 912+#define REP_StgRegTable_rRet b64+#define StgRegTable_rRet(__ptr__) REP_StgRegTable_rRet[__ptr__+OFFSET_StgRegTable_rRet]+#define OFFSET_StgRegTable_rNursery 880+#define REP_StgRegTable_rNursery b64+#define StgRegTable_rNursery(__ptr__) REP_StgRegTable_rNursery[__ptr__+OFFSET_StgRegTable_rNursery]+#define OFFSET_stgEagerBlackholeInfo -24+#define OFFSET_stgGCEnter1 -16+#define OFFSET_stgGCFun -8+#define OFFSET_Capability_r 24+#define OFFSET_Capability_lock 1216+#define OFFSET_Capability_no 944+#define REP_Capability_no b32+#define Capability_no(__ptr__) REP_Capability_no[__ptr__+OFFSET_Capability_no]+#define OFFSET_Capability_mut_lists 1016+#define REP_Capability_mut_lists b64+#define Capability_mut_lists(__ptr__) REP_Capability_mut_lists[__ptr__+OFFSET_Capability_mut_lists]+#define OFFSET_Capability_context_switch 1184+#define REP_Capability_context_switch b32+#define Capability_context_switch(__ptr__) REP_Capability_context_switch[__ptr__+OFFSET_Capability_context_switch]+#define OFFSET_Capability_interrupt 1188+#define REP_Capability_interrupt b32+#define Capability_interrupt(__ptr__) REP_Capability_interrupt[__ptr__+OFFSET_Capability_interrupt]+#define OFFSET_Capability_sparks 1320+#define REP_Capability_sparks b64+#define Capability_sparks(__ptr__) REP_Capability_sparks[__ptr__+OFFSET_Capability_sparks]+#define OFFSET_Capability_total_allocated 1192+#define REP_Capability_total_allocated b64+#define Capability_total_allocated(__ptr__) REP_Capability_total_allocated[__ptr__+OFFSET_Capability_total_allocated]+#define OFFSET_Capability_weak_ptr_list_hd 1168+#define REP_Capability_weak_ptr_list_hd b64+#define Capability_weak_ptr_list_hd(__ptr__) REP_Capability_weak_ptr_list_hd[__ptr__+OFFSET_Capability_weak_ptr_list_hd]+#define OFFSET_Capability_weak_ptr_list_tl 1176+#define REP_Capability_weak_ptr_list_tl b64+#define Capability_weak_ptr_list_tl(__ptr__) REP_Capability_weak_ptr_list_tl[__ptr__+OFFSET_Capability_weak_ptr_list_tl]+#define OFFSET_bdescr_start 0+#define REP_bdescr_start b64+#define bdescr_start(__ptr__) REP_bdescr_start[__ptr__+OFFSET_bdescr_start]+#define OFFSET_bdescr_free 8+#define REP_bdescr_free b64+#define bdescr_free(__ptr__) REP_bdescr_free[__ptr__+OFFSET_bdescr_free]+#define OFFSET_bdescr_blocks 48+#define REP_bdescr_blocks b32+#define bdescr_blocks(__ptr__) REP_bdescr_blocks[__ptr__+OFFSET_bdescr_blocks]+#define OFFSET_bdescr_gen_no 40+#define REP_bdescr_gen_no b16+#define bdescr_gen_no(__ptr__) REP_bdescr_gen_no[__ptr__+OFFSET_bdescr_gen_no]+#define OFFSET_bdescr_link 16+#define REP_bdescr_link b64+#define bdescr_link(__ptr__) REP_bdescr_link[__ptr__+OFFSET_bdescr_link]+#define OFFSET_bdescr_flags 46+#define REP_bdescr_flags b16+#define bdescr_flags(__ptr__) REP_bdescr_flags[__ptr__+OFFSET_bdescr_flags]+#define SIZEOF_generation 384+#define OFFSET_generation_n_new_large_words 56+#define REP_generation_n_new_large_words b64+#define generation_n_new_large_words(__ptr__) REP_generation_n_new_large_words[__ptr__+OFFSET_generation_n_new_large_words]+#define OFFSET_generation_weak_ptr_list 112+#define REP_generation_weak_ptr_list b64+#define generation_weak_ptr_list(__ptr__) REP_generation_weak_ptr_list[__ptr__+OFFSET_generation_weak_ptr_list]+#define SIZEOF_CostCentreStack 96+#define OFFSET_CostCentreStack_ccsID 0+#define REP_CostCentreStack_ccsID b64+#define CostCentreStack_ccsID(__ptr__) REP_CostCentreStack_ccsID[__ptr__+OFFSET_CostCentreStack_ccsID]+#define OFFSET_CostCentreStack_mem_alloc 72+#define REP_CostCentreStack_mem_alloc b64+#define CostCentreStack_mem_alloc(__ptr__) REP_CostCentreStack_mem_alloc[__ptr__+OFFSET_CostCentreStack_mem_alloc]+#define OFFSET_CostCentreStack_scc_count 48+#define REP_CostCentreStack_scc_count b64+#define CostCentreStack_scc_count(__ptr__) REP_CostCentreStack_scc_count[__ptr__+OFFSET_CostCentreStack_scc_count]+#define OFFSET_CostCentreStack_prevStack 16+#define REP_CostCentreStack_prevStack b64+#define CostCentreStack_prevStack(__ptr__) REP_CostCentreStack_prevStack[__ptr__+OFFSET_CostCentreStack_prevStack]+#define OFFSET_CostCentre_ccID 0+#define REP_CostCentre_ccID b64+#define CostCentre_ccID(__ptr__) REP_CostCentre_ccID[__ptr__+OFFSET_CostCentre_ccID]+#define OFFSET_CostCentre_link 56+#define REP_CostCentre_link b64+#define CostCentre_link(__ptr__) REP_CostCentre_link[__ptr__+OFFSET_CostCentre_link]+#define OFFSET_StgHeader_info 0+#define REP_StgHeader_info b64+#define StgHeader_info(__ptr__) REP_StgHeader_info[__ptr__+OFFSET_StgHeader_info]+#define OFFSET_StgHeader_ccs 8+#define REP_StgHeader_ccs b64+#define StgHeader_ccs(__ptr__) REP_StgHeader_ccs[__ptr__+OFFSET_StgHeader_ccs]+#define OFFSET_StgHeader_ldvw 16+#define REP_StgHeader_ldvw b64+#define StgHeader_ldvw(__ptr__) REP_StgHeader_ldvw[__ptr__+OFFSET_StgHeader_ldvw]+#define SIZEOF_StgSMPThunkHeader 8+#define OFFSET_StgClosure_payload 0+#define StgClosure_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgClosure_payload + WDS(__ix__)]+#define OFFSET_StgEntCounter_allocs 64+#define REP_StgEntCounter_allocs b64+#define StgEntCounter_allocs(__ptr__) REP_StgEntCounter_allocs[__ptr__+OFFSET_StgEntCounter_allocs]+#define OFFSET_StgEntCounter_allocd 16+#define REP_StgEntCounter_allocd b64+#define StgEntCounter_allocd(__ptr__) REP_StgEntCounter_allocd[__ptr__+OFFSET_StgEntCounter_allocd]+#define OFFSET_StgEntCounter_registeredp 0+#define REP_StgEntCounter_registeredp b64+#define StgEntCounter_registeredp(__ptr__) REP_StgEntCounter_registeredp[__ptr__+OFFSET_StgEntCounter_registeredp]+#define OFFSET_StgEntCounter_link 72+#define REP_StgEntCounter_link b64+#define StgEntCounter_link(__ptr__) REP_StgEntCounter_link[__ptr__+OFFSET_StgEntCounter_link]+#define OFFSET_StgEntCounter_entry_count 56+#define REP_StgEntCounter_entry_count b64+#define StgEntCounter_entry_count(__ptr__) REP_StgEntCounter_entry_count[__ptr__+OFFSET_StgEntCounter_entry_count]+#define SIZEOF_StgUpdateFrame_NoHdr 8+#define SIZEOF_StgUpdateFrame (SIZEOF_StgHeader+8)+#define SIZEOF_StgCatchFrame_NoHdr 16+#define SIZEOF_StgCatchFrame (SIZEOF_StgHeader+16)+#define SIZEOF_StgStopFrame_NoHdr 0+#define SIZEOF_StgStopFrame (SIZEOF_StgHeader+0)+#define SIZEOF_StgMutArrPtrs_NoHdr 16+#define SIZEOF_StgMutArrPtrs (SIZEOF_StgHeader+16)+#define OFFSET_StgMutArrPtrs_ptrs 0+#define REP_StgMutArrPtrs_ptrs b64+#define StgMutArrPtrs_ptrs(__ptr__) REP_StgMutArrPtrs_ptrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgMutArrPtrs_ptrs]+#define OFFSET_StgMutArrPtrs_size 8+#define REP_StgMutArrPtrs_size b64+#define StgMutArrPtrs_size(__ptr__) REP_StgMutArrPtrs_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgMutArrPtrs_size]+#define SIZEOF_StgSmallMutArrPtrs_NoHdr 8+#define SIZEOF_StgSmallMutArrPtrs (SIZEOF_StgHeader+8)+#define OFFSET_StgSmallMutArrPtrs_ptrs 0+#define REP_StgSmallMutArrPtrs_ptrs b64+#define StgSmallMutArrPtrs_ptrs(__ptr__) REP_StgSmallMutArrPtrs_ptrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgSmallMutArrPtrs_ptrs]+#define SIZEOF_StgArrBytes_NoHdr 8+#define SIZEOF_StgArrBytes (SIZEOF_StgHeader+8)+#define OFFSET_StgArrBytes_bytes 0+#define REP_StgArrBytes_bytes b64+#define StgArrBytes_bytes(__ptr__) REP_StgArrBytes_bytes[__ptr__+SIZEOF_StgHeader+OFFSET_StgArrBytes_bytes]+#define OFFSET_StgArrBytes_payload 8+#define StgArrBytes_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgArrBytes_payload + WDS(__ix__)]+#define OFFSET_StgTSO__link 0+#define REP_StgTSO__link b64+#define StgTSO__link(__ptr__) REP_StgTSO__link[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO__link]+#define OFFSET_StgTSO_global_link 8+#define REP_StgTSO_global_link b64+#define StgTSO_global_link(__ptr__) REP_StgTSO_global_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_global_link]+#define OFFSET_StgTSO_what_next 24+#define REP_StgTSO_what_next b16+#define StgTSO_what_next(__ptr__) REP_StgTSO_what_next[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_what_next]+#define OFFSET_StgTSO_why_blocked 26+#define REP_StgTSO_why_blocked b16+#define StgTSO_why_blocked(__ptr__) REP_StgTSO_why_blocked[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_why_blocked]+#define OFFSET_StgTSO_block_info 32+#define REP_StgTSO_block_info b64+#define StgTSO_block_info(__ptr__) REP_StgTSO_block_info[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_block_info]+#define OFFSET_StgTSO_blocked_exceptions 80+#define REP_StgTSO_blocked_exceptions b64+#define StgTSO_blocked_exceptions(__ptr__) REP_StgTSO_blocked_exceptions[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_blocked_exceptions]+#define OFFSET_StgTSO_id 40+#define REP_StgTSO_id b64+#define StgTSO_id(__ptr__) REP_StgTSO_id[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_id]+#define OFFSET_StgTSO_cap 64+#define REP_StgTSO_cap b64+#define StgTSO_cap(__ptr__) REP_StgTSO_cap[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_cap]+#define OFFSET_StgTSO_saved_errno 48+#define REP_StgTSO_saved_errno b32+#define StgTSO_saved_errno(__ptr__) REP_StgTSO_saved_errno[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_saved_errno]+#define OFFSET_StgTSO_trec 72+#define REP_StgTSO_trec b64+#define StgTSO_trec(__ptr__) REP_StgTSO_trec[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_trec]+#define OFFSET_StgTSO_flags 28+#define REP_StgTSO_flags b32+#define StgTSO_flags(__ptr__) REP_StgTSO_flags[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_flags]+#define OFFSET_StgTSO_dirty 52+#define REP_StgTSO_dirty b32+#define StgTSO_dirty(__ptr__) REP_StgTSO_dirty[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_dirty]+#define OFFSET_StgTSO_bq 88+#define REP_StgTSO_bq b64+#define StgTSO_bq(__ptr__) REP_StgTSO_bq[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_bq]+#define OFFSET_StgTSO_alloc_limit 96+#define REP_StgTSO_alloc_limit b64+#define StgTSO_alloc_limit(__ptr__) REP_StgTSO_alloc_limit[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_alloc_limit]+#define OFFSET_StgTSO_cccs 112+#define REP_StgTSO_cccs b64+#define StgTSO_cccs(__ptr__) REP_StgTSO_cccs[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_cccs]+#define OFFSET_StgTSO_stackobj 16+#define REP_StgTSO_stackobj b64+#define StgTSO_stackobj(__ptr__) REP_StgTSO_stackobj[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_stackobj]+#define OFFSET_StgStack_sp 8+#define REP_StgStack_sp b64+#define StgStack_sp(__ptr__) REP_StgStack_sp[__ptr__+SIZEOF_StgHeader+OFFSET_StgStack_sp]+#define OFFSET_StgStack_stack 16+#define OFFSET_StgStack_stack_size 0+#define REP_StgStack_stack_size b32+#define StgStack_stack_size(__ptr__) REP_StgStack_stack_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgStack_stack_size]+#define OFFSET_StgStack_dirty 4+#define REP_StgStack_dirty b8+#define StgStack_dirty(__ptr__) REP_StgStack_dirty[__ptr__+SIZEOF_StgHeader+OFFSET_StgStack_dirty]+#define SIZEOF_StgTSOProfInfo 8+#define OFFSET_StgUpdateFrame_updatee 0+#define REP_StgUpdateFrame_updatee b64+#define StgUpdateFrame_updatee(__ptr__) REP_StgUpdateFrame_updatee[__ptr__+SIZEOF_StgHeader+OFFSET_StgUpdateFrame_updatee]+#define OFFSET_StgCatchFrame_handler 8+#define REP_StgCatchFrame_handler b64+#define StgCatchFrame_handler(__ptr__) REP_StgCatchFrame_handler[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchFrame_handler]+#define OFFSET_StgCatchFrame_exceptions_blocked 0+#define REP_StgCatchFrame_exceptions_blocked b64+#define StgCatchFrame_exceptions_blocked(__ptr__) REP_StgCatchFrame_exceptions_blocked[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchFrame_exceptions_blocked]+#define SIZEOF_StgPAP_NoHdr 16+#define SIZEOF_StgPAP (SIZEOF_StgHeader+16)+#define OFFSET_StgPAP_n_args 4+#define REP_StgPAP_n_args b32+#define StgPAP_n_args(__ptr__) REP_StgPAP_n_args[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_n_args]+#define OFFSET_StgPAP_fun 8+#define REP_StgPAP_fun gcptr+#define StgPAP_fun(__ptr__) REP_StgPAP_fun[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_fun]+#define OFFSET_StgPAP_arity 0+#define REP_StgPAP_arity b32+#define StgPAP_arity(__ptr__) REP_StgPAP_arity[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_arity]+#define OFFSET_StgPAP_payload 16+#define StgPAP_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_payload + WDS(__ix__)]+#define SIZEOF_StgAP_NoThunkHdr 16+#define SIZEOF_StgAP_NoHdr 24+#define SIZEOF_StgAP (SIZEOF_StgHeader+24)+#define OFFSET_StgAP_n_args 12+#define REP_StgAP_n_args b32+#define StgAP_n_args(__ptr__) REP_StgAP_n_args[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_n_args]+#define OFFSET_StgAP_fun 16+#define REP_StgAP_fun gcptr+#define StgAP_fun(__ptr__) REP_StgAP_fun[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_fun]+#define OFFSET_StgAP_payload 24+#define StgAP_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_payload + WDS(__ix__)]+#define SIZEOF_StgAP_STACK_NoThunkHdr 16+#define SIZEOF_StgAP_STACK_NoHdr 24+#define SIZEOF_StgAP_STACK (SIZEOF_StgHeader+24)+#define OFFSET_StgAP_STACK_size 8+#define REP_StgAP_STACK_size b64+#define StgAP_STACK_size(__ptr__) REP_StgAP_STACK_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_STACK_size]+#define OFFSET_StgAP_STACK_fun 16+#define REP_StgAP_STACK_fun gcptr+#define StgAP_STACK_fun(__ptr__) REP_StgAP_STACK_fun[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_STACK_fun]+#define OFFSET_StgAP_STACK_payload 24+#define StgAP_STACK_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_STACK_payload + WDS(__ix__)]+#define SIZEOF_StgSelector_NoThunkHdr 8+#define SIZEOF_StgSelector_NoHdr 16+#define SIZEOF_StgSelector (SIZEOF_StgHeader+16)+#define OFFSET_StgInd_indirectee 0+#define REP_StgInd_indirectee gcptr+#define StgInd_indirectee(__ptr__) REP_StgInd_indirectee[__ptr__+SIZEOF_StgHeader+OFFSET_StgInd_indirectee]+#define SIZEOF_StgMutVar_NoHdr 8+#define SIZEOF_StgMutVar (SIZEOF_StgHeader+8)+#define OFFSET_StgMutVar_var 0+#define REP_StgMutVar_var b64+#define StgMutVar_var(__ptr__) REP_StgMutVar_var[__ptr__+SIZEOF_StgHeader+OFFSET_StgMutVar_var]+#define SIZEOF_StgAtomicallyFrame_NoHdr 16+#define SIZEOF_StgAtomicallyFrame (SIZEOF_StgHeader+16)+#define OFFSET_StgAtomicallyFrame_code 0+#define REP_StgAtomicallyFrame_code b64+#define StgAtomicallyFrame_code(__ptr__) REP_StgAtomicallyFrame_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgAtomicallyFrame_code]+#define OFFSET_StgAtomicallyFrame_result 8+#define REP_StgAtomicallyFrame_result b64+#define StgAtomicallyFrame_result(__ptr__) REP_StgAtomicallyFrame_result[__ptr__+SIZEOF_StgHeader+OFFSET_StgAtomicallyFrame_result]+#define OFFSET_StgTRecHeader_enclosing_trec 0+#define REP_StgTRecHeader_enclosing_trec b64+#define StgTRecHeader_enclosing_trec(__ptr__) REP_StgTRecHeader_enclosing_trec[__ptr__+SIZEOF_StgHeader+OFFSET_StgTRecHeader_enclosing_trec]+#define SIZEOF_StgCatchSTMFrame_NoHdr 16+#define SIZEOF_StgCatchSTMFrame (SIZEOF_StgHeader+16)+#define OFFSET_StgCatchSTMFrame_handler 8+#define REP_StgCatchSTMFrame_handler b64+#define StgCatchSTMFrame_handler(__ptr__) REP_StgCatchSTMFrame_handler[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchSTMFrame_handler]+#define OFFSET_StgCatchSTMFrame_code 0+#define REP_StgCatchSTMFrame_code b64+#define StgCatchSTMFrame_code(__ptr__) REP_StgCatchSTMFrame_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchSTMFrame_code]+#define SIZEOF_StgCatchRetryFrame_NoHdr 24+#define SIZEOF_StgCatchRetryFrame (SIZEOF_StgHeader+24)+#define OFFSET_StgCatchRetryFrame_running_alt_code 0+#define REP_StgCatchRetryFrame_running_alt_code b64+#define StgCatchRetryFrame_running_alt_code(__ptr__) REP_StgCatchRetryFrame_running_alt_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchRetryFrame_running_alt_code]+#define OFFSET_StgCatchRetryFrame_first_code 8+#define REP_StgCatchRetryFrame_first_code b64+#define StgCatchRetryFrame_first_code(__ptr__) REP_StgCatchRetryFrame_first_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchRetryFrame_first_code]+#define OFFSET_StgCatchRetryFrame_alt_code 16+#define REP_StgCatchRetryFrame_alt_code b64+#define StgCatchRetryFrame_alt_code(__ptr__) REP_StgCatchRetryFrame_alt_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchRetryFrame_alt_code]+#define OFFSET_StgTVarWatchQueue_closure 0+#define REP_StgTVarWatchQueue_closure b64+#define StgTVarWatchQueue_closure(__ptr__) REP_StgTVarWatchQueue_closure[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVarWatchQueue_closure]+#define OFFSET_StgTVarWatchQueue_next_queue_entry 8+#define REP_StgTVarWatchQueue_next_queue_entry b64+#define StgTVarWatchQueue_next_queue_entry(__ptr__) REP_StgTVarWatchQueue_next_queue_entry[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVarWatchQueue_next_queue_entry]+#define OFFSET_StgTVarWatchQueue_prev_queue_entry 16+#define REP_StgTVarWatchQueue_prev_queue_entry b64+#define StgTVarWatchQueue_prev_queue_entry(__ptr__) REP_StgTVarWatchQueue_prev_queue_entry[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVarWatchQueue_prev_queue_entry]+#define SIZEOF_StgTVar_NoHdr 24+#define SIZEOF_StgTVar (SIZEOF_StgHeader+24)+#define OFFSET_StgTVar_current_value 0+#define REP_StgTVar_current_value b64+#define StgTVar_current_value(__ptr__) REP_StgTVar_current_value[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVar_current_value]+#define OFFSET_StgTVar_first_watch_queue_entry 8+#define REP_StgTVar_first_watch_queue_entry b64+#define StgTVar_first_watch_queue_entry(__ptr__) REP_StgTVar_first_watch_queue_entry[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVar_first_watch_queue_entry]+#define OFFSET_StgTVar_num_updates 16+#define REP_StgTVar_num_updates b64+#define StgTVar_num_updates(__ptr__) REP_StgTVar_num_updates[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVar_num_updates]+#define SIZEOF_StgWeak_NoHdr 40+#define SIZEOF_StgWeak (SIZEOF_StgHeader+40)+#define OFFSET_StgWeak_link 32+#define REP_StgWeak_link b64+#define StgWeak_link(__ptr__) REP_StgWeak_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_link]+#define OFFSET_StgWeak_key 8+#define REP_StgWeak_key b64+#define StgWeak_key(__ptr__) REP_StgWeak_key[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_key]+#define OFFSET_StgWeak_value 16+#define REP_StgWeak_value b64+#define StgWeak_value(__ptr__) REP_StgWeak_value[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_value]+#define OFFSET_StgWeak_finalizer 24+#define REP_StgWeak_finalizer b64+#define StgWeak_finalizer(__ptr__) REP_StgWeak_finalizer[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_finalizer]+#define OFFSET_StgWeak_cfinalizers 0+#define REP_StgWeak_cfinalizers b64+#define StgWeak_cfinalizers(__ptr__) REP_StgWeak_cfinalizers[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_cfinalizers]+#define SIZEOF_StgCFinalizerList_NoHdr 40+#define SIZEOF_StgCFinalizerList (SIZEOF_StgHeader+40)+#define OFFSET_StgCFinalizerList_link 0+#define REP_StgCFinalizerList_link b64+#define StgCFinalizerList_link(__ptr__) REP_StgCFinalizerList_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_link]+#define OFFSET_StgCFinalizerList_fptr 8+#define REP_StgCFinalizerList_fptr b64+#define StgCFinalizerList_fptr(__ptr__) REP_StgCFinalizerList_fptr[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_fptr]+#define OFFSET_StgCFinalizerList_ptr 16+#define REP_StgCFinalizerList_ptr b64+#define StgCFinalizerList_ptr(__ptr__) REP_StgCFinalizerList_ptr[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_ptr]+#define OFFSET_StgCFinalizerList_eptr 24+#define REP_StgCFinalizerList_eptr b64+#define StgCFinalizerList_eptr(__ptr__) REP_StgCFinalizerList_eptr[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_eptr]+#define OFFSET_StgCFinalizerList_flag 32+#define REP_StgCFinalizerList_flag b64+#define StgCFinalizerList_flag(__ptr__) REP_StgCFinalizerList_flag[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_flag]+#define SIZEOF_StgMVar_NoHdr 24+#define SIZEOF_StgMVar (SIZEOF_StgHeader+24)+#define OFFSET_StgMVar_head 0+#define REP_StgMVar_head b64+#define StgMVar_head(__ptr__) REP_StgMVar_head[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVar_head]+#define OFFSET_StgMVar_tail 8+#define REP_StgMVar_tail b64+#define StgMVar_tail(__ptr__) REP_StgMVar_tail[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVar_tail]+#define OFFSET_StgMVar_value 16+#define REP_StgMVar_value b64+#define StgMVar_value(__ptr__) REP_StgMVar_value[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVar_value]+#define SIZEOF_StgMVarTSOQueue_NoHdr 16+#define SIZEOF_StgMVarTSOQueue (SIZEOF_StgHeader+16)+#define OFFSET_StgMVarTSOQueue_link 0+#define REP_StgMVarTSOQueue_link b64+#define StgMVarTSOQueue_link(__ptr__) REP_StgMVarTSOQueue_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVarTSOQueue_link]+#define OFFSET_StgMVarTSOQueue_tso 8+#define REP_StgMVarTSOQueue_tso b64+#define StgMVarTSOQueue_tso(__ptr__) REP_StgMVarTSOQueue_tso[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVarTSOQueue_tso]+#define SIZEOF_StgBCO_NoHdr 32+#define SIZEOF_StgBCO (SIZEOF_StgHeader+32)+#define OFFSET_StgBCO_instrs 0+#define REP_StgBCO_instrs b64+#define StgBCO_instrs(__ptr__) REP_StgBCO_instrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_instrs]+#define OFFSET_StgBCO_literals 8+#define REP_StgBCO_literals b64+#define StgBCO_literals(__ptr__) REP_StgBCO_literals[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_literals]+#define OFFSET_StgBCO_ptrs 16+#define REP_StgBCO_ptrs b64+#define StgBCO_ptrs(__ptr__) REP_StgBCO_ptrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_ptrs]+#define OFFSET_StgBCO_arity 24+#define REP_StgBCO_arity b32+#define StgBCO_arity(__ptr__) REP_StgBCO_arity[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_arity]+#define OFFSET_StgBCO_size 28+#define REP_StgBCO_size b32+#define StgBCO_size(__ptr__) REP_StgBCO_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_size]+#define OFFSET_StgBCO_bitmap 32+#define StgBCO_bitmap(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_bitmap + WDS(__ix__)]+#define SIZEOF_StgStableName_NoHdr 8+#define SIZEOF_StgStableName (SIZEOF_StgHeader+8)+#define OFFSET_StgStableName_sn 0+#define REP_StgStableName_sn b64+#define StgStableName_sn(__ptr__) REP_StgStableName_sn[__ptr__+SIZEOF_StgHeader+OFFSET_StgStableName_sn]+#define SIZEOF_StgBlockingQueue_NoHdr 32+#define SIZEOF_StgBlockingQueue (SIZEOF_StgHeader+32)+#define OFFSET_StgBlockingQueue_bh 8+#define REP_StgBlockingQueue_bh b64+#define StgBlockingQueue_bh(__ptr__) REP_StgBlockingQueue_bh[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_bh]+#define OFFSET_StgBlockingQueue_owner 16+#define REP_StgBlockingQueue_owner b64+#define StgBlockingQueue_owner(__ptr__) REP_StgBlockingQueue_owner[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_owner]+#define OFFSET_StgBlockingQueue_queue 24+#define REP_StgBlockingQueue_queue b64+#define StgBlockingQueue_queue(__ptr__) REP_StgBlockingQueue_queue[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_queue]+#define OFFSET_StgBlockingQueue_link 0+#define REP_StgBlockingQueue_link b64+#define StgBlockingQueue_link(__ptr__) REP_StgBlockingQueue_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_link]+#define SIZEOF_MessageBlackHole_NoHdr 24+#define SIZEOF_MessageBlackHole (SIZEOF_StgHeader+24)+#define OFFSET_MessageBlackHole_link 0+#define REP_MessageBlackHole_link b64+#define MessageBlackHole_link(__ptr__) REP_MessageBlackHole_link[__ptr__+SIZEOF_StgHeader+OFFSET_MessageBlackHole_link]+#define OFFSET_MessageBlackHole_tso 8+#define REP_MessageBlackHole_tso b64+#define MessageBlackHole_tso(__ptr__) REP_MessageBlackHole_tso[__ptr__+SIZEOF_StgHeader+OFFSET_MessageBlackHole_tso]+#define OFFSET_MessageBlackHole_bh 16+#define REP_MessageBlackHole_bh b64+#define MessageBlackHole_bh(__ptr__) REP_MessageBlackHole_bh[__ptr__+SIZEOF_StgHeader+OFFSET_MessageBlackHole_bh]+#define SIZEOF_StgCompactNFData_NoHdr 72+#define SIZEOF_StgCompactNFData (SIZEOF_StgHeader+72)+#define OFFSET_StgCompactNFData_totalW 0+#define REP_StgCompactNFData_totalW b64+#define StgCompactNFData_totalW(__ptr__) REP_StgCompactNFData_totalW[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_totalW]+#define OFFSET_StgCompactNFData_autoBlockW 8+#define REP_StgCompactNFData_autoBlockW b64+#define StgCompactNFData_autoBlockW(__ptr__) REP_StgCompactNFData_autoBlockW[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_autoBlockW]+#define OFFSET_StgCompactNFData_nursery 32+#define REP_StgCompactNFData_nursery b64+#define StgCompactNFData_nursery(__ptr__) REP_StgCompactNFData_nursery[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_nursery]+#define OFFSET_StgCompactNFData_last 40+#define REP_StgCompactNFData_last b64+#define StgCompactNFData_last(__ptr__) REP_StgCompactNFData_last[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_last]+#define OFFSET_StgCompactNFData_hp 16+#define REP_StgCompactNFData_hp b64+#define StgCompactNFData_hp(__ptr__) REP_StgCompactNFData_hp[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_hp]+#define OFFSET_StgCompactNFData_hpLim 24+#define REP_StgCompactNFData_hpLim b64+#define StgCompactNFData_hpLim(__ptr__) REP_StgCompactNFData_hpLim[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_hpLim]+#define OFFSET_StgCompactNFData_hash 48+#define REP_StgCompactNFData_hash b64+#define StgCompactNFData_hash(__ptr__) REP_StgCompactNFData_hash[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_hash]+#define OFFSET_StgCompactNFData_result 56+#define REP_StgCompactNFData_result b64+#define StgCompactNFData_result(__ptr__) REP_StgCompactNFData_result[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_result]+#define SIZEOF_StgCompactNFDataBlock 24+#define OFFSET_StgCompactNFDataBlock_self 0+#define REP_StgCompactNFDataBlock_self b64+#define StgCompactNFDataBlock_self(__ptr__) REP_StgCompactNFDataBlock_self[__ptr__+OFFSET_StgCompactNFDataBlock_self]+#define OFFSET_StgCompactNFDataBlock_owner 8+#define REP_StgCompactNFDataBlock_owner b64+#define StgCompactNFDataBlock_owner(__ptr__) REP_StgCompactNFDataBlock_owner[__ptr__+OFFSET_StgCompactNFDataBlock_owner]+#define OFFSET_StgCompactNFDataBlock_next 16+#define REP_StgCompactNFDataBlock_next b64+#define StgCompactNFDataBlock_next(__ptr__) REP_StgCompactNFDataBlock_next[__ptr__+OFFSET_StgCompactNFDataBlock_next]+#define OFFSET_RtsFlags_ProfFlags_doHeapProfile 280+#define REP_RtsFlags_ProfFlags_doHeapProfile b32+#define RtsFlags_ProfFlags_doHeapProfile(__ptr__) REP_RtsFlags_ProfFlags_doHeapProfile[__ptr__+OFFSET_RtsFlags_ProfFlags_doHeapProfile]+#define OFFSET_RtsFlags_ProfFlags_showCCSOnException 301+#define REP_RtsFlags_ProfFlags_showCCSOnException b8+#define RtsFlags_ProfFlags_showCCSOnException(__ptr__) REP_RtsFlags_ProfFlags_showCCSOnException[__ptr__+OFFSET_RtsFlags_ProfFlags_showCCSOnException]+#define OFFSET_RtsFlags_DebugFlags_apply 245+#define REP_RtsFlags_DebugFlags_apply b8+#define RtsFlags_DebugFlags_apply(__ptr__) REP_RtsFlags_DebugFlags_apply[__ptr__+OFFSET_RtsFlags_DebugFlags_apply]+#define OFFSET_RtsFlags_DebugFlags_sanity 239+#define REP_RtsFlags_DebugFlags_sanity b8+#define RtsFlags_DebugFlags_sanity(__ptr__) REP_RtsFlags_DebugFlags_sanity[__ptr__+OFFSET_RtsFlags_DebugFlags_sanity]+#define OFFSET_RtsFlags_DebugFlags_weak 234+#define REP_RtsFlags_DebugFlags_weak b8+#define RtsFlags_DebugFlags_weak(__ptr__) REP_RtsFlags_DebugFlags_weak[__ptr__+OFFSET_RtsFlags_DebugFlags_weak]+#define OFFSET_RtsFlags_GcFlags_initialStkSize 16+#define REP_RtsFlags_GcFlags_initialStkSize b32+#define RtsFlags_GcFlags_initialStkSize(__ptr__) REP_RtsFlags_GcFlags_initialStkSize[__ptr__+OFFSET_RtsFlags_GcFlags_initialStkSize]+#define OFFSET_RtsFlags_MiscFlags_tickInterval 200+#define REP_RtsFlags_MiscFlags_tickInterval b64+#define RtsFlags_MiscFlags_tickInterval(__ptr__) REP_RtsFlags_MiscFlags_tickInterval[__ptr__+OFFSET_RtsFlags_MiscFlags_tickInterval]+#define SIZEOF_StgFunInfoExtraFwd 32+#define OFFSET_StgFunInfoExtraFwd_slow_apply 24+#define REP_StgFunInfoExtraFwd_slow_apply b64+#define StgFunInfoExtraFwd_slow_apply(__ptr__) REP_StgFunInfoExtraFwd_slow_apply[__ptr__+OFFSET_StgFunInfoExtraFwd_slow_apply]+#define OFFSET_StgFunInfoExtraFwd_fun_type 0+#define REP_StgFunInfoExtraFwd_fun_type b32+#define StgFunInfoExtraFwd_fun_type(__ptr__) REP_StgFunInfoExtraFwd_fun_type[__ptr__+OFFSET_StgFunInfoExtraFwd_fun_type]+#define OFFSET_StgFunInfoExtraFwd_arity 4+#define REP_StgFunInfoExtraFwd_arity b32+#define StgFunInfoExtraFwd_arity(__ptr__) REP_StgFunInfoExtraFwd_arity[__ptr__+OFFSET_StgFunInfoExtraFwd_arity]+#define OFFSET_StgFunInfoExtraFwd_bitmap 16+#define REP_StgFunInfoExtraFwd_bitmap b64+#define StgFunInfoExtraFwd_bitmap(__ptr__) REP_StgFunInfoExtraFwd_bitmap[__ptr__+OFFSET_StgFunInfoExtraFwd_bitmap]+#define SIZEOF_StgFunInfoExtraRev 24+#define OFFSET_StgFunInfoExtraRev_slow_apply_offset 0+#define REP_StgFunInfoExtraRev_slow_apply_offset b32+#define StgFunInfoExtraRev_slow_apply_offset(__ptr__) REP_StgFunInfoExtraRev_slow_apply_offset[__ptr__+OFFSET_StgFunInfoExtraRev_slow_apply_offset]+#define OFFSET_StgFunInfoExtraRev_fun_type 16+#define REP_StgFunInfoExtraRev_fun_type b32+#define StgFunInfoExtraRev_fun_type(__ptr__) REP_StgFunInfoExtraRev_fun_type[__ptr__+OFFSET_StgFunInfoExtraRev_fun_type]+#define OFFSET_StgFunInfoExtraRev_arity 20+#define REP_StgFunInfoExtraRev_arity b32+#define StgFunInfoExtraRev_arity(__ptr__) REP_StgFunInfoExtraRev_arity[__ptr__+OFFSET_StgFunInfoExtraRev_arity]+#define OFFSET_StgFunInfoExtraRev_bitmap 8+#define REP_StgFunInfoExtraRev_bitmap b64+#define StgFunInfoExtraRev_bitmap(__ptr__) REP_StgFunInfoExtraRev_bitmap[__ptr__+OFFSET_StgFunInfoExtraRev_bitmap]+#define OFFSET_StgFunInfoExtraRev_bitmap_offset 8+#define REP_StgFunInfoExtraRev_bitmap_offset b32+#define StgFunInfoExtraRev_bitmap_offset(__ptr__) REP_StgFunInfoExtraRev_bitmap_offset[__ptr__+OFFSET_StgFunInfoExtraRev_bitmap_offset]+#define OFFSET_StgLargeBitmap_size 0+#define REP_StgLargeBitmap_size b64+#define StgLargeBitmap_size(__ptr__) REP_StgLargeBitmap_size[__ptr__+OFFSET_StgLargeBitmap_size]+#define OFFSET_StgLargeBitmap_bitmap 8+#define SIZEOF_snEntry 24+#define OFFSET_snEntry_sn_obj 16+#define REP_snEntry_sn_obj b64+#define snEntry_sn_obj(__ptr__) REP_snEntry_sn_obj[__ptr__+OFFSET_snEntry_sn_obj]+#define OFFSET_snEntry_addr 0+#define REP_snEntry_addr b64+#define snEntry_addr(__ptr__) REP_snEntry_addr[__ptr__+OFFSET_snEntry_addr]+#define SIZEOF_spEntry 8+#define OFFSET_spEntry_addr 0+#define REP_spEntry_addr b64+#define spEntry_addr(__ptr__) REP_spEntry_addr[__ptr__+OFFSET_spEntry_addr]
+ ghc-lib/stage0/rts/build/include/ghcautoconf.h view
@@ -0,0 +1,639 @@+#if !defined(__GHCAUTOCONF_H__)+#define __GHCAUTOCONF_H__+/* mk/config.h.  Generated from config.h.in by configure.  */+/* mk/config.h.in.  Generated from configure.ac by autoheader.  */++/* Define if building universal (internal helper macro) */+/* #undef AC_APPLE_UNIVERSAL_BUILD */++/* The alignment of a `char'. */+#define ALIGNMENT_CHAR 1++/* The alignment of a `double'. */+#define ALIGNMENT_DOUBLE 8++/* The alignment of a `float'. */+#define ALIGNMENT_FLOAT 4++/* The alignment of a `int'. */+#define ALIGNMENT_INT 4++/* The alignment of a `int16_t'. */+#define ALIGNMENT_INT16_T 2++/* The alignment of a `int32_t'. */+#define ALIGNMENT_INT32_T 4++/* The alignment of a `int64_t'. */+#define ALIGNMENT_INT64_T 8++/* The alignment of a `int8_t'. */+#define ALIGNMENT_INT8_T 1++/* The alignment of a `long'. */+#define ALIGNMENT_LONG 8++/* The alignment of a `long long'. */+#define ALIGNMENT_LONG_LONG 8++/* The alignment of a `short'. */+#define ALIGNMENT_SHORT 2++/* The alignment of a `uint16_t'. */+#define ALIGNMENT_UINT16_T 2++/* The alignment of a `uint32_t'. */+#define ALIGNMENT_UINT32_T 4++/* The alignment of a `uint64_t'. */+#define ALIGNMENT_UINT64_T 8++/* The alignment of a `uint8_t'. */+#define ALIGNMENT_UINT8_T 1++/* The alignment of a `unsigned char'. */+#define ALIGNMENT_UNSIGNED_CHAR 1++/* The alignment of a `unsigned int'. */+#define ALIGNMENT_UNSIGNED_INT 4++/* The alignment of a `unsigned long'. */+#define ALIGNMENT_UNSIGNED_LONG 8++/* The alignment of a `unsigned long long'. */+#define ALIGNMENT_UNSIGNED_LONG_LONG 8++/* The alignment of a `unsigned short'. */+#define ALIGNMENT_UNSIGNED_SHORT 2++/* The alignment of a `void *'. */+#define ALIGNMENT_VOID_P 8++/* Define (to 1) if C compiler has an LLVM back end */+#define CC_LLVM_BACKEND 1++/* Define to 1 if __thread is supported */+#define CC_SUPPORTS_TLS 1++/* Define to 1 if using 'alloca.c'. */+/* #undef C_ALLOCA */++/* Enable Native I/O manager as default. */+/* #undef DEFAULT_NATIVE_IO_MANAGER */++/* Define to 1 if your processor stores words of floats with the most+   significant byte first */+/* #undef FLOAT_WORDS_BIGENDIAN */++/* Has visibility hidden */+#define HAS_VISIBILITY_HIDDEN 1++/* Define to 1 if you have 'alloca', as a function or macro. */+#define HAVE_ALLOCA 1++/* Define to 1 if <alloca.h> works. */+#define HAVE_ALLOCA_H 1++/* Define to 1 if you have the <bfd.h> header file. */+/* #undef HAVE_BFD_H */++/* Does C compiler support __atomic primitives? */+#define HAVE_C11_ATOMICS 1++/* Define to 1 if you have the `clock_gettime' function. */+#define HAVE_CLOCK_GETTIME 1++/* Define to 1 if you have the `ctime_r' function. */+#define HAVE_CTIME_R 1++/* Define to 1 if you have the <ctype.h> header file. */+#define HAVE_CTYPE_H 1++/* Define to 1 if you have the declaration of `ctime_r', and to 0 if you+   don't. */+#define HAVE_DECL_CTIME_R 1++/* Define to 1 if you have the declaration of `environ', and to 0 if you+   don't. */+#define HAVE_DECL_ENVIRON 0++/* Define to 1 if you have the declaration of `MADV_DONTNEED', and to 0 if you+   don't. */+/* #undef HAVE_DECL_MADV_DONTNEED */++/* Define to 1 if you have the declaration of `MADV_FREE', and to 0 if you+   don't. */+/* #undef HAVE_DECL_MADV_FREE */++/* Define to 1 if you have the declaration of `MAP_NORESERVE', and to 0 if you+   don't. */+/* #undef HAVE_DECL_MAP_NORESERVE */++/* Define to 1 if you have the <dirent.h> header file. */+#define HAVE_DIRENT_H 1++/* Define to 1 if you have the <dlfcn.h> header file. */+#define HAVE_DLFCN_H 1++/* Define to 1 if you have the `dlinfo' function. */+/* #undef HAVE_DLINFO */++/* Define to 1 if you have the <elfutils/libdw.h> header file. */+/* #undef HAVE_ELFUTILS_LIBDW_H */++/* Define to 1 if you have the <errno.h> header file. */+#define HAVE_ERRNO_H 1++/* Define to 1 if you have the `eventfd' function. */+/* #undef HAVE_EVENTFD */++/* Define to 1 if you have the <fcntl.h> header file. */+#define HAVE_FCNTL_H 1++/* Define to 1 if you have the <ffi.h> header file. */+/* #undef HAVE_FFI_H */++/* Define to 1 if you have the `fork' function. */+#define HAVE_FORK 1++/* Define to 1 if you have the `getclock' function. */+/* #undef HAVE_GETCLOCK */++/* Define to 1 if you have the `GetModuleFileName' function. */+/* #undef HAVE_GETMODULEFILENAME */++/* Define to 1 if you have the `getrusage' function. */+#define HAVE_GETRUSAGE 1++/* Define to 1 if you have the `gettimeofday' function. */+#define HAVE_GETTIMEOFDAY 1++/* Define to 1 if you have the <grp.h> header file. */+#define HAVE_GRP_H 1++/* Define to 1 if you have the <inttypes.h> header file. */+#define HAVE_INTTYPES_H 1++/* Define to 1 if you have the `bfd' library (-lbfd). */+/* #undef HAVE_LIBBFD */++/* Define to 1 if you have the `dl' library (-ldl). */+#define HAVE_LIBDL 1++/* Define to 1 if you have the `iberty' library (-liberty). */+/* #undef HAVE_LIBIBERTY */++/* Define to 1 if you need to link with libm */+#define HAVE_LIBM 1++/* Define to 1 if you have libnuma */+#define HAVE_LIBNUMA 0++/* Define to 1 if you have the `pthread' library (-lpthread). */+#define HAVE_LIBPTHREAD 1++/* Define to 1 if you have the `rt' library (-lrt). */+/* #undef HAVE_LIBRT */++/* Define to 1 if you have the <limits.h> header file. */+#define HAVE_LIMITS_H 1++/* Define to 1 if you have the <locale.h> header file. */+#define HAVE_LOCALE_H 1++/* Define to 1 if the system has the type `long long'. */+#define HAVE_LONG_LONG 1++/* Define to 1 if you have the mingwex library. */+/* #undef HAVE_MINGWEX */++/* Define to 1 if you have the <minix/config.h> header file. */+/* #undef HAVE_MINIX_CONFIG_H */++/* Define to 1 if you have the <nlist.h> header file. */+#define HAVE_NLIST_H 1++/* Define to 1 if you have the <numaif.h> header file. */+/* #undef HAVE_NUMAIF_H */++/* Define to 1 if you have the <numa.h> header file. */+/* #undef HAVE_NUMA_H */++/* Define to 1 if we have printf$LDBLStub (Apple Mac OS >= 10.4, PPC). */+#define HAVE_PRINTF_LDBLSTUB 0++/* Define to 1 if you have the `pthread_condattr_setclock' function. */+/* #undef HAVE_PTHREAD_CONDATTR_SETCLOCK */++/* Define to 1 if you have the <pthread.h> header file. */+#define HAVE_PTHREAD_H 1++/* Define to 1 if you have the <pthread_np.h> header file. */+/* #undef HAVE_PTHREAD_NP_H */++/* Define to 1 if you have the glibc version of pthread_setname_np */+/* #undef HAVE_PTHREAD_SETNAME_NP */++/* Define to 1 if you have the Darwin version of pthread_setname_np */+#define HAVE_PTHREAD_SETNAME_NP_DARWIN 1++/* Define to 1 if you have the NetBSD version of pthread_setname_np */+/* #undef HAVE_PTHREAD_SETNAME_NP_NETBSD */++/* Define to 1 if you have pthread_set_name_np */+/* #undef HAVE_PTHREAD_SET_NAME_NP */++/* Define to 1 if you have the <pwd.h> header file. */+#define HAVE_PWD_H 1++/* Define to 1 if you have the `sched_getaffinity' function. */+/* #undef HAVE_SCHED_GETAFFINITY */++/* Define to 1 if you have the <sched.h> header file. */+#define HAVE_SCHED_H 1++/* Define to 1 if you have the `sched_setaffinity' function. */+/* #undef HAVE_SCHED_SETAFFINITY */++/* Define to 1 if you have the `setitimer' function. */+#define HAVE_SETITIMER 1++/* Define to 1 if you have the `setlocale' function. */+#define HAVE_SETLOCALE 1++/* Define to 1 if you have the `siginterrupt' function. */+#define HAVE_SIGINTERRUPT 1++/* Define to 1 if you have the <signal.h> header file. */+#define HAVE_SIGNAL_H 1++/* Define to 1 if you have the <stdint.h> header file. */+#define HAVE_STDINT_H 1++/* Define to 1 if you have the <stdio.h> header file. */+#define HAVE_STDIO_H 1++/* Define to 1 if you have the <stdlib.h> header file. */+#define HAVE_STDLIB_H 1++/* Define to 1 if you have the <strings.h> header file. */+#define HAVE_STRINGS_H 1++/* Define to 1 if you have the <string.h> header file. */+#define HAVE_STRING_H 1++/* Define to 1 if Apple-style dead-stripping is supported. */+#define HAVE_SUBSECTIONS_VIA_SYMBOLS 1++/* Define to 1 if you have the `sysconf' function. */+#define HAVE_SYSCONF 1++/* Define to 1 if you have libffi. */+/* #undef HAVE_SYSTEM_LIBFFI */++/* Define to 1 if you have the <sys/cpuset.h> header file. */+/* #undef HAVE_SYS_CPUSET_H */++/* Define to 1 if you have the <sys/eventfd.h> header file. */+/* #undef HAVE_SYS_EVENTFD_H */++/* Define to 1 if you have the <sys/mman.h> header file. */+#define HAVE_SYS_MMAN_H 1++/* Define to 1 if you have the <sys/param.h> header file. */+#define HAVE_SYS_PARAM_H 1++/* Define to 1 if you have the <sys/resource.h> header file. */+#define HAVE_SYS_RESOURCE_H 1++/* Define to 1 if you have the <sys/select.h> header file. */+#define HAVE_SYS_SELECT_H 1++/* Define to 1 if you have the <sys/stat.h> header file. */+#define HAVE_SYS_STAT_H 1++/* Define to 1 if you have the <sys/timeb.h> header file. */+#define HAVE_SYS_TIMEB_H 1++/* Define to 1 if you have the <sys/timerfd.h> header file. */+/* #undef HAVE_SYS_TIMERFD_H */++/* Define to 1 if you have the <sys/timers.h> header file. */+/* #undef HAVE_SYS_TIMERS_H */++/* Define to 1 if you have the <sys/times.h> header file. */+#define HAVE_SYS_TIMES_H 1++/* Define to 1 if you have the <sys/time.h> header file. */+#define HAVE_SYS_TIME_H 1++/* Define to 1 if you have the <sys/types.h> header file. */+#define HAVE_SYS_TYPES_H 1++/* Define to 1 if you have the <sys/utsname.h> header file. */+#define HAVE_SYS_UTSNAME_H 1++/* Define to 1 if you have the <sys/wait.h> header file. */+#define HAVE_SYS_WAIT_H 1++/* Define to 1 if you have the <termios.h> header file. */+#define HAVE_TERMIOS_H 1++/* Define to 1 if you have the `timer_settime' function. */+/* #undef HAVE_TIMER_SETTIME */++/* Define to 1 if you have the `times' function. */+#define HAVE_TIMES 1++/* Define to 1 if you have the <time.h> header file. */+#define HAVE_TIME_H 1++/* Define to 1 if you have the <unistd.h> header file. */+#define HAVE_UNISTD_H 1++/* Define to 1 if you have the `uselocale' function. */+#define HAVE_USELOCALE 1++/* Define to 1 if you have the <utime.h> header file. */+#define HAVE_UTIME_H 1++/* Define to 1 if you have the `vfork' function. */+#define HAVE_VFORK 1++/* Define to 1 if you have the <vfork.h> header file. */+/* #undef HAVE_VFORK_H */++/* Define to 1 if you have the <wchar.h> header file. */+#define HAVE_WCHAR_H 1++/* Define to 1 if you have the <windows.h> header file. */+/* #undef HAVE_WINDOWS_H */++/* Define to 1 if you have the `WinExec' function. */+/* #undef HAVE_WINEXEC */++/* Define to 1 if you have the <winsock.h> header file. */+/* #undef HAVE_WINSOCK_H */++/* Define to 1 if `fork' works. */+#define HAVE_WORKING_FORK 1++/* Define to 1 if `vfork' works. */+#define HAVE_WORKING_VFORK 1++/* Define to 1 if C symbols have a leading underscore added by the compiler.+   */+#define LEADING_UNDERSCORE 1++/* Define to 1 if we need -latomic. */+#define NEED_ATOMIC_LIB 0++/* Define 1 if we need to link code using pthreads with -lpthread */+#define NEED_PTHREAD_LIB 0++/* Define to the address where bug reports for this package should be sent. */+/* #undef PACKAGE_BUGREPORT */++/* Define to the full name of this package. */+/* #undef PACKAGE_NAME */++/* Define to the full name and version of this package. */+/* #undef PACKAGE_STRING */++/* Define to the one symbol short name of this package. */+/* #undef PACKAGE_TARNAME */++/* Define to the home page for this package. */+/* #undef PACKAGE_URL */++/* Define to the version of this package. */+/* #undef PACKAGE_VERSION */++/* Use mmap in the runtime linker */+#define RTS_LINKER_USE_MMAP 1++/* The size of `char', as computed by sizeof. */+#define SIZEOF_CHAR 1++/* The size of `double', as computed by sizeof. */+#define SIZEOF_DOUBLE 8++/* The size of `float', as computed by sizeof. */+#define SIZEOF_FLOAT 4++/* The size of `int', as computed by sizeof. */+#define SIZEOF_INT 4++/* The size of `int16_t', as computed by sizeof. */+#define SIZEOF_INT16_T 2++/* The size of `int32_t', as computed by sizeof. */+#define SIZEOF_INT32_T 4++/* The size of `int64_t', as computed by sizeof. */+#define SIZEOF_INT64_T 8++/* The size of `int8_t', as computed by sizeof. */+#define SIZEOF_INT8_T 1++/* The size of `long', as computed by sizeof. */+#define SIZEOF_LONG 8++/* The size of `long long', as computed by sizeof. */+#define SIZEOF_LONG_LONG 8++/* The size of `short', as computed by sizeof. */+#define SIZEOF_SHORT 2++/* The size of `uint16_t', as computed by sizeof. */+#define SIZEOF_UINT16_T 2++/* The size of `uint32_t', as computed by sizeof. */+#define SIZEOF_UINT32_T 4++/* The size of `uint64_t', as computed by sizeof. */+#define SIZEOF_UINT64_T 8++/* The size of `uint8_t', as computed by sizeof. */+#define SIZEOF_UINT8_T 1++/* The size of `unsigned char', as computed by sizeof. */+#define SIZEOF_UNSIGNED_CHAR 1++/* The size of `unsigned int', as computed by sizeof. */+#define SIZEOF_UNSIGNED_INT 4++/* The size of `unsigned long', as computed by sizeof. */+#define SIZEOF_UNSIGNED_LONG 8++/* The size of `unsigned long long', as computed by sizeof. */+#define SIZEOF_UNSIGNED_LONG_LONG 8++/* The size of `unsigned short', as computed by sizeof. */+#define SIZEOF_UNSIGNED_SHORT 2++/* The size of `void *', as computed by sizeof. */+#define SIZEOF_VOID_P 8++/* If using the C implementation of alloca, define if you know the+   direction of stack growth for your system; otherwise it will be+   automatically deduced at runtime.+	STACK_DIRECTION > 0 => grows toward higher addresses+	STACK_DIRECTION < 0 => grows toward lower addresses+	STACK_DIRECTION = 0 => direction of growth unknown */+/* #undef STACK_DIRECTION */++/* Define to 1 if all of the C90 standard headers exist (not just the ones+   required in a freestanding environment). This macro is provided for+   backward compatibility; new code need not use it. */+#define STDC_HEADERS 1++/* Define to 1 if info tables are laid out next to code */+#define TABLES_NEXT_TO_CODE 1++/* Define to 1 if you can safely include both <sys/time.h> and <time.h>. This+   macro is obsolete. */+#define TIME_WITH_SYS_TIME 1++/* Compile-in ASSERTs in all ways. */+/* #undef USE_ASSERTS_ALL_WAYS */++/* Enable single heap address space support */+#define USE_LARGE_ADDRESS_SPACE 1++/* Set to 1 to use libdw */+#define USE_LIBDW 0++/* Enable extensions on AIX 3, Interix.  */+#ifndef _ALL_SOURCE+# define _ALL_SOURCE 1+#endif+/* Enable general extensions on macOS.  */+#ifndef _DARWIN_C_SOURCE+# define _DARWIN_C_SOURCE 1+#endif+/* Enable general extensions on Solaris.  */+#ifndef __EXTENSIONS__+# define __EXTENSIONS__ 1+#endif+/* Enable GNU extensions on systems that have them.  */+#ifndef _GNU_SOURCE+# define _GNU_SOURCE 1+#endif+/* Enable X/Open compliant socket functions that do not require linking+   with -lxnet on HP-UX 11.11.  */+#ifndef _HPUX_ALT_XOPEN_SOCKET_API+# define _HPUX_ALT_XOPEN_SOCKET_API 1+#endif+/* Identify the host operating system as Minix.+   This macro does not affect the system headers' behavior.+   A future release of Autoconf may stop defining this macro.  */+#ifndef _MINIX+/* # undef _MINIX */+#endif+/* Enable general extensions on NetBSD.+   Enable NetBSD compatibility extensions on Minix.  */+#ifndef _NETBSD_SOURCE+# define _NETBSD_SOURCE 1+#endif+/* Enable OpenBSD compatibility extensions on NetBSD.+   Oddly enough, this does nothing on OpenBSD.  */+#ifndef _OPENBSD_SOURCE+# define _OPENBSD_SOURCE 1+#endif+/* Define to 1 if needed for POSIX-compatible behavior.  */+#ifndef _POSIX_SOURCE+/* # undef _POSIX_SOURCE */+#endif+/* Define to 2 if needed for POSIX-compatible behavior.  */+#ifndef _POSIX_1_SOURCE+/* # undef _POSIX_1_SOURCE */+#endif+/* Enable POSIX-compatible threading on Solaris.  */+#ifndef _POSIX_PTHREAD_SEMANTICS+# define _POSIX_PTHREAD_SEMANTICS 1+#endif+/* Enable extensions specified by ISO/IEC TS 18661-5:2014.  */+#ifndef __STDC_WANT_IEC_60559_ATTRIBS_EXT__+# define __STDC_WANT_IEC_60559_ATTRIBS_EXT__ 1+#endif+/* Enable extensions specified by ISO/IEC TS 18661-1:2014.  */+#ifndef __STDC_WANT_IEC_60559_BFP_EXT__+# define __STDC_WANT_IEC_60559_BFP_EXT__ 1+#endif+/* Enable extensions specified by ISO/IEC TS 18661-2:2015.  */+#ifndef __STDC_WANT_IEC_60559_DFP_EXT__+# define __STDC_WANT_IEC_60559_DFP_EXT__ 1+#endif+/* Enable extensions specified by ISO/IEC TS 18661-4:2015.  */+#ifndef __STDC_WANT_IEC_60559_FUNCS_EXT__+# define __STDC_WANT_IEC_60559_FUNCS_EXT__ 1+#endif+/* Enable extensions specified by ISO/IEC TS 18661-3:2015.  */+#ifndef __STDC_WANT_IEC_60559_TYPES_EXT__+# define __STDC_WANT_IEC_60559_TYPES_EXT__ 1+#endif+/* Enable extensions specified by ISO/IEC TR 24731-2:2010.  */+#ifndef __STDC_WANT_LIB_EXT2__+# define __STDC_WANT_LIB_EXT2__ 1+#endif+/* Enable extensions specified by ISO/IEC 24747:2009.  */+#ifndef __STDC_WANT_MATH_SPEC_FUNCS__+# define __STDC_WANT_MATH_SPEC_FUNCS__ 1+#endif+/* Enable extensions on HP NonStop.  */+#ifndef _TANDEM_SOURCE+# define _TANDEM_SOURCE 1+#endif+/* Enable X/Open extensions.  Define to 500 only if necessary+   to make mbstate_t available.  */+#ifndef _XOPEN_SOURCE+/* # undef _XOPEN_SOURCE */+#endif+++/* Define to 1 if we can use timer_create(CLOCK_REALTIME,...) */+/* #undef USE_TIMER_CREATE */++/* Define WORDS_BIGENDIAN to 1 if your processor stores words with the most+   significant byte first (like Motorola and SPARC, unlike Intel). */+#if defined AC_APPLE_UNIVERSAL_BUILD+# if defined __BIG_ENDIAN__+#  define WORDS_BIGENDIAN 1+# endif+#else+# ifndef WORDS_BIGENDIAN+/* #  undef WORDS_BIGENDIAN */+# endif+#endif++/* Number of bits in a file offset, on hosts where this is settable. */+/* #undef _FILE_OFFSET_BITS */++/* Define for large files, on AIX-style hosts. */+/* #undef _LARGE_FILES */++/* ARM pre v6 */+/* #undef arm_HOST_ARCH_PRE_ARMv6 */++/* ARM pre v7 */+/* #undef arm_HOST_ARCH_PRE_ARMv7 */++/* Define to empty if `const' does not conform to ANSI C. */+/* #undef const */++/* Define as a signed integer type capable of holding a process identifier. */+/* #undef pid_t */++/* The maximum supported LLVM version number */+#define sUPPORTED_LLVM_VERSION_MAX (14)++/* The minimum supported LLVM version number */+#define sUPPORTED_LLVM_VERSION_MIN (10)++/* Define to `unsigned int' if <sys/types.h> does not define. */+/* #undef size_t */++/* Define as `fork' if `vfork' does not work. */+/* #undef vfork */+#endif /* __GHCAUTOCONF_H__ */
+ ghc-lib/stage0/rts/build/include/ghcplatform.h view
@@ -0,0 +1,26 @@+#if !defined(__GHCPLATFORM_H__)+#define __GHCPLATFORM_H__++#define BuildPlatform_TYPE  x86_64_apple_darwin+#define HostPlatform_TYPE   x86_64_apple_darwin++#define x86_64_apple_darwin_BUILD 1+#define x86_64_apple_darwin_HOST 1++#define x86_64_BUILD_ARCH 1+#define x86_64_HOST_ARCH 1+#define BUILD_ARCH "x86_64"+#define HOST_ARCH "x86_64"++#define darwin_BUILD_OS 1+#define darwin_HOST_OS 1+#define BUILD_OS "darwin"+#define HOST_OS "darwin"++#define apple_BUILD_VENDOR 1+#define apple_HOST_VENDOR 1+#define BUILD_VENDOR "apple"+#define HOST_VENDOR "apple"+++#endif /* __GHCPLATFORM_H__ */
− includes/CodeGen.Platform.hs 
@@ -1,1267 +0,0 @@--import GHC.Cmm.Expr-#if !(defined(MACHREGS_i386) || defined(MACHREGS_x86_64) \-    || defined(MACHREGS_sparc) || defined(MACHREGS_powerpc) \-    || defined(MACHREGS_aarch64))-import GHC.Utils.Panic.Plain-#endif-import GHC.Platform.Reg--#include "stg/MachRegs.h"--#if defined(MACHREGS_i386) || defined(MACHREGS_x86_64)--# if defined(MACHREGS_i386)-#  define eax 0-#  define ebx 1-#  define ecx 2-#  define edx 3-#  define esi 4-#  define edi 5-#  define ebp 6-#  define esp 7-# endif--# if defined(MACHREGS_x86_64)-#  define rax   0-#  define rbx   1-#  define rcx   2-#  define rdx   3-#  define rsi   4-#  define rdi   5-#  define rbp   6-#  define rsp   7-#  define r8    8-#  define r9    9-#  define r10   10-#  define r11   11-#  define r12   12-#  define r13   13-#  define r14   14-#  define r15   15-# endif----- N.B. XMM, YMM, and ZMM are all aliased to the same hardware registers hence--- being assigned the same RegNos.-# define xmm0  16-# define xmm1  17-# define xmm2  18-# define xmm3  19-# define xmm4  20-# define xmm5  21-# define xmm6  22-# define xmm7  23-# define xmm8  24-# define xmm9  25-# define xmm10 26-# define xmm11 27-# define xmm12 28-# define xmm13 29-# define xmm14 30-# define xmm15 31--# define ymm0  16-# define ymm1  17-# define ymm2  18-# define ymm3  19-# define ymm4  20-# define ymm5  21-# define ymm6  22-# define ymm7  23-# define ymm8  24-# define ymm9  25-# define ymm10 26-# define ymm11 27-# define ymm12 28-# define ymm13 29-# define ymm14 30-# define ymm15 31--# define zmm0  16-# define zmm1  17-# define zmm2  18-# define zmm3  19-# define zmm4  20-# define zmm5  21-# define zmm6  22-# define zmm7  23-# define zmm8  24-# define zmm9  25-# define zmm10 26-# define zmm11 27-# define zmm12 28-# define zmm13 29-# define zmm14 30-# define zmm15 31---- Note: these are only needed for ARM/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_sparc)--# define g0  0-# define g1  1-# define g2  2-# define g3  3-# define g4  4-# define g5  5-# define g6  6-# define g7  7--# define o0  8-# define o1  9-# define o2  10-# define o3  11-# define o4  12-# define o5  13-# define o6  14-# define o7  15--# define l0  16-# define l1  17-# define l2  18-# define l3  19-# define l4  20-# define l5  21-# define l6  22-# define l7  23--# define i0  24-# define i1  25-# define i2  26-# define i3  27-# define i4  28-# define i5  29-# define i6  30-# define i7  31--# define f0  32-# define f1  33-# define f2  34-# define f3  35-# define f4  36-# define f5  37-# define f6  38-# define f7  39-# define f8  40-# define f9  41-# define f10 42-# define f11 43-# define f12 44-# define f13 45-# define f14 46-# define f15 47-# define f16 48-# define f17 49-# define f18 50-# define f19 51-# define f20 52-# define f21 53-# define f22 54-# define f23 55-# define f24 56-# define f25 57-# define f26 58-# define f27 59-# define f28 60-# define f29 61-# define f30 62-# define f31 63--#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_sparc) || 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)            =-#  if defined(MACHREGS_sparc)-                                          Just (RealRegPair REG_D1 (REG_D1 + 1))-#  else-                                          Just (RealRegSingle REG_D1)-#  endif-# endif-# if defined(REG_D2)-globalRegMaybe (DoubleReg 2)            =-#  if defined(MACHREGS_sparc)-                                          Just (RealRegPair REG_D2 (REG_D2 + 1))-#  else-                                          Just (RealRegSingle REG_D2)-#  endif-# endif-# if defined(REG_D3)-globalRegMaybe (DoubleReg 3)            =-#  if defined(MACHREGS_sparc)-                                          Just (RealRegPair REG_D3 (REG_D3 + 1))-#  else-                                          Just (RealRegSingle REG_D3)-#  endif-# endif-# if defined(REG_D4)-globalRegMaybe (DoubleReg 4)            =-#  if defined(MACHREGS_sparc)-                                          Just (RealRegPair REG_D4 (REG_D4 + 1))-#  else-                                          Just (RealRegSingle REG_D4)-#  endif-# endif-# if defined(REG_D5)-globalRegMaybe (DoubleReg 5)            =-#  if defined(MACHREGS_sparc)-                                          Just (RealRegPair REG_D5 (REG_D5 + 1))-#  else-                                          Just (RealRegSingle REG_D5)-#  endif-# endif-# if defined(REG_D6)-globalRegMaybe (DoubleReg 6)            =-#  if defined(MACHREGS_sparc)-                                          Just (RealRegPair REG_D6 (REG_D6 + 1))-#  else-                                          Just (RealRegSingle REG_D6)-#  endif-# endif-# if MAX_REAL_XMM_REG != 0-#  if defined(REG_XMM1)-globalRegMaybe (XmmReg 1)               = Just (RealRegSingle REG_XMM1)-#  endif-#  if defined(REG_XMM2)-globalRegMaybe (XmmReg 2)               = Just (RealRegSingle REG_XMM2)-#  endif-#  if defined(REG_XMM3)-globalRegMaybe (XmmReg 3)               = Just (RealRegSingle REG_XMM3)-#  endif-#  if defined(REG_XMM4)-globalRegMaybe (XmmReg 4)               = Just (RealRegSingle REG_XMM4)-#  endif-#  if defined(REG_XMM5)-globalRegMaybe (XmmReg 5)               = Just (RealRegSingle REG_XMM5)-#  endif-#  if defined(REG_XMM6)-globalRegMaybe (XmmReg 6)               = Just (RealRegSingle REG_XMM6)-#  endif-# endif-# if defined(MAX_REAL_YMM_REG) && MAX_REAL_YMM_REG != 0-#  if defined(REG_YMM1)-globalRegMaybe (YmmReg 1)               = Just (RealRegSingle REG_YMM1)-#  endif-#  if defined(REG_YMM2)-globalRegMaybe (YmmReg 2)               = Just (RealRegSingle REG_YMM2)-#  endif-#  if defined(REG_YMM3)-globalRegMaybe (YmmReg 3)               = Just (RealRegSingle REG_YMM3)-#  endif-#  if defined(REG_YMM4)-globalRegMaybe (YmmReg 4)               = Just (RealRegSingle REG_YMM4)-#  endif-#  if defined(REG_YMM5)-globalRegMaybe (YmmReg 5)               = Just (RealRegSingle REG_YMM5)-#  endif-#  if defined(REG_YMM6)-globalRegMaybe (YmmReg 6)               = Just (RealRegSingle REG_YMM6)-#  endif-# endif-# if defined(MAX_REAL_ZMM_REG) && MAX_REAL_ZMM_REG != 0-#  if defined(REG_ZMM1)-globalRegMaybe (ZmmReg 1)               = Just (RealRegSingle REG_ZMM1)-#  endif-#  if defined(REG_ZMM2)-globalRegMaybe (ZmmReg 2)               = Just (RealRegSingle REG_ZMM2)-#  endif-#  if defined(REG_ZMM3)-globalRegMaybe (ZmmReg 3)               = Just (RealRegSingle REG_ZMM3)-#  endif-#  if defined(REG_ZMM4)-globalRegMaybe (ZmmReg 4)               = Just (RealRegSingle REG_ZMM4)-#  endif-#  if defined(REG_ZMM5)-globalRegMaybe (ZmmReg 5)               = Just (RealRegSingle REG_ZMM5)-#  endif-#  if defined(REG_ZMM6)-globalRegMaybe (ZmmReg 6)               = Just (RealRegSingle REG_ZMM6)-#  endif-# endif-# if defined(REG_Sp)-globalRegMaybe Sp                       = Just (RealRegSingle REG_Sp)-# endif-# if defined(REG_Lng1)-globalRegMaybe (LongReg 1)              = Just (RealRegSingle REG_Lng1)-# endif-# if defined(REG_Lng2)-globalRegMaybe (LongReg 2)              = Just (RealRegSingle REG_Lng2)-# endif-# if defined(REG_SpLim)-globalRegMaybe SpLim                    = Just (RealRegSingle REG_SpLim)-# endif-# if defined(REG_Hp)-globalRegMaybe Hp                       = Just (RealRegSingle REG_Hp)-# endif-# if defined(REG_HpLim)-globalRegMaybe HpLim                    = Just (RealRegSingle REG_HpLim)-# endif-# if defined(REG_CurrentTSO)-globalRegMaybe CurrentTSO               = Just (RealRegSingle REG_CurrentTSO)-# endif-# if defined(REG_CurrentNursery)-globalRegMaybe CurrentNursery           = Just (RealRegSingle REG_CurrentNursery)-# endif-# if defined(REG_MachSp)-globalRegMaybe MachSp                   = Just (RealRegSingle REG_MachSp)-# endif-globalRegMaybe _                        = Nothing-#elif defined(MACHREGS_NO_REGS)-globalRegMaybe _ = Nothing-#else-globalRegMaybe = panic "globalRegMaybe not defined for this platform"-#endif--freeReg :: RegNo -> Bool--#if defined(MACHREGS_i386) || defined(MACHREGS_x86_64)--# if defined(MACHREGS_i386)-freeReg esp = False -- %esp is the C stack pointer-freeReg esi = False -- Note [esi/edi/ebp not allocatable]-freeReg edi = False-freeReg ebp = False-# endif-# if defined(MACHREGS_x86_64)-freeReg rsp = False  --        %rsp is the C stack pointer-# endif--{--Note [esi/edi/ebp not allocatable]--%esi is mapped to R1, so %esi would normally be allocatable while it-is not being used for R1.  However, %esi has no 8-bit version on x86,-and the linear register allocator is not sophisticated enough to-handle this irregularity (we need more RegClasses).  The-graph-colouring allocator also cannot handle this - it was designed-with more flexibility in mind, but the current implementation is-restricted to the same set of classes as the linear allocator.--Hence, on x86 esi, edi and ebp are treated as not allocatable.--}---- split patterns in two functions to prevent overlaps-freeReg r         = freeRegBase r--freeRegBase :: RegNo -> Bool-# if defined(REG_Base)-freeRegBase REG_Base  = False-# endif-# if defined(REG_Sp)-freeRegBase REG_Sp    = False-# endif-# if defined(REG_SpLim)-freeRegBase REG_SpLim = False-# endif-# if defined(REG_Hp)-freeRegBase REG_Hp    = False-# endif-# if defined(REG_HpLim)-freeRegBase REG_HpLim = False-# endif--- All other regs are considered to be "free", because we can track--- their liveness accurately.-freeRegBase _ = True--#elif defined(MACHREGS_powerpc)--freeReg 0 = False -- Used by code setting the back chain pointer-                  -- in stack reallocations on Linux.-                  -- Moreover r0 is not usable in all insns.-freeReg 1 = False -- The Stack Pointer--- most ELF PowerPC OSes use r2 as a TOC pointer-freeReg 2 = False-freeReg 13 = False -- reserved for system thread ID on 64 bit--- at least linux in -fPIC relies on r30 in PLT stubs-freeReg 30 = False-{- TODO: reserve r13 on 64 bit systems only and r30 on 32 bit respectively.-   For now we use r30 on 64 bit and r13 on 32 bit as a temporary register-   in stack handling code. See compiler/GHC/CmmToAsm/PPC/Instr.hs.--   Later we might want to reserve r13 and r30 only where it is required.-   Then use r12 as temporary register, which is also what the C ABI does.--}--# if defined(REG_Base)-freeReg REG_Base  = False-# endif-# if defined(REG_Sp)-freeReg REG_Sp    = False-# endif-# if defined(REG_SpLim)-freeReg REG_SpLim = False-# endif-# if defined(REG_Hp)-freeReg REG_Hp    = False-# endif-# if defined(REG_HpLim)-freeReg REG_HpLim = False-# endif-freeReg _ = True--#elif defined(MACHREGS_aarch64)---- stack pointer / zero reg-freeReg 31 = False--- link register-freeReg 30 = False--- frame pointer-freeReg 29 = False--- ip0 -- used for spill offset computations-freeReg 16 = False--#if defined(darwin_HOST_OS) || defined(ios_HOST_OS)--- x18 is reserved by the platform on Darwin/iOS, and can not be used--- More about ARM64 ABI that Apple platforms support:--- https://developer.apple.com/documentation/xcode/writing-arm64-code-for-apple-platforms--- https://github.com/Siguza/ios-resources/blob/master/bits/arm64.md-freeReg 18 = False-#endif--# if defined(REG_Base)-freeReg REG_Base  = False-# endif-# if defined(REG_Sp)-freeReg REG_Sp    = False-# endif-# if defined(REG_SpLim)-freeReg REG_SpLim = False-# endif-# if defined(REG_Hp)-freeReg REG_Hp    = False-# endif-# if defined(REG_HpLim)-freeReg REG_HpLim = False-# endif--# if defined(REG_R1)-freeReg REG_R1    = False-# endif-# if defined(REG_R2)-freeReg REG_R2    = False-# endif-# if defined(REG_R3)-freeReg REG_R3    = False-# endif-# if defined(REG_R4)-freeReg REG_R4    = False-# endif-# if defined(REG_R5)-freeReg REG_R5    = False-# endif-# if defined(REG_R6)-freeReg REG_R6    = False-# endif-# if defined(REG_R7)-freeReg REG_R7    = False-# endif-# if defined(REG_R8)-freeReg REG_R8    = False-# endif--# if defined(REG_F1)-freeReg REG_F1    = False-# endif-# if defined(REG_F2)-freeReg REG_F2    = False-# endif-# if defined(REG_F3)-freeReg REG_F3    = False-# endif-# if defined(REG_F4)-freeReg REG_F4    = False-# endif-# if defined(REG_F5)-freeReg REG_F5    = False-# endif-# if defined(REG_F6)-freeReg REG_F6    = False-# endif--# if defined(REG_D1)-freeReg REG_D1    = False-# endif-# if defined(REG_D2)-freeReg REG_D2    = False-# endif-# if defined(REG_D3)-freeReg REG_D3    = False-# endif-# if defined(REG_D4)-freeReg REG_D4    = False-# endif-# if defined(REG_D5)-freeReg REG_D5    = False-# endif-# if defined(REG_D6)-freeReg REG_D6    = False-# endif--freeReg _ = True--#elif defined(MACHREGS_sparc)---- SPARC regs used by the OS / ABI--- %g0(r0) is always zero-freeReg g0  = False---- %g5(r5) - %g7(r7)---  are reserved for the OS-freeReg g5  = False-freeReg g6  = False-freeReg g7  = False---- %o6(r14)---  is the C stack pointer-freeReg o6  = False---- %o7(r15)---  holds the C return address-freeReg o7  = False---- %i6(r30)---  is the C frame pointer-freeReg i6  = False---- %i7(r31)---  is used for C return addresses-freeReg i7  = False---- %f0(r32) - %f1(r32)---  are C floating point return regs-freeReg f0  = False-freeReg f1  = False--{--freeReg regNo-    -- don't release high half of double regs-    | regNo >= f0-    , regNo <  NCG_FirstFloatReg-    , regNo `mod` 2 /= 0-    = False--}--# if defined(REG_Base)-freeReg REG_Base  = False-# endif-# if defined(REG_R1)-freeReg REG_R1    = False-# endif-# if defined(REG_R2)-freeReg REG_R2    = False-# endif-# if defined(REG_R3)-freeReg REG_R3    = False-# endif-# if defined(REG_R4)-freeReg REG_R4    = False-# endif-# if defined(REG_R5)-freeReg REG_R5    = False-# endif-# if defined(REG_R6)-freeReg REG_R6    = False-# endif-# if defined(REG_R7)-freeReg REG_R7    = False-# endif-# if defined(REG_R8)-freeReg REG_R8    = False-# endif-# if defined(REG_R9)-freeReg REG_R9    = False-# endif-# if defined(REG_R10)-freeReg REG_R10   = False-# endif-# if defined(REG_F1)-freeReg REG_F1    = False-# endif-# if defined(REG_F2)-freeReg REG_F2    = False-# endif-# if defined(REG_F3)-freeReg REG_F3    = False-# endif-# if defined(REG_F4)-freeReg REG_F4    = False-# endif-# if defined(REG_F5)-freeReg REG_F5    = False-# endif-# if defined(REG_F6)-freeReg REG_F6    = False-# endif-# if defined(REG_D1)-freeReg REG_D1    = False-# endif-# if defined(REG_D1_2)-freeReg REG_D1_2  = False-# endif-# if defined(REG_D2)-freeReg REG_D2    = False-# endif-# if defined(REG_D2_2)-freeReg REG_D2_2  = False-# endif-# if defined(REG_D3)-freeReg REG_D3    = False-# endif-# if defined(REG_D3_2)-freeReg REG_D3_2  = False-# endif-# if defined(REG_D4)-freeReg REG_D4    = False-# endif-# if defined(REG_D4_2)-freeReg REG_D4_2  = False-# endif-# if defined(REG_D5)-freeReg REG_D5    = False-# endif-# if defined(REG_D5_2)-freeReg REG_D5_2  = False-# endif-# if defined(REG_D6)-freeReg REG_D6    = False-# endif-# if defined(REG_D6_2)-freeReg REG_D6_2  = False-# endif-# if defined(REG_Sp)-freeReg REG_Sp    = False-# endif-# if defined(REG_SpLim)-freeReg REG_SpLim = False-# endif-# if defined(REG_Hp)-freeReg REG_Hp    = False-# endif-# if defined(REG_HpLim)-freeReg REG_HpLim = False-# endif-freeReg _ = True--#else--freeReg = panic "freeReg not defined for this platform"--#endif
− includes/MachDeps.h 
@@ -1,119 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The University of Glasgow 2002- *- * Definitions that characterise machine specific properties of basic- * types (C & Haskell) of a target platform.- *- * NB: Keep in sync with HsFFI.h and StgTypes.h.- * NB: THIS FILE IS INCLUDED IN HASKELL SOURCE!- *- * To understand the structure of the RTS headers, see the wiki:- *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes- *- * ---------------------------------------------------------------------------*/--#pragma once--/* Don't allow stage1 (cross-)compiler embed assumptions about target- * platform. When ghc-stage1 is being built by ghc-stage0 is should not- * refer to target defines. A few past examples:- *  - https://gitlab.haskell.org/ghc/ghc/issues/13491- *  - https://phabricator.haskell.org/D3122- *  - https://phabricator.haskell.org/D3405- *- * In those cases code change assumed target defines like SIZEOF_HSINT- * are applied to host platform, not target platform.- *- * So what should be used instead in GHC_STAGE=1?- *- * To get host's equivalent of SIZEOF_HSINT you can use Bits instances:- *    Data.Bits.finiteBitSize (0 :: Int)- *- * To get target's values it is preferred to use runtime target- * configuration from 'targetPlatform :: DynFlags -> Platform'- * record.- *- * Hence we hide these macros from GHC_STAGE=1- */--/* Sizes of C types come from here... */-#include "ghcautoconf.h"--/* Sizes of Haskell types follow.  These sizes correspond to:- *   - the number of bytes in the primitive type (eg. Int#)- *   - the number of bytes in the external representation (eg. HsInt)- *   - the scale offset used by writeFooOffAddr#- *- * In the heap, the type may take up more space: eg. SIZEOF_INT8 == 1,- * but it takes up SIZEOF_HSWORD (4 or 8) bytes in the heap.- */--#define SIZEOF_HSCHAR           SIZEOF_WORD32-#define ALIGNMENT_HSCHAR        ALIGNMENT_WORD32--#define SIZEOF_HSINT            SIZEOF_VOID_P-#define ALIGNMENT_HSINT         ALIGNMENT_VOID_P--#define SIZEOF_HSWORD           SIZEOF_VOID_P-#define ALIGNMENT_HSWORD        ALIGNMENT_VOID_P--#define SIZEOF_HSDOUBLE         SIZEOF_DOUBLE-#define ALIGNMENT_HSDOUBLE      ALIGNMENT_DOUBLE--#define SIZEOF_HSFLOAT          SIZEOF_FLOAT-#define ALIGNMENT_HSFLOAT       ALIGNMENT_FLOAT--#define SIZEOF_HSPTR            SIZEOF_VOID_P-#define ALIGNMENT_HSPTR         ALIGNMENT_VOID_P--#define SIZEOF_HSFUNPTR         SIZEOF_VOID_P-#define ALIGNMENT_HSFUNPTR      ALIGNMENT_VOID_P--#define SIZEOF_HSSTABLEPTR      SIZEOF_VOID_P-#define ALIGNMENT_HSSTABLEPTR   ALIGNMENT_VOID_P--#define SIZEOF_INT8             SIZEOF_INT8_T-#define ALIGNMENT_INT8          ALIGNMENT_INT8_T--#define SIZEOF_WORD8            SIZEOF_UINT8_T-#define ALIGNMENT_WORD8         ALIGNMENT_UINT8_T--#define SIZEOF_INT16            SIZEOF_INT16_T-#define ALIGNMENT_INT16         ALIGNMENT_INT16_T--#define SIZEOF_WORD16           SIZEOF_UINT16_T-#define ALIGNMENT_WORD16        ALIGNMENT_UINT16_T--#define SIZEOF_INT32            SIZEOF_INT32_T-#define ALIGNMENT_INT32         ALIGNMENT_INT32_T--#define SIZEOF_WORD32           SIZEOF_UINT32_T-#define ALIGNMENT_WORD32        ALIGNMENT_UINT32_T--#define SIZEOF_INT64            SIZEOF_INT64_T-#define ALIGNMENT_INT64         ALIGNMENT_INT64_T--#define SIZEOF_WORD64           SIZEOF_UINT64_T-#define ALIGNMENT_WORD64        ALIGNMENT_UINT64_T--#if !defined(WORD_SIZE_IN_BITS)-#if SIZEOF_HSWORD == 4-#define WORD_SIZE_IN_BITS       32-#define WORD_SIZE_IN_BITS_FLOAT 32.0-#else-#define WORD_SIZE_IN_BITS       64-#define WORD_SIZE_IN_BITS_FLOAT 64.0-#endif-#endif--#if !defined(TAG_BITS)-#if SIZEOF_HSWORD == 4-#define TAG_BITS                2-#else-#define TAG_BITS                3-#endif-#endif--#define TAG_MASK ((1 << TAG_BITS) - 1)-
− includes/stg/MachRegs.h 
@@ -1,854 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The GHC Team, 1998-2014- *- * Registers used in STG code.  Might or might not correspond to- * actual machine registers.- *- * Do not #include this file directly: #include "Rts.h" instead.- *- * To understand the structure of the RTS headers, see the wiki:- *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes- *- * ---------------------------------------------------------------------------*/--#pragma once--/* This file is #included into Haskell code in the compiler: #defines- * only in here please.- */--/*- * Undefine these as a precaution: some of them were found to be- * defined by system headers on ARM/Linux.- */-#undef REG_R1-#undef REG_R2-#undef REG_R3-#undef REG_R4-#undef REG_R5-#undef REG_R6-#undef REG_R7-#undef REG_R8-#undef REG_R9-#undef REG_R10--/*- * Defining MACHREGS_NO_REGS to 1 causes no global registers to be used.- * MACHREGS_NO_REGS is typically controlled by NO_REGS, which is- * typically defined by GHC, via a command-line option passed to gcc,- * when the -funregisterised flag is given.- *- * NB. When MACHREGS_NO_REGS to 1, calling & return conventions may be- * different.  For example, all function arguments will be passed on- * the stack, and components of an unboxed tuple will be returned on- * the stack rather than in registers.- */-#if MACHREGS_NO_REGS == 1--/* Nothing */--#elif MACHREGS_NO_REGS == 0--/* -----------------------------------------------------------------------------   Caller saves and callee-saves regs.--   Caller-saves regs have to be saved around C-calls made from STG-   land, so this file defines CALLER_SAVES_<reg> for each <reg> that-   is designated caller-saves in that machine's C calling convention.--   As it stands, the only registers that are ever marked caller saves-   are the RX, FX, DX and USER registers; as a result, if you-   decide to caller save a system register (e.g. SP, HP, etc), note that-   this code path is completely untested! -- EZY--   See Note [Register parameter passing] for details.-   -------------------------------------------------------------------------- */--/* ------------------------------------------------------------------------------   The x86 register mapping--   Ok, we've only got 6 general purpose registers, a frame pointer and a-   stack pointer.  \tr{%eax} and \tr{%edx} are return values from C functions,-   hence they get trashed across ccalls and are caller saves. \tr{%ebx},-   \tr{%esi}, \tr{%edi}, \tr{%ebp} are all callee-saves.--   Reg     STG-Reg-   ----------------   ebx     Base-   ebp     Sp-   esi     R1-   edi     Hp--   Leaving SpLim out of the picture.-   -------------------------------------------------------------------------- */--#if defined(MACHREGS_i386)--#define REG(x) __asm__("%" #x)--#if !defined(not_doing_dynamic_linking)-#define REG_Base    ebx-#endif-#define REG_Sp      ebp--#if !defined(STOLEN_X86_REGS)-#define STOLEN_X86_REGS 4-#endif--#if STOLEN_X86_REGS >= 3-# define REG_R1     esi-#endif--#if STOLEN_X86_REGS >= 4-# define REG_Hp     edi-#endif-#define REG_MachSp  esp--#define REG_XMM1    xmm0-#define REG_XMM2    xmm1-#define REG_XMM3    xmm2-#define REG_XMM4    xmm3--#define REG_YMM1    ymm0-#define REG_YMM2    ymm1-#define REG_YMM3    ymm2-#define REG_YMM4    ymm3--#define REG_ZMM1    zmm0-#define REG_ZMM2    zmm1-#define REG_ZMM3    zmm2-#define REG_ZMM4    zmm3--#define MAX_REAL_VANILLA_REG 1  /* always, since it defines the entry conv */-#define MAX_REAL_FLOAT_REG   0-#define MAX_REAL_DOUBLE_REG  0-#define MAX_REAL_LONG_REG    0-#define MAX_REAL_XMM_REG     4-#define MAX_REAL_YMM_REG     4-#define MAX_REAL_ZMM_REG     4--/* ------------------------------------------------------------------------------  The x86-64 register mapping--  %rax          caller-saves, don't steal this one-  %rbx          YES-  %rcx          arg reg, caller-saves-  %rdx          arg reg, caller-saves-  %rsi          arg reg, caller-saves-  %rdi          arg reg, caller-saves-  %rbp          YES (our *prime* register)-  %rsp          (unavailable - stack pointer)-  %r8           arg reg, caller-saves-  %r9           arg reg, caller-saves-  %r10          caller-saves-  %r11          caller-saves-  %r12          YES-  %r13          YES-  %r14          YES-  %r15          YES--  %xmm0-7       arg regs, caller-saves-  %xmm8-15      caller-saves--  Use the caller-saves regs for Rn, because we don't always have to-  save those (as opposed to Sp/Hp/SpLim etc. which always have to be-  saved).--  --------------------------------------------------------------------------- */--#elif defined(MACHREGS_x86_64)--#define REG(x) __asm__("%" #x)--#define REG_Base  r13-#define REG_Sp    rbp-#define REG_Hp    r12-#define REG_R1    rbx-#define REG_R2    r14-#define REG_R3    rsi-#define REG_R4    rdi-#define REG_R5    r8-#define REG_R6    r9-#define REG_SpLim r15-#define REG_MachSp  rsp--/*-Map both Fn and Dn to register xmmn so that we can pass a function any-combination of up to six Float# or Double# arguments without touching-the stack. See Note [Overlapping global registers] for implications.-*/--#define REG_F1    xmm1-#define REG_F2    xmm2-#define REG_F3    xmm3-#define REG_F4    xmm4-#define REG_F5    xmm5-#define REG_F6    xmm6--#define REG_D1    xmm1-#define REG_D2    xmm2-#define REG_D3    xmm3-#define REG_D4    xmm4-#define REG_D5    xmm5-#define REG_D6    xmm6--#define REG_XMM1    xmm1-#define REG_XMM2    xmm2-#define REG_XMM3    xmm3-#define REG_XMM4    xmm4-#define REG_XMM5    xmm5-#define REG_XMM6    xmm6--#define REG_YMM1    ymm1-#define REG_YMM2    ymm2-#define REG_YMM3    ymm3-#define REG_YMM4    ymm4-#define REG_YMM5    ymm5-#define REG_YMM6    ymm6--#define REG_ZMM1    zmm1-#define REG_ZMM2    zmm2-#define REG_ZMM3    zmm3-#define REG_ZMM4    zmm4-#define REG_ZMM5    zmm5-#define REG_ZMM6    zmm6--#if !defined(mingw32_HOST_OS)-#define CALLER_SAVES_R3-#define CALLER_SAVES_R4-#endif-#define CALLER_SAVES_R5-#define CALLER_SAVES_R6--#define CALLER_SAVES_F1-#define CALLER_SAVES_F2-#define CALLER_SAVES_F3-#define CALLER_SAVES_F4-#define CALLER_SAVES_F5-#if !defined(mingw32_HOST_OS)-#define CALLER_SAVES_F6-#endif--#define CALLER_SAVES_D1-#define CALLER_SAVES_D2-#define CALLER_SAVES_D3-#define CALLER_SAVES_D4-#define CALLER_SAVES_D5-#if !defined(mingw32_HOST_OS)-#define CALLER_SAVES_D6-#endif--#define CALLER_SAVES_XMM1-#define CALLER_SAVES_XMM2-#define CALLER_SAVES_XMM3-#define CALLER_SAVES_XMM4-#define CALLER_SAVES_XMM5-#if !defined(mingw32_HOST_OS)-#define CALLER_SAVES_XMM6-#endif--#define CALLER_SAVES_YMM1-#define CALLER_SAVES_YMM2-#define CALLER_SAVES_YMM3-#define CALLER_SAVES_YMM4-#define CALLER_SAVES_YMM5-#if !defined(mingw32_HOST_OS)-#define CALLER_SAVES_YMM6-#endif--#define CALLER_SAVES_ZMM1-#define CALLER_SAVES_ZMM2-#define CALLER_SAVES_ZMM3-#define CALLER_SAVES_ZMM4-#define CALLER_SAVES_ZMM5-#if !defined(mingw32_HOST_OS)-#define CALLER_SAVES_ZMM6-#endif--#define MAX_REAL_VANILLA_REG 6-#define MAX_REAL_FLOAT_REG   6-#define MAX_REAL_DOUBLE_REG  6-#define MAX_REAL_LONG_REG    0-#define MAX_REAL_XMM_REG     6-#define MAX_REAL_YMM_REG     6-#define MAX_REAL_ZMM_REG     6--/* ------------------------------------------------------------------------------   The PowerPC register mapping--   0            system glue?    (caller-save, volatile)-   1            SP              (callee-save, non-volatile)-   2            AIX, powerpc64-linux:-                    RTOC        (a strange special case)-                powerpc32-linux:-                                reserved for use by system--   3-10         args/return     (caller-save, volatile)-   11,12        system glue?    (caller-save, volatile)-   13           on 64-bit:      reserved for thread state pointer-                on 32-bit:      (callee-save, non-volatile)-   14-31                        (callee-save, non-volatile)--   f0                           (caller-save, volatile)-   f1-f13       args/return     (caller-save, volatile)-   f14-f31                      (callee-save, non-volatile)--   \tr{14}--\tr{31} are wonderful callee-save registers on all ppc OSes.-   \tr{0}--\tr{12} are caller-save registers.--   \tr{%f14}--\tr{%f31} are callee-save floating-point registers.--   We can do the Whole Business with callee-save registers only!-   -------------------------------------------------------------------------- */--#elif defined(MACHREGS_powerpc)--#define REG(x) __asm__(#x)--#define REG_R1          r14-#define REG_R2          r15-#define REG_R3          r16-#define REG_R4          r17-#define REG_R5          r18-#define REG_R6          r19-#define REG_R7          r20-#define REG_R8          r21-#define REG_R9          r22-#define REG_R10         r23--#define REG_F1          fr14-#define REG_F2          fr15-#define REG_F3          fr16-#define REG_F4          fr17-#define REG_F5          fr18-#define REG_F6          fr19--#define REG_D1          fr20-#define REG_D2          fr21-#define REG_D3          fr22-#define REG_D4          fr23-#define REG_D5          fr24-#define REG_D6          fr25--#define REG_Sp          r24-#define REG_SpLim       r25-#define REG_Hp          r26-#define REG_Base        r27--#define MAX_REAL_FLOAT_REG   6-#define MAX_REAL_DOUBLE_REG  6--/* ------------------------------------------------------------------------------   The Sun SPARC register mapping--   !! IMPORTANT: if you change this register mapping you must also update-                 compiler/GHC/CmmToAsm/SPARC/Regs.hs. That file handles the-                 mapping for the NCG. This one only affects via-c code.--   The SPARC register (window) story: Remember, within the Haskell-   Threaded World, we essentially ``shut down'' the register-window-   mechanism---the window doesn't move at all while in this World.  It-   *does* move, of course, if we call out to arbitrary~C...--   The %i, %l, and %o registers (8 each) are the input, local, and-   output registers visible in one register window.  The 8 %g (global)-   registers are visible all the time.--      zero: always zero-   scratch: volatile across C-fn calls. used by linker.-       app: usable by application-    system: reserved for system--     alloc: allocated to in the register allocator, intra-closure only--                GHC usage     v8 ABI        v9 ABI-   Global-     %g0        zero        zero          zero-     %g1        alloc       scratch       scrach-     %g2        alloc       app           app-     %g3        alloc       app           app-     %g4        alloc       app           scratch-     %g5                    system        scratch-     %g6                    system        system-     %g7                    system        system--   Output: can be zapped by callee-     %o0-o5     alloc       caller saves-     %o6                    C stack ptr-     %o7                    C ret addr--   Local: maintained by register windowing mechanism-     %l0        alloc-     %l1        R1-     %l2        R2-     %l3        R3-     %l4        R4-     %l5        R5-     %l6        alloc-     %l7        alloc--   Input-     %i0        Sp-     %i1        Base-     %i2        SpLim-     %i3        Hp-     %i4        alloc-     %i5        R6-     %i6                    C frame ptr-     %i7                    C ret addr--   The paired nature of the floating point registers causes complications for-   the native code generator.  For convenience, we pretend that the first 22-   fp regs %f0 .. %f21 are actually 11 double regs, and the remaining 10 are-   float (single) regs.  The NCG acts accordingly.  That means that the-   following FP assignment is rather fragile, and should only be changed-   with extreme care.  The current scheme is:--      %f0 /%f1    FP return from C-      %f2 /%f3    D1-      %f4 /%f5    D2-      %f6 /%f7    ncg double spill tmp #1-      %f8 /%f9    ncg double spill tmp #2-      %f10/%f11   allocatable-      %f12/%f13   allocatable-      %f14/%f15   allocatable-      %f16/%f17   allocatable-      %f18/%f19   allocatable-      %f20/%f21   allocatable--      %f22        F1-      %f23        F2-      %f24        F3-      %f25        F4-      %f26        ncg single spill tmp #1-      %f27        ncg single spill tmp #2-      %f28        allocatable-      %f29        allocatable-      %f30        allocatable-      %f31        allocatable--   -------------------------------------------------------------------------- */--#elif defined(MACHREGS_sparc)--#define REG(x) __asm__("%" #x)--#define CALLER_SAVES_USER--#define CALLER_SAVES_F1-#define CALLER_SAVES_F2-#define CALLER_SAVES_F3-#define CALLER_SAVES_F4-#define CALLER_SAVES_D1-#define CALLER_SAVES_D2--#define REG_R1          l1-#define REG_R2          l2-#define REG_R3          l3-#define REG_R4          l4-#define REG_R5          l5-#define REG_R6          i5--#define REG_F1          f22-#define REG_F2          f23-#define REG_F3          f24-#define REG_F4          f25--/* for each of the double arg regs,-   Dn_2 is the high half. */--#define REG_D1          f2-#define REG_D1_2        f3--#define REG_D2          f4-#define REG_D2_2        f5--#define REG_Sp          i0-#define REG_SpLim       i2--#define REG_Hp          i3--#define REG_Base        i1--#define NCG_FirstFloatReg f22--/* ------------------------------------------------------------------------------   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
libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs view
@@ -62,7 +62,7 @@    | NumDecimals    | DisambiguateRecordFields    | RecordWildCards-   | RecordPuns+   | NamedFieldPuns    | ViewPatterns    | GADTs    | GADTSyntax
libraries/ghc-boot/GHC/BaseDir.hs view
@@ -2,7 +2,6 @@  -- | Note [Base Dir] -- ~~~~~~~~~~~~~~~~~--- -- GHC's base directory or top directory containers miscellaneous settings and -- the package database.  The main compiler of course needs this directory to -- read those settings and read and write packages. ghc-pkg uses it to find the@@ -12,6 +11,7 @@ -- will expand `${top_dir}` inside strings so GHC doesn't need to know it's on -- installation location at build time. ghc-pkg also can expand those variables -- and so needs the top dir location to do that too.+ module GHC.BaseDir where  import Prelude -- See Note [Why do we import Prelude here?]@@ -23,7 +23,7 @@ #if defined(mingw32_HOST_OS) import System.Environment (getExecutablePath) -- POSIX-#elif defined(darwin_HOST_OS) || defined(linux_HOST_OS) || defined(freebsd_HOST_OS)+#elif defined(darwin_HOST_OS) || defined(linux_HOST_OS) || defined(freebsd_HOST_OS) || defined(openbsd_HOST_OS) || defined(netbsd_HOST_OS) import System.Environment (getExecutablePath) #endif @@ -52,7 +52,7 @@     -- that is running this function.     rootDir :: FilePath -> FilePath     rootDir = takeDirectory . takeDirectory . normalise-#elif defined(darwin_HOST_OS) || defined(linux_HOST_OS) || defined(freebsd_HOST_OS)+#elif defined(darwin_HOST_OS) || defined(linux_HOST_OS) || defined(freebsd_HOST_OS) || defined(openbsd_HOST_OS) || defined(netbsd_HOST_OS) -- on unix, this is a bit more confusing. -- The layout right now is something like --
libraries/ghc-boot/GHC/Data/ShortText.hs view
@@ -14,7 +14,7 @@ -- -- This can be removed when we exit the boot compiler window. Thus once we drop GHC-9.2 as boot compiler, -- we can drop this code as well.-#if GHC_STAGE < 1+#if !MIN_VERSION_GLASGOW_HASKELL(9,3,0,0) {-# OPTIONS_GHC -fignore-interface-pragmas #-} #endif -- |
libraries/ghc-boot/GHC/Platform/ArchOS.hs view
@@ -24,7 +24,7 @@       { archOS_arch :: Arch       , archOS_OS   :: OS       }-   deriving (Read, Show, Eq)+   deriving (Read, Show, Eq, Ord)  -- | Architectures --@@ -38,8 +38,6 @@    | ArchPPC    | ArchPPC_64 PPC_64ABI    | ArchS390X-   | ArchSPARC-   | ArchSPARC64    | ArchARM ArmISA [ArmISAExt] ArmABI    | ArchAArch64    | ArchAlpha@@ -47,14 +45,14 @@    | ArchMipsel    | ArchRISCV64    | ArchJavaScript-   deriving (Read, Show, Eq)+   deriving (Read, Show, Eq, Ord)  -- | ARM Instruction Set Architecture data ArmISA    = ARMv5    | ARMv6    | ARMv7-   deriving (Read, Show, Eq)+   deriving (Read, Show, Eq, Ord)  -- | ARM extensions data ArmISAExt@@ -63,20 +61,20 @@    | VFPv3D16    | NEON    | IWMMX2-   deriving (Read, Show, Eq)+   deriving (Read, Show, Eq, Ord)  -- | ARM ABI data ArmABI    = SOFT    | SOFTFP    | HARD-   deriving (Read, Show, Eq)+   deriving (Read, Show, Eq, Ord)  -- | PowerPC 64-bit ABI data PPC_64ABI    = ELF_V1 -- ^ PowerPC64    | ELF_V2 -- ^ PowerPC64 LE-   deriving (Read, Show, Eq)+   deriving (Read, Show, Eq, Ord)  -- | Operating systems. --@@ -97,7 +95,7 @@    | OSQNXNTO    | OSAIX    | OSHurd-   deriving (Read, Show, Eq)+   deriving (Read, Show, Eq, Ord)   -- Note [Platform Syntax]@@ -126,8 +124,6 @@   ArchPPC_64 ELF_V1 -> "powerpc64"   ArchPPC_64 ELF_V2 -> "powerpc64le"   ArchS390X         -> "s390x"-  ArchSPARC         -> "sparc"-  ArchSPARC64       -> "sparc64"   ArchARM ARMv5 _ _ -> "armv5"   ArchARM ARMv6 _ _ -> "armv6"   ArchARM ARMv7 _ _ -> "armv7"
libraries/ghc-boot/GHC/Unit/Database.hs view
@@ -88,8 +88,9 @@ import Control.Monad (when) import System.FilePath as FilePath #if !defined(mingw32_HOST_OS)+import Data.Bits ((.|.)) import System.Posix.Files-import GHC.IO.Exception (ioe_type, IOErrorType(NoSuchThing))+import System.Posix.Types (FileMode) #endif import System.IO import System.IO.Error@@ -99,7 +100,7 @@ import System.Directory  -- | @ghc-boot@'s UnitInfo, serialized to the database.-type DbUnitInfo      = GenericUnitInfo BS.ByteString BS.ByteString BS.ByteString BS.ByteString BS.ByteString DbModule+type DbUnitInfo      = GenericUnitInfo BS.ByteString BS.ByteString BS.ByteString BS.ByteString DbModule  -- | Information about an unit (a unit is an installed module library). --@@ -109,14 +110,16 @@ -- Some types are left as parameters to be instantiated differently in ghc-pkg -- and in ghc itself. ---data GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod = GenericUnitInfo+data GenericUnitInfo srcpkgid srcpkgname uid modulename mod = GenericUnitInfo    { unitId             :: uid       -- ^ Unique unit identifier that is used during compilation (e.g. to       -- generate symbols). -   , unitInstanceOf     :: compid+   , unitInstanceOf     :: uid       -- ^ Identifier of an indefinite unit (i.e. with module holes) that this       -- unit is an instance of.+      --+      -- For non instantiated units, unitInstanceOf=unitId     , unitInstantiations :: [(modulename, mod)]       -- ^ How this unit instantiates some of its module holes. Map hole module@@ -252,16 +255,15 @@ -- | Convert between GenericUnitInfo instances mapGenericUnitInfo    :: (uid1 -> uid2)-   -> (cid1 -> cid2)    -> (srcpkg1 -> srcpkg2)    -> (srcpkgname1 -> srcpkgname2)    -> (modname1 -> modname2)    -> (mod1 -> mod2)-   -> (GenericUnitInfo cid1 srcpkg1 srcpkgname1 uid1 modname1 mod1-       -> GenericUnitInfo cid2 srcpkg2 srcpkgname2 uid2 modname2 mod2)-mapGenericUnitInfo fuid fcid fsrcpkg fsrcpkgname fmodname fmod g@(GenericUnitInfo {..}) =+   -> (GenericUnitInfo srcpkg1 srcpkgname1 uid1 modname1 mod1+       -> GenericUnitInfo srcpkg2 srcpkgname2 uid2 modname2 mod2)+mapGenericUnitInfo fuid fsrcpkg fsrcpkgname fmodname fmod g@(GenericUnitInfo {..}) =    g { unitId              = fuid unitId-     , unitInstanceOf      = fcid unitInstanceOf+     , unitInstanceOf      = fuid unitInstanceOf      , unitInstantiations  = fmap (bimap fmodname fmod) unitInstantiations      , unitPackageId       = fsrcpkg unitPackageId      , unitPackageName     = fsrcpkgname unitPackageName@@ -412,8 +414,14 @@ -- | Write the whole of the package DB, both parts. -- writePackageDb :: Binary pkgs => FilePath -> [DbUnitInfo] -> pkgs -> IO ()-writePackageDb file ghcPkgs ghcPkgPart =+writePackageDb file ghcPkgs ghcPkgPart = do   writeFileAtomic file (runPut putDbForGhcPkg)+#if !defined(mingw32_HOST_OS)+  addFileMode file 0o444+  --  ^ In case the current umask is too restrictive force all read bits to+  --  allow access.+#endif+  return ()   where     putDbForGhcPkg = do         putHeader@@ -425,6 +433,13 @@         ghcPartLen = fromIntegral (BS.Lazy.length ghcPart)         ghcPart    = encode ghcPkgs +#if !defined(mingw32_HOST_OS)+addFileMode :: FilePath -> FileMode -> IO ()+addFileMode file m = do+  o <- fileMode <$> getFileStatus file+  setFileMode file (m .|. o)+#endif+ getHeader :: Get (Word32, Word32) getHeader = do     magic <- getByteString (BS.length headerMagic)@@ -507,26 +522,6 @@ -- Copied from Cabal's Distribution.Simple.Utils. writeFileAtomic :: FilePath -> BS.Lazy.ByteString -> IO () writeFileAtomic targetPath content = do-  -- Figure out how to update the file mode after we create the temporary file-  let no_update _path = return ()-#if !defined(mingw32_HOST_OS)-  let on_error ioe =-          -- If the file doesn't yet exist then just use the default owner and-          -- mode.-          case ioe_type ioe of-            NoSuchThing -> return no_update-            _ -> ioError ioe-  let handleIO :: (IOException -> IO a) -> IO a -> IO a-      handleIO = flip catch-  set_metadata <- handleIO on_error $ do-      status <- getFileStatus targetPath-      return $ \path -> do-        setFileMode path (fileMode status)-        setOwnerAndGroup path (fileOwner status) (fileGroup status)-#else-  let set_metadata = no_update-#endif-   let (targetDir, targetFile) = splitFileName targetPath   Exception.bracketOnError     (openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> "tmp")@@ -534,7 +529,6 @@     (\(tmpPath, handle) -> do         BS.Lazy.hPut handle content         hClose handle-        set_metadata tmpPath         renameFile tmpPath targetPath)  instance Binary DbUnitInfo where@@ -711,7 +705,7 @@ -- Also perform a similar substitution for the older GHC-specific -- "$topdir" variable. The "topdir" is the location of the ghc -- installation (obtained from the -B option).-mungeUnitInfoPaths :: FilePathST -> FilePathST -> GenericUnitInfo a b c d e f -> GenericUnitInfo a b c d e f+mungeUnitInfoPaths :: FilePathST -> FilePathST -> GenericUnitInfo a b c d e -> GenericUnitInfo a b c d e mungeUnitInfoPaths top_dir pkgroot pkg =    -- TODO: similar code is duplicated in utils/ghc-pkg/Main.hs     pkg
libraries/ghc-boot/GHC/Utils/Encoding.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-}+{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, MultiWayIf #-} {-# OPTIONS_GHC -O2 -fno-warn-name-shadowing #-} -- We always optimise this, otherwise performance of a non-optimised -- compiler is severely affected. This module used to live in the `ghc`
libraries/ghc-heap/GHC/Exts/Heap.hs view
@@ -1,13 +1,10 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE PolyKinds #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-}-+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeInType #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE UnliftedFFITypes #-} @@ -157,7 +154,7 @@             let infoTablePtr = Ptr infoTableAddr                 ptrList = [case indexArray# pointersArray i of                                 (# ptr #) -> Box ptr-                            | I# i <- [0..(I# (sizeofArray# pointersArray)) - 1]+                            | I# i <- [0..I# (sizeofArray# pointersArray) - 1]                             ]              infoTable <- peekItbl infoTablePtr@@ -204,7 +201,7 @@         rawHeapWords :: [Word]         rawHeapWords = [W# (indexWordArray# heapRep i) | I# i <- [0.. end] ]             where-            nelems = (I# (sizeofByteArray# heapRep)) `div` wORD_SIZE+            nelems = I# (sizeofByteArray# heapRep) `div` wORD_SIZE             end = fromIntegral nelems - 1          -- Just the payload of rawHeapWords (no header).@@ -236,7 +233,7 @@                 fail "Expected at least 1 ptr argument to AP"             -- We expect at least the arity, n_args, and fun fields             unless (length payloadWords >= 2) $-                fail $ "Expected at least 2 raw words to AP"+                fail "Expected at least 2 raw words to AP"             let splitWord = payloadWords !! 0             pure $ APClosure itbl #if defined(WORDS_BIGENDIAN)@@ -340,14 +337,17 @@          --  pure $ OtherClosure itbl pts rawHeapWords         ---        WEAK ->+        WEAK -> do             pure $ WeakClosure                 { info = itbl                 , cfinalizers = pts !! 0                 , key = pts !! 1                 , value = pts !! 2                 , finalizer = pts !! 3-                , link = pts !! 4+                , weakLink = case drop 4 pts of+                           []  -> Nothing+                           [p] -> Just p+                           _   -> error $ "Expected 4 or 5 words in WEAK, found " ++ show (length pts)                 }         TSO | [ u_lnk, u_gbl_lnk, tso_stack, u_trec, u_blk_ex, u_bq] <- pts                 -> withArray rawHeapWords (\ptr -> do
libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs view
@@ -12,7 +12,7 @@ {- --------------------------------------------- -- Enum representing closure types -- This is a mirror of:--- includes/rts/storage/ClosureTypes.h+-- rts/include/rts/storage/ClosureTypes.h -- ---------------------------------------------}  data ClosureType
libraries/ghc-heap/GHC/Exts/Heap/Closures.hs view
@@ -41,6 +41,7 @@ import GHC.Exts.Heap.ProfInfo.Types  import Data.Bits+import Data.Foldable (toList) import Data.Int import Data.Word import GHC.Exts@@ -98,7 +99,7 @@ type Closure = GenClosure Box  -- | This is the representation of a Haskell value on the heap. It reflects--- <https://gitlab.haskell.org/ghc/ghc/blob/master/includes/rts/storage/Closures.h>+-- <https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/storage/Closures.h> -- -- The data type is parametrized by `b`: the type to store references in. -- Usually this is a 'Box' with the type synonym 'Closure'.@@ -228,8 +229,8 @@         , mccPayload :: ![b]            -- ^ Array payload         } -    -- | An @MVar#@, with a queue of thread state objects blocking on them-    | MVarClosure+  -- | An @MVar#@, with a queue of thread state objects blocking on them+  | MVarClosure     { info       :: !StgInfoTable     , queueHead  :: !b              -- ^ Pointer to head of queue     , queueTail  :: !b              -- ^ Pointer to tail of queue@@ -265,7 +266,7 @@         , key         :: !b         , value       :: !b         , finalizer   :: !b-        , link        :: !b -- ^ next weak pointer for the capability, can be NULL.+        , weakLink    :: !(Maybe b) -- ^ next weak pointer for the capability         }    -- | Representation of StgTSO: A Thread State Object. The values for@@ -386,9 +387,6 @@   | BlockedOnCCall   | BlockedOnCCall_Interruptible   | BlockedOnMsgThrowTo-#if __GLASGOW_HASKELL__ >= 811 && __GLASGOW_HASKELL__ < 902-  | BlockedOnIOCompletion-#endif   | ThreadMigrating   | WhyBlockedUnknownValue Word16 -- ^ Please report this as a bug   deriving (Eq, Show, Generic, Ord)@@ -423,7 +421,7 @@ allClosures (IOPortClosure {..}) = [queueHead,queueTail,value] allClosures (FunClosure {..}) = ptrArgs allClosures (BlockingQueueClosure {..}) = [link, blackHole, owner, queue]-allClosures (WeakClosure {..}) = [cfinalizers, key, value, finalizer, link]+allClosures (WeakClosure {..}) = [cfinalizers, key, value, finalizer] ++ Data.Foldable.toList weakLink allClosures (OtherClosure {..}) = hvalues allClosures _ = []
libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc view
@@ -77,9 +77,6 @@                         (#const BlockedOnCCall_Interruptible) -> BlockedOnCCall_Interruptible                         (#const BlockedOnMsgThrowTo) -> BlockedOnMsgThrowTo                         (#const ThreadMigrating) -> ThreadMigrating-#if __GLASGOW_HASKELL__ >= 811 && __GLASGOW_HASKELL__ < 902-                        (#const BlockedOnIOCompletion) -> BlockedOnIOCompletion-#endif                         _ -> WhyBlockedUnknownValue w  parseTsoFlags :: Word32 -> [TsoFlags]
libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc view
@@ -77,9 +77,6 @@                         (#const BlockedOnCCall_Interruptible) -> BlockedOnCCall_Interruptible                         (#const BlockedOnMsgThrowTo) -> BlockedOnMsgThrowTo                         (#const ThreadMigrating) -> ThreadMigrating-#if __GLASGOW_HASKELL__ >= 811 && __GLASGOW_HASKELL__ < 902-                        (#const BlockedOnIOCompletion) -> BlockedOnIOCompletion-#endif                         _ -> WhyBlockedUnknownValue w  parseTsoFlags :: Word32 -> [TsoFlags]
libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc view
@@ -28,7 +28,7 @@ type EntryFunPtr = FunPtr (Ptr () -> IO (Ptr ()))  -- | This is a somewhat faithful representation of an info table. See--- <https://gitlab.haskell.org/ghc/ghc/blob/master/includes/rts/storage/InfoTables.h>+-- <https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/storage/InfoTables.h> -- for more details on this data structure. data StgInfoTable = StgInfoTable {    entry  :: Maybe EntryFunPtr, -- Just <=> not TABLES_NEXT_TO_CODE
libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/Types.hs view
@@ -7,14 +7,14 @@ import GHC.Generics  -- | This is a somewhat faithful representation of StgTSOProfInfo. See--- <https://gitlab.haskell.org/ghc/ghc/blob/master/includes/rts/storage/TSO.h>+-- <https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/storage/TSO.h> -- for more details on this data structure.-data StgTSOProfInfo = StgTSOProfInfo {+newtype StgTSOProfInfo = StgTSOProfInfo {     cccs :: Maybe CostCentreStack } deriving (Show, Generic, Eq, Ord)  -- | This is a somewhat faithful representation of CostCentreStack. See--- <https://gitlab.haskell.org/ghc/ghc/blob/master/includes/rts/prof/CCS.h>+-- <https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/prof/CCS.h> -- for more details on this data structure. data CostCentreStack = CostCentreStack {     ccs_ccsID :: Int,@@ -32,7 +32,7 @@ } deriving (Show, Generic, Eq, Ord)  -- | This is a somewhat faithful representation of CostCentre. See--- <https://gitlab.haskell.org/ghc/ghc/blob/master/includes/rts/prof/CCS.h>+-- <https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/prof/CCS.h> -- for more details on this data structure. data CostCentre = CostCentre {     cc_ccID :: Int,@@ -46,7 +46,7 @@ } deriving (Show, Generic, Eq, Ord)  -- | This is a somewhat faithful representation of IndexTable. See--- <https://gitlab.haskell.org/ghc/ghc/blob/master/includes/rts/prof/CCS.h>+-- <https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/prof/CCS.h> -- for more details on this data structure. data IndexTable = IndexTable {     it_cc :: CostCentre,
+ libraries/ghci/GHCi/BinaryArray.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, FlexibleContexts #-}+-- | Efficient serialisation for GHCi Instruction arrays+--+-- Author: Ben Gamari+--+module GHCi.BinaryArray(putArray, getArray) where++import Prelude+import Foreign.Ptr+import Data.Binary+import Data.Binary.Put (putBuilder)+import qualified Data.Binary.Get.Internal as Binary+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Builder.Internal as BB+import qualified Data.Array.Base as A+import qualified Data.Array.IO.Internals as A+import qualified Data.Array.Unboxed as A+import GHC.Exts+import GHC.IO++-- | An efficient serialiser of 'A.UArray'.+putArray :: Binary i => A.UArray i a -> Put+putArray (A.UArray l u _ arr#) = do+    put l+    put u+    putBuilder $ byteArrayBuilder arr#++byteArrayBuilder :: ByteArray# -> BB.Builder+byteArrayBuilder arr# = BB.builder $ go 0 (I# (sizeofByteArray# arr#))+  where+    go :: Int -> Int -> BB.BuildStep a -> BB.BuildStep a+    go !inStart !inEnd k (BB.BufferRange outStart outEnd)+      -- There is enough room in this output buffer to write all remaining array+      -- contents+      | inRemaining <= outRemaining = do+          copyByteArrayToAddr arr# inStart outStart inRemaining+          k (BB.BufferRange (outStart `plusPtr` inRemaining) outEnd)+      -- There is only enough space for a fraction of the remaining contents+      | otherwise = do+          copyByteArrayToAddr arr# inStart outStart outRemaining+          let !inStart' = inStart + outRemaining+          return $! BB.bufferFull 1 outEnd (go inStart' inEnd k)+      where+        inRemaining  = inEnd - inStart+        outRemaining = outEnd `minusPtr` outStart++    copyByteArrayToAddr :: ByteArray# -> Int -> Ptr a -> Int -> IO ()+    copyByteArrayToAddr src# (I# src_off#) (Ptr dst#) (I# len#) =+        IO $ \s -> case copyByteArrayToAddr# src# src_off# dst# len# s of+                     s' -> (# s', () #)++-- | An efficient deserialiser of 'A.UArray'.+getArray :: (Binary i, A.Ix i, A.MArray A.IOUArray a IO) => Get (A.UArray i a)+getArray = do+    l <- get+    u <- get+    arr@(A.IOUArray (A.STUArray _ _ _ arr#)) <-+        return $ unsafeDupablePerformIO $ A.newArray_ (l,u)+    let go 0 _ = return ()+        go !remaining !off = do+            Binary.readNWith n $ \ptr ->+              copyAddrToByteArray ptr arr# off n+            go (remaining - n) (off + n)+          where n = min chunkSize remaining+    go (I# (sizeofMutableByteArray# arr#)) 0+    return $! unsafeDupablePerformIO $ unsafeFreezeIOUArray arr+  where+    chunkSize = 10*1024++    copyAddrToByteArray :: Ptr a -> MutableByteArray# RealWorld+                        -> Int -> Int -> IO ()+    copyAddrToByteArray (Ptr src#) dst# (I# dst_off#) (I# len#) =+        IO $ \s -> case copyAddrToByteArray# src# dst# dst_off# len# s of+                     s' -> (# s', () #)++-- this is inexplicably not exported in currently released array versions+unsafeFreezeIOUArray :: A.IOUArray ix e -> IO (A.UArray ix e)+unsafeFreezeIOUArray (A.IOUArray marr) = stToIO (A.unsafeFreezeSTUArray marr)
libraries/ghci/GHCi/Message.hs view
@@ -259,6 +259,7 @@   ReifyModule :: TH.Module -> THMessage (THResult TH.ModuleInfo)   ReifyConStrictness :: TH.Name -> THMessage (THResult [TH.DecidedStrictness]) +  GetPackageRoot :: THMessage (THResult FilePath)   AddDependentFile :: FilePath -> THMessage (THResult ())   AddTempFile :: String -> THMessage (THResult FilePath)   AddModFinalizer :: RemoteRef (TH.Q ()) -> THMessage (THResult ())@@ -311,6 +312,7 @@     22 -> THMsg <$> ReifyType <$> get     23 -> THMsg <$> (PutDoc <$> get <*> get)     24 -> THMsg <$> GetDoc <$> get+    25 -> THMsg <$> return GetPackageRoot     n -> error ("getTHMessage: unknown message " ++ show n)  putTHMessage :: THMessage a -> Put@@ -340,6 +342,7 @@   ReifyType a                 -> putWord8 22 >> put a   PutDoc l s                  -> putWord8 23 >> put l >> put s   GetDoc l                    -> putWord8 24 >> put l+  GetPackageRoot              -> putWord8 25   data EvalOpts = EvalOpts@@ -461,8 +464,8 @@ #ifndef MIN_VERSION_ghc_heap #define MIN_VERSION_ghc_heap(major1,major2,minor) (\   (major1) <  9 || \-  (major1) == 9 && (major2) <  2 || \-  (major1) == 9 && (major2) == 2 && (minor) <= 8)+  (major1) == 9 && (major2) <  4 || \+  (major1) == 9 && (major2) == 4 && (minor) <= 1) #endif /* MIN_VERSION_ghc_heap */ #if MIN_VERSION_ghc_heap(8,11,0) instance Binary Heap.StgTSOProfInfo
+ libraries/ghci/GHCi/ResolvedBCO.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE RecordWildCards, DeriveGeneric, GeneralizedNewtypeDeriving,+    BangPatterns, CPP #-}+module GHCi.ResolvedBCO+  ( ResolvedBCO(..)+  , ResolvedBCOPtr(..)+  , isLittleEndian+  ) where++import Prelude -- See note [Why do we import Prelude here?]+import GHC.Data.SizedSeq+import GHCi.RemoteTypes+import GHCi.BreakArray++import Data.Array.Unboxed+import Data.Binary+import GHC.Generics+import GHCi.BinaryArray+++#include "MachDeps.h"++isLittleEndian :: Bool+#if defined(WORDS_BIGENDIAN)+isLittleEndian = False+#else+isLittleEndian = True+#endif++-- -----------------------------------------------------------------------------+-- ResolvedBCO++-- | A 'ResolvedBCO' is one in which all the 'Name' references have been+-- resolved to actual addresses or 'RemoteHValues'.+--+-- Note, all arrays are zero-indexed (we assume this when+-- serializing/deserializing)+data ResolvedBCO+   = ResolvedBCO {+        resolvedBCOIsLE   :: Bool,+        resolvedBCOArity  :: {-# UNPACK #-} !Int,+        resolvedBCOInstrs :: UArray Int Word16,         -- insns+        resolvedBCOBitmap :: UArray Int Word64,         -- bitmap+        resolvedBCOLits   :: UArray Int Word64,         -- non-ptrs+        resolvedBCOPtrs   :: (SizedSeq ResolvedBCOPtr)  -- ptrs+   }+   deriving (Generic, Show)++-- | The Binary instance for ResolvedBCOs.+--+-- Note, that we do encode the endianness, however there is no support for mixed+-- endianness setups.  This is primarily to ensure that ghc and iserv share the+-- same endianness.+instance Binary ResolvedBCO where+  put ResolvedBCO{..} = do+    put resolvedBCOIsLE+    put resolvedBCOArity+    putArray resolvedBCOInstrs+    putArray resolvedBCOBitmap+    putArray resolvedBCOLits+    put resolvedBCOPtrs+  get = ResolvedBCO+        <$> get <*> get <*> getArray <*> getArray <*> getArray <*> get++data ResolvedBCOPtr+  = ResolvedBCORef {-# UNPACK #-} !Int+      -- ^ reference to the Nth BCO in the current set+  | ResolvedBCOPtr {-# UNPACK #-} !(RemoteRef HValue)+      -- ^ reference to a previously created BCO+  | ResolvedBCOStaticPtr {-# UNPACK #-} !(RemotePtr ())+      -- ^ reference to a static ptr+  | ResolvedBCOPtrBCO ResolvedBCO+      -- ^ a nested BCO+  | ResolvedBCOPtrBreakArray {-# UNPACK #-} !(RemoteRef BreakArray)+      -- ^ Resolves to the MutableArray# inside the BreakArray+  deriving (Generic, Show)++instance Binary ResolvedBCOPtr
libraries/template-haskell/Language/Haskell/TH.hs view
@@ -22,6 +22,7 @@         -- *** Reify         reify,            -- :: Name -> Q Info         reifyModule,+        newDeclarationGroup,         Info(..), ModuleInfo(..),         InstanceDec,         ParentName,
libraries/template-haskell/Language/Haskell/TH/Lib.hs view
@@ -42,9 +42,9 @@     -- *** Expressions         dyn, varE, unboundVarE, labelE, implicitParamVarE, conE, litE, staticE,         appE, appTypeE, uInfixE, parensE, infixE, infixApp, sectionL, sectionR,-        lamE, lam1E, lamCaseE, tupE, unboxedTupE, unboxedSumE, condE, multiIfE,-        letE, caseE, appsE, listE, sigE, recConE, recUpdE, stringE, fieldExp,-        getFieldE, projectionE,+        lamE, lam1E, lamCaseE, lamCasesE, tupE, unboxedTupE, unboxedSumE, condE,+        multiIfE, letE, caseE, appsE, listE, sigE, recConE, recUpdE, stringE,+        fieldExp, getFieldE, projectionE,     -- **** Ranges     fromE, fromThenE, fromToE, fromThenToE, @@ -56,9 +56,9 @@     bindS, letS, noBindS, parS, recS,      -- *** Types-        forallT, forallVisT, varT, conT, appT, appKindT, arrowT, infixT,-        mulArrowT,-        uInfixT, parensT, equalityT, listT, tupleT, unboxedTupleT, unboxedSumT,+        forallT, forallVisT, varT, conT, appT, appKindT, arrowT, mulArrowT,+        infixT, uInfixT, promotedInfixT, promotedUInfixT,+        parensT, equalityT, listT, tupleT, unboxedTupleT, unboxedSumT,         sigT, litT, wildCardT, promotedT, promotedTupleT, promotedNilT,         promotedConsT, implicitParamT,     -- **** Type literals@@ -103,6 +103,9 @@      -- **** Fixity     infixLD, infixRD, infixND,++    -- **** Default declaration+    defaultD,      -- **** Foreign Function Interface (FFI)     cCall, stdCall, cApi, prim, javaScript,
libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs view
@@ -31,7 +31,7 @@ -- * Type synonyms ---------------------------------------------------------- --- | Levity-polymorphic since /template-haskell-2.17.0.0/.+-- | Representation-polymorphic since /template-haskell-2.17.0.0/. type TExpQ :: TYPE r -> Kind.Type type TExpQ a = Q (TExp a) @@ -300,9 +300,14 @@ lam1E :: Quote m => m Pat -> m Exp -> m Exp lam1E p e = lamE [p] e +-- | Lambda-case (@\case@) lamCaseE :: Quote m => [m Match] -> m Exp lamCaseE ms = LamCaseE <$> sequenceA ms +-- | Lambda-cases (@\cases@)+lamCasesE :: Quote m => [m Clause] -> m Exp+lamCasesE ms = LamCasesE <$> sequenceA ms+ tupE :: Quote m => [Maybe (m Exp)] -> m Exp tupE es = do { es1 <- traverse sequenceA es; pure (TupE es1)} @@ -477,10 +482,16 @@ infixND :: Quote m => Int -> Name -> m Dec infixND prec nm = pure (InfixD (Fixity prec InfixN) nm) +defaultD :: Quote m => [m Type] -> m Dec+defaultD tys = DefaultD <$> sequenceA tys+ pragInlD :: Quote m => Name -> Inline -> RuleMatch -> Phases -> m Dec pragInlD name inline rm phases   = pure $ PragmaD $ InlineP name inline rm phases +pragOpaqueD :: Quote m => Name -> m Dec+pragOpaqueD name = pure $ PragmaD $ OpaqueP name+ pragSpecD :: Quote m => Name -> m Type -> Phases -> m Dec pragSpecD n ty phases   = do@@ -695,6 +706,16 @@                      t2' <- t2                      pure (UInfixT t1' n t2') +promotedInfixT :: Quote m => m Type -> Name -> m Type -> m Type+promotedInfixT t1 n t2 = do t1' <- t1+                            t2' <- t2+                            pure (PromotedInfixT t1' n t2')++promotedUInfixT :: Quote m => m Type -> Name -> m Type -> m Type+promotedUInfixT t1 n t2 = do t1' <- t1+                             t2' <- t2+                             pure (PromotedUInfixT t1' n t2')+ parensT :: Quote m => m Type -> m Type parensT t = do t' <- t                pure (ParensT t')@@ -1039,6 +1060,7 @@     doc_loc (StandaloneDerivD _ _ _) = Nothing     doc_loc (DefaultSigD _ _)        = Nothing     doc_loc (ImplicitParamBindD _ _) = Nothing+    doc_loc (DefaultD _)             = Nothing  -- | Variant of 'withDecDoc' that applies the same documentation to -- multiple declarations. Useful for documenting quoted declarations.
libraries/template-haskell/Language/Haskell/TH/Ppr.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE Safe #-}+{-# LANGUAGE LambdaCase #-} -- | contains a prettyprinter for the -- Template Haskell datatypes @@ -94,10 +95,10 @@ pprPatSynType ty@(ForallT uniTys reqs ty'@(ForallT exTys provs ty''))   | null exTys,  null provs = ppr (ForallT uniTys reqs ty'')   | null uniTys, null reqs  = noreqs <+> ppr ty'-  | null reqs               = forall uniTys <+> noreqs <+> ppr ty'+  | null reqs               = pprForallBndrs uniTys <+> noreqs <+> ppr ty'   | otherwise               = ppr ty-  where noreqs     = text "() =>"-        forall tvs = text "forall" <+> (hsep (map ppr tvs)) <+> text "."+  where noreqs = text "() =>"+        pprForallBndrs tvs = text "forall" <+> hsep (map ppr tvs) <+> text "." pprPatSynType ty            = ppr ty  ------------------------------@@ -153,8 +154,11 @@ pprExp i (LamE [] e) = pprExp i e -- #13856 pprExp i (LamE ps e) = parensIf (i > noPrec) $ char '\\' <> hsep (map (pprPat appPrec) ps)                                            <+> text "->" <+> ppr e-pprExp i (LamCaseE ms) = parensIf (i > noPrec)-                       $ text "\\case" $$ nest nestDepth (ppr ms)+pprExp i (LamCaseE ms)+  = parensIf (i > noPrec) $ text "\\case" $$ braces (semiSep ms)+pprExp i (LamCasesE ms)+  = parensIf (i > noPrec) $ text "\\cases" $$ braces (semi_sep ms)+  where semi_sep = sep . punctuate semi . map (pprClause False) pprExp i (TupE es)   | [Just e] <- es   = pprExp i (ConE (tupleDataName 1) `AppE` e)@@ -182,7 +186,7 @@  pprExp i (CaseE e ms)  = parensIf (i > noPrec) $ text "case" <+> ppr e <+> text "of"-                        $$ nest nestDepth (ppr ms)+                        $$ braces (semiSep ms) pprExp i (DoE m ss_) = parensIf (i > noPrec) $     pprQualifier m <> text "do" <+> pprStms ss_   where@@ -269,6 +273,12 @@               | otherwise = arrow  ------------------------------+pprClause :: Bool -> Clause -> Doc+pprClause eqDoc (Clause ps rhs ds)+  = hsep (map (pprPat appPrec) ps) <+> pprBody eqDoc rhs+    $$ where_clause ds++------------------------------ instance Ppr Lit where   ppr = pprLit noPrec @@ -286,9 +296,42 @@ pprLit _ (StringL s)     = pprString s pprLit _ (StringPrimL s) = pprString (bytesToString s) <> char '#' pprLit _ (BytesPrimL {}) = pprString "<binary data>"-pprLit i (RationalL rat) = parensIf (i > noPrec) $-                           integer (numerator rat) <+> char '/'-                              <+> integer (denominator rat)+pprLit i (RationalL rat)+  | withoutFactor 2 (withoutFactor 5 $ denominator rat) /= 1+  -- if the denominator has prime factors other than 2 and 5, show as fraction+  = parensIf (i > noPrec) $+    integer (numerator rat) <+> char '/' <+> integer (denominator rat)+  | rat /= 0 && (zeroes < -1 || zeroes > 7),+    let (n, d) = properFraction (rat' / magnitude)+        (rat', zeroes')+          | abs rat < 1 = (10 * rat, zeroes - 1)+          | otherwise = (rat, zeroes)+  -- if < 0.01 or >= 100_000_000, use scientific notation+  = parensIf (i > noPrec && rat < 0)+             (integer n+              <> (if d == 0 then empty else char '.' <> decimals (abs d))+              <> char 'e' <> integer zeroes')+  | let (n, d) = properFraction rat+  = parensIf (i > noPrec && rat < 0)+             (integer n <> char '.'+              <> if d == 0 then char '0' else decimals (abs d))+  where zeroes :: Integer+        zeroes = truncate (logBase 10 (abs (fromRational rat) :: Double)+                           * (1 - epsilon))+        epsilon = 0.0000001+        magnitude :: Rational+        magnitude = 10 ^^ zeroes+        withoutFactor :: Integer -> Integer -> Integer+        withoutFactor _ 0 = 0+        withoutFactor p n+          | (n', 0) <- divMod n p = withoutFactor p n'+          | otherwise = n+        -- | Expects the argument 0 <= x < 1+        decimals :: Rational -> Doc+        decimals x+          | x == 0 = empty+          | otherwise = integer n <> decimals d+          where (n, d) = properFraction (x * 10)  bytesToString :: [Word8] -> String bytesToString = map (chr . fromIntegral)@@ -364,6 +407,8 @@ ppr_dec _ (KiSigD f k)  = text "type" <+> pprPrefixOcc f <+> dcolon <+> ppr k ppr_dec _ (ForeignD f)  = ppr f ppr_dec _ (InfixD fx n) = pprFixity n fx+ppr_dec _ (DefaultD tys) =+        text "default" <+> parens (sep $ punctuate comma $ map ppr tys) ppr_dec _ (PragmaD p)   = ppr p ppr_dec isTop (DataFamilyD tc tvs kind)   = text "data" <+> maybeFamily <+> ppr tc <+> hsep (map ppr tvs) <+> maybeKind@@ -442,14 +487,21 @@  ppr_data :: Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause]          -> Doc-ppr_data maybeInst ctxt t argsDoc ksig cs decs-  = sep [text "data" <+> maybeInst+ppr_data = ppr_typedef "data"++ppr_newtype :: Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> Con -> [DerivClause]+            -> Doc+ppr_newtype maybeInst ctxt t argsDoc ksig c decs = ppr_typedef "newtype" maybeInst ctxt t argsDoc ksig [c] decs++ppr_typedef :: String -> Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause] -> Doc+ppr_typedef data_or_newtype maybeInst ctxt t argsDoc ksig cs decs+  = sep [text data_or_newtype <+> maybeInst             <+> pprCxt ctxt             <+> case t of                  Just n -> pprName' Applied n <+> argsDoc                  Nothing -> argsDoc             <+> ksigDoc <+> maybeWhere,-         nest nestDepth (sep (pref $ map ppr cs)),+         nest nestDepth (vcat (pref $ map ppr cs)),          if null decs            then empty            else nest nestDepth@@ -475,24 +527,6 @@                 Nothing -> empty                 Just k  -> dcolon <+> ppr k -ppr_newtype :: Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> Con -> [DerivClause]-            -> Doc-ppr_newtype maybeInst ctxt t argsDoc ksig c decs-  = sep [text "newtype" <+> maybeInst-            <+> pprCxt ctxt-            <+> case t of-                 Just n -> ppr n <+> argsDoc-                 Nothing -> argsDoc-            <+> ksigDoc,-         nest 2 (char '=' <+> ppr c),-         if null decs-           then empty-           else nest nestDepth-                $ vcat $ map ppr_deriv_clause decs]-  where-    ksigDoc = case ksig of-                Nothing -> empty-                Just k  -> dcolon <+> ppr k  ppr_deriv_clause :: DerivClause -> Doc ppr_deriv_clause (DerivClause ds ctxt)@@ -568,6 +602,8 @@      <+> ppr phases      <+> pprName' Applied n      <+> text "#-}"+    ppr (OpaqueP n)+       = text "{-# OPAQUE" <+> pprName' Applied n <+> text "#-}"     ppr (SpecialiseP n ty inline phases)        =   text "{-# SPECIALISE"        <+> maybe empty ppr inline@@ -625,8 +661,7 @@  ------------------------------ instance Ppr Clause where-    ppr (Clause ps rhs ds) = hsep (map (pprPat appPrec) ps) <+> pprBody True rhs-                             $$ where_clause ds+    ppr = pprClause True  ------------------------------ instance Ppr Con where@@ -758,44 +793,52 @@  ------------------------------ pprParendType :: Type -> Doc-pprParendType (VarT v)            = pprName' Applied v+pprParendType (VarT v)               = pprName' Applied v -- `Applied` is used here instead of `ppr` because of infix names (#13887)-pprParendType (ConT c)            = pprName' Applied c-pprParendType (TupleT 0)          = text "()"-pprParendType (TupleT 1)          = pprParendType (ConT (tupleTypeName 1))-pprParendType (TupleT n)          = parens (hcat (replicate (n-1) comma))-pprParendType (UnboxedTupleT n)   = hashParens $ hcat $ replicate (n-1) comma-pprParendType (UnboxedSumT arity) = hashParens $ hcat $ replicate (arity-1) bar-pprParendType ArrowT              = parens (text "->")-pprParendType MulArrowT           = text "FUN"-pprParendType ListT               = text "[]"-pprParendType (LitT l)            = pprTyLit l-pprParendType (PromotedT c)       = text "'" <> pprName' Applied c-pprParendType (PromotedTupleT 0)  = text "'()"-pprParendType (PromotedTupleT 1)  = pprParendType (PromotedT (tupleDataName 1))-pprParendType (PromotedTupleT n)  = quoteParens (hcat (replicate (n-1) comma))-pprParendType PromotedNilT        = text "'[]"-pprParendType PromotedConsT       = text "'(:)"-pprParendType StarT               = char '*'-pprParendType ConstraintT         = text "Constraint"-pprParendType (SigT ty k)         = parens (ppr ty <+> text "::" <+> ppr k)-pprParendType WildCardT           = char '_'-pprParendType (InfixT x n y)      = parens (ppr x <+> pprName' Infix n <+> ppr y)-pprParendType t@(UInfixT {})      = parens (pprUInfixT t)-pprParendType (ParensT t)         = ppr t+pprParendType (ConT c)               = pprName' Applied c+pprParendType (TupleT 0)             = text "()"+pprParendType (TupleT 1)             = pprParendType (ConT (tupleTypeName 1))+pprParendType (TupleT n)             = parens (hcat (replicate (n-1) comma))+pprParendType (UnboxedTupleT n)      = hashParens $ hcat $ replicate (n-1) comma+pprParendType (UnboxedSumT arity)    = hashParens $ hcat $ replicate (arity-1) bar+pprParendType ArrowT                 = parens (text "->")+pprParendType MulArrowT              = text "FUN"+pprParendType ListT                  = text "[]"+pprParendType (LitT l)               = pprTyLit l+pprParendType (PromotedT c)          = text "'" <> pprName' Applied c+pprParendType (PromotedTupleT 0)     = text "'()"+pprParendType (PromotedTupleT 1)     = pprParendType (PromotedT (tupleDataName 1))+pprParendType (PromotedTupleT n)     = quoteParens (hcat (replicate (n-1) comma))+pprParendType PromotedNilT           = text "'[]"+pprParendType PromotedConsT          = text "'(:)"+pprParendType StarT                  = char '*'+pprParendType ConstraintT            = text "Constraint"+pprParendType (SigT ty k)            = parens (ppr ty <+> text "::" <+> ppr k)+pprParendType WildCardT              = char '_'+pprParendType t@(InfixT {})          = parens (pprInfixT t)+pprParendType t@(UInfixT {})         = parens (pprInfixT t)+pprParendType t@(PromotedInfixT {})  = parens (pprInfixT t)+pprParendType t@(PromotedUInfixT {}) = parens (pprInfixT t)+pprParendType (ParensT t)            = ppr t pprParendType tuple | (TupleT n, args) <- split tuple                     , length args == n                     = parens (commaSep args)-pprParendType (ImplicitParamT n t)= text ('?':n) <+> text "::" <+> ppr t-pprParendType EqualityT           = text "(~)"-pprParendType t@(ForallT {})      = parens (ppr t)-pprParendType t@(ForallVisT {})   = parens (ppr t)-pprParendType t@(AppT {})         = parens (ppr t)-pprParendType t@(AppKindT {})     = parens (ppr t)+pprParendType (ImplicitParamT n t)   = text ('?':n) <+> text "::" <+> ppr t+pprParendType EqualityT              = text "(~)"+pprParendType t@(ForallT {})         = parens (ppr t)+pprParendType t@(ForallVisT {})      = parens (ppr t)+pprParendType t@(AppT {})            = parens (ppr t)+pprParendType t@(AppKindT {})        = parens (ppr t) -pprUInfixT :: Type -> Doc-pprUInfixT (UInfixT x n y) = pprUInfixT x <+> pprName' Infix n <+> pprUInfixT y-pprUInfixT t               = ppr t+pprInfixT :: Type -> Doc+pprInfixT = \case+  (InfixT x n y)          -> with x n y ""  ppr+  (UInfixT x n y)         -> with x n y ""  pprInfixT+  (PromotedInfixT x n y)  -> with x n y "'" ppr+  (PromotedUInfixT x n y) -> with x n y "'" pprInfixT+  t                       -> ppr t+  where+    with x n y prefix ppr' = ppr' x <+> text prefix <> pprName' Infix n <+> ppr' y  instance Ppr Type where     ppr (ForallT tvars ctxt ty) = sep [pprForall tvars ctxt, ppr ty]@@ -916,18 +959,18 @@ instance Ppr Range where     ppr = brackets . pprRange         where pprRange :: Range -> Doc-              pprRange (FromR e) = ppr e <> text ".."+              pprRange (FromR e) = ppr e <+> text ".."               pprRange (FromThenR e1 e2) = ppr e1 <> text ","-                                        <> ppr e2 <> text ".."-              pprRange (FromToR e1 e2) = ppr e1 <> text ".." <> ppr e2+                                           <+> ppr e2 <+> text ".."+              pprRange (FromToR e1 e2) = ppr e1 <+> text ".." <+> ppr e2               pprRange (FromThenToR e1 e2 e3) = ppr e1 <> text ","-                                             <> ppr e2 <> text ".."-                                             <> ppr e3+                                             <+> ppr e2 <+> text ".."+                                             <+> ppr e3  ------------------------------ where_clause :: [Dec] -> Doc where_clause [] = empty-where_clause ds = nest nestDepth $ text "where" <+> vcat (map (ppr_dec False) ds)+where_clause ds = nest nestDepth $ text "where" <+> braces (semiSepWith (ppr_dec False) ds)  showtextl :: Show a => a -> Doc showtextl = text . map toLower . show@@ -949,6 +992,11 @@            , text "-"            , parens $ int end_ln <> comma <> int end_col ] +-- Takes a separator and a pretty-printing function and prints a list of things+-- separated by the separator followed by space.+sepWith :: Doc -> (a -> Doc) -> [a] -> Doc+sepWith sepDoc pprFun = sep . punctuate sepDoc . map pprFun+ -- Takes a list of printable things and prints them separated by commas followed -- by space. commaSep :: Ppr a => [a] -> Doc@@ -957,12 +1005,17 @@ -- Takes a list of things and prints them with the given pretty-printing -- function, separated by commas followed by space. commaSepWith :: (a -> Doc) -> [a] -> Doc-commaSepWith pprFun = sep . punctuate comma . map pprFun+commaSepWith pprFun = sepWith comma pprFun  -- Takes a list of printable things and prints them separated by semicolons -- followed by space. semiSep :: Ppr a => [a] -> Doc semiSep = sep . punctuate semi . map ppr++-- Takes a list of things and prints them with the given pretty-printing+-- function, separated by semicolons followed by space.+semiSepWith :: (a -> Doc) -> [a] -> Doc+semiSepWith pprFun = sepWith semi pprFun  -- Prints out the series of vertical bars that wraps an expression or pattern -- used in an unboxed sum.
libraries/template-haskell/Language/Haskell/TH/Syntax.hs view
@@ -2,8 +2,8 @@              DeriveGeneric, FlexibleInstances, DefaultSignatures,              RankNTypes, RoleAnnotations, ScopedTypeVariables,              MagicHash, KindSignatures, PolyKinds, TypeApplications, DataKinds,-             GADTs, UnboxedTuples, UnboxedSums, TypeInType,-             Trustworthy, DeriveFunctor #-}+             GADTs, UnboxedTuples, UnboxedSums, TypeInType, TypeOperators,+             Trustworthy, DeriveFunctor, BangPatterns, RecordWildCards, ImplicitParams #-}  {-# OPTIONS_GHC -fno-warn-inline-rule-shadowing #-} @@ -31,6 +31,7 @@ import Data.Data hiding (Fixity(..)) import Data.IORef import System.IO.Unsafe ( unsafePerformIO )+import System.FilePath import GHC.IO.Unsafe    ( unsafeDupableInterleaveIO ) import Control.Monad (liftM) import Control.Monad.IO.Class (MonadIO (..))@@ -60,11 +61,22 @@ import Foreign.ForeignPtr import Foreign.C.String import Foreign.C.Types+import GHC.Stack  #if __GLASGOW_HASKELL__ >= 901 import GHC.Types ( Levity(..) ) #endif +#if __GLASGOW_HASKELL__ >= 903+import Data.Array.Byte (ByteArray(..))+import GHC.Exts+  ( ByteArray#, unsafeFreezeByteArray#, copyAddrToByteArray#, newByteArray#+  , isByteArrayPinned#, isTrue#, sizeofByteArray#, unsafeCoerce#, byteArrayContents#+  , copyByteArray#, newPinnedByteArray#)+import GHC.ForeignPtr (ForeignPtr(..), ForeignPtrContents(..))+import GHC.ST (ST(..), runST)+#endif+ ----------------------------------------------------- -- --              The Quasi class@@ -103,6 +115,7 @@   qRunIO :: IO a -> m a   qRunIO = liftIO   -- ^ Input/output (dangerous)+  qGetPackageRoot :: m FilePath    qAddDependentFile :: FilePath -> m () @@ -154,6 +167,7 @@   qReifyConStrictness _ = badIO "reifyConStrictness"   qLocation             = badIO "currentLocation"   qRecover _ _          = badIO "recover" -- Maybe we could fix this?+  qGetPackageRoot       = badIO "getProjectRoot"   qAddDependentFile _   = badIO "addDependentFile"   qAddTempFile _        = badIO "addTempFile"   qAddTopDecls _        = badIO "addTopDecls"@@ -351,12 +365,12 @@ --       In the expression: [|| "foo" ||] --       In the Template Haskell splice $$([|| "foo" ||]) ----- Levity-polymorphic since /template-haskell-2.16.0.0/.+-- Representation-polymorphic since /template-haskell-2.16.0.0/.  -- | Discard the type annotation and produce a plain Template Haskell -- expression ----- Levity-polymorphic since /template-haskell-2.16.0.0/.+-- Representation-polymorphic since /template-haskell-2.16.0.0/. unTypeQ :: forall (r :: RuntimeRep) (a :: TYPE r) m . Quote m => m (TExp a) -> m Exp unTypeQ m = do { TExp e <- m                ; return e }@@ -366,7 +380,7 @@ -- This is unsafe because GHC cannot check for you that the expression -- really does have the type you claim it has. ----- Levity-polymorphic since /template-haskell-2.16.0.0/.+-- Representation-polymorphic since /template-haskell-2.16.0.0/. unsafeTExpCoerce :: forall (r :: RuntimeRep) (a :: TYPE r) m .                       Quote m => m Exp -> m (TExp a) unsafeTExpCoerce m = do { e <- m@@ -532,7 +546,10 @@ -}  -{- | 'reify' looks up information about the 'Name'.+{- | 'reify' looks up information about the 'Name'. It will fail with+a compile error if the 'Name' is not visible. A 'Name' is visible if it is+imported or defined in a prior top-level declaration group. See the+documentation for 'newDeclarationGroup' for more details.  It is sometimes useful to construct the argument name using 'lookupTypeName' or 'lookupValueName' to ensure that we are reifying from the right namespace. For instance, in this context:@@ -568,6 +585,60 @@ reifyType :: Name -> Q Type reifyType nm = Q (qReifyType nm) +{- | Template Haskell is capable of reifying information about types and+terms defined in previous declaration groups. Top-level declaration splices break up+declaration groups.++For an example, consider this  code block. We define a datatype @X@ and+then try to call 'reify' on the datatype.++@+module Check where++data X = X+    deriving Eq++$(do+    info <- reify ''X+    runIO $ print info+ )+@++This code fails to compile, noting that @X@ is not available for reification at the site of 'reify'. We can fix this by creating a new declaration group using an empty top-level splice:++@+data X = X+    deriving Eq++$(pure [])++$(do+    info <- reify ''X+    runIO $ print info+ )+@++We provide 'newDeclarationGroup' as a means of documenting this behavior+and providing a name for the pattern.++Since top level splices infer the presence of the @$( ... )@ brackets, we can also write:++@+data X = X+    deriving Eq++newDeclarationGroup++$(do+    info <- reify ''X+    runIO $ print info+ )+@++-}+newDeclarationGroup :: Q [Dec]+newDeclarationGroup = pure []+ {- | @reifyInstances nm tys@ returns a list of visible instances of @nm tys@. That is, if @nm@ is the name of a type class, then all instances of this class at the types @tys@ are returned. Alternatively, if @nm@ is the name of a data family or type family,@@ -585,13 +656,29 @@  There is one edge case: @reifyInstances ''Typeable tys@ currently always produces an empty list (no matter what @tys@ are given).++An instance is visible if it is imported or defined in a prior top-level+declaration group. See the documentation for 'newDeclarationGroup' for more details.+ -} reifyInstances :: Name -> [Type] -> Q [InstanceDec] reifyInstances cls tys = Q (qReifyInstances cls tys) -{- | @reifyRoles nm@ returns the list of roles associated with the parameters of+{- | @reifyRoles nm@ returns the list of roles associated with the parameters+(both visible and invisible) of the tycon @nm@. Fails if @nm@ cannot be found or is not a tycon. The returned list should never contain 'InferR'.++An invisible parameter to a tycon is often a kind parameter. For example, if+we have++@+type Proxy :: forall k. k -> Type+data Proxy a = MkProxy+@++and @reifyRoles Proxy@, we will get @['NominalR', 'PhantomR']@. The 'NominalR' is+the role of the invisible @k@ parameter. Kind parameters are always nominal. -} reifyRoles :: Name -> Q [Role] reifyRoles nm = Q (qReifyRoles nm)@@ -625,6 +712,10 @@ reifyConStrictness n = Q (qReifyConStrictness n)  -- | Is the list of instances returned by 'reifyInstances' nonempty?+--+-- If you're confused by an instance not being visible despite being+-- defined in the same module and above the splice in question, see the+-- docs for 'newDeclarationGroup' for a possible explanation. isInstance :: Name -> [Type] -> Q Bool isInstance nm tys = do { decs <- reifyInstances nm tys                        ; return (not (null decs)) }@@ -643,6 +734,27 @@ runIO :: IO a -> Q a runIO m = Q (qRunIO m) +-- | Get the package root for the current package which is being compiled.+-- This can be set explicitly with the -package-root flag but is normally+-- just the current working directory.+--+-- The motivation for this flag is to provide a principled means to remove the+-- assumption from splices that they will be executed in the directory where the+-- cabal file resides. Projects such as haskell-language-server can't and don't+-- change directory when compiling files but instead set the -package-root flag+-- appropiately.+getPackageRoot :: Q FilePath+getPackageRoot = Q qGetPackageRoot++-- | The input is a filepath, which if relative is offset by the package root.+makeRelativeToProject :: FilePath -> Q FilePath+makeRelativeToProject fp | isRelative fp = do+  root <- getPackageRoot+  return (root </> fp)+makeRelativeToProject fp = return fp+++ -- | Record external files that runIO is using (dependent upon). -- The compiler can then recognize that it should re-compile the Haskell file -- when an external file changes.@@ -793,6 +905,7 @@   qReifyConStrictness = reifyConStrictness   qLookupName         = lookupName   qLocation           = location+  qGetPackageRoot     = getPackageRoot   qAddDependentFile   = addDependentFile   qAddTempFile        = addTempFile   qAddTopDecls        = addTopDecls@@ -848,7 +961,7 @@ -- > data Bar a = Bar1 a (Bar a) | Bar2 String -- >   deriving Lift ----- Levity-polymorphic since /template-haskell-2.16.0.0/.+-- Representation-polymorphic since /template-haskell-2.16.0.0/. class Lift (t :: TYPE r) where   -- | Turn a value into a Template Haskell expression, suitable for use in   -- a splice.@@ -972,6 +1085,51 @@   lift x     = return (LitE (StringPrimL (map (fromIntegral . ord) (unpackCString# x)))) +#if __GLASGOW_HASKELL__ >= 903++-- |+-- @since 2.19.0.0+instance Lift ByteArray where+  liftTyped x = unsafeCodeCoerce (lift x)+  lift (ByteArray b) = return+    (AppE (AppE (VarE addrToByteArrayName) (LitE (IntegerL (fromIntegral len))))+      (LitE (BytesPrimL (Bytes ptr 0 (fromIntegral len)))))+    where+      len# = sizeofByteArray# b+      len = I# len#+      pb :: ByteArray#+      !(ByteArray pb)+        | isTrue# (isByteArrayPinned# b) = ByteArray b+        | otherwise = runST $ ST $+          \s -> case newPinnedByteArray# len# s of+            (# s', mb #) -> case copyByteArray# b 0# mb 0# len# s' of+              s'' -> case unsafeFreezeByteArray# mb s'' of+                (# s''', ret #) -> (# s''', ByteArray ret #)+      ptr :: ForeignPtr Word8+      ptr = ForeignPtr (byteArrayContents# pb) (PlainPtr (unsafeCoerce# pb))+++-- We can't use a TH quote in this module because we're in the template-haskell+-- package, so we conconct this quite defensive solution to make the correct name+-- which will work if the package name or module name changes in future.+addrToByteArrayName :: Name+addrToByteArrayName = helper+  where+    helper :: HasCallStack => Name+    helper =+      case head (getCallStack ?callStack) of+        (_, SrcLoc{..}) -> mkNameG_v srcLocPackage srcLocModule "addrToByteArray"+++addrToByteArray :: Int -> Addr# -> ByteArray+addrToByteArray (I# len) addr = runST $ ST $+  \s -> case newByteArray# len s of+    (# s', mb #) -> case copyAddrToByteArray# addr mb 0# len s' of+      s'' -> case unsafeFreezeByteArray# mb s'' of+        (# s''', ret #) -> (# s''', ByteArray ret #)++#endif+ instance Lift a => Lift (Maybe a) where   liftTyped x = unsafeCodeCoerce (lift x) @@ -1921,9 +2079,10 @@ @+@ and @*@, we don't know whether to parse it as @a + (b * c)@ or @(a + b) * c@. -In cases like this, use 'UInfixE', 'UInfixP', or 'UInfixT', which stand for-\"unresolved infix expression/pattern/type\", respectively. When the compiler-is given a splice containing a tree of @UInfixE@ applications such as+In cases like this, use 'UInfixE', 'UInfixP', 'UInfixT', or 'PromotedUInfixT',+which stand for \"unresolved infix expression/pattern/type/promoted+constructor\", respectively. When the compiler is given a splice containing a+tree of @UInfixE@ applications such as  > UInfixE >   (UInfixE e1 op1 e2)@@ -1938,7 +2097,8 @@      > (a + b * c) + d * e -  * 'InfixE', 'InfixP', and 'InfixT' expressions are never reassociated.+  * 'InfixE', 'InfixP', 'InfixT', and 'PromotedInfixT' expressions are never+    reassociated.    * The 'UInfixE' constructor doesn't support sections. Sections     such as @(a *)@ have no ambiguity, so 'InfixE' suffices. For longer@@ -1965,8 +2125,8 @@     > [p| a : b : c |] :: Q Pat     > [t| T + T |] :: Q Type -    will never contain 'UInfixE', 'UInfixP', 'UInfixT', 'InfixT', 'ParensE',-    'ParensP', or 'ParensT' constructors.+    will never contain 'UInfixE', 'UInfixP', 'UInfixT', 'PromotedUInfixT',+    'InfixT', 'PromotedInfixT, 'ParensE', 'ParensP', or 'ParensT' constructors.  -} @@ -2004,6 +2164,7 @@    { bytesPtr    :: ForeignPtr Word8 -- ^ Pointer to the data    , bytesOffset :: Word             -- ^ Offset from the pointer    , bytesSize   :: Word             -- ^ Number of bytes+    -- Maybe someday:    -- , bytesAlignement  :: Word -- ^ Alignement constraint    -- , bytesReadOnly    :: Bool -- ^ Shall we embed into a read-only@@ -2081,6 +2242,7 @@  data Match = Match Pat Body [Dec] -- ^ @case e of { pat -> body where decs }@     deriving( Show, Eq, Ord, Data, Generic )+ data Clause = Clause [Pat] Body [Dec]                                   -- ^ @f { p1 p2 = body where decs }@     deriving( Show, Eq, Ord, Data, Generic )@@ -2112,6 +2274,7 @@                                        -- See "Language.Haskell.TH.Syntax#infix"   | LamE [Pat] Exp                     -- ^ @{ \\ p1 p2 -> e }@   | LamCaseE [Match]                   -- ^ @{ \\case m1; m2 }@+  | LamCasesE [Clause]                 -- ^ @{ \\cases m1; m2 }@   | TupE [Maybe Exp]                   -- ^ @{ (e1,e2) }  @                                        --                                        -- The 'Maybe' is necessary for handling@@ -2226,6 +2389,7 @@                                   --{ foreign export ... }@    | InfixD Fixity Name            -- ^ @{ infix 3 foo }@+  | DefaultD [Type]               -- ^ @{ default (Integer, Double) }@    -- | pragmas   | PragmaD Pragma                -- ^ @{ {\-\# INLINE [1] foo \#-\} }@@@ -2285,7 +2449,7 @@ data Overlap = Overlappable   -- ^ May be overlapped by more specific instances              | Overlapping    -- ^ May overlap a more general instance              | Overlaps       -- ^ Both 'Overlapping' and 'Overlappable'-             | Incoherent     -- ^ Both 'Overlappable' and 'Overlappable', and+             | Incoherent     -- ^ Both 'Overlapping' and 'Overlappable', and                               -- pick an arbitrary one if multiple choices are                               -- available.   deriving( Show, Eq, Ord, Data, Generic )@@ -2393,6 +2557,7 @@         deriving( Show, Eq, Ord, Data, Generic )  data Pragma = InlineP         Name Inline RuleMatch Phases+            | OpaqueP         Name             | SpecialiseP     Name Type (Maybe Inline) Phases             | SpecialiseInstP Type             | RuleP           String (Maybe [TyVarBndr ()]) [RuleBndr] Exp Exp Phases@@ -2481,6 +2646,10 @@ --   @ -- --   In @MkBar@, 'ForallC' will quantify @a@, @b@, and @c@.+--+-- Multiplicity annotations for data types are currently not supported+-- in Template Haskell (i.e. all fields represented by Template Haskell+-- will be linear). data Con = NormalC Name [BangType]       -- ^ @C Int a@          | RecC Name [VarBangType]       -- ^ @C { v :: Int, w :: a }@          | InfixC BangType Name BangType -- ^ @Int :+ a@@@ -2495,7 +2664,6 @@  -- Note [GADT return type] -- ~~~~~~~~~~~~~~~~~~~~~~~--- -- The return type of a GADT constructor does not necessarily match the name of -- the data type: --@@ -2554,35 +2722,41 @@   deriving( Show, Eq, Ord, Data, Generic )  data Type = ForallT [TyVarBndr Specificity] Cxt Type -- ^ @forall \<vars\>. \<ctxt\> => \<type\>@-          | ForallVisT [TyVarBndr ()] Type  -- ^ @forall \<vars\> -> \<type\>@-          | AppT Type Type                -- ^ @T a b@-          | AppKindT Type Kind            -- ^ @T \@k t@-          | SigT Type Kind                -- ^ @t :: k@-          | VarT Name                     -- ^ @a@-          | ConT Name                     -- ^ @T@-          | PromotedT Name                -- ^ @'T@-          | InfixT Type Name Type         -- ^ @T + T@-          | UInfixT Type Name Type        -- ^ @T + T@-                                          ---                                          -- See "Language.Haskell.TH.Syntax#infix"-          | ParensT Type                  -- ^ @(T)@+          | ForallVisT [TyVarBndr ()] Type -- ^ @forall \<vars\> -> \<type\>@+          | AppT Type Type                 -- ^ @T a b@+          | AppKindT Type Kind             -- ^ @T \@k t@+          | SigT Type Kind                 -- ^ @t :: k@+          | VarT Name                      -- ^ @a@+          | ConT Name                      -- ^ @T@+          | PromotedT Name                 -- ^ @'T@+          | InfixT Type Name Type          -- ^ @T + T@+          | UInfixT Type Name Type         -- ^ @T + T@+                                           --+                                           -- See "Language.Haskell.TH.Syntax#infix"+          | PromotedInfixT Type Name Type  -- ^ @T :+: T@+          | PromotedUInfixT Type Name Type -- ^ @T :+: T@+                                           --+                                           -- See "Language.Haskell.TH.Syntax#infix"+          | ParensT Type                   -- ^ @(T)@            -- See Note [Representing concrete syntax in types]-          | TupleT Int                    -- ^ @(,), (,,), etc.@-          | UnboxedTupleT Int             -- ^ @(\#,\#), (\#,,\#), etc.@-          | UnboxedSumT SumArity          -- ^ @(\#|\#), (\#||\#), etc.@-          | ArrowT                        -- ^ @->@-          | MulArrowT                     -- ^ @FUN@-          | EqualityT                     -- ^ @~@-          | ListT                         -- ^ @[]@-          | PromotedTupleT Int            -- ^ @'(), '(,), '(,,), etc.@-          | PromotedNilT                  -- ^ @'[]@-          | PromotedConsT                 -- ^ @(':)@-          | StarT                         -- ^ @*@-          | ConstraintT                   -- ^ @Constraint@-          | LitT TyLit                    -- ^ @0,1,2, etc.@-          | WildCardT                     -- ^ @_@-          | ImplicitParamT String Type    -- ^ @?x :: t@+          | TupleT Int                     -- ^ @(,), (,,), etc.@+          | UnboxedTupleT Int              -- ^ @(\#,\#), (\#,,\#), etc.@+          | UnboxedSumT SumArity           -- ^ @(\#|\#), (\#||\#), etc.@+          | ArrowT                         -- ^ @->@+          | MulArrowT                      -- ^ @%n ->@+                                           --+                                           -- Generalised arrow type with multiplicity argument+          | EqualityT                      -- ^ @~@+          | ListT                          -- ^ @[]@+          | PromotedTupleT Int             -- ^ @'(), '(,), '(,,), etc.@+          | PromotedNilT                   -- ^ @'[]@+          | PromotedConsT                  -- ^ @(':)@+          | StarT                          -- ^ @*@+          | ConstraintT                    -- ^ @Constraint@+          | LitT TyLit                     -- ^ @0,1,2, etc.@+          | WildCardT                      -- ^ @_@+          | ImplicitParamT String Type     -- ^ @?x :: t@       deriving( Show, Eq, Ord, Data, Generic )  data Specificity = SpecifiedSpec          -- ^ @a@
+ rts/include/ghcconfig.h view
@@ -0,0 +1,4 @@+#pragma once++#include "ghcautoconf.h"+#include "ghcplatform.h"