packages feed

ghc-lib 9.2.8.20230729 → 9.4.1.20220807

raw patch · 388 files changed

+64535/−63305 lines, 388 filesdep +stmdep ~basedep ~bytestringdep ~ghc-lib-parser

Dependencies added: stm

Dependency ranges changed: base, bytestring, ghc-lib-parser, 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.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE CPP, NondecreasingIndentation, ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE NondecreasingIndentation, ScopedTypeVariables #-} {-# LANGUAGE TupleSections, NamedFieldPuns #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TypeFamilies #-}@@ -24,13 +25,15 @@         runGhc, runGhcT, initGhcMonad,         printException,         handleSourceError,-        needsTemplateHaskellOrQQ,          -- * Flags and settings         DynFlags(..), GeneralFlag(..), Severity(..), Backend(..), gopt,         GhcMode(..), GhcLink(..),         parseDynamicFlags, parseTargetFiles,-        getSessionDynFlags, setSessionDynFlags,+        getSessionDynFlags,+        setTopSessionDynFlags,+        setSessionDynFlags,+        setUnitDynFlags,         getProgramDynFlags, setProgramDynFlags,         getInteractiveDynFlags, setInteractiveDynFlags,         interpretPackageEnv,@@ -52,16 +55,17 @@          -- * Loading\/compiling the program         depanal, depanalE,-        load, LoadHowMuch(..), InteractiveImport(..),+        load, loadWithCache, LoadHowMuch(..), InteractiveImport(..),         SuccessFlag(..), succeeded, failed,         defaultWarnErrLogger, WarnErrLogger,         workingDirectoryChanged,-        parseModule, typecheckModule, desugarModule, loadModule,+        parseModule, typecheckModule, desugarModule,         ParsedModule(..), TypecheckedModule(..), DesugaredModule(..),         TypecheckedSource, ParsedSource, RenamedSource,   -- ditto         TypecheckedMod, ParsedMod,         moduleInfo, renamedSource, typecheckedSource,         parsedSource, coreModule,+        PkgQual(..),          -- ** Compiling to Core         CoreModule(..),@@ -74,6 +78,7 @@         getModSummary,         getModuleGraph,         isLoaded,+        isLoadedModule,         topSortModuleGraph,          -- * Inspecting modules@@ -95,9 +100,6 @@         ModIface, ModIface_(..),         SafeHaskellMode(..), -        -- * Querying the environment-        -- packageDbModules,-         -- * Printing         PrintUnqualified, alwaysQualify, @@ -118,6 +120,8 @@         -- ** Inspecting the current context         getBindings, getInsts, getPrintUnqual,         findModule, lookupModule,+        findQualifiedModule, lookupQualifiedModule,+        renamePkgQualM, renameRawPkgQualM,         isModuleTrusted, moduleTrustReqs,         getNamesInScope,         getRdrNamesInScope,@@ -296,8 +300,6 @@   * inline bits of GHC.Driver.Main here to simplify layering: hscTcExpr, hscStmt. -} -#include "GhclibHsVersions.h"- import GHC.Prelude hiding (init)  import GHC.Platform@@ -307,14 +309,17 @@                            , isSourceFilename, startPhase ) import GHC.Driver.Env import GHC.Driver.Errors+import GHC.Driver.Errors.Types import GHC.Driver.CmdLine-import GHC.Driver.Session hiding (WarnReason(..))+import GHC.Driver.Session import GHC.Driver.Backend-import GHC.Driver.Config+import GHC.Driver.Config.Finder (initFinderOpts)+import GHC.Driver.Config.Parser (initParserOpts)+import GHC.Driver.Config.Logger (initLogFlags)+import GHC.Driver.Config.Diagnostic import GHC.Driver.Main import GHC.Driver.Make import GHC.Driver.Hooks-import GHC.Driver.Pipeline   ( compileOne' ) import GHC.Driver.Monad import GHC.Driver.Ppr @@ -322,7 +327,6 @@ import qualified GHC.Linker.Loader as Loader import GHC.Runtime.Loader import GHC.Runtime.Eval-import GHC.Runtime.Eval.Types import GHC.Runtime.Interpreter import GHC.Runtime.Context import GHCi.RemoteTypes@@ -330,17 +334,15 @@ import qualified GHC.Parser as Parser import GHC.Parser.Lexer import GHC.Parser.Annotation-import GHC.Parser.Errors.Ppr import GHC.Parser.Utils  import GHC.Iface.Load        ( loadSysInterface ) import GHC.Hs import GHC.Builtin.Types.Prim ( alphaTyVars )-import GHC.Iface.Tidy-import GHC.Data.Bag        ( listToBag ) import GHC.Data.StringBuffer import GHC.Data.FastString import qualified GHC.LanguageExtensions as LangExt+import GHC.Rename.Names (renamePkgQual, renameRawPkgQual)  import GHC.Tc.Utils.Monad    ( finalSafeMode, fixSafeInstances, initIfaceTcRn ) import GHC.Tc.Types@@ -359,6 +361,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Logger+import GHC.Utils.Fingerprint  import GHC.Core.Predicate import GHC.Core.Type  hiding( typeKind )@@ -381,6 +384,7 @@ import GHC.Types.Name.Reader import GHC.Types.SourceError import GHC.Types.SafeHaskell+import GHC.Types.Error import GHC.Types.Fixity import GHC.Types.Target import GHC.Types.Basic@@ -388,12 +392,12 @@ import GHC.Types.Name.Env import GHC.Types.Name.Ppr import GHC.Types.TypeEnv-import GHC.Types.SourceFile+import GHC.Types.BreakInfo+import GHC.Types.PkgQual  import GHC.Unit import GHC.Unit.Env import GHC.Unit.External-import GHC.Unit.State import GHC.Unit.Finder import GHC.Unit.Module.ModIface import GHC.Unit.Module.ModGuts@@ -405,10 +409,8 @@ import Data.Foldable import qualified Data.Map.Strict as Map import Data.Set (Set)-import qualified Data.Set as S import qualified Data.Sequence as Seq import Data.Maybe-import Data.Time import Data.Typeable    ( Typeable ) import Data.Word        ( Word8 ) import Control.Monad@@ -422,9 +424,10 @@  import GHC.Data.Maybe import System.IO.Error  ( isDoesNotExistError )-import System.Environment ( getEnv )+import System.Environment ( getEnv, getProgName ) import System.Directory import Data.List (isPrefixOf)+import qualified Data.Set as S   -- %************************************************************************@@ -447,19 +450,18 @@            case fromException exception of                 -- an IO exception probably isn't our fault, so don't panic                 Just (ioe :: IOException) ->-                  fatalErrorMsg'' fm (show ioe)+                  fm (show ioe)                 _ -> case fromException exception of                      Just UserInterrupt ->                          -- Important to let this one propagate out so our                          -- calling process knows we were interrupted by ^C                          liftIO $ throwIO UserInterrupt                      Just StackOverflow ->-                         fatalErrorMsg'' fm "stack overflow: use +RTS -K<size> to increase it"+                         fm "stack overflow: use +RTS -K<size> to increase it"                      _ -> case fromException exception of                           Just (ex :: ExitCode) -> liftIO $ throwIO ex                           _ ->-                              fatalErrorMsg'' fm-                                  (show (Panic (show exception)))+                              fm (show (Panic (show exception)))            exitWith (ExitFailure 1)          ) $ @@ -468,9 +470,13 @@             (\ge -> liftIO $ do                 flushOut                 case ge of-                     Signal _ -> exitWith (ExitFailure 1)-                     _ -> do fatalErrorMsg'' fm (show ge)-                             exitWith (ExitFailure 1)+                  Signal _       -> return ()+                  ProgramError _ -> fm (show ge)+                  CmdLineError _ -> fm ("<command line>: " ++ show ge)+                  _              -> do+                                    progName <- getProgName+                                    fm (progName ++ ": " ++ show ge)+                exitWith (ExitFailure 1)             ) $   inner @@ -533,8 +539,9 @@       let logger = hsc_logger hsc_env       let tmpfs  = hsc_tmpfs hsc_env       liftIO $ do-          cleanTempFiles logger tmpfs dflags-          cleanTempDirs logger tmpfs dflags+          unless (gopt Opt_KeepTmpFiles dflags) $ do+            cleanTempFiles logger tmpfs+            cleanTempDirs logger tmpfs           traverse_ stopInterp (hsc_interp hsc_env)           --  exceptions will be blocked while we clean the temporary files,           -- so there shouldn't be any difficulty if we receive further@@ -554,12 +561,7 @@  initGhcMonad :: GhcMonad m => Maybe FilePath -> m () initGhcMonad mb_top_dir-  = do { -- The call to c_keepCAFsForGHCi must not be optimized away. Even in non-debug builds.-         -- So we can't use assertM here.-         -- See Note [keepCAFsForGHCi] in keepCAFsForGHCi.c for details about why.-         !keep_cafs <- liftIO $ c_keepCAFsForGHCi-       ; MASSERT( keep_cafs )-       ; env <- liftIO $+  = do { env <- liftIO $                 do { top_dir <- findTopDir mb_top_dir                    ; mySettings <- initSysTools top_dir                    ; myLlvmConfig <- lazyInitLlvmConfig top_dir@@ -593,10 +595,10 @@  checkBrokenTablesNextToCode' :: MonadIO m => Logger -> DynFlags -> m Bool checkBrokenTablesNextToCode' logger dflags-  | not (isARM arch)                 = return False-  | WayDyn `S.notMember` ways dflags = return False-  | not tablesNextToCode             = return False-  | otherwise                        = do+  | not (isARM arch)               = return False+  | ways dflags `hasNotWay` WayDyn = return False+  | not tablesNextToCode           = return False+  | otherwise                      = do     linkerInfo <- liftIO $ getLinkerInfo logger dflags     case linkerInfo of       GnuLD _  -> return True@@ -605,6 +607,7 @@         arch = platformArch platform         tablesNextToCode = platformTablesNextToCode platform + -- %************************************************************************ -- %*                                                                      * --             Flags & settings@@ -632,22 +635,85 @@ -- 'setSessionDynFlags' sets both @DynFlags@, and 'getSessionDynFlags' -- retrieves the program @DynFlags@ (for backwards compatibility). ---- | Updates both the interactive and program DynFlags in a Session.--- This also reads the package database (unless it has already been--- read), and prepares the compilers knowledge about packages.  It can--- be called again to load new packages: just add new package flags to--- (packageFlags dflags).-setSessionDynFlags :: GhcMonad m => DynFlags -> m ()+-- This is a compatability function which sets dynflags for the top session+-- as well as the unit.+setSessionDynFlags :: (HasCallStack, GhcMonad m) => DynFlags -> m () setSessionDynFlags dflags0 = do+  hsc_env <- getSession   logger <- getLogger+  dflags <- checkNewDynFlags logger dflags0+  let all_uids = hsc_all_home_unit_ids hsc_env+  case S.toList all_uids of+    [uid] -> do+      setUnitDynFlagsNoCheck uid dflags+      modifySession (hscSetActiveUnitId (homeUnitId_ dflags))+      dflags' <- getDynFlags+      setTopSessionDynFlags dflags'+    [] -> panic "nohue"+    _ -> panic "setSessionDynFlags can only be used with a single home unit"+++setUnitDynFlags :: GhcMonad m => UnitId -> DynFlags -> m ()+setUnitDynFlags uid dflags0 = do+  logger <- getLogger   dflags1 <- checkNewDynFlags logger dflags0+  setUnitDynFlagsNoCheck uid dflags1++setUnitDynFlagsNoCheck :: GhcMonad m => UnitId -> DynFlags -> m ()+setUnitDynFlagsNoCheck uid dflags1 = do+  logger <- getLogger   hsc_env <- getSession-  let cached_unit_dbs = hsc_unit_dbs hsc_env-  (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 cached_unit_dbs -  dflags <- liftIO $ updatePlatformConstants dflags1 mconstants+  let old_hue = ue_findHomeUnitEnv uid (hsc_unit_env hsc_env)+  let cached_unit_dbs = homeUnitEnv_unit_dbs old_hue+  (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 cached_unit_dbs (hsc_all_home_unit_ids hsc_env)+  updated_dflags <- liftIO $ updatePlatformConstants dflags1 mconstants +  let upd hue =+       hue+          { homeUnitEnv_units = unit_state+          , homeUnitEnv_unit_dbs = Just dbs+          , homeUnitEnv_dflags = updated_dflags+          , homeUnitEnv_home_unit = Just home_unit+          }++  let unit_env = ue_updateHomeUnitEnv upd uid (hsc_unit_env hsc_env)++  let dflags = updated_dflags++  let unit_env0 = unit_env+        { ue_platform        = targetPlatform dflags+        , ue_namever         = ghcNameVersion dflags+        }++  -- if necessary, change the key for the currently active unit+  -- as the dynflags might have been changed++  -- This function is called on every --make invocation because at the start of+  -- the session there is one fake unit called main which is immediately replaced+  -- after the DynFlags are parsed.+  let !unit_env1 =+        if homeUnitId_ dflags /= uid+          then+            ue_renameUnitId+                  uid+                  (homeUnitId_ dflags)+                  unit_env0+          else unit_env0++  modifySession $ \h -> h{ hsc_unit_env  = unit_env1+                         }++  invalidateModSummaryCache+++++setTopSessionDynFlags :: GhcMonad m => DynFlags -> m ()+setTopSessionDynFlags dflags = do+  hsc_env <- getSession+  logger  <- getLogger+   -- Interpreter   interp <- if gopt Opt_ExternalInterpreter dflags     then do@@ -661,7 +727,7 @@              | otherwise = ""            msg = text "Starting " <> text prog          tr <- if verbosity dflags >= 3-                then return (logInfo logger dflags $ withPprStyle defaultDumpStyle msg)+                then return (logInfo logger $ withPprStyle defaultDumpStyle msg)                 else return (pure ())          let           conf = IServConfig@@ -684,20 +750,12 @@       return Nothing #endif -  let unit_env = UnitEnv-        { ue_platform  = targetPlatform dflags-        , ue_namever   = ghcNameVersion dflags-        , ue_home_unit = home_unit-        , ue_units     = unit_state-        }-  modifySession $ \h -> h{ hsc_dflags = dflags-                         , hsc_IC = (hsc_IC h){ ic_dflags = dflags }++  modifySession $ \h -> hscSetFlags dflags+                        h{ hsc_IC = (hsc_IC h){ ic_dflags = dflags }                          , hsc_interp = hsc_interp h <|> interp-                           -- we only update the interpreter if there wasn't-                           -- already one set up-                         , hsc_unit_env = unit_env-                         , hsc_unit_dbs = Just dbs                          }+   invalidateModSummaryCache  -- | Sets the program 'DynFlags'.  Note: this invalidates the internal@@ -717,23 +775,37 @@   let changed = packageFlagsChanged dflags_prev dflags0   if changed     then do-        hsc_env <- getSession-        let cached_unit_dbs = hsc_unit_dbs hsc_env-        (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 cached_unit_dbs+        -- additionally, set checked dflags so we don't lose fixes+        old_unit_env <- ue_setFlags dflags0 . hsc_unit_env <$> getSession -        dflags1 <- liftIO $ updatePlatformConstants dflags0 mconstants+        home_unit_graph <- forM (ue_home_unit_graph old_unit_env) $ \homeUnitEnv -> do+          let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv+              dflags = homeUnitEnv_dflags homeUnitEnv+              old_hpt = homeUnitEnv_hpt homeUnitEnv+              home_units = unitEnv_keys (ue_home_unit_graph old_unit_env) +          (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags cached_unit_dbs home_units++          updated_dflags <- liftIO $ updatePlatformConstants dflags0 mconstants+          pure HomeUnitEnv+            { homeUnitEnv_units = unit_state+            , homeUnitEnv_unit_dbs = Just dbs+            , homeUnitEnv_dflags = updated_dflags+            , homeUnitEnv_hpt = old_hpt+            , homeUnitEnv_home_unit = Just home_unit+            }++        let dflags1 = homeUnitEnv_dflags $ unitEnv_lookup (ue_currentUnit old_unit_env) home_unit_graph         let unit_env = UnitEnv-              { ue_platform  = targetPlatform dflags1-              , ue_namever   = ghcNameVersion dflags1-              , ue_home_unit = home_unit-              , ue_units     = unit_state+              { ue_platform        = targetPlatform dflags1+              , ue_namever         = ghcNameVersion dflags1+              , ue_home_unit_graph = home_unit_graph+              , ue_current_unit    = ue_currentUnit old_unit_env+              , ue_eps             = ue_eps old_unit_env               }-        modifySession $ \h -> h{ hsc_dflags   = dflags1-                               , hsc_unit_dbs = Just dbs-                               , hsc_unit_env = unit_env-                               }-    else modifySession $ \h -> h{ hsc_dflags = dflags0 }+        modifySession $ \h -> hscSetFlags dflags1 h{ hsc_unit_env = unit_env }+    else modifySession (hscSetFlags dflags0)+   when invalidate_needed $ invalidateModSummaryCache   return changed @@ -750,7 +822,7 @@ -- old log_action.  This is definitely wrong (#7478). -- -- Hence, we invalidate the ModSummary cache after changing the--- DynFlags.  We do this by tweaking the date on each ModSummary, so+-- DynFlags.  We do this by tweaking the hash on each ModSummary, so -- that the next downsweep will think that all the files have changed -- and preprocess them again.  This won't necessarily cause everything -- to be recompiled, because by the time we check whether we need to@@ -761,7 +833,7 @@ invalidateModSummaryCache =   modifySession $ \h -> h { hsc_mod_graph = mapMG inval (hsc_mod_graph h) }  where-  inval ms = ms { ms_hs_date = addUTCTime (-1) (ms_hs_date ms) }+  inval ms = ms { ms_hs_hash = fingerprint0 }  -- | Returns the program 'DynFlags'. getProgramDynFlags :: GhcMonad m => m DynFlags@@ -808,7 +880,10 @@     -> m (DynFlags, [Located String], [Warn]) parseDynamicFlags logger dflags cmdline = do   (dflags1, leftovers, warns) <- parseDynamicFlagsCmdLine dflags cmdline-  dflags2 <- liftIO $ interpretPackageEnv logger dflags1+  -- flags that have just been read are used by the logger when loading package+  -- env (this is checked by T16318)+  let logger1 = setLogFlags logger (initLogFlags dflags1)+  dflags2 <- liftIO $ interpretPackageEnv logger1 dflags1   return (dflags2, leftovers, warns)  -- | Parse command line arguments that look like files.@@ -819,7 +894,8 @@ parseTargetFiles dflags0 fileish_args =   let     normal_fileish_paths = map normalise_hyp fileish_args-    (srcs, objs)         = partition_args normal_fileish_paths [] []+    (srcs, raw_objs)         = partition_args normal_fileish_paths [] []+    objs = map (augmentByWorkingDirectory dflags0) raw_objs      dflags1 = dflags0 { ldInputs = map (FileOption "") objs                                    ++ ldInputs dflags0 }@@ -901,7 +977,8 @@ checkNewDynFlags logger dflags = do   -- See Note [DynFlags consistency]   let (dflags', warnings) = makeDynFlagsConsistent dflags-  liftIO $ handleFlagWarnings logger dflags (map (Warn NoReason) warnings)+  let diag_opts = initDiagOpts dflags+  liftIO $ handleFlagWarnings logger diag_opts (map (Warn WarningWithoutFlag) warnings)   return dflags'  checkNewInteractiveDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags@@ -909,10 +986,12 @@   -- We currently don't support use of StaticPointers in expressions entered on   -- the REPL. See #12356.   if xopt LangExt.StaticPointers dflags0-  then do liftIO $ printOrThrowWarnings logger dflags0 $ listToBag-            [mkPlainWarnMsg interactiveSrcSpan-             $ text "StaticPointers is not supported in GHCi interactive expressions."]-          return $ xopt_unset dflags0 LangExt.StaticPointers+  then do+    let diag_opts = initDiagOpts dflags0+    liftIO $ printOrThrowDiagnostics logger diag_opts $ singleMessage+      $ fmap GhcDriverMessage+      $ mkPlainMsgEnvelope diag_opts interactiveSrcSpan DriverStaticPointersNotSupported+    return $ xopt_unset dflags0 LangExt.StaticPointers   else return dflags0  @@ -946,7 +1025,7 @@ removeTarget target_id   = modifySession (\h -> h{ hsc_targets = filter (hsc_targets h) })   where-   filter targets = [ t | t@(Target id _ _) <- targets, id /= target_id ]+   filter targets = [ t | t@Target { targetId = id } <- targets, id /= target_id ]  -- | Attempts to guess what Target a string refers to.  This function -- implements the @--make@/GHCi command-line syntax for filenames:@@ -959,23 +1038,25 @@ -- --   - otherwise interpret the string as a module name ---guessTarget :: GhcMonad m => String -> Maybe Phase -> m Target-guessTarget str (Just phase)-   = return (Target (TargetFile str (Just phase)) True Nothing)-guessTarget str Nothing+guessTarget :: GhcMonad m => String -> Maybe UnitId -> Maybe Phase -> m Target+guessTarget str mUnitId (Just phase)+   = do+     tuid <- unitIdOrHomeUnit mUnitId+     return (Target (TargetFile str (Just phase)) True tuid Nothing)+guessTarget str mUnitId Nothing    | isHaskellSrcFilename file-   = return (target (TargetFile file Nothing))+   = target (TargetFile file Nothing)    | otherwise    = do exists <- liftIO $ doesFileExist hs_file         if exists-           then return (target (TargetFile hs_file Nothing))+           then target (TargetFile hs_file Nothing)            else do         exists <- liftIO $ doesFileExist lhs_file         if exists-           then return (target (TargetFile lhs_file Nothing))+           then target (TargetFile lhs_file Nothing)            else do         if looksLikeModuleName file-           then return (target (TargetModule (mkModuleName file)))+           then target (TargetModule (mkModuleName file))            else do         dflags <- getDynFlags         liftIO $ throwGhcExceptionIO@@ -990,8 +1071,16 @@          hs_file  = file <.> "hs"          lhs_file = file <.> "lhs" -         target tid = Target tid obj_allowed Nothing+         target tid = do+           tuid <- unitIdOrHomeUnit mUnitId+           pure $ Target tid obj_allowed tuid Nothing +-- | Unwrap 'UnitId' or retrieve the 'UnitId'+-- of the current 'HomeUnit'.+unitIdOrHomeUnit :: GhcMonad m => Maybe UnitId -> m UnitId+unitIdOrHomeUnit mUnitId = do+  currentHomeUnitId <- homeUnitId . hsc_home_unit <$> getSession+  pure (fromMaybe currentHomeUnitId mUnitId)  -- | Inform GHC that the working directory has changed.  GHC will flush -- its cache of module locations, since it may no longer be valid.@@ -1001,7 +1090,9 @@ -- you should also unload the current program (set targets to empty, -- followed by load). workingDirectoryChanged :: GhcMonad m => m ()-workingDirectoryChanged = withSession $ (liftIO . flushFinderCaches)+workingDirectoryChanged = do+  hsc_env <- getSession+  liftIO $ flushFinderCaches (hsc_FC hsc_env) (hsc_unit_env hsc_env)   -- %************************************************************************@@ -1080,7 +1171,7 @@  type ParsedSource      = Located HsModule type RenamedSource     = (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)],-                          Maybe LHsDocString)+                          Maybe (LHsDoc GhcRn)) type TypecheckedSource = LHsBinds GhcTc  -- NOTE:@@ -1122,9 +1213,10 @@ parseModule :: GhcMonad m => ModSummary -> m ParsedModule parseModule ms = do    hsc_env <- getSession-   let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }-   hpm <- liftIO $ hscParse hsc_env_tmp ms-   return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm))+   liftIO $ do+     let lcl_hsc_env = hscSetFlags (ms_hspp_opts ms) hsc_env+     hpm <- hscParse lcl_hsc_env ms+     return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm))                -- See Note [exact print annotations] in GHC.Parser.Annotation  -- | Typecheck and rename a parsed module.@@ -1132,17 +1224,20 @@ -- Throws a 'SourceError' if either fails. typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule typecheckModule pmod = do- let ms = modSummary pmod  hsc_env <- getSession- let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }- (tc_gbl_env, rn_info)-       <- liftIO $ hscTypecheckRename hsc_env_tmp ms $-                      HsParsedModule { hpm_module = parsedSource pmod,-                                       hpm_src_files = pm_extra_src_files pmod }- details <- liftIO $ makeSimpleDetails hsc_env_tmp tc_gbl_env- safe    <- liftIO $ finalSafeMode (ms_hspp_opts ms) tc_gbl_env - return $+ liftIO $ do+   let ms          = modSummary pmod+   let lcl_dflags  = ms_hspp_opts ms -- take into account pragmas (OPTIONS_GHC, etc.)+   let lcl_hsc_env = hscSetFlags lcl_dflags hsc_env+   let lcl_logger  = hsc_logger lcl_hsc_env+   (tc_gbl_env, rn_info) <- hscTypecheckRename lcl_hsc_env ms $+                        HsParsedModule { hpm_module = parsedSource pmod,+                                         hpm_src_files = pm_extra_src_files pmod }+   details <- makeSimpleDetails lcl_logger tc_gbl_env+   safe    <- finalSafeMode lcl_dflags tc_gbl_env++   return $      TypecheckedModule {        tm_internals_          = (tc_gbl_env, details),        tm_parsed_module       = pmod,@@ -1153,7 +1248,7 @@            minf_type_env  = md_types details,            minf_exports   = md_exports details,            minf_rdr_env   = Just (tcg_rdr_env tc_gbl_env),-           minf_instances = fixSafeInstances safe $ md_insts details,+           minf_instances = fixSafeInstances safe $ instEnvElts $ md_insts details,            minf_iface     = Nothing,            minf_safe      = safe,            minf_modBreaks = emptyModBreaks@@ -1162,54 +1257,20 @@ -- | Desugar a typechecked module. desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule desugarModule tcm = do- let ms = modSummary tcm- let (tcg, _) = tm_internals tcm  hsc_env <- getSession- let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }- guts <- liftIO $ hscDesugar hsc_env_tmp ms tcg- return $+ liftIO $ do+   let ms = modSummary tcm+   let (tcg, _) = tm_internals tcm+   let lcl_hsc_env = hscSetFlags (ms_hspp_opts ms) hsc_env+   guts <- hscDesugar lcl_hsc_env ms tcg+   return $      DesugaredModule {        dm_typechecked_module = tcm,        dm_core_module        = guts      } --- | Load a module.  Input doesn't need to be desugared.------ A module must be loaded before dependent modules can be typechecked.  This--- always includes generating a 'ModIface' and, depending on the--- @DynFlags@\'s 'GHC.Driver.Session.backend', may also include code generation.------ This function will always cause recompilation and will always overwrite--- previous compilation results (potentially files on disk).----loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod-loadModule tcm = do-   let ms = modSummary tcm-   let mod = ms_mod_name ms-   let loc = ms_location ms-   let (tcg, _details) = tm_internals tcm -   mb_linkable <- case ms_obj_date ms of-                     Just t | t > ms_hs_date ms  -> do-                         l <- liftIO $ findObjectLinkable (ms_mod ms)-                                                  (ml_obj_file loc) t-                         return (Just l)-                     _otherwise -> return Nothing -   let source_modified | isNothing mb_linkable = SourceModified-                       | otherwise             = SourceUnmodified-                       -- we can't determine stability here--   -- compile doesn't change the session-   hsc_env <- getSession-   mod_info <- liftIO $ compileOne' (Just tcg) Nothing-                                    hsc_env ms 1 1 Nothing mb_linkable-                                    source_modified--   modifySession $ \e -> e{ hsc_HPT = addToHpt (hsc_HPT e) mod mod_info }-   return tcm-- -- %************************************************************************ -- %*                                                                      * --             Dealing with Core@@ -1252,7 +1313,7 @@ compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule compileCore simplify fn = do    -- First, set the target to the desired filename-   target <- guessTarget fn Nothing+   target <- guessTarget fn Nothing Nothing    addTarget target    _ <- load LoadAllTargets    -- Then find dependencies@@ -1269,12 +1330,12 @@          if simplify           then do              -- If simplify is true: simplify (hscSimplify), then tidy-             -- (tidyProgram).+             -- (hscTidy).              hsc_env <- getSession              simpl_guts <- liftIO $ do                plugins <- readIORef (tcg_th_coreplugins tcg)                hscSimplify hsc_env plugins mod_guts-             tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts+             tidy_guts <- liftIO $ hscTidy hsc_env simpl_guts              return $ Left tidy_guts           else              return $ Right mod_guts@@ -1317,6 +1378,10 @@ isLoaded m = withSession $ \hsc_env ->   return $! isJust (lookupHpt (hsc_HPT hsc_env) m) +isLoadedModule :: GhcMonad m => UnitId -> ModuleName -> m Bool+isLoadedModule uid m = withSession $ \hsc_env ->+  return $! isJust (lookupHug (hsc_HUG hsc_env) uid m)+ -- | Return the bindings for the current interactive session. getBindings :: GhcMonad m => m [TyThing] getBindings = withSession $ \hsc_env ->@@ -1325,7 +1390,8 @@ -- | Return the instances for the current interactive session. getInsts :: GhcMonad m => m ([ClsInst], [FamInst]) getInsts = withSession $ \hsc_env ->-    return $ ic_instances (hsc_IC hsc_env)+    let (inst_env, fam_env) = ic_instances (hsc_IC hsc_env)+    in return (instEnvElts inst_env, fam_env)  getPrintUnqual :: GhcMonad m => m PrintUnqualified getPrintUnqual = withSession $ \hsc_env -> do@@ -1344,22 +1410,13 @@         -- We don't want HomeModInfo here, because a ModuleInfo applies         -- to package modules too. + -- | Request information about a loaded 'Module' getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo)  -- XXX: Maybe X getModuleInfo mdl = withSession $ \hsc_env -> do-  let mg = hsc_mod_graph hsc_env-  if mgElemModule mg mdl+  if moduleUnitId mdl `S.member` hsc_all_home_unit_ids hsc_env         then liftIO $ getHomeModuleInfo hsc_env mdl-        else do-  {- if isHomeModule (hsc_dflags hsc_env) mdl-        then return Nothing-        else -} liftIO $ getPackageModuleInfo hsc_env mdl-   -- ToDo: we don't understand what the following comment means.-   --    (SDM, 19/7/2011)-   -- getPackageModuleInfo will attempt to find the interface, so-   -- we don't want to call it for a home module, just in case there-   -- was a problem loading the module and the interface doesn't-   -- exist... hence the isHomeModule test here.  (ToDo: reinstate)+        else liftIO $ getPackageModuleInfo hsc_env mdl  getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) getPackageModuleInfo hsc_env mdl@@ -1395,7 +1452,7 @@  getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) getHomeModuleInfo hsc_env mdl =-  case lookupHpt (hsc_HPT hsc_env) (moduleName mdl) of+  case lookupHugByModule mdl (hsc_HUG hsc_env) of     Nothing  -> return Nothing     Just hmi -> do       let details = hm_details hmi@@ -1404,7 +1461,7 @@                         minf_type_env  = md_types details,                         minf_exports   = md_exports details,                         minf_rdr_env   = mi_globals $! hm_iface hmi,-                        minf_instances = md_insts details,+                        minf_instances = instEnvElts $ md_insts details,                         minf_iface     = Just iface,                         minf_safe      = getSafeMode $ mi_trust iface                        ,minf_modBreaks = getModBreaks hmi@@ -1480,7 +1537,7 @@  -- | get the GlobalRdrEnv for a session getGRE :: GhcMonad m => m GlobalRdrEnv-getGRE = withSession $ \hsc_env-> return $ ic_rn_gbl_env (hsc_IC hsc_env)+getGRE = withSession $ \hsc_env-> return $ icReaderEnv (hsc_IC hsc_env)  -- | Retrieve all type and family instances in the environment, indexed -- by 'Name'. Each name's lists will contain every instance in which that name@@ -1490,7 +1547,7 @@                      -- if it is visible from at least one module in the list.   -> Maybe [Module]  -- ^ modules to load. If this is not specified, we load                      -- modules for everything that is in scope unqualified.-  -> m (Messages DecoratedSDoc, Maybe (NameEnv ([ClsInst], [FamInst])))+  -> m (Messages TcRnMessage, Maybe (NameEnv ([ClsInst], [FamInst]))) getNameToInstancesIndex visible_mods mods_to_load = do   hsc_env <- getSession   liftIO $ runTcInteractive hsc_env $@@ -1525,27 +1582,6 @@            ] }  -- -------------------------------------------------------------------------------{- ToDo: Move the primary logic here to "GHC.Unit.State"--- | Return all /external/ modules available in the package database.--- Modules from the current session (i.e., from the 'HomePackageTable') are--- not included.  This includes module names which are reexported by packages.-packageDbModules :: GhcMonad m =>-                    Bool  -- ^ Only consider exposed packages.-                 -> m [Module]-packageDbModules only_exposed = do-   dflags <- getSessionDynFlags-   let pkgs = eltsUFM (unitInfoMap (unitState dflags))-   return $-     [ mkModule pid modname-     | p <- pkgs-     , not only_exposed || exposed p-     , let pid = mkUnit p-     , modname <- exposedModules p-               ++ map exportName (reexportedModules p) ]-               -}---- ----------------------------------------------------------------------------- -- Misc exported utils  dataConType :: DataCon -> Type@@ -1571,42 +1607,43 @@ -- on whether the module is interpreted or not.  --- Extract the filename, stringbuffer content and dynflags associed to a module+-- Extract the filename, stringbuffer content and dynflags associed to a ModSummary+-- Given an initialised GHC session a ModSummary can be retrieved for+-- a module by using 'getModSummary' -- -- XXX: Explain pre-conditions-getModuleSourceAndFlags :: GhcMonad m => Module -> m (String, StringBuffer, DynFlags)-getModuleSourceAndFlags mod = do-  m <- getModSummary (moduleName mod)+getModuleSourceAndFlags :: ModSummary -> IO (String, StringBuffer, DynFlags)+getModuleSourceAndFlags m = do   case ml_hs_file $ ms_location m of-    Nothing -> do dflags <- getDynFlags-                  liftIO $ throwIO $ mkApiErr dflags (text "No source available for module " <+> ppr mod)+    Nothing -> throwIO $ mkApiErr (ms_hspp_opts m) (text "No source available for module " <+> ppr (ms_mod m))     Just sourceFile -> do-        source <- liftIO $ hGetStringBuffer sourceFile+        source <- hGetStringBuffer sourceFile         return (sourceFile, source, ms_hspp_opts m)   -- | Return module source as token stream, including comments. ----- The module must be in the module graph and its source must be available.+-- A 'Module' can be turned into a 'ModSummary' using 'getModSummary' if+-- your session is fully initialised. -- Throws a 'GHC.Driver.Env.SourceError' on parse error.-getTokenStream :: GhcMonad m => Module -> m [Located Token]+getTokenStream :: ModSummary -> IO [Located Token] getTokenStream mod = do   (sourceFile, source, dflags) <- getModuleSourceAndFlags mod   let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1   case lexTokenStream (initParserOpts dflags) source startLoc of     POk _ ts    -> return ts-    PFailed pst -> throwErrors (fmap pprError (getErrorMessages pst))+    PFailed pst -> throwErrors (GhcPsMessage <$> getPsErrorMessages pst)  -- | Give even more information on the source than 'getTokenStream' -- This function allows reconstructing the source completely with -- 'showRichTokenStream'.-getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)]+getRichTokenStream :: ModSummary -> IO [(Located Token, String)] getRichTokenStream mod = do   (sourceFile, source, dflags) <- getModuleSourceAndFlags mod   let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1   case lexTokenStream (initParserOpts dflags) source startLoc of     POk _ ts    -> return $ addSourceToTokens startLoc source ts-    PFailed pst -> throwErrors (fmap pprError (getErrorMessages pst))+    PFailed pst -> throwErrors (GhcPsMessage <$> getPsErrorMessages pst)  -- | Given a source location and a StringBuffer corresponding to this -- location, return a rich token stream with the source associated to the@@ -1662,32 +1699,46 @@ -- filesystem and package database to find the corresponding 'Module', -- using the algorithm that is used for an @import@ declaration. findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module-findModule mod_name maybe_pkg = withSession $ \hsc_env -> do-  let dflags     = hsc_dflags hsc_env-      home_unit  = hsc_home_unit hsc_env-  case maybe_pkg of-    Just pkg | not (isHomeUnit home_unit (fsToUnit pkg)) && pkg /= fsLit "this" -> liftIO $ do-      res <- findImportedModule hsc_env mod_name maybe_pkg-      case res of-        Found _ m -> return m-        err       -> throwOneError $ noModError hsc_env noSrcSpan mod_name err-    _otherwise -> do-      home <- lookupLoadedHomeModule mod_name+findModule mod_name maybe_pkg = do+  pkg_qual <- renamePkgQualM mod_name maybe_pkg+  findQualifiedModule pkg_qual mod_name+++findQualifiedModule :: GhcMonad m => PkgQual -> ModuleName -> m Module+findQualifiedModule pkgqual mod_name = withSession $ \hsc_env -> do+  let mhome_unit = hsc_home_unit_maybe hsc_env+  let dflags    = hsc_dflags hsc_env+  case pkgqual of+    ThisPkg uid -> do+      home <- lookupLoadedHomeModule uid mod_name       case home of         Just m  -> return m         Nothing -> liftIO $ do-           res <- findImportedModule hsc_env mod_name maybe_pkg+           res <- findImportedModule hsc_env mod_name pkgqual            case res of-             Found loc m | not (isHomeModule home_unit m) -> return m+             Found loc m | notHomeModuleMaybe mhome_unit m -> return m                          | otherwise -> modNotLoadedError dflags m loc              err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err +    _ -> liftIO $ do+      res <- findImportedModule hsc_env mod_name pkgqual+      case res of+        Found _ m -> return m+        err       -> throwOneError $ noModError hsc_env noSrcSpan mod_name err++ modNotLoadedError :: DynFlags -> Module -> ModLocation -> IO a modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc dflags $    text "module is not loaded:" <+>    quotes (ppr (moduleName m)) <+>    parens (text (expectJust "modNotLoadedError" (ml_hs_file loc))) +renamePkgQualM :: GhcMonad m => ModuleName -> Maybe FastString -> m PkgQual+renamePkgQualM mn p = withSession $ \hsc_env -> pure (renamePkgQual (hsc_unit_env hsc_env) mn p)++renameRawPkgQualM :: GhcMonad m => ModuleName -> RawPkgQual -> m PkgQual+renameRawPkgQualM mn p = withSession $ \hsc_env -> pure (renameRawPkgQual (hsc_unit_env hsc_env) mn p)+ -- | Like 'findModule', but differs slightly when the module refers to -- a source file, and the file has not been loaded via 'load'.  In -- this case, 'findModule' will throw an error (module not loaded),@@ -1696,20 +1747,29 @@ -- returned.  If not, the usual module-not-found error will be thrown. -- lookupModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module-lookupModule mod_name (Just pkg) = findModule mod_name (Just pkg)-lookupModule mod_name Nothing = withSession $ \hsc_env -> do-  home <- lookupLoadedHomeModule mod_name+lookupModule mod_name maybe_pkg = do+  pkgqual <- renamePkgQualM mod_name maybe_pkg+  lookupQualifiedModule pkgqual mod_name++lookupQualifiedModule :: GhcMonad m => PkgQual -> ModuleName -> m Module+lookupQualifiedModule NoPkgQual mod_name = withSession $ \hsc_env -> do+  home <- lookupLoadedHomeModule (homeUnitId $ hsc_home_unit hsc_env) mod_name   case home of     Just m  -> return m     Nothing -> liftIO $ do-      res <- findExposedPackageModule hsc_env mod_name Nothing+      let fc     = hsc_FC hsc_env+      let units  = hsc_units hsc_env+      let dflags = hsc_dflags hsc_env+      let fopts  = initFinderOpts dflags+      res <- findExposedPackageModule fc fopts units mod_name NoPkgQual       case res of         Found _ m -> return m         err       -> throwOneError $ noModError hsc_env noSrcSpan mod_name err+lookupQualifiedModule pkgqual mod_name = findQualifiedModule pkgqual mod_name -lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module)-lookupLoadedHomeModule mod_name = withSession $ \hsc_env ->-  case lookupHpt (hsc_HPT hsc_env) mod_name of+lookupLoadedHomeModule :: GhcMonad m => UnitId -> ModuleName -> m (Maybe Module)+lookupLoadedHomeModule uid mod_name = withSession $ \hsc_env ->+  case lookupHug  (hsc_HUG hsc_env) uid mod_name  of     Just mod_info      -> return (Just (mi_module (hm_iface mod_info)))     _not_a_home_module -> return Nothing @@ -1780,12 +1840,12 @@    case unP Parser.parseModule (initParserState (initParserOpts dflags) buf loc) of       PFailed pst ->-         let (warns,errs) = getMessages pst in-         (fmap pprWarning warns, Left (fmap pprError errs))+         let (warns,errs) = getPsMessages pst in+         (GhcPsMessage <$> warns, Left $ GhcPsMessage <$> errs)       POk pst rdr_module ->-         let (warns,_) = getMessages pst in-         (fmap pprWarning warns, Right rdr_module)+         let (warns,_) = getPsMessages pst in+         (GhcPsMessage <$> warns, Right rdr_module)  -- ----------------------------------------------------------------------------- -- | Find the package environment (if one exists)@@ -1844,8 +1904,8 @@         return dflags       Just envfile -> do         content <- readFile envfile-        compilationProgressMsg logger dflags (text "Loaded package environment from " <> text envfile)-        let (_, dflags') = runCmdLine (runEwM (setFlagsFromEnvFile envfile content)) dflags+        compilationProgressMsg logger (text "Loaded package environment from " <> text envfile)+        let (_, dflags') = runCmdLineP (runEwM (setFlagsFromEnvFile envfile content)) dflags          return dflags'   where@@ -1934,6 +1994,3 @@  mkApiErr :: DynFlags -> SDoc -> GhcApiError mkApiErr dflags msg = GhcApiError (showSDoc dflags msg)--foreign import ccall unsafe "keepCAFsForGHCi"-    c_keepCAFsForGHCi   :: IO Bool
compiler/GHC/Builtin/Names/TH.hs view
@@ -54,7 +54,7 @@     -- Exp     varEName, conEName, litEName, appEName, appTypeEName, infixEName,     infixAppName, sectionLName, sectionRName, lamEName, lamCaseEName,-    tupEName, unboxedTupEName, unboxedSumEName,+    lamCasesEName, tupEName, unboxedTupEName, unboxedSumEName,     condEName, multiIfEName, letEName, caseEName, doEName, mdoEName, compEName,     fromEName, fromThenEName, fromToEName, fromThenToEName,     listEName, sigEName, recConEName, recUpdEName, staticEName, unboundVarEName,@@ -71,8 +71,8 @@     funDName, valDName, dataDName, newtypeDName, tySynDName,     classDName, instanceWithOverlapDName,     standaloneDerivWithStrategyDName, sigDName, kiSigDName, forImpDName,-    pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,-    pragRuleDName, pragCompleteDName, pragAnnDName, defaultSigDName,+    pragInlDName, pragOpaqueDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,+    pragRuleDName, pragCompleteDName, pragAnnDName, defaultSigDName, defaultDName,     dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName,     dataInstDName, newtypeInstDName, tySynInstDName,     infixLDName, infixRDName, infixNDName,@@ -285,7 +285,7 @@  -- data Exp = ... varEName, conEName, litEName, appEName, appTypeEName, infixEName, infixAppName,-    sectionLName, sectionRName, lamEName, lamCaseEName, tupEName,+    sectionLName, sectionRName, lamEName, lamCaseEName, lamCasesEName, tupEName,     unboxedTupEName, unboxedSumEName, condEName, multiIfEName, letEName,     caseEName, doEName, mdoEName, compEName, staticEName, unboundVarEName,     labelEName, implicitParamVarEName, getFieldEName, projectionEName :: Name@@ -300,6 +300,7 @@ sectionRName          = libFun (fsLit "sectionR")          sectionRIdKey lamEName              = libFun (fsLit "lamE")              lamEIdKey lamCaseEName          = libFun (fsLit "lamCaseE")          lamCaseEIdKey+lamCasesEName         = libFun (fsLit "lamCasesE")         lamCasesEIdKey tupEName              = libFun (fsLit "tupE")              tupEIdKey unboxedTupEName       = libFun (fsLit "unboxedTupE")       unboxedTupEIdKey unboxedSumEName       = libFun (fsLit "unboxedSumE")       unboxedSumEIdKey@@ -355,11 +356,11 @@ funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,     instanceWithOverlapDName, sigDName, kiSigDName, forImpDName, pragInlDName,     pragSpecDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName,-    pragAnnDName, standaloneDerivWithStrategyDName, defaultSigDName,+    pragAnnDName, standaloneDerivWithStrategyDName, defaultSigDName, defaultDName,     dataInstDName, newtypeInstDName, tySynInstDName, dataFamilyDName,     openTypeFamilyDName, closedTypeFamilyDName, infixLDName, infixRDName,     infixNDName, roleAnnotDName, patSynDName, patSynSigDName,-    pragCompleteDName, implicitParamBindDName :: Name+    pragCompleteDName, implicitParamBindDName, pragOpaqueDName :: Name funDName                         = libFun (fsLit "funD")                         funDIdKey valDName                         = libFun (fsLit "valD")                         valDIdKey dataDName                        = libFun (fsLit "dataD")                        dataDIdKey@@ -370,9 +371,11 @@ standaloneDerivWithStrategyDName = libFun (fsLit "standaloneDerivWithStrategyD") standaloneDerivWithStrategyDIdKey sigDName                         = libFun (fsLit "sigD")                         sigDIdKey kiSigDName                       = libFun (fsLit "kiSigD")                       kiSigDIdKey+defaultDName                     = libFun (fsLit "defaultD")                     defaultDIdKey defaultSigDName                  = libFun (fsLit "defaultSigD")                  defaultSigDIdKey forImpDName                      = libFun (fsLit "forImpD")                      forImpDIdKey pragInlDName                     = libFun (fsLit "pragInlD")                     pragInlDIdKey+pragOpaqueDName                  = libFun (fsLit "pragOpaqueD")                  pragOpaqueDIdKey pragSpecDName                    = libFun (fsLit "pragSpecD")                    pragSpecDIdKey pragSpecInlDName                 = libFun (fsLit "pragSpecInlD")                 pragSpecInlDIdKey pragSpecInstDName                = libFun (fsLit "pragSpecInstD")                pragSpecInstDIdKey@@ -706,14 +709,14 @@  -- data RuleMatch = ... conLikeDataConKey, funLikeDataConKey :: Unique-conLikeDataConKey = mkPreludeDataConUnique 203-funLikeDataConKey = mkPreludeDataConUnique 204+conLikeDataConKey = mkPreludeDataConUnique 204+funLikeDataConKey = mkPreludeDataConUnique 205  -- data Phases = ... allPhasesDataConKey, fromPhaseDataConKey, beforePhaseDataConKey :: Unique-allPhasesDataConKey   = mkPreludeDataConUnique 205-fromPhaseDataConKey   = mkPreludeDataConUnique 206-beforePhaseDataConKey = mkPreludeDataConUnique 207+allPhasesDataConKey   = mkPreludeDataConUnique 206+fromPhaseDataConKey   = mkPreludeDataConUnique 207+beforePhaseDataConKey = mkPreludeDataConUnique 208  -- data Overlap = .. overlappableDataConKey,@@ -810,8 +813,8 @@ -- data Exp = ... varEIdKey, conEIdKey, litEIdKey, appEIdKey, appTypeEIdKey, infixEIdKey,     infixAppIdKey, sectionLIdKey, sectionRIdKey, lamEIdKey, lamCaseEIdKey,-    tupEIdKey, unboxedTupEIdKey, unboxedSumEIdKey, condEIdKey, multiIfEIdKey,-    letEIdKey, caseEIdKey, doEIdKey, compEIdKey,+    lamCasesEIdKey, tupEIdKey, unboxedTupEIdKey, unboxedSumEIdKey, condEIdKey,+    multiIfEIdKey, letEIdKey, caseEIdKey, doEIdKey, compEIdKey,     fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,     listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey,     unboundVarEIdKey, labelEIdKey, implicitParamVarEIdKey, mdoEIdKey,@@ -827,52 +830,53 @@ sectionRIdKey          = mkPreludeMiscIdUnique 278 lamEIdKey              = mkPreludeMiscIdUnique 279 lamCaseEIdKey          = mkPreludeMiscIdUnique 280-tupEIdKey              = mkPreludeMiscIdUnique 281-unboxedTupEIdKey       = mkPreludeMiscIdUnique 282-unboxedSumEIdKey       = mkPreludeMiscIdUnique 283-condEIdKey             = mkPreludeMiscIdUnique 284-multiIfEIdKey          = mkPreludeMiscIdUnique 285-letEIdKey              = mkPreludeMiscIdUnique 286-caseEIdKey             = mkPreludeMiscIdUnique 287-doEIdKey               = mkPreludeMiscIdUnique 288-compEIdKey             = mkPreludeMiscIdUnique 289-fromEIdKey             = mkPreludeMiscIdUnique 290-fromThenEIdKey         = mkPreludeMiscIdUnique 291-fromToEIdKey           = mkPreludeMiscIdUnique 292-fromThenToEIdKey       = mkPreludeMiscIdUnique 293-listEIdKey             = mkPreludeMiscIdUnique 294-sigEIdKey              = mkPreludeMiscIdUnique 295-recConEIdKey           = mkPreludeMiscIdUnique 296-recUpdEIdKey           = mkPreludeMiscIdUnique 297-staticEIdKey           = mkPreludeMiscIdUnique 298-unboundVarEIdKey       = mkPreludeMiscIdUnique 299-labelEIdKey            = mkPreludeMiscIdUnique 300-implicitParamVarEIdKey = mkPreludeMiscIdUnique 301-mdoEIdKey              = mkPreludeMiscIdUnique 302-getFieldEIdKey         = mkPreludeMiscIdUnique 303-projectionEIdKey       = mkPreludeMiscIdUnique 304+lamCasesEIdKey         = mkPreludeMiscIdUnique 281+tupEIdKey              = mkPreludeMiscIdUnique 282+unboxedTupEIdKey       = mkPreludeMiscIdUnique 283+unboxedSumEIdKey       = mkPreludeMiscIdUnique 284+condEIdKey             = mkPreludeMiscIdUnique 285+multiIfEIdKey          = mkPreludeMiscIdUnique 286+letEIdKey              = mkPreludeMiscIdUnique 287+caseEIdKey             = mkPreludeMiscIdUnique 288+doEIdKey               = mkPreludeMiscIdUnique 289+compEIdKey             = mkPreludeMiscIdUnique 290+fromEIdKey             = mkPreludeMiscIdUnique 291+fromThenEIdKey         = mkPreludeMiscIdUnique 292+fromToEIdKey           = mkPreludeMiscIdUnique 293+fromThenToEIdKey       = mkPreludeMiscIdUnique 294+listEIdKey             = mkPreludeMiscIdUnique 295+sigEIdKey              = mkPreludeMiscIdUnique 296+recConEIdKey           = mkPreludeMiscIdUnique 297+recUpdEIdKey           = mkPreludeMiscIdUnique 298+staticEIdKey           = mkPreludeMiscIdUnique 299+unboundVarEIdKey       = mkPreludeMiscIdUnique 300+labelEIdKey            = mkPreludeMiscIdUnique 301+implicitParamVarEIdKey = mkPreludeMiscIdUnique 302+mdoEIdKey              = mkPreludeMiscIdUnique 303+getFieldEIdKey         = mkPreludeMiscIdUnique 304+projectionEIdKey       = mkPreludeMiscIdUnique 305  -- type FieldExp = ... fieldExpIdKey :: Unique-fieldExpIdKey       = mkPreludeMiscIdUnique 305+fieldExpIdKey       = mkPreludeMiscIdUnique 306  -- data Body = ... guardedBIdKey, normalBIdKey :: Unique-guardedBIdKey     = mkPreludeMiscIdUnique 306-normalBIdKey      = mkPreludeMiscIdUnique 307+guardedBIdKey     = mkPreludeMiscIdUnique 307+normalBIdKey      = mkPreludeMiscIdUnique 308  -- data Guard = ... normalGEIdKey, patGEIdKey :: Unique-normalGEIdKey     = mkPreludeMiscIdUnique 308-patGEIdKey        = mkPreludeMiscIdUnique 309+normalGEIdKey     = mkPreludeMiscIdUnique 309+patGEIdKey        = mkPreludeMiscIdUnique 310  -- data Stmt = ... bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey, recSIdKey :: Unique-bindSIdKey       = mkPreludeMiscIdUnique 310-letSIdKey        = mkPreludeMiscIdUnique 311-noBindSIdKey     = mkPreludeMiscIdUnique 312-parSIdKey        = mkPreludeMiscIdUnique 313-recSIdKey        = mkPreludeMiscIdUnique 314+bindSIdKey       = mkPreludeMiscIdUnique 311+letSIdKey        = mkPreludeMiscIdUnique 312+noBindSIdKey     = mkPreludeMiscIdUnique 313+parSIdKey        = mkPreludeMiscIdUnique 314+recSIdKey        = mkPreludeMiscIdUnique 315  -- data Dec = ... funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey,@@ -883,7 +887,7 @@     newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivWithStrategyDIdKey,     infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey, patSynDIdKey,     patSynSigDIdKey, pragCompleteDIdKey, implicitParamBindDIdKey,-    kiSigDIdKey :: Unique+    kiSigDIdKey, defaultDIdKey, pragOpaqueDIdKey :: Unique funDIdKey                         = mkPreludeMiscIdUnique 320 valDIdKey                         = mkPreludeMiscIdUnique 321 dataDIdKey                        = mkPreludeMiscIdUnique 322@@ -917,6 +921,8 @@ pragCompleteDIdKey                = mkPreludeMiscIdUnique 350 implicitParamBindDIdKey           = mkPreludeMiscIdUnique 351 kiSigDIdKey                       = mkPreludeMiscIdUnique 352+defaultDIdKey                     = mkPreludeMiscIdUnique 353+pragOpaqueDIdKey                   = mkPreludeMiscIdUnique 354  -- type Cxt = ... cxtIdKey :: Unique
compiler/GHC/Builtin/Utils.hs view
@@ -3,8 +3,8 @@  -} -{-# LANGUAGE CPP #-} + -- | The @GHC.Builtin.Utils@ interface to the compiler's prelude knowledge. -- -- This module serves as the central gathering point for names which the@@ -31,11 +31,9 @@          -- * Miscellaneous         wiredInIds, ghcPrimIds,-        primOpRules, builtinRules,          ghcPrimExports,         ghcPrimDeclDocs,-        primOpId,          -- * Random other things         maybeCharLikeCon, maybeIntLikeCon,@@ -45,12 +43,11 @@      ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Builtin.Uniques import GHC.Builtin.PrimOps+import GHC.Builtin.PrimOps.Ids import GHC.Builtin.Types import GHC.Builtin.Types.Literals ( typeNatTyCons ) import GHC.Builtin.Types.Prim@@ -58,7 +55,6 @@ import GHC.Builtin.Names  import GHC.Core.ConLike ( ConLike(..) )-import GHC.Core.Opt.ConstantFold import GHC.Core.DataCon import GHC.Core.Class import GHC.Core.TyCon@@ -69,20 +65,22 @@ import GHC.Types.Name.Env import GHC.Types.Id.Make import GHC.Types.Unique.FM+import GHC.Types.Unique.Map import GHC.Types.TyThing import GHC.Types.Unique ( isValidKnownKeyUnique )  import GHC.Utils.Outputable import GHC.Utils.Misc as Utils import GHC.Utils.Panic+import GHC.Utils.Constants (debugIsOn) import GHC.Hs.Doc import GHC.Unit.Module.ModIface (IfaceExport) +import GHC.Data.List.SetOps+ import Control.Applicative ((<|>)) import Data.List        ( intercalate , find )-import Data.Array import Data.Maybe-import qualified Data.Map as Map  {- ************************************************************************@@ -132,7 +130,7 @@              , concatMap wired_tycon_kk_names wiredInTyCons              , concatMap wired_tycon_kk_names typeNatTyCons              , map idName wiredInIds-             , map (idName . primOpId) allThePrimOps+             , map idName allThePrimOpIds              , map (idName . primOpWrapperId) allThePrimOps              , basicKnownKeyNames              , templateHaskellNames@@ -229,22 +227,8 @@ We let a lot of "non-standard" values be visible, so that we can make sense of them in interface pragmas. It's cool, though they all have "non-standard" names, so they won't get past the parser in user code.--************************************************************************-*                                                                      *-                PrimOpIds-*                                                                      *-************************************************************************ -} -primOpIds :: Array Int Id--- A cache of the PrimOp Ids, indexed by PrimOp tag-primOpIds = array (1,maxPrimOpTag) [ (primOpTag op, mkPrimOpId op)-                                   | op <- allThePrimOps ]--primOpId :: PrimOp -> Id-primOpId op = primOpIds ! primOpTag op- {- ************************************************************************ *                                                                      *@@ -256,19 +240,19 @@ ghcPrimExports :: [IfaceExport] ghcPrimExports  = map (avail . idName) ghcPrimIds ++-   map (avail . idName . primOpId) allThePrimOps +++   map (avail . idName) allThePrimOpIds ++    [ availTC n [n] []    | tc <- exposedPrimTyCons, let n = tyConName tc  ] -ghcPrimDeclDocs :: DeclDocMap-ghcPrimDeclDocs = DeclDocMap $ Map.fromList $ mapMaybe findName primOpDocs+ghcPrimDeclDocs :: Docs+ghcPrimDeclDocs = emptyDocs { docs_decls = listToUniqMap $ mapMaybe findName primOpDocs }   where     names = map idName ghcPrimIds ++-            map (idName . primOpId) allThePrimOps +++            map idName allThePrimOpIds ++             map tyConName exposedPrimTyCons     findName (nameStr, doc)       | Just name <- find ((nameStr ==) . getOccString) names-      = Just (name, mkHsDocString doc)+      = Just (name, [WithHsDocIdentifiers (mkGeneratedHsDocString doc) []])       | otherwise = Nothing  {-
compiler/GHC/ByteCode/Asm.hs view
@@ -15,8 +15,6 @@         mkTupleInfoLit   ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.ByteCode.Instr@@ -34,7 +32,7 @@  import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Misc+import GHC.Utils.Panic.Plain  import GHC.Core.TyCon import GHC.Data.FastString@@ -204,7 +202,7 @@   (final_insns, final_lits, final_ptrs) <- flip execStateT initial_state $ runAsm platform long_jumps env asm    -- precomputed size should be equal to final size-  ASSERT(n_insns == sizeSS final_insns) return ()+  massert (n_insns == sizeSS final_insns)    let asm_insns = ssElts final_insns       insns_arr = Array.listArray (0, fromIntegral n_insns - 1) asm_insns@@ -342,12 +340,7 @@ --      count (LargeOp _) = largeArg16s platform  -- Bring in all the bci_ bytecode constants.-#include "rts/Bytecodes.h"-#if __GLASGOW_HASKELL__ <= 901-#  define bci_RETURN_T          69-#  define bci_PUSH_ALTS_T       70-#endif-+#include "Bytecodes.h"  largeArgInstr :: Word16 -> Word16 largeArgInstr bci = bci_FLAG_LARGE_ARGS .|. bci@@ -495,8 +488,7 @@       LitNumWord32  -> int32 (fromIntegral i)       LitNumInt64   -> int64 (fromIntegral i)       LitNumWord64  -> int64 (fromIntegral i)-      LitNumInteger -> panic "GHC.ByteCode.Asm.literal: LitNumInteger"-      LitNumNatural -> panic "GHC.ByteCode.Asm.literal: LitNumNatural"+      LitNumBigNat  -> panic "GHC.ByteCode.Asm.literal: LitNumBigNat"      -- We can lower 'LitRubbish' to an arbitrary constant, but @NULL@ is most     -- likely to elicit a crash (rather than corrupt memory) in case absence@@ -505,7 +497,7 @@      litlabel fs = lit [BCONPtrLbl fs]     addr (RemotePtr a) = words [fromIntegral a]-    float = words . mkLitF+    float = words . mkLitF platform     double = words . mkLitD platform     int = words . mkLitI     int8 = words . mkLitI64 platform@@ -574,9 +566,9 @@               text "Use -fobject-code to get around this limit"              )   | otherwise-  = ASSERT(length regs <= 24) {- 24 bits for bitmap -}-    ASSERT(tupleNativeStackSize < 255) {- 8 bits for stack size -}-    ASSERT(all (`elem` regs) (regSetToList tupleRegs)) {- all regs accounted for -}+  = assert (length regs <= 24) {- 24 bits for bitmap -}+    assert (tupleNativeStackSize < 255) {- 8 bits for stack size -}+    assert (all (`elem` regs) (regSetToList tupleRegs)) {- all regs accounted for -}     foldl' reg_bit 0 (zip regs [0..]) .|.       (fromIntegral tupleNativeStackSize `shiftL` 24)   where@@ -594,18 +586,28 @@ -- words are placed in memory at increasing addresses, the -- bit pattern is correct for the host's word size and endianness. mkLitI   ::             Int    -> [Word]-mkLitF   ::             Float  -> [Word]+mkLitF   :: Platform -> Float  -> [Word] mkLitD   :: Platform -> Double -> [Word] mkLitI64 :: Platform -> Int64  -> [Word] -mkLitF f-   = runST (do+mkLitF platform f = case platformWordSize platform of+  PW4 -> runST $ do         arr <- newArray_ ((0::Int),0)         writeArray arr 0 f         f_arr <- castSTUArray arr         w0 <- readArray f_arr 0         return [w0 :: Word]-     )++  PW8 -> runST $ do+        arr <- newArray_ ((0::Int),1)+        writeArray arr 0 f+        -- on 64-bit architectures we read two (32-bit) Float cells when we read+        -- a (64-bit) Word: so we write a dummy value in the second cell to+        -- avoid an out-of-bound read.+        writeArray arr 1 0.0+        f_arr <- castSTUArray arr+        w0 <- readArray f_arr 0+        return [w0 :: Word]  mkLitD platform d = case platformWordSize platform of    PW4 -> runST (do
compiler/GHC/ByteCode/InfoTable.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} --@@ -8,11 +8,7 @@ -- | Generate infotables for interpreter-made bytecodes module GHC.ByteCode.InfoTable ( mkITbls ) where -#include "GhclibHsVersions.h"- import GHC.Prelude--import GHC.Driver.Session  import GHC.Platform import GHC.Platform.Profile
compiler/GHC/ByteCode/Instr.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP              #-}+ {-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -funbox-strict-fields #-} --@@ -10,8 +10,6 @@         BCInstr(..), ProtoBCO(..), bciStackUse, LocalLabel(..)   ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.ByteCode.Types@@ -225,7 +223,7 @@   char '{' <+> ppr (fst (head bs)) <+> text "= ...; ... }"  pprStgAltShort :: OutputablePass pass => StgPprOpts -> GenStgAlt pass -> SDoc-pprStgAltShort opts (con, args, expr) =+pprStgAltShort opts GenStgAlt{alt_con=con, alt_bndrs=args, alt_rhs=expr} =   ppr con <+> sep (map ppr args) <+> text "->" <+> pprStgExprShort opts expr  pprStgRhsShort :: OutputablePass pass => StgPprOpts -> GenStgRhs pass -> SDoc
compiler/GHC/ByteCode/Linker.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP                   #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MagicHash             #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -20,8 +19,6 @@   ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Runtime.Interpreter@@ -31,6 +28,7 @@ import GHCi.BreakArray  import GHC.Builtin.PrimOps+import GHC.Builtin.Names  import GHC.Unit.Types import GHC.Unit.Module.Name@@ -39,8 +37,8 @@ import GHC.Data.SizedSeq  import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Outputable-import GHC.Utils.Misc  import GHC.Types.Name import GHC.Types.Name.Env@@ -150,7 +148,7 @@     -> return (ResolvedBCOPtr (unsafeForeignRefToRemoteRef rhv))      | otherwise-    -> ASSERT2(isExternalName nm, ppr nm)+    -> assertPpr (isExternalName nm) (ppr nm) $        do           let sym_to_find = nameToCLabel nm "closure"           m <- lookupSymbol interp sym_to_find@@ -187,7 +185,11 @@ nameToCLabel n suffix = mkFastString label   where     encodeZ = zString . zEncodeFS-    (Module pkgKey modName) = ASSERT( isExternalName n ) nameModule n+    (Module pkgKey modName) = assert (isExternalName n) $ case nameModule n of+        -- Primops are exported from GHC.Prim, their HValues live in GHC.PrimopWrappers+        -- See Note [Primop wrappers] in GHC.Builtin.PrimOps.+        mod | mod == gHC_PRIM -> gHC_PRIMOPWRAPPERS+        mod -> mod     packagePart = encodeZ (unitFS pkgKey)     modulePart  = encodeZ (moduleNameFS modName)     occPart     = encodeZ (occNameFS (nameOccName n))
compiler/GHC/Cmm/CallConv.hs view
@@ -14,7 +14,6 @@ import GHC.Cmm (Convention(..)) import GHC.Cmm.Ppr () -- For Outputable instances -import GHC.Driver.Session import GHC.Platform import GHC.Platform.Profile import GHC.Utils.Outputable
compiler/GHC/Cmm/CommonBlockElim.hs view
@@ -222,7 +222,7 @@ eqExprWith eqBid = eq  where   CmmLit l1          `eq` CmmLit l2          = eqLit l1 l2-  CmmLoad e1 t1 a1   `eq` CmmLoad e2 t2 a2   = t1 `cmmEqType` t2 && e1 `eq` e2 && a1 == a2+  CmmLoad e1 t1 a1   `eq` CmmLoad e2 t2 a2   = t1 `cmmEqType` t2 && e1 `eq` e2 && a1==a2   CmmReg r1          `eq` CmmReg r2          = r1==r2   CmmRegOff r1 i1    `eq` CmmRegOff r2 i2    = r1==r2 && i1==i2   CmmMachOp op1 es1  `eq` CmmMachOp op2 es2  = op1==op2 && es1 `eqs` es2
+ compiler/GHC/Cmm/Config.hs view
@@ -0,0 +1,31 @@+-- | Cmm compilation configuration++{-# LANGUAGE DerivingStrategies         #-}++module GHC.Cmm.Config+  ( CmmConfig(..)+  , cmmPlatform+  ) where++import GHC.Prelude++import GHC.Platform+import GHC.Platform.Profile+++data CmmConfig = CmmConfig+  { cmmProfile             :: !Profile -- ^ Target Profile+  , cmmOptControlFlow      :: !Bool    -- ^ Optimize Cmm Control Flow or not+  , cmmDoLinting           :: !Bool    -- ^ Do Cmm Linting Optimization or not+  , cmmOptElimCommonBlks   :: !Bool    -- ^ Eliminate common blocks or not+  , cmmOptSink             :: !Bool    -- ^ Perform sink after stack layout or not+  , cmmGenStackUnwindInstr :: !Bool    -- ^ Generate stack unwinding instructions (for debugging)+  , cmmExternalDynamicRefs :: !Bool    -- ^ Generate code to link against dynamic libraries+  , cmmDoCmmSwitchPlans    :: !Bool    -- ^ Should the Cmm pass replace Stg switch statements+  , cmmSplitProcPoints     :: !Bool    -- ^ Should Cmm split proc points or not+  }++-- | retrieve the target Cmm platform+cmmPlatform :: CmmConfig -> Platform+cmmPlatform = profilePlatform . cmmProfile+
compiler/GHC/Cmm/ContFlowOpt.hs view
@@ -29,7 +29,6 @@  -- Note [What is shortcutting] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~--- -- Consider this Cmm code: -- -- L1: ...@@ -53,7 +52,6 @@  -- Note [Control-flow optimisations] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- -- This optimisation does three things: -- --   - If a block finishes in an unconditional branch to another block@@ -80,7 +78,6 @@  -- Note [Shortcut call returns] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- -- We are going to maintain the "current" graph (LabelMap CmmBlock) as -- we go, and also a mapping from BlockId to BlockId, representing -- continuation labels that we have renamed.  This latter mapping is@@ -106,7 +103,6 @@  -- Note [Shortcut call returns and proc-points] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- -- Consider this code that you might get from a recursive -- let-no-escape: --
compiler/GHC/Cmm/Dataflow.hs view
@@ -82,6 +82,11 @@  type TransferFun f = CmmBlock -> FactBase f -> FactBase f +-- | `TransferFun` abstracted over `n` (the node type)+type TransferFun' (n :: Extensibility -> Extensibility -> Type) f =+    Block n C C -> FactBase f -> FactBase f++ -- | Function for rewrtiting and analysis combined. To be used with -- @rewriteCmm@. --@@ -90,20 +95,26 @@ -- to the particular monads through SPECIALIZE). type RewriteFun f = CmmBlock -> FactBase f -> UniqSM (CmmBlock, FactBase f) +-- | `RewriteFun` abstracted over `n` (the node type)+type RewriteFun' (n :: Extensibility -> Extensibility -> Type) f =+    Block n C C -> FactBase f -> UniqSM (Block n C C, FactBase f)+ analyzeCmmBwd, analyzeCmmFwd-    :: DataflowLattice f-    -> TransferFun f-    -> CmmGraph+    :: (NonLocal node)+    => DataflowLattice f+    -> TransferFun' node f+    -> GenCmmGraph node     -> FactBase f     -> FactBase f analyzeCmmBwd = analyzeCmm Bwd analyzeCmmFwd = analyzeCmm Fwd  analyzeCmm-    :: Direction+    :: (NonLocal node)+    => Direction     -> DataflowLattice f-    -> TransferFun f-    -> CmmGraph+    -> TransferFun' node f+    -> GenCmmGraph node     -> FactBase f     -> FactBase f analyzeCmm dir lattice transfer cmmGraph initFact =@@ -117,12 +128,13 @@  -- Fixpoint algorithm. fixpointAnalysis-    :: forall f.-       Direction+    :: forall f node.+       (NonLocal node)+    => Direction     -> DataflowLattice f-    -> TransferFun f+    -> TransferFun' node f     -> Label-    -> LabelMap CmmBlock+    -> LabelMap (Block node C C)     -> FactBase f     -> FactBase f fixpointAnalysis direction lattice do_block entry blockmap = loop start@@ -139,8 +151,8 @@     join       = fact_join lattice      loop-        :: IntHeap     -- ^ Worklist, i.e., blocks to process-        -> FactBase f  -- ^ Current result (increases monotonically)+        :: IntHeap     -- Worklist, i.e., blocks to process+        -> FactBase f  -- Current result (increases monotonically)         -> FactBase f     loop todo !fbase1 | Just (index, todo1) <- IntSet.minView todo =         let block = block_arr ! index@@ -155,20 +167,22 @@     loop _ !fbase1 = fbase1  rewriteCmmBwd-    :: DataflowLattice f-    -> RewriteFun f-    -> CmmGraph+    :: (NonLocal node)+    => DataflowLattice f+    -> RewriteFun' node f+    -> GenCmmGraph node     -> FactBase f-    -> UniqSM (CmmGraph, FactBase f)+    -> UniqSM (GenCmmGraph node, FactBase f) rewriteCmmBwd = rewriteCmm Bwd  rewriteCmm-    :: Direction+    :: (NonLocal node)+    => Direction     -> DataflowLattice f-    -> RewriteFun f-    -> CmmGraph+    -> RewriteFun' node f+    -> GenCmmGraph node     -> FactBase f-    -> UniqSM (CmmGraph, FactBase f)+    -> UniqSM (GenCmmGraph node, FactBase f) rewriteCmm dir lattice rwFun cmmGraph initFact = {-# SCC rewriteCmm #-} do     let entry = g_entry cmmGraph         hooplGraph = g_graph cmmGraph@@ -180,14 +194,15 @@     return (cmmGraph {g_graph = GMany NothingO blockMap2 NothingO}, facts)  fixpointRewrite-    :: forall f.-       Direction+    :: forall f node.+       NonLocal node+    => Direction     -> DataflowLattice f-    -> RewriteFun f+    -> RewriteFun' node f     -> Label-    -> LabelMap CmmBlock+    -> LabelMap (Block node C C)     -> FactBase f-    -> UniqSM (LabelMap CmmBlock, FactBase f)+    -> UniqSM (LabelMap (Block node C C), FactBase f) fixpointRewrite dir lattice do_block entry blockmap = loop start blockmap   where     -- Sorting the blocks helps to minimize the number of times we need to@@ -203,10 +218,10 @@     join       = fact_join lattice      loop-        :: IntHeap            -- ^ Worklist, i.e., blocks to process-        -> LabelMap CmmBlock  -- ^ Rewritten blocks.-        -> FactBase f         -- ^ Current facts.-        -> UniqSM (LabelMap CmmBlock, FactBase f)+        :: IntHeap                    -- Worklist, i.e., blocks to process+        -> LabelMap (Block node C C)  -- Rewritten blocks.+        -> FactBase f                 -- Current facts.+        -> UniqSM (LabelMap (Block node C C), FactBase f)     loop todo !blocks1 !fbase1       | Just (index, todo1) <- IntSet.minView todo = do         -- Note that we use the *original* block here. This is important.@@ -279,7 +294,7 @@     fwd = revPostorderFrom blockmap entry  -- Note [Backward vs forward analysis]---+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- The forward and backward cases are not dual.  In the forward case, the entry -- points are known, and one simply traverses the body blocks from those points. -- In the backward case, something is known about the exit points, but a@@ -309,7 +324,7 @@ -- * for a backward analysis we need to re-analyze all the predecessors, but -- * for a forward analysis, we only need to re-analyze the current block --   (and that will in turn propagate facts into its successors).-mkDepBlocks :: Direction -> [CmmBlock] -> LabelMap IntSet+mkDepBlocks :: NonLocal node => Direction -> [Block node C C] -> LabelMap IntSet mkDepBlocks Fwd blocks = go blocks 0 mapEmpty   where     go []     !_ !dep_map = dep_map@@ -335,7 +350,7 @@ updateFact fact_join dep_blocks (todo, fbase) lbl new_fact   = case lookupFact lbl fbase of       Nothing ->-          -- Note [No old fact]+          -- See Note [No old fact]           let !z = mapInsert lbl new_fact fbase in (changed, z)       Just old_fact ->           case fact_join (OldFact old_fact) (NewFact new_fact) of@@ -347,7 +362,7 @@  {- Note [No old fact]-+~~~~~~~~~~~~~~~~~~ We know that the new_fact is >= _|_, so we don't need to join.  However, if the new fact is also _|_, and we have already analysed its block, we don't need to record a change.  So there's a tradeoff here.  It turns@@ -396,7 +411,7 @@  -- | Folds backward over all nodes of an open-open block. -- Strict in the accumulator.-foldNodesBwdOO :: (CmmNode O O -> f -> f) -> Block CmmNode O O -> f -> f+foldNodesBwdOO :: (node O O -> f -> f) -> Block node O O -> f -> f foldNodesBwdOO funOO = go   where     go (BCat b1 b2) f = go b1 $! go b2 f@@ -411,11 +426,11 @@ -- dataflow facts). -- Strict in both accumulated parts. foldRewriteNodesBwdOO-    :: forall f.-       (CmmNode O O -> f -> UniqSM (Block CmmNode O O, f))-    -> Block CmmNode O O+    :: forall f node.+       (node O O -> f -> UniqSM (Block node O O, f))+    -> Block node O O     -> f-    -> UniqSM (Block CmmNode O O, f)+    -> UniqSM (Block node O O, f) foldRewriteNodesBwdOO rewriteOO initBlock initFacts = go initBlock initFacts   where     go (BCons node1 block1) !fact1 = (rewriteOO node1 `comp` go block1) fact1
compiler/GHC/Cmm/Graph.hs view
@@ -38,8 +38,8 @@ import GHC.Data.OrdList import GHC.Runtime.Heap.Layout (ByteOff) import GHC.Types.Unique.Supply-import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Constants (debugIsOn)   -----------------------------------------------------------------------------@@ -426,7 +426,7 @@   -- Note [Width of parameters]---+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~ -- Consider passing a small (< word width) primitive like Int8# to a function. -- It's actually non-trivial to do this without extending/narrowing: -- * Global registers are considered to have native word width (i.e., 64-bits on
compiler/GHC/Cmm/Info.hs view
@@ -1,11 +1,10 @@-{-# LANGUAGE CPP #-}+ module GHC.Cmm.Info (   mkEmptyContInfoTable,   cmmToRawCmm,   srtEscape,    -- info table accessors-  PtrOpts (..),   closureInfoPtr,   entryCode,   getConstrTag,@@ -32,8 +31,6 @@   stdPtrsOffset, stdNonPtrsOffset, ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Cmm@@ -48,9 +45,9 @@ import GHC.Platform import GHC.Platform.Profile import GHC.Data.Maybe-import GHC.Driver.Session import GHC.Utils.Error (withTimingSilent) import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Types.Unique.Supply import GHC.Utils.Logger import GHC.Utils.Monad@@ -68,20 +65,19 @@                  , cit_srt  = Nothing                  , cit_clo  = Nothing } -cmmToRawCmm :: Logger -> DynFlags -> Stream IO CmmGroupSRTs a+cmmToRawCmm :: Logger -> Profile -> Stream IO CmmGroupSRTs a             -> IO (Stream IO RawCmmGroup a)-cmmToRawCmm logger dflags cmms+cmmToRawCmm logger profile cmms   = do {        ; let do_one :: [CmmDeclSRTs] -> IO [RawCmmDecl]              do_one cmm = do                uniqs <- mkSplitUniqSupply 'i'                -- NB. strictness fixes a space leak.  DO NOT REMOVE.-               withTimingSilent logger dflags (text "Cmm -> Raw Cmm")-                          (\x -> seqList x ())+               withTimingSilent logger (text "Cmm -> Raw Cmm") (\x -> seqList x ())                   -- TODO: It might be better to make `mkInfoTable` run in                   -- IO as well so we don't have to pass around                   -- a UniqSupply (see #16843)-                 (return $ initUs_ uniqs $ concatMapM (mkInfoTable dflags) cmm)+                 (return $ initUs_ uniqs $ concatMapM (mkInfoTable profile) cmm)        ; return (Stream.mapM do_one cmms)        } @@ -101,7 +97,7 @@ --      <normal forward rest of StgInfoTable> --      <forward variable part> -----      See includes/rts/storage/InfoTables.h+--      See rts/include/rts/storage/InfoTables.h -- -- For return-points these are as follows --@@ -119,15 +115,15 @@ -- --  * The SRT slot is only there if there is SRT info to record -mkInfoTable :: DynFlags -> CmmDeclSRTs -> UniqSM [RawCmmDecl]+mkInfoTable :: Profile -> CmmDeclSRTs -> UniqSM [RawCmmDecl] mkInfoTable _ (CmmData sec dat) = return [CmmData sec dat] -mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks)+mkInfoTable profile proc@(CmmProc infos entry_lbl live blocks)   --   -- in the non-tables-next-to-code case, procs can have at most a   -- single info table associated with the entry label of the proc.   ---  | not (platformTablesNextToCode (targetPlatform dflags))+  | not (platformTablesNextToCode platform)   = case topInfoTable proc of   --  must be at most one       -- no info table       Nothing ->@@ -135,7 +131,7 @@        Just info@CmmInfoTable { cit_lbl = info_lbl } -> do         (top_decls, (std_info, extra_bits)) <--             mkInfoTableContents dflags info Nothing+             mkInfoTableContents profile info Nothing         let           rel_std_info   = map (makeRelativeRefTo platform info_lbl) std_info           rel_extra_bits = map (makeRelativeRefTo platform info_lbl) extra_bits@@ -162,10 +158,10 @@             [CmmProc (mapFromList raw_infos) entry_lbl live blocks])    where-   platform = targetPlatform dflags+   platform = profilePlatform profile    do_one_info (lbl,itbl) = do      (top_decls, (std_info, extra_bits)) <--         mkInfoTableContents dflags itbl Nothing+         mkInfoTableContents profile itbl Nothing      let         info_lbl = cit_lbl itbl         rel_std_info   = map (makeRelativeRefTo platform info_lbl) std_info@@ -179,20 +175,20 @@                          , [CmmLit] )        -- The "extra bits" -- These Lits have *not* had mkRelativeTo applied to them -mkInfoTableContents :: DynFlags+mkInfoTableContents :: Profile                     -> CmmInfoTable                     -> Maybe Int               -- Override default RTS type tag?                     -> UniqSM ([RawCmmDecl],             -- Auxiliary top decls                                InfoTableContents)       -- Info tbl + extra bits -mkInfoTableContents dflags+mkInfoTableContents profile                     info@(CmmInfoTable { cit_lbl  = info_lbl                                        , cit_rep  = smrep                                        , cit_prof = prof                                        , cit_srt = srt })                     mb_rts_tag   | RTSRep rts_tag rep <- smrep-  = mkInfoTableContents dflags info{cit_rep = rep} (Just rts_tag)+  = mkInfoTableContents profile info{cit_rep = rep} (Just rts_tag)     -- Completely override the rts_tag that mkInfoTableContents would     -- otherwise compute, with the rts_tag stored in the RTSRep     -- (which in turn came from a handwritten .cmm file)@@ -200,9 +196,9 @@   | StackRep frame <- smrep   = do { (prof_lits, prof_data) <- mkProfLits platform prof        ; let (srt_label, srt_bitmap) = mkSRTLit platform info_lbl srt-       ; (liveness_lit, liveness_data) <- mkLivenessBits dflags frame+       ; (liveness_lit, liveness_data) <- mkLivenessBits platform frame        ; let-             std_info = mkStdInfoTable dflags prof_lits rts_tag srt_bitmap liveness_lit+             std_info = mkStdInfoTable profile prof_lits rts_tag srt_bitmap liveness_lit              rts_tag | Just tag <- mb_rts_tag = tag                      | null liveness_data     = rET_SMALL -- Fits in extra_bits                      | otherwise              = rET_BIG   -- Does not; extra_bits is@@ -215,13 +211,13 @@        ; let (srt_label, srt_bitmap) = mkSRTLit platform info_lbl srt        ; (mb_srt_field, mb_layout, extra_bits, ct_data)                                 <- mk_pieces closure_type srt_label-       ; let std_info = mkStdInfoTable dflags prof_lits+       ; let std_info = mkStdInfoTable profile prof_lits                                        (mb_rts_tag   `orElse` rtsClosureType smrep)                                        (mb_srt_field `orElse` srt_bitmap)                                        (mb_layout    `orElse` layout)        ; return (prof_data ++ ct_data, (std_info, extra_bits)) }   where-    platform = targetPlatform dflags+    platform = profilePlatform profile     mk_pieces :: ClosureTypeInfo -> [CmmLit]               -> UniqSM ( Maybe CmmLit  -- Override the SRT field with this                         , Maybe CmmLit  -- Override the layout field with this@@ -246,7 +242,7 @@            ; return (Nothing, Nothing,  extra_bits, []) }      mk_pieces (Fun arity (ArgGen arg_bits)) srt_label-      = do { (liveness_lit, liveness_data) <- mkLivenessBits dflags arg_bits+      = do { (liveness_lit, liveness_data) <- mkLivenessBits platform arg_bits            ; let fun_type | null liveness_data = aRG_GEN                           | otherwise          = aRG_GEN_BIG                  extra_bits = [ packIntsCLit platform fun_type arity ]@@ -257,7 +253,7 @@         slow_entry = CmmLabel (toSlowEntryLbl platform info_lbl)         srt_lit = case srt_label of                     []          -> mkIntCLit platform 0-                    (lit:_rest) -> ASSERT( null _rest ) lit+                    (lit:_rest) -> assert (null _rest) lit      mk_pieces other _ = pprPanic "mk_pieces" (ppr other) @@ -286,8 +282,7 @@ -- See the section "Referring to an SRT from the info table" in -- Note [SRTs] in "GHC.Cmm.Info.Build" inlineSRT :: Platform -> Bool-inlineSRT platform = platformArch platform == ArchX86_64-  && platformTablesNextToCode platform+inlineSRT = pc_USE_INLINE_SRT_FIELD . platformConstants  ------------------------------------------------------------------------- --@@ -344,12 +339,12 @@ -- The head of the stack layout is the top of the stack and -- the least-significant bit. -mkLivenessBits :: DynFlags -> Liveness -> UniqSM (CmmLit, [RawCmmDecl])+mkLivenessBits :: Platform -> Liveness -> UniqSM (CmmLit, [RawCmmDecl])               -- ^ Returns:               --   1. The bitmap (literal value or label)               --   2. Large bitmap CmmData if needed -mkLivenessBits dflags liveness+mkLivenessBits platform liveness   | n_bits > mAX_SMALL_BITMAP_SIZE platform -- does not fit in one word   = do { uniq <- getUniqueM        ; let bitmap_lbl = mkBitmapLabel uniq@@ -359,7 +354,6 @@   | otherwise -- Fits in one word   = return (mkStgWordCLit platform bitmap_word, [])   where-    platform = targetPlatform dflags     n_bits = length liveness      bitmap :: Bitmap@@ -375,7 +369,7 @@     lits = mkWordCLit platform (fromIntegral n_bits)          : map (mkStgWordCLit platform) bitmap       -- The first word is the size.  The structure must match-      -- StgLargeBitmap in includes/rts/storage/InfoTable.h+      -- StgLargeBitmap in rts/include/rts/storage/InfoTable.h  ------------------------------------------------------------------------- --@@ -385,20 +379,20 @@  -- The standard bits of an info table.  This part of the info table -- corresponds to the StgInfoTable type defined in--- includes/rts/storage/InfoTables.h.+-- rts/include/rts/storage/InfoTables.h. -- -- Its shape varies with ticky/profiling/tables next to code etc -- so we can't use constant offsets from Constants  mkStdInfoTable-   :: DynFlags+   :: Profile    -> (CmmLit,CmmLit)   -- Closure type descr and closure descr  (profiling)    -> Int               -- Closure RTS tag    -> CmmLit            -- SRT length    -> CmmLit            -- layout field    -> [CmmLit] -mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt layout_lit+mkStdInfoTable profile (type_descr, closure_descr) cl_type srt layout_lit  =      -- Parallel revertible-black hole field     prof_info         -- Ticky info (none at present)@@ -406,9 +400,9 @@  ++ [layout_lit, tag, srt]   where-    platform = targetPlatform dflags+    platform = profilePlatform profile     prof_info-        | sccProfilingEnabled dflags = [type_descr, closure_descr]+        | profileIsProfiling profile = [type_descr, closure_descr]         | otherwise = []      tag = CmmInt (fromIntegral cl_type) (halfWordWidth platform)@@ -444,25 +438,19 @@ -- ------------------------------------------------------------------------- -data PtrOpts = PtrOpts-   { po_profile     :: !Profile -- ^ Platform profile-   , po_align_check :: !Bool    -- ^ Insert alignment check (cf @-falignment-sanitisation@)-   }- -- | Wrap a 'CmmExpr' in an alignment check when @-falignment-sanitisation@ is -- enabled.-wordAligned :: PtrOpts -> CmmExpr -> CmmExpr-wordAligned opts e-  | po_align_check opts+wordAligned :: Platform -> DoAlignSanitisation -> CmmExpr -> CmmExpr+wordAligned platform align_check e+  | align_check   = CmmMachOp (MO_AlignmentCheck (platformWordSizeInBytes platform) (wordWidth platform)) [e]   | otherwise   = e-  where platform = profilePlatform (po_profile opts)  -- | Takes a closure pointer and returns the info table pointer-closureInfoPtr :: PtrOpts -> CmmExpr -> CmmExpr-closureInfoPtr opts@(PtrOpts profile _) e =-    cmmLoadBWord  (profilePlatform profile) (wordAligned opts e)+closureInfoPtr :: Platform -> DoAlignSanitisation -> CmmExpr -> CmmExpr+closureInfoPtr platform align_check e =+    cmmLoadBWord platform (wordAligned platform align_check e)  -- | Takes an info pointer (the first word of a closure) and returns its entry -- code@@ -476,23 +464,21 @@ -- constructor tag obtained from the info table -- This lives in the SRT field of the info table -- (constructors don't need SRTs).-getConstrTag :: PtrOpts -> CmmExpr -> CmmExpr-getConstrTag opts closure_ptr+getConstrTag :: Profile -> DoAlignSanitisation -> CmmExpr -> CmmExpr+getConstrTag profile align_check closure_ptr   = CmmMachOp (MO_UU_Conv (halfWordWidth platform) (wordWidth platform)) [infoTableConstrTag profile info_table]   where-    info_table = infoTable profile (closureInfoPtr opts closure_ptr)+    info_table = infoTable profile (closureInfoPtr platform align_check closure_ptr)     platform   = profilePlatform profile-    profile    = po_profile opts  -- | Takes a closure pointer, and return the closure type -- obtained from the info table-cmmGetClosureType :: PtrOpts -> CmmExpr -> CmmExpr-cmmGetClosureType opts closure_ptr+cmmGetClosureType :: Profile -> DoAlignSanitisation -> CmmExpr -> CmmExpr+cmmGetClosureType profile align_check closure_ptr   = CmmMachOp (MO_UU_Conv (halfWordWidth platform) (wordWidth platform)) [infoTableClosureType profile info_table]   where-    info_table = infoTable profile (closureInfoPtr opts closure_ptr)+    info_table = infoTable profile (closureInfoPtr platform align_check closure_ptr)     platform   = profilePlatform profile-    profile    = po_profile opts  -- | Takes an info pointer (the first word of a closure) -- and returns a pointer to the first word of the standard-form
compiler/GHC/Cmm/Info/Build.hs view
@@ -23,6 +23,7 @@ import GHC.Types.Id import GHC.Types.Id.Info import GHC.Cmm.BlockId+import GHC.Cmm.Config import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label@@ -33,7 +34,6 @@ import GHC.Cmm.CLabel import GHC.Cmm import GHC.Cmm.Utils-import GHC.Driver.Session import GHC.Data.Maybe import GHC.Utils.Outputable import GHC.Utils.Panic@@ -41,7 +41,6 @@ import GHC.Types.Unique.Supply import GHC.Types.CostCentre import GHC.StgToCmm.Heap-import GHC.CmmToAsm  import Control.Monad import Data.Map.Strict (Map)@@ -55,9 +54,11 @@ import GHC.Types.Name.Set  {- Note [SRTs]--SRTs are the mechanism by which the garbage collector can determine-the live CAFs in the program.+   ~~~~~~~~~~~+Static Reference Tables (SRTs) are the mechanism by which the garbage collector+can determine the live CAFs in the program. An SRT is a static table associated+with a CAFfy closure which record which CAFfy objects are reachable from+the closure's code.  Representation ^^^^^^^^^^^^^^@@ -112,9 +113,15 @@ - Static thunks (THUNK), ie. CAFs - Continuations (RET_SMALL, etc.) -In each case, the info table points to the SRT.+In each case, the info table points to the SRT.  There are three ways which we+may encode the location of the SRT in the info table, described below. -- info->srt is zero if there's no SRT, otherwise:+USE_SRT_OFFSET+--------------+In this case we use the info->srt to encode whether or not there is an+SRT and if so encode the offset to its location in info->f.srt_offset:++- info->srt is 0 if there's no SRT, otherwise, - info->srt == 1 and info->f.srt_offset points to the SRT  e.g. for a FUN with an SRT:@@ -128,12 +135,27 @@   info->type          | ...  |                       |------| -On x86_64, we optimise the info table representation further.  The-offset to the SRT can be stored in 32 bits (all code lives within a-2GB region in x86_64's small memory model), so we can save a word in-the info table by storing the srt_offset in the srt field, which is-half a word.+USE_SRT_POINTER+---------------+When tables-next-to-code isn't in use we rather encode an absolute pointer to+the SRT in info->srt. e.g. for a FUN with an SRT: +StgFunInfoTable       +------++  info->f.srt_offset  |  ------------> pointer to SRT object+StgStdInfoTable       +------++  info->layout.ptrs   | ...  |+  info->layout.nptrs  | ...  |+  info->srt           |  1   |+  info->type          | ...  |+                      |------|+USE_INLINE_SRT_FIELD+--------------------+When using TNTC on x86_64 (and other platforms using the small memory model),+we optimise the info table representation further.  The offset to the SRT can+be stored in 32 bits (all code lives within a 2GB region in x86_64's small+memory model), so we can save a word in the info table by storing the+srt_offset in the srt field, which is half a word.+ On x86_64 with TABLES_NEXT_TO_CODE (except on MachO, due to #15169):  - info->srt is zero if there's no SRT, otherwise:@@ -201,22 +223,23 @@ Algorithm ^^^^^^^^^ -0. let srtMap :: Map CAFLabel (Maybe SRTEntry) = {}+0. let srtMap :: Map CAFfyLabel (Maybe SRTEntry) = {}    Maps closures to their SRT entries (i.e. how they appear in a SRT payload)  1. Start with decls :: [CmmDecl]. This corresponds to an SCC of bindings in STG    after code-generation. -2. CPS-convert each CmmDecl (cpsTop), resulting in a list [CmmDecl]. There might-   be multiple CmmDecls in the result, due to proc-point splitting.+2. CPS-convert each CmmDecl (GHC.Cmm.Pipeline.cpsTop), resulting in a list+   [CmmDecl]. There might be multiple CmmDecls in the result, due to proc-point+   splitting.  3. In cpsTop, *before* proc-point splitting, when we still have a single    CmmDecl, we do cafAnal for procs:     * cafAnal performs a backwards analysis on the code blocks -   * For each labelled block, the analysis produces a CAFSet (= Set CAFLabel),-     representing all the CAFLabels reachable from this label.+   * For each labelled block, the analysis produces a CAFSet (= Set CAFfyLabel),+     representing all the CAFfyLabels reachable from this label.     * A label is added to the set if it refers to a FUN, THUNK, or RET,      and its CafInfo /= NoCafRefs.@@ -241,20 +264,21 @@  6. For static data generate a Map CLabel CAFSet (maps static data to their CAFSets) -7. Dependency-analyse the decls using CAFEnv and CAFSets, giving us SCC CAFLabel+7. Dependency-analyse the decls using CAFEnv and CAFSets, giving us SCC CAFfyLabel  8. For each SCC in dependency order-   - Let lbls :: [CAFLabel] be the non-recursive labels in this SCC-   - Apply CAFEnv to each label and concat the result :: [CAFLabel]-   - For each CAFLabel in the set apply srtMap (and ignore Nothing) to get+   - Let lbls :: [CAFfyLabel] be the non-recursive labels in this SCC+   - Apply CAFEnv to each label and concat the result :: [CAFfyLabel]+   - For each CAFfyLabel in the set apply srtMap (and ignore Nothing) to get      srt :: [SRTEntry]    - Make a label for this SRT, call it l    - If the SRT is not empty (i.e. the group is CAFFY) add FUN_STATICs in the      group to the SRT (see Note [Invalid optimisation: shortcutting])    - Add to srtMap: lbls -> if null srt then Nothing else Just l -9. At the end, for every top-level binding x, if srtMap x == Nothing, then the-   binding is non-CAFFY, otherwise it is CAFFY.+9. At the end, update the IdInfo for every top-level binding x:+   if srtMap x == Nothing, then the binding is non-CAFFY, otherwise it is+   CAFFY.  Optimisations ^^^^^^^^^^^^^@@ -476,34 +500,39 @@ -- --------------------------------------------------------------------- -- Label types --- Labels that come from cafAnal can be:---   - _closure labels for static functions or CAFs---   - _info labels for dynamic functions, thunks, or continuations---   - _entry labels for functions or thunks+-- |+-- The label of a CAFfy thing. ----- Meanwhile the labels on top-level blocks are _entry labels.+-- Labels that come from 'cafAnal' can be:+--   - @_closure@ labels for static functions, static data constructor+--     applications, or static thunks+--   - @_info@ labels for dynamic functions, thunks, or continuations+--   - @_entry@ labels for functions or thunks --+-- Meanwhile the labels on top-level blocks are @_entry@ labels.+-- -- To put everything in the same namespace we convert all labels to--- closure labels using toClosureLbl.  Note that some of these+-- closure labels using 'toClosureLbl'.  Note that some of these -- labels will not actually exist; that's ok because we're going to -- map them to SRTEntry later, which ranges over labels that do exist. ---newtype CAFLabel = CAFLabel CLabel+newtype CAFfyLabel = CAFfyLabel CLabel   deriving (Eq,Ord) -deriving newtype instance OutputableP env CLabel => OutputableP env CAFLabel+deriving newtype instance OutputableP env CLabel => OutputableP env CAFfyLabel -type CAFSet = Set CAFLabel+type CAFSet = Set CAFfyLabel type CAFEnv = LabelMap CAFSet  -- | Records the CAFfy references of a set of static data decls. type DataCAFEnv = Map CLabel CAFSet -mkCAFLabel :: Platform -> CLabel -> CAFLabel-mkCAFLabel platform lbl = CAFLabel (toClosureLbl platform lbl) +mkCAFfyLabel :: Platform -> CLabel -> CAFfyLabel+mkCAFfyLabel platform lbl = CAFfyLabel (toClosureLbl platform lbl)+ -- This is a label that we can put in an SRT.  It *must* be a closure label,--- pointing to either a FUN_STATIC, THUNK_STATIC, or CONSTR.+-- pointing to either a @FUN_STATIC@, @THUNK_STATIC@, or @CONSTR@. newtype SRTEntry = SRTEntry CLabel   deriving (Eq, Ord) @@ -516,7 +545,7 @@ addCafLabel :: Platform -> CLabel -> CAFSet -> CAFSet addCafLabel platform l s   | Just _ <- hasHaskellName l-  , let caf_label = mkCAFLabel platform l+  , let caf_label = mkCAFfyLabel platform l     -- For imported Ids hasCAF will have accurate CafInfo     -- Locals are initialized as CAFFY. We turn labels with empty SRTs into     -- non-CAFFYs in doSRTs@@ -525,6 +554,7 @@   | otherwise   = s +-- | Collect possible CAFfy references from a 'CmmData' decl. cafAnalData   :: Platform   -> CmmStatics@@ -544,17 +574,17 @@ -- | -- For each code block: --   - collect the references reachable from this code block to FUN,---     THUNK or RET labels for which hasCAF == True+--     THUNK or RET labels for which @hasCAF == True@ ----- This gives us a `CAFEnv`: a mapping from code block to sets of labels+-- This gives us a 'CAFEnv': a mapping from code block to sets of labels -- cafAnal   :: Platform-  -> LabelSet   -- The blocks representing continuations, ie. those+  -> LabelSet   -- ^ The blocks representing continuations, ie. those                 -- that will get RET info tables.  These labels will                 -- get their own SRTs, so we don't aggregate CAFs from                 -- references to these labels, we just use the label.-  -> CLabel     -- The top label of the proc+  -> CLabel     -- ^ The top label of the proc   -> CmmGraph   -> CAFEnv cafAnal platform contLbls topLbl cmmGraph =@@ -579,13 +609,13 @@         result :: CAFSet         !result = foldNodesBwdOO cafsInNode middle joined -        facts :: [Set CAFLabel]+        facts :: [Set CAFfyLabel]         facts = mapMaybe successorFact (successors xNode)          live' :: CAFSet         live' = joinFacts cafLattice facts -        successorFact :: Label -> Maybe (Set CAFLabel)+        successorFact :: Label -> Maybe (Set CAFfyLabel)         successorFact s           -- If this is a loop back to the entry, we can refer to the           -- entry label.@@ -593,7 +623,7 @@           -- If this is a continuation, we want to refer to the           -- SRT for the continuation's info table           | s `setMember` contLbls-          = Just (Set.singleton (mkCAFLabel platform (infoTblLbl s)))+          = Just (Set.singleton (mkCAFfyLabel platform (infoTblLbl s)))           -- Otherwise, takes the CAF references from the destination           | otherwise           = lookupFact s fBase@@ -601,7 +631,7 @@         cafsInNode :: CmmNode e x -> CAFSet -> CAFSet         cafsInNode node set = foldExpDeep addCafExpr node set -        addCafExpr :: CmmExpr -> Set CAFLabel -> Set CAFLabel+        addCafExpr :: CmmExpr -> Set CAFfyLabel -> Set CAFfyLabel         addCafExpr expr !set =           case expr of             CmmLit (CmmLabel c) ->@@ -689,64 +719,73 @@ getBlockLabels :: [SomeLabel] -> [Label] getBlockLabels = mapMaybe getBlockLabel --- | Return a (Label,CLabel) pair for each labelled block of a CmmDecl,+-- | Return a @(Label,CLabel)@ pair for each labelled block of a 'CmmDecl', --   where the label is --   - the info label for a continuation or dynamic closure --   - the closure label for a top-level function (not a CAF)-getLabelledBlocks :: Platform -> CmmDecl -> [(SomeLabel, CAFLabel)]+getLabelledBlocks :: Platform -> CmmDecl -> [(SomeLabel, CAFfyLabel)] getLabelledBlocks platform decl = case decl of    CmmData _ (CmmStaticsRaw _ _)    -> []-   CmmData _ (CmmStatics lbl _ _ _) -> [ (DeclLabel lbl, mkCAFLabel platform lbl) ]+   CmmData _ (CmmStatics lbl _ _ _) -> [ (DeclLabel lbl, mkCAFfyLabel platform lbl) ]    CmmProc top_info _ _ _           -> [ (BlockLabel blockId, caf_lbl)                                        | (blockId, info) <- mapToList (info_tbls top_info)                                        , let rep = cit_rep info                                        , not (isStaticRep rep) || not (isThunkRep rep)-                                       , let !caf_lbl = mkCAFLabel platform (cit_lbl info)+                                       , let !caf_lbl = mkCAFfyLabel platform (cit_lbl info)                                        ]  -- | Put the labelled blocks that we will be annotating with SRTs into -- dependency order.  This is so that we can process them one at a -- time, resolving references to earlier blocks to point to their--- SRTs. CAFs themselves are not included here; see getCAFs below.+-- SRTs. CAFs themselves are not included here; see 'getCAFs' below. depAnalSRTs   :: Platform-  -> CAFEnv-  -> Map CLabel CAFSet -- CAFEnv for statics-  -> [CmmDecl]-  -> [SCC (SomeLabel, CAFLabel, Set CAFLabel)]+  -> CAFEnv            -- ^ 'CAFEnv' for procedures. From 'cafAnal'.+  -> Map CLabel CAFSet -- ^ CAFEnv for statics. Maps statics to the set of the+                       -- CAFfy things which they refer to. From 'cafAnalData'.+  -> [CmmDecl]         -- ^ the decls to analyse.+  -> [SCC (SomeLabel, CAFfyLabel, Set CAFfyLabel)] depAnalSRTs platform cafEnv cafEnv_static decls =   srtTrace "depAnalSRTs" (text "decls:"  <+> pdoc platform decls $$                            text "nodes:" <+> pdoc platform (map node_payload nodes) $$                            text "graph:" <+> pdoc platform graph) graph  where-  labelledBlocks :: [(SomeLabel, CAFLabel)]+  labelledBlocks :: [(SomeLabel, CAFfyLabel)]   labelledBlocks = concatMap (getLabelledBlocks platform) decls-  labelToBlock :: Map CAFLabel SomeLabel+  labelToBlock :: Map CAFfyLabel SomeLabel   labelToBlock = foldl' (\m (v,k) -> Map.insert k v m) Map.empty labelledBlocks -  nodes :: [Node SomeLabel (SomeLabel, CAFLabel, Set CAFLabel)]+  -- the set of graph nodes. A node is identified by either a BlockLabel (in+  -- the case of code) or a DeclLabel (in the case of static data).+  nodes :: [Node SomeLabel (SomeLabel, CAFfyLabel, Set CAFfyLabel)]   nodes = [ DigraphNode (l,lbl,cafs') l               (mapMaybe (flip Map.lookup labelToBlock) (Set.toList cafs'))           | (l, lbl) <- labelledBlocks-          , Just (cafs :: Set CAFLabel) <-+          , Just (cafs :: Set CAFfyLabel) <-               [case l of                  BlockLabel l -> mapLookup l cafEnv                  DeclLabel cl -> Map.lookup cl cafEnv_static]           , let cafs' = Set.delete lbl cafs           ] -  graph :: [SCC (SomeLabel, CAFLabel, Set CAFLabel)]+  graph :: [SCC (SomeLabel, CAFfyLabel, Set CAFfyLabel)]   graph = stronglyConnCompFromEdgedVerticesOrd nodes --- | Get (Label, CAFLabel, Set CAFLabel) for each block that represents a CAF.--- These are treated differently from other labelled blocks:+-- | Get @(Label, CAFfyLabel, Set CAFfyLabel)@ for each CAF block.+-- The @Set CafLabel@ represents the set of CAFfy things which this CAF's code+-- depends upon.+--+-- CAFs are treated differently from other labelled blocks:+-- --  - we never shortcut a reference to a CAF to the contents of its --    SRT, since the point of SRTs is to keep CAFs alive.+-- --  - CAFs therefore don't take part in the dependency analysis in depAnalSRTs. --    instead we generate their SRTs after everything else.-getCAFs :: Platform -> CAFEnv -> [CmmDecl] -> [(Label, CAFLabel, Set CAFLabel)]+--+getCAFs :: Platform -> CAFEnv -> [CmmDecl] -> [(Label, CAFfyLabel, Set CAFfyLabel)] getCAFs platform cafEnv decls =-  [ (g_entry g, mkCAFLabel platform topLbl, cafs)+  [ (g_entry g, mkCAFfyLabel platform topLbl, cafs)   | CmmProc top_info topLbl _ g <- decls   , Just info <- [mapLookup (g_entry g) (info_tbls top_info)]   , let rep = cit_rep info@@ -756,7 +795,7 @@   -- | Get the list of blocks that correspond to the entry points for--- FUN_STATIC closures.  These are the blocks for which if we have an+-- @FUN_STATIC@ closures.  These are the blocks for which if we have an -- SRT we can merge it with the static closure. [FUN] getStaticFuns :: [CmmDecl] -> [(BlockId, CLabel)] getStaticFuns decls =@@ -766,7 +805,7 @@   , Just (id, _) <- [cit_clo info]   , let rep = cit_rep info   , isStaticRep rep && isFunRep rep-  , let !lbl = mkLocalClosureLabel (idName id) (idCafInfo id)+  , let !lbl = mkClosureLabel (idName id) (idCafInfo id)   ]  @@ -777,7 +816,7 @@ --   - CAFs must not map to anything! --   - if a labels maps to Nothing, we found that this label's SRT --     is empty, so we don't need to refer to it from other SRTs.-type SRTMap = Map CAFLabel (Maybe SRTEntry)+type SRTMap = Map CAFfyLabel (Maybe SRTEntry)   -- | Given 'SRTMap' of a module, returns the set of non-CAFFY names in the@@ -786,30 +825,35 @@ srtMapNonCAFs srtMap =     NonCaffySet $ mkNameSet (mapMaybe get_name (Map.toList srtMap))   where-    get_name (CAFLabel l, Nothing) = hasHaskellName l+    get_name (CAFfyLabel l, Nothing) = hasHaskellName l     get_name (_l, Just _srt_entry) = Nothing --- | resolve a CAFLabel to its SRTEntry using the SRTMap-resolveCAF :: Platform -> SRTMap -> CAFLabel -> Maybe SRTEntry-resolveCAF platform srtMap lbl@(CAFLabel l) =+-- | Resolve a CAFfyLabel to its 'SRTEntry' using the 'SRTMap'.+resolveCAF :: Platform -> SRTMap -> CAFfyLabel -> Maybe SRTEntry+resolveCAF platform srtMap lbl@(CAFfyLabel l) =     srtTrace "resolveCAF" ("l:" <+> pdoc platform l <+> "resolved:" <+> pdoc platform ret) ret   where     ret = Map.findWithDefault (Just (SRTEntry (toClosureLbl platform l))) lbl srtMap --- | Attach SRTs to all info tables in the CmmDecls, and add SRT--- declarations to the ModuleSRTInfo.+anyCafRefs :: [CafInfo] -> CafInfo+anyCafRefs caf_infos = case any mayHaveCafRefs caf_infos of+                         True -> MayHaveCafRefs+                         False -> NoCafRefs++-- | Attach SRTs to all info tables in the 'CmmDecl's, and add SRT+-- declarations to the 'ModuleSRTInfo'. -- doSRTs-  :: DynFlags+  :: CmmConfig   -> ModuleSRTInfo-  -> [(CAFEnv, [CmmDecl])]-  -> [(CAFSet, CmmDecl)]+  -> [(CAFEnv, [CmmDecl])]   -- ^ 'CAFEnv's and 'CmmDecl's for code blocks+  -> [(CAFSet, CmmDecl)]     -- ^ static data decls and their 'CAFSet's   -> IO (ModuleSRTInfo, [CmmDeclSRTs]) -doSRTs dflags moduleSRTInfo procs data_ = do+doSRTs cfg moduleSRTInfo procs data_ = do   us <- mkSplitUniqSupply 'u' -  let profile = targetProfile dflags+  let profile = cmmProfile cfg    -- Ignore the original grouping of decls, and combine all the   -- CAFEnvs into a single CAFEnv.@@ -831,7 +875,7 @@       decls = map snd data_ ++ concat procss       staticFuns = mapFromList (getStaticFuns decls) -      platform = targetPlatform dflags+      platform = cmmPlatform cfg    -- Put the decls in dependency order. Why? So that we can implement   -- [Inline] and [Filter].  If we need to refer to an SRT that has@@ -840,10 +884,10 @@   -- to do this we need to process blocks before things that depend on   -- them.   let-    sccs :: [SCC (SomeLabel, CAFLabel, Set CAFLabel)]+    sccs :: [SCC (SomeLabel, CAFfyLabel, Set CAFfyLabel)]     sccs = {-# SCC depAnalSRTs #-} depAnalSRTs platform cafEnv static_data_env decls -    cafsWithSRTs :: [(Label, CAFLabel, Set CAFLabel)]+    cafsWithSRTs :: [(Label, CAFfyLabel, Set CAFfyLabel)]     cafsWithSRTs = getCAFs platform cafEnv decls    srtTraceM "doSRTs" (text "data:"            <+> pdoc platform data_ $$@@ -858,15 +902,15 @@         [ ( [CmmDeclSRTs]          -- generated SRTs           , [(Label, CLabel)]      -- SRT fields for info tables           , [(Label, [SRTEntry])]  -- SRTs to attach to static functions-          , Bool                   -- Whether the group has CAF references+          , CafInfo                -- Whether the group has CAF references           ) ]        (result, moduleSRTInfo') =         initUs_ us $         flip runStateT moduleSRTInfo $ do-          nonCAFs <- mapM (doSCC dflags staticFuns static_data_env) sccs+          nonCAFs <- mapM (doSCC cfg staticFuns static_data_env) sccs           cAFs <- forM cafsWithSRTs $ \(l, cafLbl, cafs) ->-            oneSRT dflags staticFuns [BlockLabel l] [cafLbl]+            oneSRT cfg staticFuns [BlockLabel l] [cafLbl]                    True{-is a CAF-} cafs static_data_env           return (nonCAFs ++ cAFs) @@ -877,7 +921,7 @@   let     srtFieldMap = mapFromList (concat pairs)     funSRTMap = mapFromList (concat funSRTs)-    has_caf_refs' = or has_caf_refs+    has_caf_refs' = anyCafRefs has_caf_refs     decls' =       concatMap (updInfoSRTs profile srtFieldMap funSRTMap has_caf_refs') decls @@ -895,7 +939,7 @@                           -- be CAFFY.                           -- See Note [Ticky labels in SRT analysis] above for                           -- why we exclude ticky labels here.-                          Map.insert (mkCAFLabel platform lbl) Nothing srtMap+                          Map.insert (mkCAFfyLabel platform lbl) Nothing srtMap                       | otherwise ->                           -- Not an IdLabel, ignore                           srtMap@@ -906,31 +950,31 @@   return (moduleSRTInfo'{ moduleSRTMap = srtMap_w_raws }, srt_decls ++ decls')  --- | Build the SRT for a strongly-connected component of blocks+-- | Build the SRT for a strongly-connected component of blocks. doSCC-  :: DynFlags-  -> LabelMap CLabel -- which blocks are static function entry points+  :: CmmConfig+  -> LabelMap CLabel -- ^ which blocks are static function entry points   -> DataCAFEnv      -- ^ static data-  -> SCC (SomeLabel, CAFLabel, Set CAFLabel)+  -> SCC (SomeLabel, CAFfyLabel, Set CAFfyLabel)   -> StateT ModuleSRTInfo UniqSM         ( [CmmDeclSRTs]          -- generated SRTs         , [(Label, CLabel)]      -- SRT fields for info tables         , [(Label, [SRTEntry])]  -- SRTs to attach to static functions-        , Bool                   -- Whether the group has CAF references+        , CafInfo                -- Whether the group has CAF references         ) -doSCC dflags staticFuns static_data_env (AcyclicSCC (l, cafLbl, cafs)) =-  oneSRT dflags staticFuns [l] [cafLbl] False cafs static_data_env+doSCC cfg staticFuns static_data_env (AcyclicSCC (l, cafLbl, cafs)) =+  oneSRT cfg staticFuns [l] [cafLbl] False cafs static_data_env -doSCC dflags staticFuns static_data_env (CyclicSCC nodes) = do+doSCC cfg staticFuns static_data_env (CyclicSCC nodes) = do   -- build a single SRT for the whole cycle, see Note [recursive SRTs]   let (lbls, caf_lbls, cafsets) = unzip3 nodes       cafs = Set.unions cafsets-  oneSRT dflags staticFuns lbls caf_lbls False cafs static_data_env+  oneSRT cfg staticFuns lbls caf_lbls False cafs static_data_env   {- Note [recursive SRTs]-+   ~~~~~~~~~~~~~~~~~~~~~ If the dependency analyser has found us a recursive group of declarations, then we build a single SRT for the whole group, on the grounds that everything in the group is reachable from everything@@ -960,29 +1004,28 @@  -- | Build an SRT for a set of blocks oneSRT-  :: DynFlags-  -> LabelMap CLabel            -- which blocks are static function entry points-  -> [SomeLabel]                -- blocks in this set-  -> [CAFLabel]                 -- labels for those blocks-  -> Bool                       -- True <=> this SRT is for a CAF-  -> Set CAFLabel               -- SRT for this set+  :: CmmConfig+  -> LabelMap CLabel            -- ^ which blocks are static function entry points+  -> [SomeLabel]                -- ^ blocks in this set+  -> [CAFfyLabel]               -- ^ labels for those blocks+  -> Bool                       -- ^ True <=> this SRT is for a CAF+  -> Set CAFfyLabel             -- ^ SRT for this set   -> DataCAFEnv                 -- Static data labels in this group   -> StateT ModuleSRTInfo UniqSM        ( [CmmDeclSRTs]                -- SRT objects we built        , [(Label, CLabel)]            -- SRT fields for these blocks' itbls        , [(Label, [SRTEntry])]        -- SRTs to attach to static functions-       , Bool                         -- Whether the group has CAF references+       , CafInfo                      -- Whether the group has CAF references        ) -oneSRT dflags staticFuns lbls caf_lbls isCAF cafs static_data_env = do+oneSRT cfg staticFuns lbls caf_lbls isCAF cafs static_data_env = do   topSRT <- get    let     this_mod = thisModule topSRT-    config = initNCGConfig dflags this_mod-    profile = targetProfile dflags+    profile  = cmmProfile cfg     platform = profilePlatform profile-    srtMap = moduleSRTMap topSRT+    srtMap   = moduleSRTMap topSRT      blockids = getBlockLabels lbls @@ -998,7 +1041,7 @@     -- Note [recursive SRTs]. We carefully reintroduce references to static     -- functions and data constructor applications below, as is necessary due     -- to Note [No static object resurrection].-    nonRec :: Set CAFLabel+    nonRec :: Set CAFfyLabel     nonRec = cafs `Set.difference` Set.fromList caf_lbls      -- Resolve references to their SRT entries@@ -1043,7 +1086,7 @@       when (not isCAF && (not isStaticFun || isNothing srtEntry)) $         modify' $ \state ->            let !srt_map =-                 foldl' (\srt_map cafLbl@(CAFLabel clbl) ->+                 foldl' (\srt_map cafLbl@(CAFfyLabel clbl) ->                           -- Only map static data to Nothing (== not CAFFY). For CAFFY                           -- statics we refer to the static itself instead of a SRT.                           if not (Map.member clbl static_data_env) || isNothing srtEntry then@@ -1056,12 +1099,12 @@                state{ moduleSRTMap = srt_map }      allStaticData =-      all (\(CAFLabel clbl) -> Map.member clbl static_data_env) caf_lbls+      all (\(CAFfyLabel clbl) -> Map.member clbl static_data_env) caf_lbls    if Set.null filtered0 then do     srtTraceM "oneSRT: empty" (pdoc platform caf_lbls)     updateSRTMap Nothing-    return ([], [], [], False)+    return ([], [], [], NoCafRefs)   else do     -- We're going to build an SRT for this group, which should include function     -- references in the group. See Note [recursive SRTs].@@ -1091,7 +1134,7 @@           -- when dynamic linking is used we cannot guarantee that the offset           -- between the SRT and the info table will fit in the offset field.           -- Consequently we build a singleton SRT in this case.-          not (labelDynamic config lbl)+          not (labelDynamic this_mod platform (cmmExternalDynamicRefs cfg) lbl)            -- MachO relocations can't express offsets between compilation units at           -- all, so we are always forced to build a singleton SRT in this case.@@ -1104,7 +1147,7 @@           -- recursive group, see Note [recursive SRTs])           case maybeFunClosure of             Just (staticFunLbl,staticFunBlock) ->-                return ([], withLabels, [], True)+                return ([], withLabels, [], MayHaveCafRefs)               where                 withLabels =                   [ (b, if b == staticFunBlock then lbl else staticFunLbl)@@ -1113,10 +1156,11 @@               srtTraceM "oneSRT: one" (text "caf_lbls:" <+> pdoc platform caf_lbls $$                                        text "one:"      <+> pdoc platform one)               updateSRTMap (Just one)-              return ([], map (,lbl) blockids, [], True)+              return ([], map (,lbl) blockids, [], MayHaveCafRefs)        cafList | allStaticData ->-        return ([], [], [], not (null cafList))+        let caffiness = if null cafList then NoCafRefs else MayHaveCafRefs+        in return ([], [], [], caffiness)        cafList ->         -- Check whether an SRT with the same entries has been emitted already.@@ -1125,7 +1169,7 @@           Just srtEntry@(SRTEntry srtLbl)  -> do             srtTraceM "oneSRT [Common]" (pdoc platform caf_lbls <+> pdoc platform srtLbl)             updateSRTMap (Just srtEntry)-            return ([], map (,srtLbl) blockids, [], True)+            return ([], map (,srtLbl) blockids, [], MayHaveCafRefs)           Nothing -> do             -- No duplicates: we have to build a new SRT object             (decls, funSRTs, srtEntry) <-@@ -1149,11 +1193,11 @@                                       text "newDedupSRTs:" <+> pdoc platform newDedupSRTs $$                                       text "newFlatSRTs:"  <+> pdoc platform newFlatSRTs)             let SRTEntry lbl = srtEntry-            return (decls, map (,lbl) blockids, funSRTs, True)+            return (decls, map (,lbl) blockids, funSRTs, MayHaveCafRefs)   -- | Build a static SRT object (or a chain of objects) from a list of--- SRTEntries.+-- 'SRTEntry's. buildSRTChain    :: Profile    -> [SRTEntry]@@ -1194,9 +1238,9 @@ -- static closures, splicing in SRT fields as necessary. updInfoSRTs   :: Profile-  -> LabelMap CLabel               -- SRT labels for each block-  -> LabelMap [SRTEntry]           -- SRTs to merge into FUN_STATIC closures-  -> Bool                          -- Whether the CmmDecl's group has CAF references+  -> LabelMap CLabel               -- ^ SRT labels for each block+  -> LabelMap [SRTEntry]           -- ^ SRTs to merge into FUN_STATIC closures+  -> CafInfo                       -- ^ Whether the CmmDecl's group has CAF references   -> CmmDecl   -> [CmmDeclSRTs] @@ -1206,14 +1250,12 @@ updInfoSRTs profile _ _ caffy (CmmData s (CmmStatics lbl itbl ccs payload))   = [CmmData s (CmmStaticsRaw lbl (map CmmStaticLit field_lits))]   where-    caf_info = if caffy then MayHaveCafRefs else NoCafRefs-    field_lits = mkStaticClosureFields profile itbl ccs caf_info payload+    field_lits = mkStaticClosureFields profile itbl ccs caffy payload  updInfoSRTs profile srt_env funSRTEnv caffy (CmmProc top_info top_l live g)   | Just (_,closure) <- maybeStaticClosure = [ proc, closure ]   | otherwise = [ proc ]   where-    caf_info = if caffy then MayHaveCafRefs else NoCafRefs     proc = CmmProc top_info { info_tbls = newTopInfo } top_l live g     newTopInfo = mapMapWithKey updInfoTbl (info_tbls top_info)     updInfoTbl l info_tbl@@ -1238,12 +1280,12 @@             Just srtEntries -> srtTrace "maybeStaticFun" (pdoc (profilePlatform profile) res)               (info_tbl { cit_rep = new_rep }, res)               where res = [ CmmLabel lbl | SRTEntry lbl <- srtEntries ]-          fields = mkStaticClosureFields profile info_tbl ccs caf_info srtEntries+          fields = mkStaticClosureFields profile info_tbl ccs caffy srtEntries           new_rep = case cit_rep of              HeapRep sta ptrs nptrs ty ->                HeapRep sta (ptrs + length srtEntries) nptrs ty              _other -> panic "maybeStaticFun"-          lbl = mkLocalClosureLabel (idName id) caf_info+          lbl = mkClosureLabel (idName id) caffy         in           Just (newInfo, mkDataLits (Section Data lbl) lbl fields)       | otherwise = Nothing
+ compiler/GHC/Cmm/InitFini.hs view
@@ -0,0 +1,78 @@+-- | Utilities for dealing with constructors/destructors.+module GHC.Cmm.InitFini+    ( InitOrFini(..)+    , isInitOrFiniArray+    ) where++import GHC.Prelude++import GHC.Cmm.CLabel+import GHC.Cmm+import GHC.Utils.Panic+import GHC.Utils.Outputable++{-+Note [Initializers and finalizers in Cmm]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Most platforms support some mechanism for marking a procedure to be run when a+program is loaded (in which case the procedure is known as an "initializer",+"constructor", or "ctor") or unloaded (a "finalizer", "deconstructor", or+"dtor").++For instance, on ELF platforms pointers to initializer and finalizer functions+are listed in .init_array and .fini_array sections, which are traversed by libc+during program startup and shutdown.++In GHC-generated code, initializers are used for a few things:++ * registration of cost-centres and cost-centre stacks for profiling+ * registration of info-table provenance entries+ * registration of ticky tickers+ * registration of HPC ticks++All of these initializers are implemented as C functions, emitted by the+compiler as ForeignStubs. Consequently the GHC.Types.ForeignStubs.CStub type+carries with it lists of functions which should be marked as initializers or+finalizers.++These initializer and finalizer lists are then turned into CmmData declarations+which are fed to the backend. These declarations are distinguished by their+Section (e.g. InitArray or FiniArray) and consist of an array of words, where each+word is a pointer to an initializer/finalizer function. Since this is the same+form that most platforms expect initializer or finalizer lists to appear in+assembler, the NCG backends naturally emit the appropriate assembler.++However, for non-NCG backends (e.g. the C and LLVM backends) these+initializer/finalizer list declarations need to be detected and dealt with+appropriately. We provide isInitOrFiniArray to distinguish such declarations+and turn them back into a list of CLabels.++On Windows initializers/finalizers are a bit tricky due to the inability to+merge objects (due to the lld linker's lack of `-r` support on Windows; see+Note [Object merging] in GHC.Driver.Pipeline.Execute) since we instead must+package foreign stubs into static archives.  However, the linker is free to not+include any constituent objects of a static library in the final object code if+nothing depends upon them. Consequently, we must ensure that the initializer+list for a module is defined in the module's object code, not its foreign+stubs. This happens naturally with the plan laid out above.++Note that we maintain the invariant that at most one initializer and one+finalizer CmmDecl will be emitted per module.+-}++data InitOrFini = IsInitArray | IsFiniArray++isInitOrFiniArray :: RawCmmDecl -> Maybe (InitOrFini, [CLabel])+isInitOrFiniArray (CmmData sect (CmmStaticsRaw _ lits))+  | Just initOrFini <- isInitOrFiniSection sect+  = Just (initOrFini, map get_label lits)+  where+    get_label :: CmmStatic -> CLabel+    get_label (CmmStaticLit (CmmLabel lbl)) = lbl+    get_label static = pprPanic "isInitOrFiniArray: invalid entry" (ppr static)+isInitOrFiniArray _ = Nothing++isInitOrFiniSection :: Section -> Maybe InitOrFini+isInitOrFiniSection (Section InitArray _) = Just IsInitArray+isInitOrFiniSection (Section FiniArray _) = Just IsFiniArray+isInitOrFiniSection _                     = Nothing
compiler/GHC/Cmm/LayoutStack.hs view
@@ -12,14 +12,12 @@ import GHC.StgToCmm.Utils      ( callerSaveVolatileRegs  ) -- XXX layering violation import GHC.StgToCmm.Foreign    ( saveThreadState, loadThreadState ) -- XXX layering violation -import GHC.Types.Basic import GHC.Cmm import GHC.Cmm.Info import GHC.Cmm.BlockId-import GHC.Cmm.CLabel+import GHC.Cmm.Config import GHC.Cmm.Utils import GHC.Cmm.Graph-import GHC.Types.ForeignCall import GHC.Cmm.Liveness import GHC.Cmm.ProcPoint import GHC.Runtime.Heap.Layout@@ -33,8 +31,6 @@ import GHC.Types.Unique.FM import GHC.Utils.Misc -import GHC.Driver.Session-import GHC.Data.FastString import GHC.Utils.Outputable hiding ( isEmpty ) import GHC.Utils.Panic import qualified Data.Set as Set@@ -43,7 +39,7 @@ import Data.List (nub)  {- Note [Stack Layout]-+   ~~~~~~~~~~~~~~~~~~~ The job of this pass is to   - replace references to abstract stack Areas with fixed offsets from Sp.@@ -145,7 +141,7 @@   Note [Two pass approach]-+~~~~~~~~~~~~~~~~~~~~~~~~ The main reason for Pass 2 is being able to insert only the reloads that are needed and the fact that the two passes need different liveness information. Let's consider an example:@@ -239,21 +235,21 @@      text "sm_regs = " <> pprUFM sm_regs ppr  -cmmLayoutStack :: DynFlags -> ProcPointSet -> ByteOff -> CmmGraph+cmmLayoutStack :: CmmConfig -> ProcPointSet -> ByteOff -> CmmGraph                -> UniqSM (CmmGraph, LabelMap StackMap)-cmmLayoutStack dflags procpoints entry_args+cmmLayoutStack cfg procpoints entry_args                graph@(CmmGraph { g_entry = entry })   = do     -- We need liveness info. Dead assignments are removed later     -- by the sinking pass.     let liveness = cmmLocalLiveness platform graph-        blocks = revPostorder graph-        profile  = targetProfile dflags+        blocks   = revPostorder graph+        profile  = cmmProfile   cfg         platform = profilePlatform profile      (final_stackmaps, _final_high_sp, new_blocks) <-           mfix $ \ ~(rec_stackmaps, rec_high_sp, _new_blocks) ->-            layout dflags procpoints liveness entry entry_args+            layout cfg procpoints liveness entry entry_args                    rec_stackmaps rec_high_sp blocks      blocks_with_reloads <-@@ -265,7 +261,7 @@ -- Pass 1 -- ----------------------------------------------------------------------------- -layout :: DynFlags+layout :: CmmConfig        -> LabelSet                      -- proc points        -> LabelMap CmmLocalLive         -- liveness        -> BlockId                       -- entry@@ -282,7 +278,7 @@           , [CmmBlock]                  -- [out] new blocks           ) -layout dflags procpoints liveness entry entry_args final_stackmaps final_sp_high blocks+layout cfg procpoints liveness entry entry_args final_stackmaps final_sp_high blocks   = go blocks init_stackmap entry_args []   where     (updfr, cont_info)  = collectContInfo blocks@@ -315,7 +311,7 @@        --     each of the successor blocks.  See handleLastNode for        --     details.        (middle1, sp_off, last1, fixup_blocks, out)-           <- handleLastNode dflags procpoints liveness cont_info+           <- handleLastNode cfg procpoints liveness cont_info                              acc_stackmaps stack1 tscope middle0 last0         -- (c) Manifest Sp: run over the nodes in the block and replace@@ -330,7 +326,7 @@        let middle_pre = blockToList $ foldl' blockSnoc middle0 middle1         let final_blocks =-               manifestSp dflags final_stackmaps stack0 sp0 final_sp_high+               manifestSp cfg final_stackmaps stack0 sp0 final_sp_high                           entry0 middle_pre sp_off last1 fixup_blocks         let acc_stackmaps' = mapUnion acc_stackmaps out@@ -437,7 +433,7 @@ -- extra code that goes *after* the Sp adjustment.  handleLastNode-   :: DynFlags -> ProcPointSet -> LabelMap CmmLocalLive -> LabelMap ByteOff+   :: CmmConfig -> ProcPointSet -> LabelMap CmmLocalLive -> LabelMap ByteOff    -> LabelMap StackMap -> StackMap -> CmmTickScope    -> Block CmmNode O O    -> CmmNode O C@@ -449,7 +445,7 @@       , LabelMap StackMap  -- stackmaps for the continuations       ) -handleLastNode dflags procpoints liveness cont_info stackmaps+handleLastNode cfg procpoints liveness cont_info stackmaps                stack0@StackMap { sm_sp = sp0 } tscp middle last   = case last of       --  At each return / tail call,@@ -471,7 +467,7 @@       CmmCondBranch {} ->  handleBranches       CmmSwitch {}     ->  handleBranches   where-     platform = targetPlatform dflags+     platform = cmmPlatform cfg      -- Calls and ForeignCalls are handled the same way:      lastCall :: BlockId -> ByteOff -> ByteOff -> ByteOff               -> ( [CmmNode O O]@@ -514,7 +510,7 @@                                 , LabelMap StackMap )       handleBranches-         -- Note [diamond proc point]+         -- See Note [diamond proc point]        | Just l <- futureContinuation middle        , (nub $ filter (`setMember` procpoints) $ successors last) == [l]        = do@@ -548,7 +544,7 @@         | Just stack2 <- mapLookup l stackmaps         = do              let assigs = fixupStack stack0 stack2-             (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 tscp assigs+             (tmp_lbl, block) <- makeFixupBlock cfg sp0 l stack2 tscp assigs              return (l, tmp_lbl, stack2, block)          --   (b) if the successor is a proc point, save everything@@ -559,7 +555,7 @@                  (stack2, assigs) =                       setupStackFrame platform l liveness (sm_ret_off stack0)                                                         cont_args stack0-             (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 tscp assigs+             (tmp_lbl, block) <- makeFixupBlock cfg sp0 l stack2 tscp assigs              return (l, tmp_lbl, stack2, block)          --   (c) otherwise, the current StackMap is the StackMap for@@ -573,16 +569,16 @@               is_live (r,_) = r `elemRegSet` live  -makeFixupBlock :: DynFlags -> ByteOff -> Label -> StackMap+makeFixupBlock :: CmmConfig -> ByteOff -> Label -> StackMap                -> CmmTickScope -> [CmmNode O O]                -> UniqSM (Label, [CmmBlock])-makeFixupBlock dflags sp0 l stack tscope assigs+makeFixupBlock cfg sp0 l stack tscope assigs   | null assigs && sp0 == sm_sp stack = return (l, [])   | otherwise = do     tmp_lbl <- newBlockId     let sp_off = sp0 - sm_sp stack         block = blockJoin (CmmEntry tmp_lbl tscope)-                          ( maybeAddSpAdj dflags sp0 sp_off+                          ( maybeAddSpAdj cfg sp0 sp_off                            $ blockFromList assigs )                           (CmmBranch l)     return (tmp_lbl, [block])@@ -649,9 +645,8 @@                          }  --- ----------------------------------------------------------------------------- -- Note [diamond proc point]---+-- ~~~~~~~~~~~~~~~~~~~~~~~~~ -- This special case looks for the pattern we get from a typical -- tagged case expression: --@@ -829,7 +824,7 @@ -- middle_post, because the Sp adjustment intervenes. -- manifestSp-   :: DynFlags+   :: CmmConfig    -> LabelMap StackMap  -- StackMaps for other blocks    -> StackMap           -- StackMap for this block    -> ByteOff            -- Sp on entry to the block@@ -841,18 +836,18 @@    -> [CmmBlock]         -- new blocks    -> [CmmBlock]         -- final blocks with Sp manifest -manifestSp dflags stackmaps stack0 sp0 sp_high+manifestSp cfg stackmaps stack0 sp0 sp_high            first middle_pre sp_off last fixup_blocks   = final_block : fixup_blocks'   where     area_off = getAreaOff stackmaps-    platform = targetPlatform dflags+    platform = cmmPlatform cfg      adj_pre_sp, adj_post_sp :: CmmNode e x -> CmmNode e x     adj_pre_sp  = mapExpDeep (areaToSp platform sp0            sp_high area_off)     adj_post_sp = mapExpDeep (areaToSp platform (sp0 - sp_off) sp_high area_off) -    final_middle = maybeAddSpAdj dflags sp0 sp_off+    final_middle = maybeAddSpAdj cfg sp0 sp_off                  . blockFromList                  . map adj_pre_sp                  . elimStackStores stack0 stackmaps area_off@@ -872,11 +867,12 @@   maybeAddSpAdj-  :: DynFlags -> ByteOff -> ByteOff -> Block CmmNode O O -> Block CmmNode O O-maybeAddSpAdj dflags sp0 sp_off block =+  :: CmmConfig -> ByteOff -> ByteOff -> Block CmmNode O O -> Block CmmNode O O+maybeAddSpAdj cfg sp0 sp_off block =   add_initial_unwind $ add_adj_unwind $ adj block   where-    platform = targetPlatform dflags+    platform             = cmmPlatform            cfg+    do_stk_unwinding_gen = cmmGenStackUnwindInstr cfg     adj block       | sp_off /= 0       = block `blockSnoc` CmmAssign spReg (cmmOffset platform spExpr sp_off)@@ -884,7 +880,7 @@     -- Add unwind pseudo-instruction at the beginning of each block to     -- document Sp level for debugging     add_initial_unwind block-      | debugLevel dflags > 0+      | do_stk_unwinding_gen       = CmmUnwind [(Sp, Just sp_unwind)] `blockCons` block       | otherwise       = block@@ -893,7 +889,7 @@     -- Add unwind pseudo-instruction right after the Sp adjustment     -- if there is one.     add_adj_unwind block-      | debugLevel dflags > 0+      | do_stk_unwinding_gen       , sp_off /= 0       = block `blockSnoc` CmmUnwind [(Sp, Just sp_unwind)]       | otherwise@@ -901,7 +897,7 @@       where sp_unwind = CmmRegOff spReg (sp0 - platformWordSizeInBytes platform - sp_off)  {- Note [SP old/young offsets]-+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~ Sp(L) is the Sp offset on entry to block L relative to the base of the OLD area. @@ -1105,7 +1101,7 @@  {- Note [Lower safe foreign calls]-+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We start with     Sp[young(L1)] = L1@@ -1194,21 +1190,14 @@   | otherwise = return block  -foreignLbl :: FastString -> CmmExpr-foreignLbl name = CmmLit (CmmLabel (mkForeignLabel name Nothing ForeignLabelInExternalPackage IsFunction))- callSuspendThread :: Platform -> LocalReg -> Bool -> CmmNode O O callSuspendThread platform id intrbl =-  CmmUnsafeForeignCall-       (ForeignTarget (foreignLbl (fsLit "suspendThread"))-        (ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint] CmmMayReturn))+  CmmUnsafeForeignCall (PrimTarget MO_SuspendThread)        [id] [baseExpr, mkIntExpr platform (fromEnum intrbl)]  callResumeThread :: LocalReg -> LocalReg -> CmmNode O O callResumeThread new_base id =-  CmmUnsafeForeignCall-       (ForeignTarget (foreignLbl (fsLit "resumeThread"))-            (ForeignConvention CCallConv [AddrHint] [AddrHint] CmmMayReturn))+  CmmUnsafeForeignCall (PrimTarget MO_ResumeThread)        [new_base] [CmmReg (CmmLocal id)]  -- -----------------------------------------------------------------------------
compiler/GHC/Cmm/Lexer.x view
@@ -26,7 +26,9 @@ import GHC.Data.StringBuffer import GHC.Data.FastString import GHC.Parser.CharClass-import GHC.Parser.Errors+import GHC.Parser.Errors.Types+import GHC.Parser.Errors.Ppr ()+import GHC.Utils.Error import GHC.Utils.Misc --import TRACE @@ -326,7 +328,9 @@     AlexEOF -> do let span = mkPsSpan loc1 loc1                   liftP (setLastToken span 0)                   return (L span CmmT_EOF)-    AlexError (loc2,_) -> liftP $ failLocMsgP (psRealLoc loc1) (psRealLoc loc2) (PsError PsErrCmmLexer [])+    AlexError (loc2,_) ->+      let msg srcLoc = mkPlainErrorMsgEnvelope srcLoc PsErrCmmLexer+      in liftP $ failLocMsgP (psRealLoc loc1) (psRealLoc loc2) msg     AlexSkip inp2 _ -> do         setInput inp2         lexToken
compiler/GHC/Cmm/Lint.hs view
@@ -170,21 +170,9 @@             platform <- getPlatform             erep <- lintCmmExpr expr             let reg_ty = cmmRegType platform reg-            unless (compat_regs erep reg_ty) $-              cmmLintAssignErr (CmmAssign reg expr) erep reg_ty-    where-      compat_regs :: CmmType -> CmmType -> Bool-      compat_regs ty1 ty2-        -- As noted in #22297, SIMD vector registers can be used for-        -- multiple different purposes, e.g. xmm1 can be used to hold 4 Floats,-        -- or 4 Int32s, or 2 Word64s, ...-        -- To allow this, we relax the check: we only ensure that the widths-        -- match, until we can find a more robust solution.-        | isVecType ty1-        , isVecType ty2-        = typeWidth ty1 == typeWidth ty2-        | otherwise-        = cmmEqType_ignoring_ptrhood ty1 ty2+            if (erep `cmmEqType_ignoring_ptrhood` reg_ty)+                then return ()+                else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty    CmmStore l r _alignment -> do             _ <- lintCmmExpr l@@ -216,10 +204,9 @@             platform <- getPlatform             mapM_ checkTarget $ switchTargetsToList ids             erep <- lintCmmExpr e-            if (erep `cmmEqType_ignoring_ptrhood` bWord platform)-              then return ()-              else cmmLintErr (text "switch scrutinee is not a word: " <>-                               pdoc platform e <> text " :: " <> ppr erep)+            unless (isWordAny erep) $+              cmmLintErr (text "switch scrutinee is not a word (of any size): " <>+                          pdoc platform e <> text " :: " <> ppr erep)    CmmCall { cml_target = target, cml_cont = cont } -> do           _ <- lintCmmExpr target
compiler/GHC/Cmm/Liveness.hs view
@@ -71,6 +71,8 @@     analyzeCmmBwd liveLattice (xferLive platform) graph mapEmpty  -- | On entry to the procedure, there had better not be any LocalReg's live-in.+-- If you see this error it most likely means you are trying to use a variable+-- without it being defined in the given scope. noLiveOnEntry :: BlockId -> CmmLive LocalReg -> a -> a noLiveOnEntry bid in_fact x =   if nullRegSet in_fact then x
compiler/GHC/Cmm/Opt.hs view
@@ -118,10 +118,6 @@         intconv True  = MO_SS_Conv         intconv False = MO_UU_Conv --- ToDo: a narrow of a load can be collapsed into a narrow load, right?--- but what if the architecture only supports word-sized loads, should--- we do the transformation anyway?- cmmMachOpFoldM platform mop [CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)]   = case mop of         -- for comparisons: don't forget to narrow the arguments before@@ -367,7 +363,7 @@              CmmReg _ <- x ->   -- We duplicate x in signedQuotRemHelper, hence require                                 -- it is a reg.  FIXME: remove this restriction.                 Just $! (cmmMachOpFold platform (MO_S_Shr rep)-                  [signedQuotRemHelper rep p, CmmLit (CmmInt p rep)])+                  [signedQuotRemHelper rep p, CmmLit (CmmInt p $ wordWidth platform)])         MO_S_Rem rep            | Just p <- exactLog2 n,              CmmReg _ <- x ->   -- We duplicate x in signedQuotRemHelper, hence require@@ -401,7 +397,7 @@       where         bits = fromIntegral (widthInBits rep) - 1         shr = if p == 1 then MO_U_Shr rep else MO_S_Shr rep-        x1 = CmmMachOp shr [x, CmmLit (CmmInt bits rep)]+        x1 = CmmMachOp shr [x, CmmLit (CmmInt bits $ wordWidth platform)]         x2 = if p == 1 then x1 else              CmmMachOp (MO_And rep) [x1, CmmLit (CmmInt (n-1) rep)]
compiler/GHC/Cmm/Parser.y view
@@ -6,9 +6,9 @@ -- ----------------------------------------------------------------------------- -{- -----------------------------------------------------------------------------+{- Note [Syntax of .cmm files]-+~~~~~~~~~~~~~~~~~~~~~~~~~~~ NOTE: You are very much on your own in .cmm.  There is very little error checking at all: @@ -205,21 +205,26 @@ import GHC.Prelude import qualified Prelude -- for happy-generated code +import GHC.Driver.Session+import GHC.Driver.Ppr+import GHC.Driver.Config.Parser (initParserOpts)+import GHC.Driver.Config.StgToCmm+ import GHC.Platform import GHC.Platform.Profile  import GHC.StgToCmm.ExtCode-import GHC.StgToCmm.Prof import GHC.StgToCmm.Heap import GHC.StgToCmm.Monad hiding ( getCode, getCodeR, getCodeScoped, emitLabel, emit                                  , emitStore, emitAssign, emitOutOfLine, withUpdFrameOff-                                 , getUpdFrameOff, getProfile, getPlatform, getPtrOpts )+                                 , getUpdFrameOff, getProfile, getPlatform, getContext) import qualified GHC.StgToCmm.Monad as F import GHC.StgToCmm.Utils import GHC.StgToCmm.Foreign import GHC.StgToCmm.Expr import GHC.StgToCmm.Lit import GHC.StgToCmm.Closure+import GHC.StgToCmm.Config import GHC.StgToCmm.Layout     hiding (ArgRep(..)) import GHC.StgToCmm.Ticky import GHC.StgToCmm.Prof@@ -234,12 +239,13 @@ import GHC.Cmm.BlockId import GHC.Cmm.Lexer import GHC.Cmm.CLabel-import GHC.Cmm.Parser.Monad hiding (getPlatform, getProfile, getPtrOpts)+import GHC.Cmm.Parser.Monad hiding (getPlatform, getProfile) import qualified GHC.Cmm.Parser.Monad as PD import GHC.Cmm.CallConv import GHC.Runtime.Heap.Layout import GHC.Parser.Lexer-import GHC.Parser.Errors+import GHC.Parser.Errors.Types+import GHC.Parser.Errors.Ppr  import GHC.Types.CostCentre import GHC.Types.ForeignCall@@ -250,9 +256,6 @@ import GHC.Types.Unique.FM import GHC.Types.SrcLoc import GHC.Types.Tickish  ( GenTickish(SourceNote) )-import GHC.Driver.Session-import GHC.Driver.Ppr-import GHC.Driver.Config import GHC.Utils.Error import GHC.Data.StringBuffer import GHC.Data.FastString@@ -270,8 +273,6 @@ import Data.Maybe import qualified Data.Map as M import qualified Data.ByteString.Char8 as BS8--#include "GhclibHsVersions.h" }  %expect 0@@ -449,10 +450,10 @@                 { do ((entry_ret_label, info, stk_formals, formals), agraph) <-                        getCodeScoped $ loopDecls $ do {                          (entry_ret_label, info, stk_formals) <- $1;-                         dflags <- getDynFlags;                          platform <- getPlatform;+                         ctx      <- getContext;                          formals <- sequence (fromMaybe [] $3);-                         withName (showSDoc dflags (pdoc platform entry_ret_label))+                         withName (renderWithContext ctx (pdoc platform entry_ret_label))                            $4;                          return (entry_ret_label, info, stk_formals, formals) }                      let do_layout = isJust $3@@ -923,13 +924,14 @@ nameToMachOp :: FastString -> PD (Width -> MachOp) nameToMachOp name =   case lookupUFM machOps name of-        Nothing -> failMsgPD $ PsError (PsErrCmmParser (CmmUnknownPrimitive name)) []+        Nothing -> failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $ PsErrCmmParser (CmmUnknownPrimitive name)         Just m  -> return m  exprOp :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse CmmExpr) exprOp name args_code = do-  ptr_opts <- PD.getPtrOpts-  case lookupUFM (exprMacros ptr_opts) name of+  profile     <- PD.getProfile+  align_check <- gopt Opt_AlignmentSanitisation <$> getDynFlags+  case lookupUFM (exprMacros profile align_check) name of      Just f  -> return $ do         args <- sequence args_code         return (f args)@@ -937,21 +939,20 @@         mo <- nameToMachOp name         return $ mkMachOp mo args_code -exprMacros :: PtrOpts -> UniqFM FastString ([CmmExpr] -> CmmExpr)-exprMacros ptr_opts = listToUFM [+exprMacros :: Profile -> DoAlignSanitisation -> UniqFM FastString ([CmmExpr] -> CmmExpr)+exprMacros profile align_check = listToUFM [   ( fsLit "ENTRY_CODE",   \ [x] -> entryCode platform x ),-  ( fsLit "INFO_PTR",     \ [x] -> closureInfoPtr ptr_opts x ),-  ( fsLit "STD_INFO",     \ [x] -> infoTable profile x ),+  ( fsLit "INFO_PTR",     \ [x] -> closureInfoPtr platform align_check x ),+  ( fsLit "STD_INFO",     \ [x] -> infoTable    profile x ),   ( fsLit "FUN_INFO",     \ [x] -> funInfoTable profile x ),-  ( fsLit "GET_ENTRY",    \ [x] -> entryCode platform (closureInfoPtr ptr_opts x) ),-  ( fsLit "GET_STD_INFO", \ [x] -> infoTable profile (closureInfoPtr ptr_opts x) ),-  ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable profile (closureInfoPtr ptr_opts x) ),+  ( fsLit "GET_ENTRY",    \ [x] -> entryCode platform   (closureInfoPtr platform align_check x) ),+  ( fsLit "GET_STD_INFO", \ [x] -> infoTable profile    (closureInfoPtr platform align_check x) ),+  ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable profile (closureInfoPtr platform align_check x) ),   ( fsLit "INFO_TYPE",    \ [x] -> infoTableClosureType profile x ),   ( fsLit "INFO_PTRS",    \ [x] -> infoTablePtrs profile x ),   ( fsLit "INFO_NPTRS",   \ [x] -> infoTableNonPtrs profile x )   ]   where-    profile  = po_profile ptr_opts     platform = profilePlatform profile  -- we understand a subset of C-- primitives:@@ -1073,6 +1074,9 @@         ( "memmove", memcpyLikeTweakArgs MO_Memmove ),         ( "memcmp", memcpyLikeTweakArgs MO_Memcmp ), +        ( "suspendThread", (MO_SuspendThread,) ),+        ( "resumeThread",  (MO_ResumeThread,) ),+         ("prefetch0", (MO_Prefetch_Data 0,)),         ("prefetch1", (MO_Prefetch_Data 1,)),         ("prefetch2", (MO_Prefetch_Data 2,)),@@ -1122,12 +1126,14 @@ parseSafety "safe"   = return PlaySafe parseSafety "unsafe" = return PlayRisky parseSafety "interruptible" = return PlayInterruptible-parseSafety str      = failMsgPD $ PsError (PsErrCmmParser (CmmUnrecognisedSafety str)) []+parseSafety str      = failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $+                                              PsErrCmmParser (CmmUnrecognisedSafety str)  parseCmmHint :: String -> PD ForeignHint parseCmmHint "ptr"    = return AddrHint parseCmmHint "signed" = return SignedHint-parseCmmHint str      = failMsgPD $ PsError (PsErrCmmParser (CmmUnrecognisedHint str)) []+parseCmmHint str      = failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $+                                               PsErrCmmParser (CmmUnrecognisedHint str)  -- labels are always pointers, so we might as well infer the hint inferCmmHint :: CmmExpr -> ForeignHint@@ -1154,7 +1160,7 @@ stmtMacro :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse ()) stmtMacro fun args_code = do   case lookupUFM stmtMacros fun of-    Nothing -> failMsgPD $ PsError (PsErrCmmParser (CmmUnknownMacro fun)) []+    Nothing -> failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $ PsErrCmmParser (CmmUnknownMacro fun)     Just fcode -> return $ do         args <- sequence args_code         code (fcode args)@@ -1260,7 +1266,8 @@   = do  conv <- case conv_string of           "C"       -> return CCallConv           "stdcall" -> return StdCallConv-          _         -> failMsgPD $ PsError (PsErrCmmParser (CmmUnknownCConv conv_string)) []+          _         -> failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $+                                              PsErrCmmParser (CmmUnknownCConv conv_string)         return $ do           platform <- getPlatform           results <- sequence results_code@@ -1337,7 +1344,7 @@   = do     platform <- PD.getPlatform     case lookupUFM (callishMachOps platform) name of-        Nothing -> failMsgPD $ PsError (PsErrCmmParser (CmmUnknownPrimitive name)) []+        Nothing -> failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $ PsErrCmmParser (CmmUnknownPrimitive name)         Just f  -> return $ do                 results <- sequence results_code                 args <- sequence args_code@@ -1492,7 +1499,11 @@   where platform = profilePlatform profile  -parseCmmFile :: DynFlags -> Module -> HomeUnit -> FilePath -> IO (Bag PsWarning, Bag PsError, Maybe (CmmGroup, [InfoProvEnt]))+parseCmmFile :: DynFlags+             -> Module+             -> HomeUnit+             -> FilePath+             -> IO (Messages PsMessage, Messages PsMessage, Maybe (CmmGroup, [InfoProvEnt])) parseCmmFile dflags this_mod home_unit filename = do   buf <- hGetStringBuffer filename   let@@ -1503,19 +1514,21 @@                 -- in there we don't want.   case unPD cmmParse dflags home_unit init_state of     PFailed pst -> do-        let (warnings,errors) = getMessages pst+        let (warnings,errors) = getPsMessages pst         return (warnings, errors, Nothing)     POk pst code -> do         st <- initC+        let fstate = F.initFCodeState (profilePlatform $ targetProfile dflags)         let fcode = do               ((), cmm) <- getCmm $ unEC code "global" (initEnv (targetProfile dflags)) [] >> return ()+              -- See Note [Mapping Info Tables to Source Positions] (IPE Maps)               let used_info = map (cmmInfoTableToInfoProvEnt this_mod)                                               (mapMaybe topInfoTable cmm)               ((), cmm2) <- getCmm $ mapM_ emitInfoTableProv used_info               return (cmm ++ cmm2, used_info)-            (cmm, _) = runC dflags no_module st fcode-            (warnings,errors) = getMessages pst-        if not (isEmptyBag errors)+            (cmm, _) = runC (initStgToCmmConfig dflags no_module) fstate st fcode+            (warnings,errors) = getPsMessages pst+        if not (isEmptyMessages errors)          then return (warnings, errors, Nothing)          else return (warnings, errors, Just cmm)   where
compiler/GHC/Cmm/Parser/Monad.hs view
@@ -13,7 +13,6 @@   , failMsgPD   , getProfile   , getPlatform-  , getPtrOpts   , getHomeUnitId   ) where @@ -21,13 +20,13 @@  import GHC.Platform import GHC.Platform.Profile-import GHC.Cmm.Info  import Control.Monad  import GHC.Driver.Session import GHC.Parser.Lexer-import GHC.Parser.Errors+import GHC.Parser.Errors.Types+import GHC.Types.Error ( MsgEnvelope ) import GHC.Types.SrcLoc import GHC.Unit.Types import GHC.Unit.Home@@ -47,7 +46,7 @@ liftP :: P a -> PD a liftP (P f) = PD $ \_ _ s -> f s -failMsgPD :: (SrcSpan -> PsError) -> PD a+failMsgPD :: (SrcSpan -> MsgEnvelope PsMessage) -> PD a failMsgPD = liftP . failMsgP  returnPD :: a -> PD a@@ -67,15 +66,6 @@  getPlatform :: PD Platform getPlatform = profilePlatform <$> getProfile--getPtrOpts :: PD PtrOpts-getPtrOpts = do-   dflags <- getDynFlags-   profile <- getProfile-   pure $ PtrOpts-      { po_profile     = profile-      , po_align_check = gopt Opt_AlignmentSanitisation dflags-      }  -- | Return the UnitId of the home-unit. This is used to create labels. getHomeUnitId :: PD UnitId
compiler/GHC/Cmm/Pipeline.hs view
@@ -10,19 +10,20 @@ import GHC.Prelude  import GHC.Cmm-import GHC.Cmm.Lint-import GHC.Cmm.Info.Build-import GHC.Cmm.CommonBlockElim-import GHC.Cmm.Switch.Implement-import GHC.Cmm.ProcPoint+import GHC.Cmm.Config import GHC.Cmm.ContFlowOpt+import GHC.Cmm.CommonBlockElim+import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Info.Build+import GHC.Cmm.Lint import GHC.Cmm.LayoutStack+import GHC.Cmm.ProcPoint import GHC.Cmm.Sink-import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Switch.Implement  import GHC.Types.Unique.Supply import GHC.Driver.Session-import GHC.Driver.Backend+import GHC.Driver.Config.Cmm import GHC.Utils.Error import GHC.Utils.Logger import GHC.Driver.Env@@ -43,23 +44,31 @@  -> IO (ModuleSRTInfo, CmmGroupSRTs) -- Output CPS transformed C--  cmmPipeline hsc_env srtInfo prog = do-  let logger = hsc_logger hsc_env-  let dflags = hsc_dflags hsc_env-  let forceRes (info, group) = info `seq` foldr (\decl r -> decl `seq` r) () group-  withTimingSilent logger dflags (text "Cmm pipeline") forceRes $ do-     tops <- {-# SCC "tops" #-} mapM (cpsTop logger dflags) prog+  let logger    = hsc_logger hsc_env+  let cmmConfig = initCmmConfig (hsc_dflags hsc_env)+  let forceRes (info, group) = info `seq` foldr seq () group+  let platform = cmmPlatform cmmConfig+  withTimingSilent logger (text "Cmm pipeline") forceRes $ do+     tops <- {-# SCC "tops" #-} mapM (cpsTop logger platform cmmConfig) prog       let (procs, data_) = partitionEithers tops-     (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags srtInfo procs data_-     let platform = targetPlatform dflags-     dumpWith logger dflags Opt_D_dump_cmm_cps "Post CPS Cmm" FormatCMM (pdoc platform cmms)+     (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs cmmConfig srtInfo procs data_+     dumpWith logger Opt_D_dump_cmm_cps "Post CPS Cmm" FormatCMM (pdoc platform cmms)       return (srtInfo, cmms)  -cpsTop :: Logger -> DynFlags -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl))-cpsTop _logger dflags p@(CmmData _ statics) = return (Right (cafAnalData (targetPlatform dflags) statics, p))-cpsTop logger dflags proc =+-- | The Cmm pipeline for a single 'CmmDecl'. Returns:+--+--   - in the case of a 'CmmProc': 'Left' of the resulting (possibly+--     proc-point-split) 'CmmDecl's and their 'CafEnv'. CAF analysis+--     necessarily happens *before* proc-point splitting, as described in Note+--     [SRTs].+--+--   - in the case of a `CmmData`, the unmodified 'CmmDecl' and a 'CAFSet' containing+cpsTop :: Logger -> Platform -> CmmConfig -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl))+cpsTop _logger platform _ p@(CmmData _ statics) = return (Right (cafAnalData platform statics, p))+cpsTop logger platform cfg proc =     do       ----------- Control-flow optimisations ---------------------------------- @@ -76,15 +85,17 @@        ----------- Eliminate common blocks -------------------------------------       g <- {-# SCC "elimCommonBlocks" #-}-           condPass Opt_CmmElimCommonBlocks elimCommonBlocks g+           condPass (cmmOptElimCommonBlks cfg) elimCommonBlocks g                          Opt_D_dump_cmm_cbe "Post common block elimination"        -- Any work storing block Labels must be performed _after_       -- elimCommonBlocks        ----------- Implement switches -------------------------------------------      g <- {-# SCC "createSwitchPlans" #-}-           runUniqSM $ cmmImplementSwitchPlans (backend dflags) platform g+      g <- if cmmDoCmmSwitchPlans cfg+             then {-# SCC "createSwitchPlans" #-}+                  runUniqSM $ cmmImplementSwitchPlans platform g+             else pure g       dump Opt_D_dump_cmm_switch "Post switch plan" g        ----------- Proc points -------------------------------------------------@@ -96,7 +107,7 @@             then do               pp <- {-# SCC "minimalProcPointSet" #-} runUniqSM $                  minimalProcPointSet platform call_pps g-              dumpWith logger dflags Opt_D_dump_cmm_proc "Proc points"+              dumpWith logger Opt_D_dump_cmm_proc "Proc points"                     FormatCMM (pdoc platform l $$ ppr pp $$ pdoc platform g)               return pp             else@@ -106,25 +117,25 @@       (g, stackmaps) <-            {-# SCC "layoutStack" #-}            if do_layout-              then runUniqSM $ cmmLayoutStack dflags proc_points entry_off g+              then runUniqSM $ cmmLayoutStack cfg proc_points entry_off g               else return (g, mapEmpty)       dump Opt_D_dump_cmm_sp "Layout Stack" g        ----------- Sink and inline assignments  --------------------------------       g <- {-# SCC "sink" #-} -- See Note [Sinking after stack layout]-           condPass Opt_CmmSink (cmmSink platform) g+           condPass (cmmOptSink cfg) (cmmSink platform) g                     Opt_D_dump_cmm_sink "Sink assignments"        ------------- CAF analysis ----------------------------------------------       let cafEnv = {-# SCC "cafAnal" #-} cafAnal platform call_pps l g-      dumpWith logger dflags Opt_D_dump_cmm_caf "CAFEnv" FormatText (pdoc platform cafEnv)+      dumpWith logger Opt_D_dump_cmm_caf "CAFEnv" FormatText (pdoc platform cafEnv)        g <- if splitting_proc_points            then do              ------------- Split into separate procedures -----------------------              let pp_map = {-# SCC "procPointAnalysis" #-}                           procPointAnalysis proc_points g-             dumpWith logger dflags Opt_D_dump_cmm_procmap "procpoint map"+             dumpWith logger Opt_D_dump_cmm_procmap "procpoint map"                 FormatCMM (ppr pp_map)              g <- {-# SCC "splitAtProcPoints" #-} runUniqSM $                   splitAtProcPoints platform l call_pps proc_points pp_map@@ -142,7 +153,7 @@        ----------- Control-flow optimisations -----------------------------       g <- {-# SCC "cmmCfgOpts(2)" #-}-           return $ if optLevel dflags >= 1+           return $ if cmmOptControlFlow cfg                     then map (cmmCfgOptsProc splitting_proc_points) g                     else g       g <- return (map removeUnreachableBlocksProc g)@@ -151,14 +162,13 @@        return (Left (cafEnv, g)) -  where platform = targetPlatform dflags-        dump = dumpGraph logger dflags+  where dump = dumpGraph logger platform (cmmDoLinting cfg)          dumps flag name-           = mapM_ (dumpWith logger dflags flag name FormatCMM . pdoc platform)+           = mapM_ (dumpWith logger flag name FormatCMM . pdoc platform) -        condPass flag pass g dumpflag dumpname =-            if gopt flag dflags+        condPass do_opt pass g dumpflag dumpname =+            if do_opt                then do                     g <- return $ pass g                     dump dumpflag dumpname g@@ -169,18 +179,10 @@         -- tablesNextToCode is off.  The latter is because we have no         -- label to put on info tables for basic blocks that are not         -- the entry point.-        splitting_proc_points = backend dflags /= NCG-                             || not (platformTablesNextToCode platform)-                             || -- Note [inconsistent-pic-reg]-                                usingInconsistentPicReg-        usingInconsistentPicReg-           = case (platformArch platform, platformOS platform, positionIndependent dflags)-             of   (ArchX86, OSDarwin, pic) -> pic-                  _                        -> False+        splitting_proc_points = cmmSplitProcPoints cfg  -- Note [Sinking after stack layout] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- -- In the past we considered running sinking pass also before stack -- layout, but after making some measurements we realized that: --@@ -306,7 +308,7 @@ --  {- Note [inconsistent-pic-reg]-+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~ On x86/Darwin, PIC is implemented by inserting a sequence like      call 1f@@ -334,7 +336,7 @@ -}  {- Note [unreachable blocks]-+   ~~~~~~~~~~~~~~~~~~~~~~~~~ The control-flow optimiser sometimes leaves unreachable blocks behind containing junk code.  These aren't necessarily a problem, but removing them is good because it might save time in the native code@@ -348,24 +350,23 @@   return (initUs_ us m)  -dumpGraph :: Logger -> DynFlags -> DumpFlag -> String -> CmmGraph -> IO ()-dumpGraph logger dflags flag name g = do-  when (gopt Opt_DoCmmLinting dflags) $ do_lint g-  dumpWith logger dflags flag name FormatCMM (pdoc platform g)+dumpGraph :: Logger -> Platform -> Bool -> DumpFlag -> String -> CmmGraph -> IO ()+dumpGraph logger platform do_linting flag name g = do+  when do_linting $ do_lint g+  dumpWith logger flag name FormatCMM (pdoc platform g)  where-  platform = targetPlatform dflags   do_lint g = case cmmLintGraph platform g of-                 Just err -> do { fatalErrorMsg logger dflags err-                                ; ghcExit logger dflags 1+                 Just err -> do { fatalErrorMsg logger err+                                ; ghcExit logger 1                                 }                  Nothing  -> return () -dumpWith :: Logger -> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()-dumpWith logger dflags flag txt fmt sdoc = do-  dumpIfSet_dyn logger dflags flag txt fmt sdoc-  when (not (dopt flag dflags)) $+dumpWith :: Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()+dumpWith logger flag txt fmt sdoc = do+  putDumpFileMaybe logger flag txt fmt sdoc+  when (not (logHasDumpFlag logger flag)) $     -- If `-ddump-cmm-verbose -ddump-to-file` is specified,     -- dump each Cmm pipeline stage output to a separate file.  #16930-    when (dopt Opt_D_dump_cmm_verbose dflags)-      $ putDumpMsg logger dflags (mkDumpStyle alwaysQualify) flag txt fmt sdoc-  dumpIfSet_dyn logger dflags Opt_D_dump_cmm_verbose_by_proc txt fmt sdoc+    when (logHasDumpFlag logger Opt_D_dump_cmm_verbose)+      $ logDumpFile logger (mkDumpStyle alwaysQualify) flag txt fmt sdoc+  putDumpFileMaybe logger Opt_D_dump_cmm_verbose_by_proc txt fmt sdoc
compiler/GHC/Cmm/Ppr.hs view
@@ -56,7 +56,7 @@ import GHC.Utils.Outputable import GHC.Cmm.Ppr.Decl import GHC.Cmm.Ppr.Expr-import GHC.Utils.Misc+import GHC.Utils.Constants (debugIsOn)  import GHC.Types.Basic import GHC.Cmm.Dataflow.Block@@ -64,6 +64,8 @@  ------------------------------------------------- -- Outputable instances+instance OutputableP Platform InfoProvEnt where+  pdoc platform (InfoProvEnt clabel _ _ _ _) = pdoc platform clabel  instance Outputable CmmStackInfo where     ppr = pprStackInfo
compiler/GHC/Cmm/Ppr/Decl.hs view
@@ -51,7 +51,6 @@ import GHC.Cmm  import GHC.Utils.Outputable-import GHC.Data.FastString  import Data.List (intersperse) @@ -160,15 +159,14 @@     section = text "section"  pprSectionType :: SectionType -> SDoc-pprSectionType s = doubleQuotes (ptext t)- where-  t = case s of-    Text              -> sLit "text"-    Data              -> sLit "data"-    ReadOnlyData      -> sLit "readonly"-    ReadOnlyData16    -> sLit "readonly16"-    RelocatableReadOnlyData-                      -> sLit "relreadonly"-    UninitialisedData -> sLit "uninitialised"-    CString           -> sLit "cstring"-    OtherSection s'   -> sLit s' -- Not actually a literal though.+pprSectionType s = doubleQuotes $ case s of+  Text                    -> text "text"+  Data                    -> text "data"+  ReadOnlyData            -> text "readonly"+  ReadOnlyData16          -> text "readonly16"+  RelocatableReadOnlyData -> text "relreadonly"+  UninitialisedData       -> text "uninitialised"+  InitArray               -> text "initarray"+  FiniArray               -> text "finiarray"+  CString                 -> text "cstring"+  OtherSection s'         -> text s'
compiler/GHC/Cmm/Ppr/Expr.hs view
@@ -44,12 +44,11 @@  import GHC.Prelude -import GHC.Driver.Ppr- import GHC.Platform import GHC.Cmm.Expr  import GHC.Utils.Outputable+import GHC.Utils.Trace  import Data.Maybe import Numeric ( fromRat )
compiler/GHC/Cmm/ProcPoint.hs view
@@ -213,7 +213,7 @@                                 ProcPoint -> 1                                 ReachedBy ps -> setSize ps                 block_procpoints = nreached (entryLabel b)-                -- | Looking for a successor of b that is reached by+                -- Looking for a successor of b that is reached by                 -- more proc points than b and is not already a proc                 -- point.  If found, it can become a proc point.                 newId succ_id = not (setMember succ_id procPoints') &&@@ -428,7 +428,7 @@  {- Note [Direct reachability]-+~~~~~~~~~~~~~~~~~~~~~~~~~~ Block B is directly reachable from proc point P iff control can flow from P to B without passing through an intervening proc point. -}@@ -437,7 +437,7 @@  {- Note [No simple dataflow]-+~~~~~~~~~~~~~~~~~~~~~~~~~ Sadly, it seems impossible to compute the proc points using a single dataflow pass.  One might attempt to use this simple lattice:
compiler/GHC/Cmm/Sink.hs view
@@ -318,21 +318,65 @@  where    go []               block as = (block, as)    go ((live,node):ns) block as+    -- discard nodes representing dead assignment     | shouldDiscard node live             = go ns block as-       -- discard dead assignment+    -- sometimes only after simplification we can tell we can discard the node.+    -- See Note [Discard simplified nodes]+    | noOpAssignment node2                = go ns block as+    -- Pick up interesting assignments     | Just a <- shouldSink platform node2 = go ns block (a : as1)+    -- Try inlining, drop assignments and move on     | otherwise                           = go ns block' as'     where+      -- Simplify node       node1 = constantFoldNode platform node +      -- Inline assignments       (node2, as1) = tryToInline platform live node1 as +      -- Drop any earlier assignments conflicting with node2       (dropped, as') = dropAssignmentsSimple platform                           (\a -> conflicts platform a node2) as1 +      -- Walk over the rest of the block. Includes dropped assignments       block' = foldl' blockSnoc block dropped `blockSnoc` node2 +{- Note [Discard simplified nodes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider a sequence like this: +      _c1::P64 = R1;+      _c3::I64 = I64[_c1::P64 + 1];+      R1 = _c1::P64;+      P64[Sp - 72] = _c1::P64;+      I64[Sp - 64] = _c3::I64;++If we discard assignments *before* simplifying nodes when we get to `R1 = _c1`.+This is then simplified into `R1 = `R1` and as a consequence prevents sinking of+loads from R1. What happens is that we:+    * Check if we can discard the node `R1 = _c1 (no)+    * Simplify the node to R1 = R1+    * We check all remaining assignments for conflicts.+    * The assignment `_c3 = [R1 + 1]`; (R1 already inlined on pickup)+      conflicts with R1 = R1, because it reads `R1` and the node writes+      to R1+    * This is clearly no-sensical because `R1 = R1` doesn't affect R1's value.++The solutions is to check if we can discard nodes before and *after* simplifying+them. We could only do it after as well, but I assume doing it early might save+some work.++That is if we process a assignment node we now:+    * Check if it can be discarded (because it's dead or a no-op)+    * Simplify the rhs of the assignment.+    * New: Check again if it might be a no-op now.+    * ...++This can help with problems like the one reported in #20334. For a full example see the test+cmm_sink_sp.++-}+ -- -- Heuristic to decide whether to pick up and sink an assignment -- Currently we pick up all assignments to local registers.  It might@@ -358,11 +402,20 @@ shouldDiscard :: CmmNode e x -> LRegSet -> Bool shouldDiscard node live    = case node of+       -- r = r        CmmAssign r (CmmReg r') | r == r' -> True+       -- r = e, r is dead after assignment        CmmAssign (CmmLocal r) _ -> not (r `elemLRegSet` live)        _otherwise -> False +noOpAssignment :: CmmNode e x -> Bool+noOpAssignment node+   = case node of+       -- r = r+       CmmAssign r (CmmReg r') | r == r' -> True+       _otherwise -> False + toNode :: Assignment -> CmmNode O O toNode (r,rhs,_) = CmmAssign (CmmLocal r) rhs @@ -379,7 +432,9 @@     go _ []             dropped kept = (dropped, kept)    go state (assig : rest) dropped kept-      | conflict  = go state' rest (toNode assig : dropped) kept+      | conflict  =+          let !node = toNode assig+          in  go state' rest (node : dropped) kept       | otherwise = go state' rest dropped (assig:kept)       where         (dropit, state') = should_drop assig state@@ -388,13 +443,12 @@  -- ----------------------------------------------------------------------------- -- Try to inline assignments into a node.--- This also does constant folding for primpops, since+-- This also does constant folding for primops, since -- inlining opens up opportunities for doing so.  tryToInline    :: forall x. Platform    -> LRegSet               -- set of registers live after this-  --  -> LocalRegSet               -- set of registers live after this                                 -- node.  We cannot inline anything                                 -- that is live after the node, unless                                 -- it is small enough to duplicate.@@ -418,7 +472,7 @@    go usages live node skipped (a@(l,rhs,_) : rest)    | cannot_inline            = dont_inline-   | occurs_none              = discard  -- Note [discard during inlining]+   | occurs_none              = discard  -- See Note [discard during inlining]    | occurs_once              = inline_and_discard    | isTrivial platform rhs   = inline_and_keep    | otherwise                = dont_inline@@ -442,7 +496,7 @@                 live' = inline foldLocalRegsUsed platform (\m r -> insertLRegSet r m)                                             live rhs -        cannot_inline = skipped `regsUsedIn` rhs -- Note [dependent assignments]+        cannot_inline = skipped `regsUsedIn` rhs -- See Note [dependent assignments]                         || l `elemLRegSet` skipped                         || not (okToInline platform rhs node) @@ -465,8 +519,7 @@         inl_exp other = other  {- Note [Keeping assignemnts mentioned in skipped RHSs]-    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~     If we have to assignments: [z = y, y = e1] and we skip     z we *must* retain the assignment y = e1. This is because     we might inline "z = y" into another node later on so we@@ -487,7 +540,7 @@ -}  {- Note [improveConditional]-+   ~~~~~~~~~~~~~~~~~~~~~~~~~ cmmMachOpFold tries to simplify conditionals to turn things like   (a == b) != 1 into@@ -525,7 +578,6 @@  -- Note [dependent assignments] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- -- If our assignment list looks like -- --    [ y = e,  x = ... y ... ]@@ -622,15 +674,20 @@   -- (5) foreign calls clobber heap: see Note [Foreign calls clobber heap]   | CmmUnsafeForeignCall{} <- node, memConflicts addr AnyMem      = True -  -- (6) native calls clobber any memory+  -- (6) suspendThread clobbers every global register not backed by a real+  -- register. It also clobbers heap and stack but this is handled by (5)+  | CmmUnsafeForeignCall (PrimTarget MO_SuspendThread) _ _ <- node+  , foldRegsUsed platform (\b g -> globalRegMaybe platform g == Nothing || b) False rhs+  = True++  -- (7) native calls clobber any memory   | CmmCall{} <- node, memConflicts addr AnyMem                   = True -  -- (7) otherwise, no conflict+  -- (8) otherwise, no conflict   | otherwise = False  {- Note [Inlining foldRegsDefd]    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~-    foldRegsDefd is, after optimization, *not* a small function so    it's only marked INLINEABLE, but not INLINE. @@ -660,7 +717,6 @@  -- Note [Sinking and calls] -- ~~~~~~~~~~~~~~~~~~~~~~~~--- -- We have three kinds of calls: normal (CmmCall), safe foreign (CmmForeignCall) -- and unsafe foreign (CmmUnsafeForeignCall). We perform sinking pass after -- stack layout (see Note [Sinking after stack layout]) which leads to two@@ -743,7 +799,6 @@  -- Note [Foreign calls clobber heap] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- -- It is tempting to say that foreign calls clobber only -- non-heap/stack memory, but unfortunately we break this invariant in -- the RTS.  For example, in stg_catch_retry_frame we call@@ -759,6 +814,10 @@ -- Some CallishMachOp imply a memory barrier e.g. AtomicRMW and -- therefore we should never float any memory operations across one of -- these calls.+--+-- `suspendThread` releases the capability used by the thread, hence we mustn't+-- float accesses to heap, stack or virtual global registers stored in the+-- capability (e.g. with unregisterised build, see #19237).   bothMems :: AbsMem -> AbsMem -> AbsMem
compiler/GHC/Cmm/Switch/Implement.hs view
@@ -6,7 +6,6 @@  import GHC.Prelude -import GHC.Driver.Backend import GHC.Platform import GHC.Cmm.Dataflow.Block import GHC.Cmm.BlockId@@ -32,11 +31,10 @@  -- | Traverses the 'CmmGraph', making sure that 'CmmSwitch' are suitable for -- code generation.-cmmImplementSwitchPlans :: Backend -> Platform -> CmmGraph -> UniqSM CmmGraph-cmmImplementSwitchPlans backend platform g+cmmImplementSwitchPlans :: Platform -> CmmGraph -> UniqSM CmmGraph+cmmImplementSwitchPlans platform g =     -- Switch generation done by backend (LLVM/C)-    | backendSupportsSwitch backend = return g-    | otherwise = do+    do     blocks' <- concatMapM (visitSwitches platform) (toBlockList g)     return $ ofBlockList (g_entry g) blocks' @@ -59,16 +57,15 @@  -- Note [Floating switch expressions] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- -- When we translate a sparse switch into a search tree we would like -- to compute the value we compare against only once.-+-- -- For this purpose we assign the switch expression to a local register -- and then use this register when constructing the actual binary tree.-+-- -- This is important as the expression could contain expensive code like -- memory loads or divisions which we REALLY don't want to duplicate.-+-- -- This happened in parts of the handwritten RTS Cmm code. See also #16933  -- See Note [Floating switch expressions]@@ -83,6 +80,8 @@ implementSwitchPlan :: Platform -> CmmTickScope -> CmmExpr -> SwitchPlan -> UniqSM (Block CmmNode O C, [CmmBlock]) implementSwitchPlan platform scope expr = go   where+    width = typeWidth $ cmmExprType platform expr+     go (Unconditionally l)       = return (emptyBlock `blockJoinTail` CmmBranch l, [])     go (JumpTable ids)@@ -92,9 +91,9 @@         (bid1, newBlocks1) <- go' ids1         (bid2, newBlocks2) <- go' ids2 -        let lt | signed    = cmmSLtWord-               | otherwise = cmmULtWord-            scrut = lt platform expr $ CmmLit $ mkWordCLit platform i+        let lt | signed    = MO_S_Lt+               | otherwise = MO_U_Lt+            scrut = CmmMachOp (lt width) [expr, CmmLit $ CmmInt i width]             lastNode = CmmCondBranch scrut bid1 bid2 Nothing             lastBlock = emptyBlock `blockJoinTail` lastNode         return (lastBlock, newBlocks1++newBlocks2)@@ -102,7 +101,7 @@       = do         (bid2, newBlocks2) <- go' ids2 -        let scrut = cmmNeWord platform expr $ CmmLit $ mkWordCLit platform i+        let scrut = CmmMachOp (MO_Ne width) [expr, CmmLit $ CmmInt i width]             lastNode = CmmCondBranch scrut bid2 l Nothing             lastBlock = emptyBlock `blockJoinTail` lastNode         return (lastBlock, newBlocks2)
compiler/GHC/Cmm/Utils.hs view
@@ -48,7 +48,7 @@         currentTSOExpr, currentNurseryExpr, cccsExpr,          -- Tagging-        cmmTagMask, cmmPointerMask, cmmUntag, cmmIsTagged,+        cmmTagMask, cmmPointerMask, cmmUntag, cmmIsTagged, cmmIsNotTagged,         cmmConstrTag1, mAX_PTR_TAG, tAG_MASK,          -- Overlap and usage@@ -115,7 +115,7 @@    AddrRep          -> bWord platform    FloatRep         -> f32    DoubleRep        -> f64-   VecRep len rep   -> vec len (primElemRepCmmType rep)+   (VecRep len rep) -> vec len (primElemRepCmmType rep)  slotCmmType :: Platform -> SlotTy -> CmmType slotCmmType platform = \case@@ -125,7 +125,6 @@    Word64Slot      -> b64    FloatSlot       -> f32    DoubleSlot      -> f64-   VecSlot l e     -> vec l (primElemRepCmmType e)  primElemRepCmmType :: PrimElemRep -> CmmType primElemRepCmmType Int8ElemRep   = b8@@ -448,13 +447,14 @@  -- Used to untag a possibly tagged pointer -- A static label need not be untagged-cmmUntag, cmmIsTagged, cmmConstrTag1 :: Platform -> CmmExpr -> CmmExpr+cmmUntag, cmmIsTagged, cmmIsNotTagged, cmmConstrTag1 :: Platform -> CmmExpr -> CmmExpr cmmUntag _ e@(CmmLit (CmmLabel _)) = e -- Default case cmmUntag platform e = cmmAndWord platform e (cmmPointerMask platform) --- Test if a closure pointer is untagged+-- Test if a closure pointer is untagged/tagged. cmmIsTagged platform e = cmmNeWord platform (cmmAndWord platform e (cmmTagMask platform)) (zeroExpr platform)+cmmIsNotTagged platform e = cmmEqWord platform (cmmAndWord platform e (cmmTagMask platform)) (zeroExpr platform)  -- Get constructor tag, but one based. cmmConstrTag1 platform e = cmmAndWord platform e (cmmTagMask platform)
compiler/GHC/CmmToAsm.hs view
@@ -6,7 +6,6 @@ -- -----------------------------------------------------------------------------  {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -76,17 +75,13 @@    -- cmmNativeGen emits    , cmmNativeGen    , NcgImpl(..)-   , initNCGConfig    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import qualified GHC.CmmToAsm.X86   as X86 import qualified GHC.CmmToAsm.PPC   as PPC-import qualified GHC.CmmToAsm.SPARC as SPARC import qualified GHC.CmmToAsm.AArch64 as AArch64  import GHC.CmmToAsm.Reg.Liveness@@ -135,9 +130,12 @@ import GHC.Utils.BufHandle import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic+import GHC.Utils.Error+import GHC.Utils.Exception (evaluate)+import GHC.Utils.Constants (debugIsOn)+ import GHC.Data.FastString import GHC.Types.Unique.Set-import GHC.Utils.Error import GHC.Unit import GHC.Data.Stream (Stream) import qualified GHC.Data.Stream as Stream@@ -145,27 +143,23 @@ import Data.List (sortBy, groupBy) import Data.Maybe import Data.Ord         ( comparing )-import Control.Exception import Control.Monad import System.IO  ---------------------nativeCodeGen :: forall a . Logger -> DynFlags -> Module -> ModLocation -> Handle -> UniqSupply+nativeCodeGen :: forall a . Logger -> NCGConfig -> ModLocation -> Handle -> UniqSupply               -> Stream IO RawCmmGroup a               -> IO a-nativeCodeGen logger dflags this_mod modLoc h us cmms- = let config   = initNCGConfig dflags this_mod-       platform = ncgPlatform config+nativeCodeGen logger config modLoc h us cmms+ = let platform = ncgPlatform config        nCG' :: ( OutputableP Platform statics, Outputable jumpDest, Instruction instr)             => NcgImpl statics instr jumpDest -> IO a-       nCG' ncgImpl = nativeCodeGen' logger dflags config modLoc ncgImpl h us cmms+       nCG' ncgImpl = nativeCodeGen' logger config modLoc ncgImpl h us cmms    in case platformArch platform of       ArchX86       -> nCG' (X86.ncgX86     config)       ArchX86_64    -> nCG' (X86.ncgX86_64  config)       ArchPPC       -> nCG' (PPC.ncgPPC     config)       ArchPPC_64 _  -> nCG' (PPC.ncgPPC     config)-      ArchSPARC     -> nCG' (SPARC.ncgSPARC config)-      ArchSPARC64   -> panic "nativeCodeGen: No NCG for SPARC64"       ArchS390X     -> panic "nativeCodeGen: No NCG for S390X"       ArchARM {}    -> panic "nativeCodeGen: No NCG for ARM"       ArchAArch64   -> nCG' (AArch64.ncgAArch64 config)@@ -198,7 +192,6 @@ {- Note [Unwinding information in the NCG] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- Unwind information is a type of metadata which allows a debugging tool to reconstruct the values of machine registers at the time a procedure was entered. For the most part, the production of unwind information is handled by@@ -222,7 +215,6 @@  nativeCodeGen' :: (OutputableP Platform statics, Outputable jumpDest, Instruction instr)                => Logger-               -> DynFlags                -> NCGConfig                -> ModLocation                -> NcgImpl statics instr jumpDest@@ -230,35 +222,34 @@                -> UniqSupply                -> Stream IO RawCmmGroup a                -> IO a-nativeCodeGen' logger dflags config modLoc ncgImpl h us cmms+nativeCodeGen' logger config modLoc ncgImpl h us cmms  = do         -- BufHandle is a performance hack.  We could hide it inside         -- Pretty if it weren't for the fact that we do lots of little         -- printDocs here (in order to do codegen in constant space).         bufh <- newBufHandle h         let ngs0 = NGS [] [] [] [] [] [] emptyUFM mapEmpty-        (ngs, us', a) <- cmmNativeGenStream logger dflags config modLoc ncgImpl bufh us+        (ngs, us', a) <- cmmNativeGenStream logger config modLoc ncgImpl bufh us                                          cmms ngs0-        _ <- finishNativeGen logger dflags config modLoc bufh us' ngs+        _ <- finishNativeGen logger config modLoc bufh us' ngs         return a  finishNativeGen :: Instruction instr                 => Logger-                -> DynFlags                 -> NCGConfig                 -> ModLocation                 -> BufHandle                 -> UniqSupply                 -> NativeGenAcc statics instr                 -> IO UniqSupply-finishNativeGen logger dflags config modLoc bufh@(BufHandle _ _ h) us ngs- = withTimingSilent logger dflags (text "NCG") (`seq` ()) $ do+finishNativeGen logger config modLoc bufh@(BufHandle _ _ h) us ngs+ = withTimingSilent logger (text "NCG") (`seq` ()) $ do         -- Write debug data and finish         us' <- if not (ncgDwarfEnabled config)                   then return us                   else do                      (dwarf, us') <- dwarfGen config modLoc us (ngs_debug ngs)-                     emitNativeCode logger dflags config bufh dwarf+                     emitNativeCode logger config bufh dwarf                      return us'         bFlush bufh @@ -275,7 +266,7 @@           dump_stats (Color.pprStats stats graphGlobal)            let platform = ncgPlatform config-          dumpIfSet_dyn logger dflags+          putDumpFileMaybe logger                   Opt_D_dump_asm_conflicts "Register conflict graph"                   FormatText                   $ Color.dotGraph@@ -297,13 +288,12 @@                 $ makeImportsDoc config (concat (ngs_imports ngs))         return us'   where-    dump_stats = putDumpMsg logger dflags (mkDumpStyle alwaysQualify)+    dump_stats = logDumpFile logger (mkDumpStyle alwaysQualify)                    Opt_D_dump_asm_stats "NCG stats"                    FormatText  cmmNativeGenStream :: forall statics jumpDest instr a . (OutputableP Platform statics, Outputable jumpDest, Instruction instr)               => Logger-              -> DynFlags               -> NCGConfig               -> ModLocation               -> NcgImpl statics instr jumpDest@@ -313,7 +303,7 @@               -> NativeGenAcc statics instr               -> IO (NativeGenAcc statics instr, UniqSupply, a) -cmmNativeGenStream logger dflags config modLoc ncgImpl h us cmm_stream ngs+cmmNativeGenStream logger config modLoc ncgImpl h us cmm_stream ngs  = loop us (Stream.runStream cmm_stream) ngs   where     ncglabel = text "NCG"@@ -335,7 +325,6 @@         Stream.Yield cmms cmm_stream' -> do           (us', ngs'') <-             withTimingSilent logger-                dflags                 ncglabel (\(a, b) -> a `seq` b `seq` ()) $ do               -- Generate debug information               let !ndbgs | ncgDwarfEnabled config = cmmDebugGen modLoc cmms@@ -343,15 +332,15 @@                   dbgMap = debugToMap ndbgs                -- Generate native code-              (ngs',us') <- cmmNativeGens logger dflags config modLoc ncgImpl h+              (ngs',us') <- cmmNativeGens logger config modLoc ncgImpl h                                           dbgMap us cmms ngs 0                -- Link native code information into debug blocks               -- See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock".               let !ldbgs = cmmDebugLink (ngs_labels ngs') (ngs_unwinds ngs') ndbgs-                  platform = targetPlatform dflags+                  platform = ncgPlatform config               unless (null ldbgs) $-                dumpIfSet_dyn logger dflags Opt_D_dump_debug "Debug Infos" FormatText+                putDumpFileMaybe logger Opt_D_dump_debug "Debug Infos" FormatText                   (vcat $ map (pdoc platform) ldbgs)                -- Accumulate debug information for emission in finishNativeGen.@@ -366,7 +355,6 @@ cmmNativeGens :: forall statics instr jumpDest.                  (OutputableP Platform statics, Outputable jumpDest, Instruction instr)               => Logger-              -> DynFlags               -> NCGConfig               -> ModLocation               -> NcgImpl statics instr jumpDest@@ -378,7 +366,7 @@               -> Int               -> IO (NativeGenAcc statics instr, UniqSupply) -cmmNativeGens logger dflags config modLoc ncgImpl h dbgMap = go+cmmNativeGens logger config modLoc ncgImpl h dbgMap = go   where     go :: UniqSupply -> [RawCmmDecl]        -> NativeGenAcc statics instr -> Int@@ -391,7 +379,7 @@         let fileIds = ngs_dwarfFiles ngs         (us', fileIds', native, imports, colorStats, linearStats, unwinds)           <- {-# SCC "cmmNativeGen" #-}-             cmmNativeGen logger dflags modLoc ncgImpl us fileIds dbgMap+             cmmNativeGen logger modLoc ncgImpl us fileIds dbgMap                           cmm count          -- Generate .file directives for every new file that has been@@ -403,17 +391,17 @@             pprDecl (f,n) = text "\t.file " <> ppr n <+>                             pprFilePathString (unpackFS f) -        emitNativeCode logger dflags config h $ vcat $+        emitNativeCode logger config h $ vcat $           map pprDecl newFileIds ++           map (pprNatCmmDecl ncgImpl) native          -- force evaluation all this stuff to avoid space leaks-        let platform = targetPlatform dflags-        {-# SCC "seqString" #-} evaluate $ seqList (showSDoc dflags $ vcat $ map (pdoc platform) imports) ()+        let platform = ncgPlatform config+        {-# SCC "seqString" #-} evaluate $ seqList (showSDocUnsafe $ vcat $ map (pdoc platform) imports) ()          let !labels' = if ncgDwarfEnabled config                        then cmmDebugLabels isMetaInstr native else []-            !natives' = if dopt Opt_D_dump_asm_stats dflags+            !natives' = if logHasDumpFlag logger Opt_D_dump_asm_stats                         then native : ngs_natives ngs else []              mCon = maybe id (:)@@ -428,14 +416,14 @@         go us' cmms ngs' (count + 1)  -emitNativeCode :: Logger -> DynFlags -> NCGConfig -> BufHandle -> SDoc -> IO ()-emitNativeCode logger dflags config h sdoc = do+emitNativeCode :: Logger -> NCGConfig -> BufHandle -> SDoc -> IO ()+emitNativeCode logger config h sdoc = do          let ctx = ncgAsmContext config         {-# SCC "pprNativeCode" #-} bufLeftRenderSDoc ctx h sdoc          -- dump native code-        dumpIfSet_dyn logger dflags+        putDumpFileMaybe logger                 Opt_D_dump_asm "Asm code" FormatASM                 sdoc @@ -445,7 +433,6 @@ cmmNativeGen     :: forall statics instr jumpDest. (Instruction instr, OutputableP Platform statics, Outputable jumpDest)     => Logger-    -> DynFlags     -> ModLocation     -> NcgImpl statics instr jumpDest         -> UniqSupply@@ -462,7 +449,7 @@                 , LabelMap [UnwindPoint]                    -- unwinding information for blocks                 ) -cmmNativeGen logger dflags modLoc ncgImpl us fileIds dbgMap cmm count+cmmNativeGen logger modLoc ncgImpl us fileIds dbgMap cmm count  = do         let config   = ncgConfig ncgImpl         let platform = ncgPlatform config@@ -482,7 +469,7 @@                 {-# SCC "cmmToCmm" #-}                 cmmToCmm config fixed_cmm -        dumpIfSet_dyn logger dflags+        putDumpFileMaybe logger                 Opt_D_dump_opt_cmm "Optimised Cmm" FormatCMM                 (pprCmmGroup platform [opt_cmm]) @@ -496,16 +483,16 @@                                         (cmmTopCodeGen ncgImpl)                                         fileIds dbgMap opt_cmm cmmCfg -        dumpIfSet_dyn logger dflags+        putDumpFileMaybe logger                 Opt_D_dump_asm_native "Native code" FormatASM                 (vcat $ map (pprNatCmmDecl ncgImpl) native) -        maybeDumpCfg logger dflags (Just nativeCfgWeights) "CFG Weights - Native" proc_name+        maybeDumpCfg logger (Just nativeCfgWeights) "CFG Weights - Native" proc_name          -- tag instructions with register liveness information         -- also drops dead code. We don't keep the cfg in sync on         -- some backends, so don't use it there.-        let livenessCfg = if backendMaintainsCfg platform+        let livenessCfg = if ncgEnableDeadCodeElimination config                                 then Just nativeCfgWeights                                 else Nothing         let (withLiveness, usLive) =@@ -513,15 +500,14 @@                 initUs usGen                         $ mapM (cmmTopLiveness livenessCfg platform) native -        dumpIfSet_dyn logger dflags+        putDumpFileMaybe logger                 Opt_D_dump_asm_liveness "Liveness annotations added"                 FormatCMM                 (vcat $ map (pprLiveCmmDecl platform) withLiveness)          -- allocate registers         (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear, raStats, stack_updt_blks) <--         if ( gopt Opt_RegsGraph dflags-           || gopt Opt_RegsIterative dflags )+         if ( ncgRegsGraph config || ncgRegsIterative config )           then do                 -- the regs usable for allocation                 let (alloc_regs :: UniqFM RegClass (UniqSet RealReg))@@ -553,12 +539,12 @@                   -- dump out what happened during register allocation-                dumpIfSet_dyn logger dflags+                putDumpFileMaybe logger                         Opt_D_dump_asm_regalloc "Registers allocated"                         FormatCMM                         (vcat $ map (pprNatCmmDecl ncgImpl) alloced) -                dumpIfSet_dyn logger dflags+                putDumpFileMaybe logger                         Opt_D_dump_asm_regalloc_stages "Build/spill stages"                         FormatText                         (vcat   $ map (\(stage, stats)@@ -568,7 +554,7 @@                                 $ zip [0..] regAllocStats)                  let mPprStats =-                        if dopt Opt_D_dump_asm_stats dflags+                        if logHasDumpFlag logger Opt_D_dump_asm_stats                          then Just regAllocStats else Nothing                  -- force evaluation of the Maybe to avoid space leak@@ -597,13 +583,13 @@                           $ liftM unzip3                           $ mapM reg_alloc withLiveness -                dumpIfSet_dyn logger dflags+                putDumpFileMaybe logger                         Opt_D_dump_asm_regalloc "Registers allocated"                         FormatCMM                         (vcat $ map (pprNatCmmDecl ncgImpl) alloced)                  let mPprStats =-                        if dopt Opt_D_dump_asm_stats dflags+                        if logHasDumpFlag logger Opt_D_dump_asm_stats                          then Just (catMaybes regAllocStats) else Nothing                  -- force evaluation of the Maybe to avoid space leak@@ -632,7 +618,7 @@                 {-# SCC "generateJumpTables" #-}                 generateJumpTables ncgImpl alloced -        when (not $ null nativeCfgWeights) $ dumpIfSet_dyn logger dflags+        when (not $ null nativeCfgWeights) $ putDumpFileMaybe logger                 Opt_D_dump_cfg_weights "CFG Update information"                 FormatText                 ( text "stack:" <+> ppr stack_updt_blks $$@@ -641,20 +627,20 @@         ---- shortcut branches         let (shorted, postShortCFG)     =                 {-# SCC "shortcutBranches" #-}-                shortcutBranches dflags ncgImpl tabled postRegCFG+                shortcutBranches config ncgImpl tabled postRegCFG          let optimizedCFG :: Maybe CFG             optimizedCFG =-                optimizeCFG (gopt Opt_CmmStaticPred dflags) weights cmm <$!> postShortCFG+                optimizeCFG (ncgCmmStaticPred config) weights cmm <$!> postShortCFG -        maybeDumpCfg logger dflags optimizedCFG "CFG Weights - Final" proc_name+        maybeDumpCfg logger optimizedCFG "CFG Weights - Final" proc_name          --TODO: Partially check validity of the cfg.         let getBlks (CmmProc _info _lbl _live (ListGraph blocks)) = blocks             getBlks _ = [] -        when ( backendMaintainsCfg platform &&-                (gopt Opt_DoAsmLinting dflags || debugIsOn )) $ do+        when ( ncgEnableDeadCodeElimination config &&+                (ncgAsmLinting config || debugIsOn )) $ do                 let blocks = concatMap getBlks shorted                 let labels = setFromList $ fmap blockId blocks :: LabelSet                 let cfg = fromJust optimizedCFG@@ -682,41 +668,30 @@                 invert (CmmProc info lbl live (ListGraph blocks)) =                     CmmProc info lbl live (ListGraph $ invertConds info blocks) -        ---- expansion of SPARC synthetic instrs-        let expanded =-                {-# SCC "sparc_expand" #-}-                ncgExpandTop ncgImpl branchOpt-                --ncgExpandTop ncgImpl sequenced--        dumpIfSet_dyn logger dflags-                Opt_D_dump_asm_expanded "Synthetic instructions expanded"-                FormatCMM-                (vcat $ map (pprNatCmmDecl ncgImpl) expanded)-         -- generate unwinding information from cmm         let unwinds :: BlockMap [UnwindPoint]             unwinds =                 {-# SCC "unwindingInfo" #-}-                foldl' addUnwind mapEmpty expanded+                foldl' addUnwind mapEmpty branchOpt               where                 addUnwind acc proc =-                    acc `mapUnion` computeUnwinding dflags ncgImpl proc+                    acc `mapUnion` computeUnwinding config ncgImpl proc          return  ( usAlloc                 , fileIds'-                , expanded+                , branchOpt                 , lastMinuteImports ++ imports                 , ppr_raStatsColor                 , ppr_raStatsLinear                 , unwinds ) -maybeDumpCfg :: Logger -> DynFlags -> Maybe CFG -> String -> SDoc -> IO ()-maybeDumpCfg _logger _dflags Nothing _ _ = return ()-maybeDumpCfg logger dflags (Just cfg) msg proc_name+maybeDumpCfg :: Logger -> Maybe CFG -> String -> SDoc -> IO ()+maybeDumpCfg _logger Nothing _ _ = return ()+maybeDumpCfg logger (Just cfg) msg proc_name         | null cfg = return ()         | otherwise-        = dumpIfSet_dyn logger-                dflags Opt_D_dump_cfg_weights msg+        = putDumpFileMaybe logger+                Opt_D_dump_cfg_weights msg                 FormatText                 (proc_name <> char ':' $$ pprEdgeWeights cfg) @@ -724,8 +699,7 @@ checkLayout :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]             -> [NatCmmDecl statics instr] checkLayout procsUnsequenced procsSequenced =-        ASSERT2(setNull diff,-                ppr "Block sequencing dropped blocks:" <> ppr diff)+        assertPpr (setNull diff) (ppr "Block sequencing dropped blocks:" <> ppr diff)         procsSequenced   where         blocks1 = foldl' (setUnion) setEmpty $@@ -740,15 +714,16 @@  -- | Compute unwinding tables for the blocks of a procedure computeUnwinding :: Instruction instr-                 => DynFlags -> NcgImpl statics instr jumpDest+                 => NCGConfig+                 -> NcgImpl statics instr jumpDest                  -> NatCmmDecl statics instr                     -- ^ the native code generated for the procedure                  -> LabelMap [UnwindPoint]                     -- ^ unwinding tables for all points of all blocks of the                     -- procedure-computeUnwinding dflags _ _-  | debugLevel dflags == 0         = mapEmpty-computeUnwinding _ _ (CmmData _ _) = mapEmpty+computeUnwinding config _ _+  | not (ncgComputeUnwinding config) = mapEmpty+computeUnwinding _ _ (CmmData _ _)   = mapEmpty computeUnwinding _ ncgImpl (CmmProc _ _ _ (ListGraph blks)) =     -- In general we would need to push unwinding information down the     -- block-level call-graph to ensure that we fully account for all@@ -834,14 +809,15 @@ -- Shortcut branches  shortcutBranches-        :: forall statics instr jumpDest. (Outputable jumpDest) => DynFlags+        :: forall statics instr jumpDest. (Outputable jumpDest)+        => NCGConfig         -> NcgImpl statics instr jumpDest         -> [NatCmmDecl statics instr]         -> Maybe CFG         -> ([NatCmmDecl statics instr],Maybe CFG) -shortcutBranches dflags ncgImpl tops weights-  | gopt Opt_AsmShortcutting dflags+shortcutBranches config ncgImpl tops weights+  | ncgEnableShortcutting config   = ( map (apply_mapping ncgImpl mapping) tops'     , shortcutWeightMap mappingBid <$!> weights )   | otherwise@@ -1146,56 +1122,3 @@          other            -> return other---- | Initialize the native code generator configuration from the DynFlags-initNCGConfig :: DynFlags -> Module -> NCGConfig-initNCGConfig dflags this_mod = NCGConfig-   { ncgPlatform              = targetPlatform dflags-   , ncgThisModule            = this_mod-   , ncgAsmContext            = initSDocContext dflags (PprCode AsmStyle)-   , ncgProcAlignment         = cmmProcAlignment dflags-   , ncgExternalDynamicRefs   = gopt Opt_ExternalDynamicRefs dflags-   , ncgPIC                   = positionIndependent dflags-   , ncgInlineThresholdMemcpy = fromIntegral $ maxInlineMemcpyInsns dflags-   , ncgInlineThresholdMemset = fromIntegral $ maxInlineMemsetInsns dflags-   , ncgSplitSections         = gopt Opt_SplitSections dflags-   , ncgRegsIterative         = gopt Opt_RegsIterative dflags-   , ncgAsmLinting            = gopt Opt_DoAsmLinting dflags-   , ncgCfgWeights            = cfgWeights dflags-   , ncgCfgBlockLayout        = gopt Opt_CfgBlocklayout dflags-   , ncgCfgWeightlessLayout   = gopt Opt_WeightlessBlocklayout dflags--     -- With -O1 and greater, the cmmSink pass does constant-folding, so-     -- we don't need to do it again in the native code generator.-   , ncgDoConstantFolding     = optLevel dflags < 1--   , ncgDumpRegAllocStages    = dopt Opt_D_dump_asm_regalloc_stages dflags-   , ncgDumpAsmStats          = dopt Opt_D_dump_asm_stats dflags-   , ncgDumpAsmConflicts      = dopt Opt_D_dump_asm_conflicts dflags-   , ncgBmiVersion            = case platformArch (targetPlatform dflags) of-                                 ArchX86_64 -> bmiVersion dflags-                                 ArchX86    -> bmiVersion dflags-                                 _          -> Nothing--     -- We assume  SSE1 and SSE2 operations are available on both-     -- x86 and x86_64. Historically we didn't default to SSE2 and-     -- SSE1 on x86, which results in defacto nondeterminism for how-     -- rounding behaves in the associated x87 floating point instructions-     -- because variations in the spill/fpu stack placement of arguments for-     -- operations would change the precision and final result of what-     -- would otherwise be the same expressions with respect to single or-     -- double precision IEEE floating point computations.-   , ncgSseVersion =-      let v | sseVersion dflags < Just SSE2 = Just SSE2-            | otherwise                     = sseVersion dflags-      in case platformArch (targetPlatform dflags) of-            ArchX86_64 -> v-            ArchX86    -> v-            _          -> Nothing--   , ncgDwarfEnabled        = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags > 0 && platformArch (targetPlatform dflags) /= ArchAArch64-   , ncgDwarfUnwindings     = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags > 0-   , ncgDwarfStripBlockInfo = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags < 2 -- We strip out block information when running with -g0 or -g1.-   , ncgDwarfSourceNotes    = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags > 2 -- We produce GHC-specific source-note DIEs only with -g3-   , ncgExposeInternalSymbols = gopt Opt_ExposeInternalSymbols dflags-   }
compiler/GHC/CmmToAsm/AArch64.hs view
@@ -32,7 +32,6 @@        ,maxSpillSlots             = AArch64.maxSpillSlots config        ,allocatableRegs           = AArch64.allocatableRegs platform        ,ncgAllocMoreStack         = AArch64.allocMoreStack platform-       ,ncgExpandTop              = id        ,ncgMakeFarBranches        = const id        ,extractUnwindPoints       = const []        ,invertCondBranches        = \_ _ -> id
compiler/GHC/CmmToAsm/AArch64/CodeGen.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE GADTs #-}+{-# language GADTs #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE BinaryLiterals #-}@@ -12,8 +11,6 @@  where -#include "GhclibHsVersions.h"- -- NCG stuff: import GHC.Prelude hiding (EQ) @@ -65,6 +62,7 @@ import GHC.Utils.Panic  -- Note [General layout of an NCG]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- @cmmTopCodeGen@ will be our main entry point to code gen.  Here we'll get -- @RawCmmDecl@; see GHC.Cmm --@@ -173,7 +171,7 @@ -- ----------------------------------------------------------------------------- -- | Utilities ann :: SDoc -> Instr -> Instr-ann doc instr  = ANN doc instr+ann doc instr {- debugIsOn -} = ANN doc instr -- ann _ instr = instr {-# INLINE ann #-} @@ -201,8 +199,8 @@ -- forced until we actually force them, and without -dppr-debug they should -- never end up being forced. annExpr :: CmmExpr -> Instr -> Instr-annExpr e instr  = ANN (text . show $ e) instr--- annExpr e instr  = ANN (pprExpr genericPlatform e) instr+annExpr e instr {- debugIsOn -} = ANN (text . show $ e) instr+-- annExpr e instr {- debugIsOn -} = ANN (pprExpr genericPlatform e) instr -- annExpr _ instr = instr {-# INLINE annExpr #-} @@ -478,7 +476,7 @@ getRegister' :: NCGConfig -> Platform -> CmmExpr -> NatM Register -- OPTIMIZATION WARNING: CmmExpr rewrites -- 1. Rewrite: Reg + (-n) => Reg - n---    TODO: this expression souldn't even be generated to begin with.+--    TODO: this expression shouldn't even be generated to begin with. getRegister' config plat (CmmMachOp (MO_Add w0) [x, CmmLit (CmmInt i w1)]) | i < 0   = getRegister' config plat (CmmMachOp (MO_Sub w0) [x, CmmLit (CmmInt (-i) w1)]) @@ -664,11 +662,10 @@         -- See Note [Signed arithmetic on AArch64].         negate code w reg = do             let w' = opRegWidth w-            (reg', code_sx) <- signExtendReg w w' reg             return $ Any (intFormat w) $ \dst ->                 code `appOL`-                code_sx `snocOL`-                NEG (OpReg w' dst) (OpReg w' reg') `appOL`+                signExtendReg w w' reg `snocOL`+                NEG (OpReg w' dst) (OpReg w' reg) `appOL`                 truncateReg w' w dst          ss_conv from to reg code =@@ -797,7 +794,7 @@             -- <OP> x<n>, x<m>, x<o>             (reg_x, format_x, code_x) <- getSomeReg x             (reg_y, format_y, code_y) <- getSomeReg y-            MASSERT2(isIntFormat format_x == isIntFormat format_y, text "bitOp: incompatible")+            massertPpr (isIntFormat format_x == isIntFormat format_y) $ text "bitOp: incompatible"             return $ Any (intFormat w) (\dst ->                 code_x `appOL`                 code_y `appOL`@@ -813,35 +810,33 @@               -- <OP> x<n>, x<m>, x<o>               (reg_x, format_x, code_x) <- getSomeReg x               (reg_y, format_y, code_y) <- getSomeReg y-              MASSERT2(isIntFormat format_x && isIntFormat format_y, text "intOp: non-int")+              massertPpr (isIntFormat format_x && isIntFormat format_y) $ text "intOp: non-int"               -- This is the width of the registers on which the operation               -- should be performed.               let w' = opRegWidth w                   signExt r-                    | not is_signed  = return (r, nilOL)+                    | not is_signed  = nilOL                     | otherwise      = signExtendReg w w' r-              (reg_x_sx, code_x_sx) <- signExt reg_x-              (reg_y_sx, code_y_sx) <- signExt reg_y               return $ Any (intFormat w) $ \dst ->                   code_x `appOL`                   code_y `appOL`                   -- sign-extend both operands-                  code_x_sx `appOL`-                  code_y_sx `appOL`-                  op (OpReg w' dst) (OpReg w' reg_x_sx) (OpReg w' reg_y_sx) `appOL`+                  signExt reg_x `appOL`+                  signExt reg_y `appOL`+                  op (OpReg w' dst) (OpReg w' reg_x) (OpReg w' reg_y) `appOL`                   truncateReg w' w dst -- truncate back to the operand's original width            floatOp w op = do             (reg_fx, format_x, code_fx) <- getFloatReg x             (reg_fy, format_y, code_fy) <- getFloatReg y-            MASSERT2(isFloatFormat format_x && isFloatFormat format_y, text "floatOp: non-float")+            massertPpr (isFloatFormat format_x && isFloatFormat format_y) $ text "floatOp: non-float"             return $ Any (floatFormat w) (\dst -> code_fx `appOL` code_fy `appOL` op (OpReg w dst) (OpReg w reg_fx) (OpReg w reg_fy))            -- need a special one for conditionals, as they return ints           floatCond w op = do             (reg_fx, format_x, code_fx) <- getFloatReg x             (reg_fy, format_y, code_fy) <- getFloatReg y-            MASSERT2(isFloatFormat format_x && isFloatFormat format_y, text "floatCond: non-float")+            massertPpr (isFloatFormat format_x && isFloatFormat format_y) $ text "floatCond: non-float"             return $ Any (intFormat w) (\dst -> code_fx `appOL` code_fy `appOL` op (OpReg w dst) (OpReg w reg_fx) (OpReg w reg_fy))        case op of@@ -852,7 +847,7 @@         MO_Sub w -> intOp False w (\d x y -> unitOL $ annExpr expr (SUB d x y))          -- Note [CSET]-        --+        -- ~~~~~~~~~~~         -- Setting conditional flags: the architecture internally knows the         -- following flag bits.  And based on thsoe comparisons as in the         -- table below.@@ -1024,21 +1019,16 @@  -- | Instructions to sign-extend the value in the given register from width @w@ -- up to width @w'@.-signExtendReg :: Width -> Width -> Reg -> NatM (Reg, OrdList Instr)+signExtendReg :: Width -> Width -> Reg -> OrdList Instr signExtendReg w w' r =     case w of-      W64 -> noop+      W64 -> nilOL       W32-        | w' == W32 -> noop-        | otherwise -> extend SXTH-      W16           -> extend SXTH-      W8            -> extend SXTB+        | w' == W32 -> nilOL+        | otherwise -> unitOL $ SXTH (OpReg w' r) (OpReg w' r)+      W16           -> unitOL $ SXTH (OpReg w' r) (OpReg w' r)+      W8            -> unitOL $ SXTB (OpReg w' r) (OpReg w' r)       _             -> panic "intOp"-  where-    noop = return (r, nilOL)-    extend instr = do-        r' <- getNewRegNat II64-        return (r', unitOL $ instr (OpReg w' r') (OpReg w' r))  -- | Instructions to truncate the value in the given register from width @w@ -- down to width @w'@.@@ -1316,7 +1306,7 @@ -- -- To actually get the value of <symbol>, we'd need to ldr x0, x0 still, which -- for the first case can be optimized to use ldr x0, [x0, #:lo12:<symbol>]--- instaed of the add instruction.+-- instead of the add instruction. -- -- As the memory model for AArch64 for PIC is considered to be +/- 4GB, we do -- not need to go through the GOT, unless we want to address the full address@@ -1524,6 +1514,9 @@         MO_Memmove _align   -> mkCCall "memmove"         MO_Memcmp  _align   -> mkCCall "memcmp" +        MO_SuspendThread    -> mkCCall "suspendThread"+        MO_ResumeThread     -> mkCCall "resumeThread"+         MO_PopCnt w         -> mkCCall (popCntLabel w)         MO_Pdep w           -> mkCCall (pdepLabel w)         MO_Pext w           -> mkCCall (pextLabel w)@@ -1546,11 +1539,11 @@     unsupported :: Show a => a -> b     unsupported mop = panic ("outOfLineCmmOp: " ++ show mop                           ++ " not supported here")-    mkCCall :: String -> NatM (InstrBlock, Maybe BlockId)+    mkCCall :: FastString -> NatM (InstrBlock, Maybe BlockId)     mkCCall name = do       config <- getConfig       target <- cmmMakeDynamicReference config CallReference $-          mkForeignLabel (fsLit name) Nothing ForeignLabelInThisPackage IsFunction+          mkForeignLabel name Nothing ForeignLabelInThisPackage IsFunction       let cconv = ForeignConvention CCallConv [NoHint] [NoHint] CmmMayReturn       genCCall (ForeignTarget target cconv) dest_regs arg_regs bid
compiler/GHC/CmmToAsm/AArch64/Instr.hs view
@@ -28,7 +28,6 @@  import GHC.Utils.Panic -import Control.Monad (replicateM) import Data.Maybe (fromMaybe)  import GHC.Stack@@ -73,12 +72,6 @@ regUsageOfInstr :: Platform -> Instr -> RegUsage regUsageOfInstr platform instr = case instr of   ANN _ i                  -> regUsageOfInstr platform i-  COMMENT{}                -> usage ([], [])-  MULTILINE_COMMENT{}      -> usage ([], [])-  PUSH_STACK_FRAME         -> usage ([], [])-  POP_STACK_FRAME          -> usage ([], [])-  DELTA{}                  -> usage ([], [])-   -- 1. Arithmetic Instructions ------------------------------------------------   ADD dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)   CMN l r                  -> usage (regOp l ++ regOp r, [])@@ -143,7 +136,7 @@   FCVTZS dst src           -> usage (regOp src, regOp dst)   FABS dst src             -> usage (regOp src, regOp dst) -  _ -> panic $ "regUsageOfInstr: " ++ instrCon instr+  _ -> panic "regUsageOfInstr"    where         -- filtering the usage is necessary, otherwise the register@@ -173,8 +166,6 @@         interesting _        (RegVirtual _)                 = True         interesting _        (RegReal (RealRegSingle (-1))) = False         interesting platform (RegReal (RealRegSingle i))    = freeReg platform i-        interesting _        (RegReal (RealRegPair{}))-            = panic "AArch64.Instr.interesting: no reg pairs on this arch"  -- Save caller save registers -- This is x0-x18@@ -209,12 +200,7 @@ patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr patchRegsOfInstr instr env = case instr of     -- 0. Meta Instructions-    ANN d i             -> ANN d (patchRegsOfInstr i env)-    COMMENT{}           -> instr-    MULTILINE_COMMENT{} -> instr-    PUSH_STACK_FRAME    -> instr-    POP_STACK_FRAME     -> instr-    DELTA{}             -> instr+    ANN d i        -> ANN d (patchRegsOfInstr i env)     -- 1. Arithmetic Instructions ----------------------------------------------     ADD o1 o2 o3   -> ADD (patchOp o1) (patchOp o2) (patchOp o3)     CMN o1 o2      -> CMN (patchOp o1) (patchOp o2)@@ -280,7 +266,8 @@     SCVTF o1 o2    -> SCVTF (patchOp o1) (patchOp o2)     FCVTZS o1 o2   -> FCVTZS (patchOp o1) (patchOp o2)     FABS o1 o2     -> FABS (patchOp o1) (patchOp o2)-    _              -> panic $ "patchRegsOfInstr: " ++ instrCon instr++    _ -> pprPanic "patchRegsOfInstr" (text $ show instr)     where         patchOp :: Operand -> Operand         patchOp (OpReg w r) = OpReg w (env r)@@ -336,7 +323,7 @@         B (TBlock bid) -> B (TBlock (patchF bid))         BL (TBlock bid) ps rs -> BL (TBlock (patchF bid)) ps rs         BCOND c (TBlock bid) -> BCOND c (TBlock (patchF bid))-        _ -> panic $ "patchJumpInstr: " ++ instrCon instr+        _ -> pprPanic "patchJumpInstr" (text $ show instr)  -- ----------------------------------------------------------------------------- -- Note [Spills and Reloads]@@ -463,7 +450,7 @@ mkStackDeallocInstr _platform n = pprPanic "mkStackDeallocInstr" (int n)  ----- See note [extra spill slots] in X86/Instr.hs+-- See Note [extra spill slots] in X86/Instr.hs -- allocMoreStack   :: Platform@@ -475,7 +462,7 @@ allocMoreStack platform slots proc@(CmmProc info lbl live (ListGraph code)) = do     let entries = entryBlocks proc -    uniqs <- replicateM (length entries) getUniqueM+    uniqs <- getUniquesM      let       delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up@@ -648,69 +635,10 @@     -- Float ABSolute value     | FABS Operand Operand -instrCon :: Instr -> String-instrCon i =-    case i of-      COMMENT{} -> "COMMENT"-      MULTILINE_COMMENT{} -> "COMMENT"-      ANN{} -> "ANN"-      LOCATION{} -> "LOCATION"-      LDATA{} -> "LDATA"-      NEWBLOCK{} -> "NEWBLOCK"-      DELTA{} -> "DELTA"-      SXTB{} -> "SXTB"-      UXTB{} -> "UXTB"-      SXTH{} -> "SXTH"-      UXTH{} -> "UXTH"-      PUSH_STACK_FRAME{} -> "PUSH_STACK_FRAME"-      POP_STACK_FRAME{} -> "POP_STACK_FRAME"-      ADD{} -> "ADD"-      CMN{} -> "CMN"-      CMP{} -> "CMP"-      MSUB{} -> "MSUB"-      MUL{} -> "MUL"-      NEG{} -> "NEG"-      SDIV{} -> "SDIV"-      SMULH{} -> "SMULH"-      SMULL{} -> "SMULL"-      SUB{} -> "SUB"-      UDIV{} -> "UDIV"-      SBFM{} -> "SBFM"-      UBFM{} -> "UBFM"-      SBFX{} -> "SBFX"-      UBFX{} -> "UBFX"-      AND{} -> "AND"-      ANDS{} -> "ANDS"-      ASR{} -> "ASR"-      BIC{} -> "BIC"-      BICS{} -> "BICS"-      EON{} -> "EON"-      EOR{} -> "EOR"-      LSL{} -> "LSL"-      LSR{} -> "LSR"-      MOV{} -> "MOV"-      MOVK{} -> "MOVK"-      MVN{} -> "MVN"-      ORN{} -> "ORN"-      ORR{} -> "ORR"-      ROR{} -> "ROR"-      TST{} -> "TST"-      STR{} -> "STR"-      LDR{} -> "LDR"-      STP{} -> "STP"-      LDP{} -> "LDP"-      CSET{} -> "CSET"-      CBZ{} -> "CBZ"-      CBNZ{} -> "CBNZ"-      J{} -> "J"-      B{} -> "B"-      BL{} -> "BL"-      BCOND{} -> "BCOND"-      DMBSY{} -> "DMBSY"-      FCVT{} -> "FCVT"-      SCVTF{} -> "SCVTF"-      FCVTZS{} -> "FCVTZS"-      FABS{} -> "FABS"+instance Show Instr where+    show (LDR _f o1 o2) = "LDR " ++ show o1 ++ ", " ++ show o2+    show (MOV o1 o2) = "MOV " ++ show o1 ++ ", " ++ show o2+    show _ = "missing"  data Target     = TBlock BlockId@@ -838,11 +766,11 @@ opRegUExt W32 r = OpRegExt W32 r EUXTW 0 opRegUExt W16 r = OpRegExt W16 r EUXTH 0 opRegUExt W8  r = OpRegExt W8  r EUXTB 0-opRegUExt w  _r = pprPanic "opRegUExt" (ppr w)+opRegUExt w  _r = pprPanic "opRegUExt" (text $ show w)  opRegSExt :: Width -> Reg -> Operand opRegSExt W64 r = OpRegExt W64 r ESXTX 0 opRegSExt W32 r = OpRegExt W32 r ESXTW 0 opRegSExt W16 r = OpRegExt W16 r ESXTH 0 opRegSExt W8  r = OpRegExt W8  r ESXTB 0-opRegSExt w  _r = pprPanic "opRegSExt" (ppr w)+opRegSExt w  _r = pprPanic "opRegSExt" (text $ show w)
compiler/GHC/CmmToAsm/AArch64/Ppr.hs view
@@ -5,11 +5,6 @@  import GHC.Prelude hiding (EQ) -import Data.Word-import qualified Data.Array.Unsafe as U ( castSTUArray )-import Data.Array.ST-import Control.Monad.ST- import GHC.CmmToAsm.AArch64.Instr import GHC.CmmToAsm.AArch64.Regs import GHC.CmmToAsm.AArch64.Cond@@ -147,7 +142,7 @@              then ppr (mkAsmTempEndLabel info_lbl) <> char ':'              else empty)     -- Make sure the info table has the right .loc for the block-    -- coming right after it. See [Note: Info Offset]+    -- coming right after it. See Note [Info Offset]     infoTableLoc = case instrs of       (l@LOCATION{} : _) -> pprInstr platform l       _other             -> empty@@ -187,11 +182,12 @@   | otherwise = text "\t.globl " <> pdoc platform lbl  -- Note [Always use objects for info tables]--- See discussion in X86.Ppr--- for why this is necessary.  Essentially we need to ensure that we never--- pass function symbols when we migth want to lookup the info table.  If we--- did, we could end up with procedure linking tables (PLT)s, and thus the--- lookup wouldn't point to the function, but into the jump table.+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- See discussion in X86.Ppr for why this is necessary.  Essentially we need to+-- ensure that we never pass function symbols when we migth want to lookup the+-- info table.  If we did, we could end up with procedure linking tables+-- (PLT)s, and thus the lookup wouldn't point to the function, but into the+-- jump table. -- -- Fun fact: The LLVMMangler exists to patch this issue su on the LLVM side as -- well.@@ -227,30 +223,14 @@          ppr_item FF32  (CmmFloat r _)            = let bs = floatToBytes (fromRational r)-             in  map (\b -> text "\t.byte\t" <> pprImm platform (ImmInt b)) bs+             in  map (\b -> text "\t.byte\t" <> int (fromIntegral b)) bs          ppr_item FF64 (CmmFloat r _)            = let bs = doubleToBytes (fromRational r)-             in  map (\b -> text "\t.byte\t" <> pprImm platform (ImmInt b)) bs+             in  map (\b -> text "\t.byte\t" <> int (fromIntegral b)) bs          ppr_item _ _ = pprPanic "pprDataItem:ppr_item" (text $ show lit) -floatToBytes :: Float -> [Int]-floatToBytes f-   = runST (do-        arr <- newArray_ ((0::Int),3)-        writeArray arr 0 f-        arr <- castFloatToWord8Array arr-        i0 <- readArray arr 0-        i1 <- readArray arr 1-        i2 <- readArray arr 2-        i3 <- readArray arr 3-        return (map fromIntegral [i0,i1,i2,i3])-     )--castFloatToWord8Array :: STUArray s Int Float -> ST s (STUArray s Int Word8)-castFloatToWord8Array = U.castSTUArray- pprImm :: Platform -> Imm -> SDoc pprImm _ (ImmInt i)     = int i pprImm _ (ImmInteger i) = integer i@@ -339,7 +319,6 @@ pprReg :: Width -> Reg -> SDoc pprReg w r = case r of   RegReal    (RealRegSingle i) -> ppr_reg_no w i-  RegReal    (RealRegPair{})   -> panic "AArch64.pprReg: no reg pairs on this arch!"   -- virtual regs should not show up, but this is helpful for debugging.   RegVirtual (VirtualRegI u)   -> text "%vI_" <> pprUniqueAlways u   RegVirtual (VirtualRegF u)   -> text "%vF_" <> pprUniqueAlways u
compiler/GHC/CmmToAsm/AArch64/Regs.hs view
@@ -129,16 +129,12 @@                         | regNo < 32    -> 1     -- first fp reg is 32                         | otherwise     -> 0 -                RealRegPair{}           -> 0-         RcDouble          -> case rr of                 RealRegSingle regNo                         | regNo < 32    -> 0                         | otherwise     -> 1 -                RealRegPair{}           -> 0-         _other -> 0  mkVirtualReg :: Unique -> Format -> VirtualReg@@ -155,9 +151,6 @@ classOfRealReg (RealRegSingle i)         | i < 32        = RcInteger         | otherwise     = RcDouble--classOfRealReg (RealRegPair{})-        = panic "regClass(ppr): no reg pairs on this architecture"  regDotColor :: RealReg -> SDoc regDotColor reg
compiler/GHC/CmmToAsm/BlockLayout.hs view
@@ -13,10 +13,9 @@     ( sequenceTop, backendMaintainsCfg) where -#include "GhclibHsVersions.h" import GHC.Prelude -import GHC.Driver.Ppr     (pprTrace)+import GHC.Platform  import GHC.CmmToAsm.Instr import GHC.CmmToAsm.Monad@@ -24,29 +23,26 @@ import GHC.CmmToAsm.Types import GHC.CmmToAsm.Config -import GHC.Cmm.BlockId import GHC.Cmm+import GHC.Cmm.BlockId import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label -import GHC.Platform import GHC.Types.Unique.FM-import GHC.Utils.Misc  import GHC.Data.Graph.Directed-import GHC.Utils.Outputable-import GHC.Utils.Panic import GHC.Data.Maybe---- DEBUGGING ONLY---import GHC.Cmm.DebugBlock---import Debug.Trace import GHC.Data.List.SetOps (removeDups)- import GHC.Data.OrdList++import GHC.Utils.Trace+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Utils.Misc+ import Data.List (sortOn, sortBy, nub) import Data.Foldable (toList)- import qualified Data.Set as Set import Data.STRef import Control.Monad.ST.Strict@@ -71,10 +67,9 @@   * Feed this CFG into the block layout code (`sequenceTop`) in this     module. Which will then produce a code layout based on the input weights. -  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-  ~~~ Note [Chain based CFG serialization]-  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +  Note [Chain based CFG serialization]+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~   For additional information also look at   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/code-layout @@ -193,10 +188,9 @@   While E does not follow X it's still beneficial to place them near each other.   This can be advantageous if eg C,X,E will end up in the same cache line. -  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-  ~~~ Note [Triangle Control Flow]-  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +  Note [Triangle Control Flow]+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~   Checking if an argument is already evaluated leads to a somewhat   special case  which looks like this: @@ -244,10 +238,9 @@   Assuming that Lwork is large the chance that the "call" ends up   in the same cache line is also fairly small. -  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-  ~~~ Note [Layout relevant edge weights]-  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +  Note [Layout relevant edge weights]+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~   The input to the chain based code layout algorithm is a CFG   with edges annotated with their frequency. The frequency   of traversal corresponds quite well to the cost of not placing@@ -313,7 +306,7 @@ -- in the chain. instance Ord (BlockChain) where    (BlockChain lbls1) `compare` (BlockChain lbls2)-       = ASSERT(toList lbls1 /= toList lbls2 || lbls1 `strictlyEqOL` lbls2)+       = assert (toList lbls1 /= toList lbls2 || lbls1 `strictlyEqOL` lbls2) $          strictlyOrdOL lbls1 lbls2  instance Outputable (BlockChain) where@@ -377,9 +370,9 @@ takeL n (BlockChain blks) =     take n . fromOL $ blks + -- Note [Combining neighborhood chains] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- -- See also Note [Chain based CFG serialization] -- We have the chains (A-B-C-D) and (E-F) and an Edge C->E. --@@ -709,7 +702,7 @@             directEdges          (neighbourChains, combined)-            = ASSERT(noDups $ mapElems builtChains)+            = assert (noDups $ mapElems builtChains) $               {-# SCC "groupNeighbourChains" #-}             --   pprTraceIt "NeighbourChains" $               combineNeighbourhood rankedEdges (mapElems builtChains)@@ -749,7 +742,7 @@ #endif          blockList-            = ASSERT(noDups [masterChain])+            = assert (noDups [masterChain])               (concatMap fromOL $ map chainBlocks prepedChains)          --chainPlaced = setFromList $ map blockId blockList :: LabelSet@@ -763,14 +756,14 @@             -- We want debug builds to catch this as it's a good indicator for             -- issues with CFG invariants. But we don't want to blow up production             -- builds if something slips through.-            ASSERT(null unplaced)+            assert (null unplaced) $             --pprTraceIt "placedBlocks" $             -- ++ [] is stil kinda expensive             if null unplaced then blockList else blockList ++ unplaced         getBlock bid = expectJust "Block placement" $ mapLookup bid blockMap     in         --Assert we placed all blocks given as input-        ASSERT(all (\bid -> mapMember bid blockMap) placedBlocks)+        assert (all (\bid -> mapMember bid blockMap) placedBlocks) $         dropJumps info $ map getBlock placedBlocks  {-# SCC dropJumps #-}
compiler/GHC/CmmToAsm/CFG.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP                        #-} {-# LANGUAGE DataKinds                  #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE Rank2Types                 #-}@@ -42,8 +41,6 @@      ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Platform @@ -76,6 +73,7 @@  import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain -- DEBUGGING ONLY --import GHC.Cmm.DebugBlock --import GHC.Data.OrdList@@ -152,7 +150,7 @@ -- or has it been introduced during assembly codegen. We use this to maintain -- some information which would otherwise be lost during the -- Cmm \<-> asm transition.--- See also Note [Inverting Conditional Branches]+-- See also Note [Inverting conditions] data TransitionSource   = CmmSource { trans_cmmNode :: (CmmNode O C)               , trans_info :: BranchInfo }@@ -215,7 +213,7 @@ hasNode :: CFG -> BlockId -> Bool hasNode m node =   -- Check the invariant that each node must exist in the first map or not at all.-  ASSERT( found || not (any (mapMember node) m))+  assert (found || not (any (mapMember node) m))   found     where       found = mapMember node m@@ -240,7 +238,7 @@       diff = (setUnion cfgNodes blockSet) `setDifference` (setIntersection cfgNodes blockSet) :: LabelSet  -- | Filter the CFG with a custom function f.---   Paramaeters are `f from to edgeInfo`+--   Parameters are `f from to edgeInfo` filterEdges :: (BlockId -> BlockId -> EdgeInfo -> Bool) -> CFG -> CFG filterEdges f cfg =     mapMapWithKey filterSources cfg@@ -250,7 +248,7 @@   {- Note [Updating the CFG during shortcutting]-+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ See Note [What is shortcutting] in the control flow optimization code (GHC.Cmm.ContFlowOpt) for a slightly more in depth explanation on shortcutting. @@ -667,8 +665,8 @@         (CmmCall { cml_cont = Nothing })   -> []         other ->             panic "Foo" $-            ASSERT2(False, ppr "Unknown successor cause:" <>-              (pdoc platform branch <+> text "=>" <> pdoc platform (G.successors other)))+            assertPpr False (ppr "Unknown successor cause:" <>+              (pdoc platform branch <+> text "=>" <> pdoc platform (G.successors other))) $             map (\x -> ((bid,x),mkEdgeInfo 0)) $ G.successors other       where         bid = G.entryLabel block@@ -714,7 +712,7 @@     increaseBackEdgeWeight (g_entry graph) $ cfg   where -    -- | Increase the weight of all backedges in the CFG+    -- Increase the weight of all backedges in the CFG     -- this helps to make loop jumpbacks the heaviest edges     increaseBackEdgeWeight :: BlockId -> CFG -> CFG     increaseBackEdgeWeight root cfg =@@ -727,7 +725,7 @@         in  foldl'  (\cfg edge -> updateEdgeWeight update edge cfg)                     cfg backedges -    -- | Since we cant fall through info tables we penalize these.+    -- Since we cant fall through info tables we penalize these.     penalizeInfoTables :: LabelMap a -> CFG -> CFG     penalizeInfoTables info cfg =         mapWeights fupdate cfg@@ -738,7 +736,7 @@           = weight - (fromIntegral $ infoTablePenalty weights)           | otherwise = weight -    -- | If a block has two successors, favour the one with fewer+    -- If a block has two successors, favour the one with fewer     -- predecessors and/or the one allowing fall through.     favourFewerPreds :: CFG -> CFG     favourFewerPreds cfg =@@ -1015,7 +1013,6 @@  {- Note [Static Branch Prediction]    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- The work here has been based on the paper "Static Branch Prediction and Program Profile Analysis" by Y Wu, JR Larus.
compiler/GHC/CmmToAsm/CPrim.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE LambdaCase #-}+ -- | Generating C symbol names emitted by the compiler. module GHC.CmmToAsm.CPrim     ( atomicReadLabel@@ -15,130 +17,144 @@     , word2FloatLabel     ) where -import GHC.Prelude- import GHC.Cmm.Type import GHC.Cmm.MachOp+import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic -popCntLabel :: Width -> String-popCntLabel w = "hs_popcnt" ++ pprWidth w-  where-    pprWidth W8  = "8"-    pprWidth W16 = "16"-    pprWidth W32 = "32"-    pprWidth W64 = "64"-    pprWidth w   = pprPanic "popCntLabel: Unsupported word width " (ppr w)+popCntLabel :: Width -> FastString+popCntLabel = \case+  W8  -> fsLit "hs_popcnt8"+  W16 -> fsLit "hs_popcnt16"+  W32 -> fsLit "hs_popcnt32"+  W64 -> fsLit "hs_popcnt64"+  w   -> pprPanic "popCntLabel: Unsupported word width " (ppr w) -pdepLabel :: Width -> String-pdepLabel w = "hs_pdep" ++ pprWidth w-  where-    pprWidth W8  = "8"-    pprWidth W16 = "16"-    pprWidth W32 = "32"-    pprWidth W64 = "64"-    pprWidth w   = pprPanic "pdepLabel: Unsupported word width " (ppr w)+pdepLabel :: Width -> FastString+pdepLabel = \case+  W8  -> fsLit "hs_pdep8"+  W16 -> fsLit "hs_pdep16"+  W32 -> fsLit "hs_pdep32"+  W64 -> fsLit "hs_pdep64"+  w   -> pprPanic "pdepLabel: Unsupported word width " (ppr w) -pextLabel :: Width -> String-pextLabel w = "hs_pext" ++ pprWidth w-  where-    pprWidth W8  = "8"-    pprWidth W16 = "16"-    pprWidth W32 = "32"-    pprWidth W64 = "64"-    pprWidth w   = pprPanic "pextLabel: Unsupported word width " (ppr w)+pextLabel :: Width -> FastString+pextLabel = \case+  W8  -> fsLit "hs_pext8"+  W16 -> fsLit "hs_pext16"+  W32 -> fsLit "hs_pext32"+  W64 -> fsLit "hs_pext64"+  w   -> pprPanic "pextLabel: Unsupported word width " (ppr w) -bSwapLabel :: Width -> String-bSwapLabel w = "hs_bswap" ++ pprWidth w-  where-    pprWidth W16 = "16"-    pprWidth W32 = "32"-    pprWidth W64 = "64"-    pprWidth w   = pprPanic "bSwapLabel: Unsupported word width " (ppr w)+bSwapLabel :: Width -> FastString+bSwapLabel = \case+  W16 -> fsLit "hs_bswap16"+  W32 -> fsLit "hs_bswap32"+  W64 -> fsLit "hs_bswap64"+  w   -> pprPanic "bSwapLabel: Unsupported word width " (ppr w) -bRevLabel :: Width -> String-bRevLabel w = "hs_bitrev" ++ pprWidth w-  where-    pprWidth W8  = "8"-    pprWidth W16 = "16"-    pprWidth W32 = "32"-    pprWidth W64 = "64"-    pprWidth w   = pprPanic "bRevLabel: Unsupported word width " (ppr w)+bRevLabel :: Width -> FastString+bRevLabel = \case+  W8  -> fsLit "hs_bitrev8"+  W16 -> fsLit "hs_bitrev16"+  W32 -> fsLit "hs_bitrev32"+  W64 -> fsLit "hs_bitrev64"+  w   -> pprPanic "bRevLabel: Unsupported word width " (ppr w) -clzLabel :: Width -> String-clzLabel w = "hs_clz" ++ pprWidth w-  where-    pprWidth W8  = "8"-    pprWidth W16 = "16"-    pprWidth W32 = "32"-    pprWidth W64 = "64"-    pprWidth w   = pprPanic "clzLabel: Unsupported word width " (ppr w)+clzLabel :: Width -> FastString+clzLabel = \case+  W8  -> fsLit "hs_clz8"+  W16 -> fsLit "hs_clz16"+  W32 -> fsLit "hs_clz32"+  W64 -> fsLit "hs_clz64"+  w   -> pprPanic "clzLabel: Unsupported word width " (ppr w) -ctzLabel :: Width -> String-ctzLabel w = "hs_ctz" ++ pprWidth w-  where-    pprWidth W8  = "8"-    pprWidth W16 = "16"-    pprWidth W32 = "32"-    pprWidth W64 = "64"-    pprWidth w   = pprPanic "ctzLabel: Unsupported word width " (ppr w)+ctzLabel :: Width -> FastString+ctzLabel = \case+  W8  -> fsLit "hs_ctz8"+  W16 -> fsLit "hs_ctz16"+  W32 -> fsLit "hs_ctz32"+  W64 -> fsLit "hs_ctz64"+  w   -> pprPanic "ctzLabel: Unsupported word width " (ppr w) -word2FloatLabel :: Width -> String-word2FloatLabel w = "hs_word2float" ++ pprWidth w-  where-    pprWidth W32 = "32"-    pprWidth W64 = "64"-    pprWidth w   = pprPanic "word2FloatLabel: Unsupported word width " (ppr w)+word2FloatLabel :: Width -> FastString+word2FloatLabel = \case+  W32 -> fsLit "hs_word2float32"+  W64 -> fsLit "hs_word2float64"+  w   -> pprPanic "word2FloatLabel: Unsupported word width " (ppr w) -atomicRMWLabel :: Width -> AtomicMachOp -> String-atomicRMWLabel w amop = "hs_atomic_" ++ pprFunName amop ++ pprWidth w-  where-    pprWidth W8  = "8"-    pprWidth W16 = "16"-    pprWidth W32 = "32"-    pprWidth W64 = "64"-    pprWidth w   = pprPanic "atomicRMWLabel: Unsupported word width " (ppr w)+atomicRMWLabel :: Width -> AtomicMachOp -> FastString+atomicRMWLabel w amop = case amop of+  -- lots of boring cases, but we do it this way to get shared FastString+  -- literals (compared to concatening strings and allocating FastStrings at+  -- runtime)+  AMO_Add  -> case w of+    W8  -> fsLit "hs_atomic_add8"+    W16 -> fsLit "hs_atomic_add16"+    W32 -> fsLit "hs_atomic_add32"+    W64 -> fsLit "hs_atomic_add64"+    _   -> pprPanic "atomicRMWLabel: Unsupported word width " (ppr w)+  AMO_Sub  -> case w of+    W8  -> fsLit "hs_atomic_sub8"+    W16 -> fsLit "hs_atomic_sub16"+    W32 -> fsLit "hs_atomic_sub32"+    W64 -> fsLit "hs_atomic_sub64"+    _   -> pprPanic "atomicRMWLabel: Unsupported word width " (ppr w)+  AMO_And  -> case w of+    W8  -> fsLit "hs_atomic_and8"+    W16 -> fsLit "hs_atomic_and16"+    W32 -> fsLit "hs_atomic_and32"+    W64 -> fsLit "hs_atomic_and64"+    _   -> pprPanic "atomicRMWLabel: Unsupported word width " (ppr w)+  AMO_Nand  -> case w of+    W8  -> fsLit "hs_atomic_nand8"+    W16 -> fsLit "hs_atomic_nand16"+    W32 -> fsLit "hs_atomic_nand32"+    W64 -> fsLit "hs_atomic_nand64"+    _   -> pprPanic "atomicRMWLabel: Unsupported word width " (ppr w)+  AMO_Or  -> case w of+    W8  -> fsLit "hs_atomic_or8"+    W16 -> fsLit "hs_atomic_or16"+    W32 -> fsLit "hs_atomic_or32"+    W64 -> fsLit "hs_atomic_or64"+    _   -> pprPanic "atomicRMWLabel: Unsupported word width " (ppr w)+  AMO_Xor  -> case w of+    W8  -> fsLit "hs_atomic_xor8"+    W16 -> fsLit "hs_atomic_xor16"+    W32 -> fsLit "hs_atomic_xor32"+    W64 -> fsLit "hs_atomic_xor64"+    _   -> pprPanic "atomicRMWLabel: Unsupported word width " (ppr w) -    pprFunName AMO_Add  = "add"-    pprFunName AMO_Sub  = "sub"-    pprFunName AMO_And  = "and"-    pprFunName AMO_Nand = "nand"-    pprFunName AMO_Or   = "or"-    pprFunName AMO_Xor  = "xor" -xchgLabel :: Width -> String-xchgLabel w = "hs_xchg" ++ pprWidth w-  where-    pprWidth W8  = "8"-    pprWidth W16 = "16"-    pprWidth W32 = "32"-    pprWidth W64 = "64"-    pprWidth w   = pprPanic "xchgLabel: Unsupported word width " (ppr w)+xchgLabel :: Width -> FastString+xchgLabel = \case+  W8  -> fsLit "hs_xchg8"+  W16 -> fsLit "hs_xchg16"+  W32 -> fsLit "hs_xchg32"+  W64 -> fsLit "hs_xchg64"+  w   -> pprPanic "xchgLabel: Unsupported word width " (ppr w) -cmpxchgLabel :: Width -> String-cmpxchgLabel w = "hs_cmpxchg" ++ pprWidth w-  where-    pprWidth W8  = "8"-    pprWidth W16 = "16"-    pprWidth W32 = "32"-    pprWidth W64 = "64"-    pprWidth w   = pprPanic "cmpxchgLabel: Unsupported word width " (ppr w)+cmpxchgLabel :: Width -> FastString+cmpxchgLabel = \case+  W8  -> fsLit "hs_cmpxchg8"+  W16 -> fsLit "hs_cmpxchg16"+  W32 -> fsLit "hs_cmpxchg32"+  W64 -> fsLit "hs_cmpxchg64"+  w   -> pprPanic "cmpxchgLabel: Unsupported word width " (ppr w) -atomicReadLabel :: Width -> String-atomicReadLabel w = "hs_atomicread" ++ pprWidth w-  where-    pprWidth W8  = "8"-    pprWidth W16 = "16"-    pprWidth W32 = "32"-    pprWidth W64 = "64"-    pprWidth w   = pprPanic "atomicReadLabel: Unsupported word width " (ppr w)+atomicReadLabel :: Width -> FastString+atomicReadLabel = \case+  W8  -> fsLit "hs_atomicread8"+  W16 -> fsLit "hs_atomicread16"+  W32 -> fsLit "hs_atomicread32"+  W64 -> fsLit "hs_atomicread64"+  w   -> pprPanic "atomicReadLabel: Unsupported word width " (ppr w) -atomicWriteLabel :: Width -> String-atomicWriteLabel w = "hs_atomicwrite" ++ pprWidth w-  where-    pprWidth W8  = "8"-    pprWidth W16 = "16"-    pprWidth W32 = "32"-    pprWidth W64 = "64"-    pprWidth w   = pprPanic "atomicWriteLabel: Unsupported word width " (ppr w)+atomicWriteLabel :: Width -> FastString+atomicWriteLabel = \case+  W8  -> fsLit "hs_atomicwrite8"+  W16 -> fsLit "hs_atomicwrite16"+  W32 -> fsLit "hs_atomicwrite32"+  W64 -> fsLit "hs_atomicwrite64"+  w   -> pprPanic "atomicWriteLabel: Unsupported word width " (ppr w)
+ compiler/GHC/CmmToAsm/Config.hs view
@@ -0,0 +1,63 @@+-- | Native code generator configuration+module GHC.CmmToAsm.Config+   ( NCGConfig(..)+   , ncgWordWidth+   , ncgSpillPreallocSize+   , platformWordWidth+   )+where++import GHC.Prelude+import GHC.Platform+import GHC.Cmm.Type (Width(..))+import GHC.CmmToAsm.CFG.Weight+import GHC.Unit.Module (Module)+import GHC.Utils.Outputable++-- | Native code generator configuration+data NCGConfig = NCGConfig+   { ncgPlatform              :: !Platform        -- ^ Target platform+   , ncgAsmContext            :: !SDocContext     -- ^ Context for ASM code generation+   , ncgThisModule            :: !Module          -- ^ The name of the module we are currently compiling+   , ncgProcAlignment         :: !(Maybe Int)     -- ^ Mandatory proc alignment+   , ncgExternalDynamicRefs   :: !Bool            -- ^ Generate code to link against dynamic libraries+   , ncgPIC                   :: !Bool            -- ^ Enable Position-Independent Code+   , ncgInlineThresholdMemcpy :: !Word            -- ^ If inlining `memcpy` produces less than this threshold (in pseudo-instruction unit), do it+   , ncgInlineThresholdMemset :: !Word            -- ^ Ditto for `memset`+   , ncgSplitSections         :: !Bool            -- ^ Split sections+   , ncgRegsIterative         :: !Bool+   , ncgRegsGraph             :: !Bool+   , ncgAsmLinting            :: !Bool            -- ^ Perform ASM linting pass+   , ncgDoConstantFolding     :: !Bool            -- ^ Perform CMM constant folding+   , ncgSseVersion            :: Maybe SseVersion -- ^ (x86) SSE instructions+   , ncgBmiVersion            :: Maybe BmiVersion -- ^ (x86) BMI instructions+   , ncgDumpRegAllocStages    :: !Bool+   , ncgDumpAsmStats          :: !Bool+   , ncgDumpAsmConflicts      :: !Bool+   , ncgCfgWeights            :: !Weights         -- ^ CFG edge weights+   , ncgCfgBlockLayout        :: !Bool            -- ^ Use CFG based block layout algorithm+   , ncgCfgWeightlessLayout   :: !Bool            -- ^ Layout based on last instruction per block.+   , ncgDwarfEnabled          :: !Bool            -- ^ Enable Dwarf generation+   , ncgDwarfUnwindings       :: !Bool            -- ^ Enable unwindings+   , ncgDwarfStripBlockInfo   :: !Bool            -- ^ Strip out block information from generated Dwarf+   , ncgExposeInternalSymbols :: !Bool            -- ^ Expose symbol table entries for internal symbols+   , ncgDwarfSourceNotes      :: !Bool            -- ^ Enable GHC-specific source note DIEs+   , ncgCmmStaticPred         :: !Bool            -- ^ Enable static control-flow prediction+   , ncgEnableShortcutting    :: !Bool            -- ^ Enable shortcutting (don't jump to blocks only containing a jump)+   , ncgComputeUnwinding      :: !Bool            -- ^ Compute block unwinding tables+   , ncgEnableDeadCodeElimination :: !Bool        -- ^ Whether to enable the dead-code elimination+   }++-- | Return Word size+ncgWordWidth :: NCGConfig -> Width+ncgWordWidth config = platformWordWidth (ncgPlatform config)++-- | Size in bytes of the pre-allocated spill space on the C stack+ncgSpillPreallocSize :: NCGConfig -> Int+ncgSpillPreallocSize config = pc_RESERVED_C_STACK_BYTES (platformConstants (ncgPlatform config))++-- | Return Word size+platformWordWidth :: Platform -> Width+platformWordWidth platform = case platformWordSize platform of+   PW4 -> W32+   PW8 -> W64
compiler/GHC/CmmToAsm/Dwarf.hs view
@@ -51,8 +51,8 @@         , dwName = fromMaybe "" (ml_hs_file modLoc)         , dwCompDir = addTrailingPathSeparator compPath         , dwProducer = cProjectName ++ " " ++ cProjectVersion-        , dwLowLabel = lowLabel-        , dwHighLabel = highLabel+        , dwLowLabel = pdoc platform lowLabel+        , dwHighLabel = pdoc platform highLabel         , dwLineLabel = dwarfLineLabel         } @@ -69,7 +69,7 @@   -- .debug_info section: Information records on procedures and blocks   let -- unique to identify start and end compilation unit .debug_inf       (unitU, us') = takeUniqFromSupply us-      infoSct = vcat [ ptext dwarfInfoLabel <> colon+      infoSct = vcat [ dwarfInfoLabel <> colon                      , dwarfInfoSection platform                      , compileUnitHeader platform unitU                      , pprDwarfInfo platform haveSrc dwarfUnit@@ -79,12 +79,12 @@   -- .debug_line section: Generated mainly by the assembler, but we   -- need to label it   let lineSct = dwarfLineSection platform $$-                ptext dwarfLineLabel <> colon+                dwarfLineLabel <> colon    -- .debug_frame section: Information about the layout of the GHC stack   let (framesU, us'') = takeUniqFromSupply us'       frameSct = dwarfFrameSection platform $$-                 ptext dwarfFrameLabel <> colon $$+                 dwarfFrameLabel <> colon $$                  pprDwarfFrame platform (debugFrame framesU procs)    -- .aranges section: Information about the bounds of compilation units@@ -114,7 +114,7 @@   in vcat [ pdoc platform cuLabel <> colon           , text "\t.long " <> length  -- compilation unit size           , pprHalf 3                          -- DWARF version-          , sectionOffset platform (ptext dwarfAbbrevLabel) (ptext dwarfAbbrevLabel)+          , sectionOffset platform dwarfAbbrevLabel dwarfAbbrevLabel                                                -- abbrevs offset           , text "\t.byte " <> ppr (platformWordSizeInBytes platform) -- word size           ]@@ -148,7 +148,7 @@  {- Note [Splitting DebugBlocks]-+~~~~~~~~~~~~~~~~~~~~~~~~~~~~ DWARF requires that we break up the nested DebugBlocks produced from the C-- AST. For instance, we begin with tick trees containing nested procs. For example,@@ -245,7 +245,7 @@           where uws'   = addDefaultUnwindings initUws uws                 nested = concatMap flatten blocks -        -- | If the current procedure has an info table, then we also say that+        -- If the current procedure has an info table, then we also say that         -- its first block has one to ensure that it gets the necessary -1         -- offset applied to its start address.         -- See Note [Info Offset] in "GHC.CmmToAsm.Dwarf.Types".
compiler/GHC/CmmToAsm/Dwarf/Constants.hs view
@@ -6,7 +6,6 @@ import GHC.Prelude  import GHC.Utils.Asm-import GHC.Data.FastString import GHC.Platform import GHC.Utils.Outputable @@ -165,11 +164,11 @@        -> text "\t.section .debug_" <> text name <> text ",\"dr\""  -- * Dwarf section labels-dwarfInfoLabel, dwarfAbbrevLabel, dwarfLineLabel, dwarfFrameLabel :: PtrString-dwarfInfoLabel   = sLit ".Lsection_info"-dwarfAbbrevLabel = sLit ".Lsection_abbrev"-dwarfLineLabel   = sLit ".Lsection_line"-dwarfFrameLabel  = sLit ".Lsection_frame"+dwarfInfoLabel, dwarfAbbrevLabel, dwarfLineLabel, dwarfFrameLabel :: SDoc+dwarfInfoLabel   = text ".Lsection_info"+dwarfAbbrevLabel = text ".Lsection_abbrev"+dwarfLineLabel   = text ".Lsection_line"+dwarfFrameLabel  = text ".Lsection_frame"  -- | Mapping of registers to DWARF register numbers dwarfRegNo :: Platform -> Reg -> Word8
compiler/GHC/CmmToAsm/Dwarf/Types.hs view
@@ -44,7 +44,7 @@ import GHC.CmmToAsm.Dwarf.Constants  import qualified Data.ByteString as BS-import qualified Control.Monad.Trans.State.Strict as S+import qualified GHC.Utils.Monad.State.Strict as S import Control.Monad (zipWithM, join) import qualified Data.Map as Map import Data.Word@@ -59,9 +59,9 @@                      , dwName :: String                      , dwProducer :: String                      , dwCompDir :: String-                     , dwLowLabel :: CLabel-                     , dwHighLabel :: CLabel-                     , dwLineLabel :: PtrString }+                     , dwLowLabel :: SDoc+                     , dwHighLabel :: SDoc+                     , dwLineLabel :: SDoc }   | DwarfSubprogram { dwChildren :: [DwarfInfo]                     , dwName :: String                     , dwLabel :: CLabel@@ -111,7 +111,7 @@            , (dW_AT_frame_base, dW_FORM_block1)            ]   in dwarfAbbrevSection platform $$-     ptext dwarfAbbrevLabel <> colon $$+     dwarfAbbrevLabel <> colon $$      mkAbbrev DwAbbrCompileUnit dW_TAG_compile_unit dW_CHILDREN_yes        ([(dW_AT_name,     dW_FORM_string)        , (dW_AT_producer, dW_FORM_string)@@ -178,10 +178,10 @@   $$ pprData4 dW_LANG_Haskell   $$ pprString compDir      -- Offset due to Note [Info Offset]-  $$ pprWord platform (pdoc platform lowLabel <> text "-1")-  $$ pprWord platform (pdoc platform highLabel)+  $$ pprWord platform (lowLabel <> text "-1")+  $$ pprWord platform highLabel   $$ if haveSrc-     then sectionOffset platform (ptext lineLbl) (ptext dwarfLineLabel)+     then sectionOffset platform lineLbl dwarfLineLabel      else empty pprDwarfInfoOpen platform _ (DwarfSubprogram _ name label parent) =   pdoc platform (mkAsmTempDieLabel label) <> colon@@ -199,7 +199,7 @@     abbrev = case parent of Nothing -> DwAbbrSubprogram                             Just _  -> DwAbbrSubprogramWithParent     parentValue = maybe empty pprParentDie parent-    pprParentDie sym = sectionOffset platform (pdoc platform sym) (ptext dwarfInfoLabel)+    pprParentDie sym = sectionOffset platform (pdoc platform sym) dwarfInfoLabel pprDwarfInfoOpen platform _ (DwarfBlock _ label Nothing) =   pdoc platform (mkAsmTempDieLabel label) <> colon   $$ pprAbbrev DwAbbrBlockWithoutCode@@ -245,8 +245,7 @@       initialLength = 8 + paddingSize + (1 + length arngs) * 2 * wordSize   in pprDwWord (ppr initialLength)      $$ pprHalf 2-     $$ sectionOffset platform (pdoc platform $ mkAsmTempLabel $ unitU)-                               (ptext dwarfInfoLabel)+     $$ sectionOffset platform (pdoc platform $ mkAsmTempLabel $ unitU) dwarfInfoLabel      $$ pprByte (fromIntegral wordSize)      $$ pprByte 0      $$ pad paddingSize@@ -258,7 +257,7 @@  pprDwarfARange :: Platform -> DwarfARange -> SDoc pprDwarfARange platform arng =-    -- Offset due to Note [Info offset].+    -- Offset due to Note [Info Offset].     pprWord platform (pdoc platform (dwArngStartLabel arng) <> text "-1")     $$ pprWord platform length   where@@ -364,8 +363,7 @@     in vcat [ whenPprDebug $ text "# Unwinding for" <+> pdoc platform procLbl <> colon             , pprData4' (pdoc platform fdeEndLabel <> char '-' <> pdoc platform fdeLabel)             , pdoc platform fdeLabel <> colon-            , pprData4' (pdoc platform frameLbl <> char '-' <>-                         ptext dwarfFrameLabel)    -- Reference to CIE+            , pprData4' (pdoc platform frameLbl <> char '-' <> dwarfFrameLabel)    -- Reference to CIE             , pprWord platform (pdoc platform procLbl <> ifInfo "-1") -- Code pointer             , pprWord platform (pdoc platform procEnd <> char '-' <>                                  pdoc platform procLbl <> ifInfo "+1") -- Block byte length@@ -412,7 +410,6 @@  -- Note [Info Offset] -- ~~~~~~~~~~~~~~~~~~--- -- GDB was pretty much written with C-like programs in mind, and as a -- result they assume that once you have a return address, it is a -- good idea to look at (PC-1) to unwind further - as that's where the@@ -602,7 +599,7 @@   = pprString' $ hcat $ map escapeChar $     if str `lengthIs` utf8EncodedLength str     then str-    else map (chr . fromIntegral) $ BS.unpack $ bytesFS $ mkFastString str+    else map (chr . fromIntegral) $ BS.unpack $ utf8EncodeString str  -- | Escape a single non-unicode character escapeChar :: Char -> SDoc
compiler/GHC/CmmToAsm/Monad.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE BangPatterns #-} @@ -30,7 +29,6 @@         getBlockIdNat,         getNewLabelNat,         getNewRegNat,-        getNewRegPairNat,         getPicBaseMaybeNat,         getPicBaseNat,         getCfgWeights,@@ -38,13 +36,15 @@         getFileId,         getDebugBlock, -        DwarfFiles+        DwarfFiles,++        -- * 64-bit registers on 32-bit architectures+        Reg64(..), RegCode64(..),+        getNewReg64, localReg64 )  where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Platform@@ -59,6 +59,8 @@ import GHC.Cmm.Dataflow.Label import GHC.Cmm.CLabel           ( CLabel ) import GHC.Cmm.DebugBlock+import GHC.Cmm.Expr             (LocalReg (..), isWord64)+ import GHC.Data.FastString      ( FastString ) import GHC.Types.Unique.FM import GHC.Types.Unique.Supply@@ -69,6 +71,7 @@  import GHC.Utils.Outputable (SDoc, ppr) import GHC.Utils.Panic      (pprPanic)+import GHC.Utils.Misc import GHC.CmmToAsm.CFG import GHC.CmmToAsm.CFG.Weight @@ -85,7 +88,6 @@     pprNatCmmDecl             :: NatCmmDecl statics instr -> SDoc,     maxSpillSlots             :: Int,     allocatableRegs           :: [RealReg],-    ncgExpandTop              :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],     ncgAllocMoreStack         :: Int -> NatCmmDecl statics instr                               -> UniqSM (NatCmmDecl statics instr, [(BlockId,BlockId)]),     -- ^ The list of block ids records the redirected jumps to allow us to update@@ -258,14 +260,38 @@       return (RegVirtual $ targetMkVirtualReg platform u rep)  -getNewRegPairNat :: Format -> NatM (Reg,Reg)-getNewRegPairNat rep- = do u <- getUniqueNat-      platform <- getPlatform-      let vLo = targetMkVirtualReg platform u rep-      let lo  = RegVirtual $ targetMkVirtualReg platform u rep-      let hi  = RegVirtual $ getHiVirtualRegFromLo vLo-      return (lo, hi)+-- | Two 32-bit regs used as a single virtual 64-bit register+data Reg64 = Reg64+  !Reg -- ^ Higher part+  !Reg -- ^ Lower part++-- | Two 32-bit regs used as a single virtual 64-bit register+-- and the code to set them appropriately+data RegCode64 code = RegCode64+  code -- ^ Code to initialize the registers+  !Reg -- ^ Higher part+  !Reg -- ^ Lower part++-- | Return a virtual 64-bit register+getNewReg64 :: NatM Reg64+getNewReg64 = do+  let rep = II32+  u <- getUniqueNat+  platform <- getPlatform+  let vLo = targetMkVirtualReg platform u rep+  let lo  = RegVirtual $ targetMkVirtualReg platform u rep+  let hi  = RegVirtual $ getHiVirtualRegFromLo vLo+  return $ Reg64 hi lo++-- | Convert a 64-bit LocalReg into two virtual 32-bit regs.+--+-- Used to handle 64-bit "registers" on 32-bit architectures+localReg64 :: HasDebugCallStack => LocalReg -> Reg64+localReg64 (LocalReg vu ty)+  | isWord64 ty = let lo = RegVirtual (VirtualRegI vu)+                      hi = getHiVRegFromLo lo+                  in Reg64 hi lo+  | otherwise   = pprPanic "localReg64" (ppr ty)   getPicBaseMaybeNat :: NatM (Maybe Reg)
compiler/GHC/CmmToAsm/PIC.hs view
@@ -210,6 +210,13 @@ -- pointers, code stubs and GOT offsets look like is located in the -- module CLabel. +-- | Helper to check whether the data resides in a DLL or not, see @labelDynamic@+ncgLabelDynamic :: NCGConfig -> CLabel -> Bool+ncgLabelDynamic config = labelDynamic (ncgThisModule config)+                                      (ncgPlatform config)+                                      (ncgExternalDynamicRefs config)++ -- We have to decide which labels need to be accessed -- indirectly or via a piece of stub code. data LabelAccessStyle@@ -248,7 +255,7 @@          -- If the target symbol is in another PE we need to access it via the         --      appropriate __imp_SYMBOL pointer.-        | labelDynamic config lbl+        | ncgLabelDynamic config lbl         = AccessViaSymbolPtr          -- Target symbol is in the same PE as the caller, so just access it directly.@@ -263,7 +270,7 @@         | not (ncgExternalDynamicRefs config)         = AccessDirectly -        | labelDynamic config lbl+        | ncgLabelDynamic config lbl         = AccessViaSymbolPtr          | otherwise@@ -280,20 +287,17 @@ -- howToAccessLabel config arch OSDarwin DataReference lbl         -- data access to a dynamic library goes via a symbol pointer-        | labelDynamic config lbl+        | ncgLabelDynamic config lbl         = AccessViaSymbolPtr          -- when generating PIC code, all cross-module data references must         -- must go via a symbol pointer, too, because the assembler         -- cannot generate code for a label difference where one-        -- label is undefined. Doesn't apply t x86_64.-        -- Unfortunately, we don't know whether it's cross-module,-        -- so we do it for all externally visible labels.-        -- This is a slight waste of time and space, but otherwise-        -- we'd need to pass the current Module all the way in to-        -- this function.+        -- label is undefined. Doesn't apply to x86_64 (why?).         | arch /= ArchX86_64-        , ncgPIC config && externallyVisibleCLabel lbl+        , not (isLocalCLabel (ncgThisModule config) lbl)+        , ncgPIC config+        , externallyVisibleCLabel lbl         = AccessViaSymbolPtr          | otherwise@@ -304,7 +308,7 @@         -- stack alignment is only right for regular calls.         -- Therefore, we have to go via a symbol pointer:         | arch == ArchX86 || arch == ArchX86_64 || arch == ArchAArch64-        , labelDynamic config lbl+        , ncgLabelDynamic config lbl         = AccessViaSymbolPtr  @@ -314,7 +318,7 @@         -- them automatically, neither on Aarch64 (arm64).         | arch /= ArchX86_64         , arch /= ArchAArch64-        , labelDynamic config lbl+        , ncgLabelDynamic config lbl         = AccessViaStub          | otherwise@@ -366,7 +370,7 @@         | osElfTarget os         = case () of             -- A dynamic label needs to be accessed via a symbol pointer.-          _ | labelDynamic config lbl+          _ | ncgLabelDynamic config lbl             -> AccessViaSymbolPtr              -- For PowerPC32 -fPIC, we have to access even static data@@ -394,18 +398,19 @@  howToAccessLabel config arch os CallReference lbl         | osElfTarget os-        , labelDynamic config lbl && not (ncgPIC config)+        , ncgLabelDynamic config lbl+        , not (ncgPIC config)         = AccessDirectly          | osElfTarget os         , arch /= ArchX86-        , labelDynamic config lbl+        , ncgLabelDynamic config lbl         , ncgPIC config         = AccessViaStub  howToAccessLabel config _arch os _kind lbl         | osElfTarget os-        = if labelDynamic config lbl+        = if ncgLabelDynamic config lbl             then AccessViaSymbolPtr             else AccessDirectly @@ -598,7 +603,7 @@              then               vcat [                   text ".symbol_stub",-                  text "L" <> ppr_lbl lbl <> ptext (sLit "$stub:"),+                  text "L" <> ppr_lbl lbl <> text "$stub:",                       text "\t.indirect_symbol" <+> ppr_lbl lbl,                       text "\tjmp *L" <> ppr_lbl lbl                           <> text "$lazy_ptr",@@ -612,7 +617,7 @@               vcat [                   text ".section __TEXT,__picsymbolstub2,"                       <> text "symbol_stubs,pure_instructions,25",-                  text "L" <> ppr_lbl lbl <> ptext (sLit "$stub:"),+                  text "L" <> ppr_lbl lbl <> text "$stub:",                       text "\t.indirect_symbol" <+> ppr_lbl lbl,                       text "\tcall ___i686.get_pc_thunk.ax",                   text "1:",@@ -629,7 +634,7 @@            $+$ vcat [        text ".section __DATA, __la_sym_ptr"                     <> (if pic then int 2 else int 3)                     <> text ",lazy_symbol_pointers",-                text "L" <> ppr_lbl lbl <> ptext (sLit "$lazy_ptr:"),+                text "L" <> ppr_lbl lbl <> text "$lazy_ptr:",                     text "\t.indirect_symbol" <+> ppr_lbl lbl,                     text "\t.long L" <> ppr_lbl lbl                     <> text "$stub_binder"]@@ -709,14 +714,14 @@      -> case dynamicLinkerLabelInfo importedLbl of             Just (SymbolPtr, lbl)               -> let symbolSize = case ncgWordWidth config of-                         W32 -> sLit "\t.long"-                         W64 -> sLit "\t.quad"+                         W32 -> text "\t.long"+                         W64 -> text "\t.quad"                          _ -> panic "Unknown wordRep in pprImportedSymbol"                   in vcat [                       text ".section \".got2\", \"aw\"",                       text ".LC_" <> ppr_lbl lbl <> char ':',-                      ptext symbolSize <+> ppr_lbl lbl ]+                      symbolSize <+> ppr_lbl lbl ]              -- PLT code stubs are generated automatically by the dynamic linker.             _ -> empty
compiler/GHC/CmmToAsm/PPC.hs view
@@ -32,7 +32,6 @@    , maxSpillSlots             = PPC.maxSpillSlots config    , allocatableRegs           = PPC.allocatableRegs platform    , ncgAllocMoreStack         = PPC.allocMoreStack platform-   , ncgExpandTop              = id    , ncgMakeFarBranches        = PPC.makeFarBranches    , extractUnwindPoints       = const []    , invertCondBranches        = \_ _ -> id@@ -57,4 +56,4 @@    mkStackAllocInstr   = PPC.mkStackAllocInstr    mkStackDeallocInstr = PPC.mkStackDeallocInstr    pprInstr            = PPC.pprInstr-   mkComment           = const []+   mkComment           = pure . PPC.COMMENT
compiler/GHC/CmmToAsm/PPC/CodeGen.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-}  -----------------------------------------------------------------------------@@ -21,8 +20,6 @@  where -#include "GhclibHsVersions.h"- -- NCG stuff: import GHC.Prelude @@ -36,7 +33,8 @@    ( DebugBlock(..) ) import GHC.CmmToAsm.Monad    ( NatM, getNewRegNat, getNewLabelNat-   , getBlockIdNat, getPicBaseNat, getNewRegPairNat+   , getBlockIdNat, getPicBaseNat+   , Reg64(..), RegCode64(..), getNewReg64, localReg64    , getPicBaseMaybeNat, getPlatform, getConfig    , getDebugBlock, getFileId    )@@ -64,13 +62,13 @@ import GHC.Data.OrdList import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain  import Control.Monad    ( mapAndUnzipM, when ) import Data.Word  import GHC.Types.Basic import GHC.Data.FastString-import GHC.Utils.Misc  -- ----------------------------------------------------------------------------- -- Top-level of the instruction selector@@ -165,7 +163,7 @@   config <- getConfig   platform <- getPlatform   case stmt of-    CmmComment s   -> return (unitOL (COMMENT s))+    CmmComment s   -> return (unitOL (COMMENT $ ftext s))     CmmTick {}     -> return nilOL     CmmUnwind {}   -> return nilOL @@ -225,12 +223,15 @@ swizzleRegisterRep (Fixed _ reg code) format = Fixed format reg code swizzleRegisterRep (Any _ codefn)     format = Any   format codefn +getLocalRegReg :: LocalReg -> Reg+getLocalRegReg (LocalReg u pk)+  = RegVirtual (mkVirtualReg u (cmmTypeFormat pk))  -- | Grab the Reg for a CmmReg getRegisterReg :: Platform -> CmmReg -> Reg -getRegisterReg _ (CmmLocal (LocalReg u pk))-  = RegVirtual $ mkVirtualReg u (cmmTypeFormat pk)+getRegisterReg _ (CmmLocal local_reg)+  = getLocalRegReg local_reg  getRegisterReg platform (CmmGlobal mid)   = case globalRegMaybe platform mid of@@ -277,16 +278,6 @@ by applying getHiVRegFromLo to it. -} -data ChildCode64        -- a.k.a "Register64"-      = ChildCode64-           InstrBlock   -- code-           Reg          -- the lower 32-bit temporary which contains the-                        -- result; use getHiVRegFromLo to find the other-                        -- VRegUnique.  Rules of this simplified insn-                        -- selection game are therefore that the returned-                        -- Reg may be modified-- -- | Compute an expression into a register, but --      we don't mind which one it is. getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)@@ -313,10 +304,8 @@ assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock assignMem_I64Code addrTree valueTree = do         (hi_addr, lo_addr, addr_code) <- getI64Amodes addrTree-        ChildCode64 vcode rlo <- iselExpr64 valueTree+        RegCode64 vcode rhi rlo <- iselExpr64 valueTree         let-                rhi = getHiVRegFromLo rlo-                 -- Big-endian store                 mov_hi = ST II32 rhi hi_addr                 mov_lo = ST II32 rlo lo_addr@@ -324,14 +313,11 @@   assignReg_I64Code :: CmmReg  -> CmmExpr -> NatM InstrBlock-assignReg_I64Code (CmmLocal (LocalReg u_dst _)) valueTree = do-   ChildCode64 vcode r_src_lo <- iselExpr64 valueTree-   let-         r_dst_lo = RegVirtual $ mkVirtualReg u_dst II32-         r_dst_hi = getHiVRegFromLo r_dst_lo-         r_src_hi = getHiVRegFromLo r_src_lo-         mov_lo = MR r_dst_lo r_src_lo-         mov_hi = MR r_dst_hi r_src_hi+assignReg_I64Code (CmmLocal lreg) valueTree = do+   RegCode64 vcode r_src_hi r_src_lo <- iselExpr64 valueTree+   let Reg64 r_dst_hi r_dst_lo = localReg64 lreg+       mov_lo = MR r_dst_lo r_src_lo+       mov_hi = MR r_dst_hi r_src_hi    return (         vcode `snocOL` mov_lo `snocOL` mov_hi      )@@ -340,20 +326,21 @@    = panic "assignReg_I64Code(powerpc): invalid lvalue"  -iselExpr64        :: CmmExpr -> NatM ChildCode64+iselExpr64        :: CmmExpr -> NatM (RegCode64 InstrBlock) iselExpr64 (CmmLoad addrTree ty _) | isWord64 ty = do     (hi_addr, lo_addr, addr_code) <- getI64Amodes addrTree-    (rlo, rhi) <- getNewRegPairNat II32+    Reg64 rhi rlo <- getNewReg64     let mov_hi = LD II32 rhi hi_addr         mov_lo = LD II32 rlo lo_addr-    return $ ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi)-                         rlo+    return $ RegCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi)+                         rhi rlo -iselExpr64 (CmmReg (CmmLocal (LocalReg vu ty))) | isWord64 ty-   = return (ChildCode64 nilOL (RegVirtual $ mkVirtualReg vu II32))+iselExpr64 (CmmReg (CmmLocal local_reg)) = do+  let Reg64 hi lo = localReg64 local_reg+  return (RegCode64 nilOL hi lo)  iselExpr64 (CmmLit (CmmInt i _)) = do-  (rlo,rhi) <- getNewRegPairNat II32+  Reg64 rhi rlo <- getNewReg64   let         half0 = fromIntegral (fromIntegral i :: Word16)         half1 = fromIntegral (fromIntegral (i `shiftR` 16) :: Word16)@@ -366,49 +353,45 @@                 LIS rhi (ImmInt half3),                 OR rhi rhi (RIImm $ ImmInt half2)                 ]-  return (ChildCode64 code rlo)+  return (RegCode64 code rhi rlo)  iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do-   ChildCode64 code1 r1lo <- iselExpr64 e1-   ChildCode64 code2 r2lo <- iselExpr64 e2-   (rlo,rhi) <- getNewRegPairNat II32+   RegCode64 code1 r1hi r1lo <- iselExpr64 e1+   RegCode64 code2 r2hi r2lo <- iselExpr64 e2+   Reg64 rhi rlo <- getNewReg64    let-        r1hi = getHiVRegFromLo r1lo-        r2hi = getHiVRegFromLo r2lo         code =  code1 `appOL`                 code2 `appOL`                 toOL [ ADDC rlo r1lo r2lo,                        ADDE rhi r1hi r2hi ]-   return (ChildCode64 code rlo)+   return (RegCode64 code rhi rlo)  iselExpr64 (CmmMachOp (MO_Sub _) [e1,e2]) = do-   ChildCode64 code1 r1lo <- iselExpr64 e1-   ChildCode64 code2 r2lo <- iselExpr64 e2-   (rlo,rhi) <- getNewRegPairNat II32+   RegCode64 code1 r1hi r1lo <- iselExpr64 e1+   RegCode64 code2 r2hi r2lo <- iselExpr64 e2+   Reg64 rhi rlo <- getNewReg64    let-        r1hi = getHiVRegFromLo r1lo-        r2hi = getHiVRegFromLo r2lo         code =  code1 `appOL`                 code2 `appOL`                 toOL [ SUBFC rlo r2lo (RIReg r1lo),                        SUBFE rhi r2hi r1hi ]-   return (ChildCode64 code rlo)+   return (RegCode64 code rhi rlo)  iselExpr64 (CmmMachOp (MO_UU_Conv W32 W64) [expr]) = do     (expr_reg,expr_code) <- getSomeReg expr-    (rlo, rhi) <- getNewRegPairNat II32+    Reg64 rhi rlo <- getNewReg64     let mov_hi = LI rhi (ImmInt 0)         mov_lo = MR rlo expr_reg-    return $ ChildCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi)-                         rlo+    return $ RegCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi)+                       rhi rlo  iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr]) = do     (expr_reg,expr_code) <- getSomeReg expr-    (rlo, rhi) <- getNewRegPairNat II32+    Reg64 rhi rlo <- getNewReg64     let mov_hi = SRA II32 rhi expr_reg (RIImm (ImmInt 31))         mov_lo = MR rlo expr_reg-    return $ ChildCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi)-                         rlo+    return $ RegCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi)+                       rhi rlo iselExpr64 expr    = do      platform <- getPlatform@@ -446,29 +429,29 @@ getRegister' _ platform (CmmMachOp (MO_UU_Conv W64 W32)                      [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])  | target32Bit platform = do-  ChildCode64 code rlo <- iselExpr64 x+  RegCode64 code _rhi rlo <- iselExpr64 x   return $ Fixed II32 (getHiVRegFromLo rlo) code  getRegister' _ platform (CmmMachOp (MO_SS_Conv W64 W32)                      [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])  | target32Bit platform = do-  ChildCode64 code rlo <- iselExpr64 x+  RegCode64 code _rhi rlo <- iselExpr64 x   return $ Fixed II32 (getHiVRegFromLo rlo) code  getRegister' _ platform (CmmMachOp (MO_UU_Conv W64 W32) [x])  | target32Bit platform = do-  ChildCode64 code rlo <- iselExpr64 x+  RegCode64 code _rhi rlo <- iselExpr64 x   return $ Fixed II32 rlo code  getRegister' _ platform (CmmMachOp (MO_SS_Conv W64 W32) [x])  | target32Bit platform = do-  ChildCode64 code rlo <- iselExpr64 x+  RegCode64 code _rhi rlo <- iselExpr64 x   return $ Fixed II32 rlo code  getRegister' _ platform (CmmLoad mem pk _)  | not (isWord64 pk) = do         Amode addr addr_code <- getAmode D mem-        let code dst = ASSERT((targetClassOfReg platform dst == RcDouble) == isFloatType pk)+        let code dst = assert ((targetClassOfReg platform dst == RcDouble) == isFloatType pk) $                        addr_code `snocOL` LD format dst addr         return (Any format code)  | not (target32Bit platform) = do@@ -741,6 +724,7 @@ -}  {- Note [Power instruction format]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In some instructions the 16 bit offset must be a multiple of 4, i.e. the two least significant bits must be zero. The "Power ISA" specification calls these instruction formats "DS-FORM" and the instructions with@@ -929,10 +913,8 @@ condIntCode' True cond W64 x y   | condUnsigned cond   = do-      ChildCode64 code_x x_lo <- iselExpr64 x-      ChildCode64 code_y y_lo <- iselExpr64 y-      let x_hi = getHiVRegFromLo x_lo-          y_hi = getHiVRegFromLo y_lo+      RegCode64 code_x x_hi x_lo <- iselExpr64 x+      RegCode64 code_y y_hi y_lo <- iselExpr64 y       end_lbl <- getBlockIdNat       let code = code_x `appOL` code_y `appOL` toOL                  [ CMPL II32 x_hi (RIReg y_hi)@@ -945,10 +927,8 @@       return (CondCode False cond code)   | otherwise   = do-      ChildCode64 code_x x_lo <- iselExpr64 x-      ChildCode64 code_y y_lo <- iselExpr64 y-      let x_hi = getHiVRegFromLo x_lo-          y_hi = getHiVRegFromLo y_lo+      RegCode64 code_x x_hi x_lo <- iselExpr64 x+      RegCode64 code_y y_hi y_lo <- iselExpr64 y       end_lbl <- getBlockIdNat       cmp_lo  <- getBlockIdNat       let code = code_x `appOL` code_y `appOL` toOL@@ -1145,9 +1125,8 @@  = return $ nilOL  genCCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n]- = do platform <- getPlatform-      let fmt      = intFormat width-          reg_dst  = getRegisterReg platform (CmmLocal dst)+ = do let fmt      = intFormat width+          reg_dst  = getLocalRegReg dst       (instr, n_code) <- case amop of             AMO_Add  -> getSomeRegOrImm ADD True reg_dst             AMO_Sub  -> case n of@@ -1196,9 +1175,8 @@                           return  (op dst dst (RIReg n_reg), n_code)  genCCall (PrimTarget (MO_AtomicRead width)) [dst] [addr]- = do platform <- getPlatform-      let fmt      = intFormat width-          reg_dst  = getRegisterReg platform (CmmLocal dst)+ = do let fmt      = intFormat width+          reg_dst  = getLocalRegReg dst           form     = if widthInBits width == 64 then DS else D       Amode addr_reg addr_code <- getAmode form addr       lbl_end <- getBlockIdNat@@ -1213,6 +1191,7 @@                                       ]  -- Note [Seemingly useless cmp and bne]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- In Power ISA, Book II, Section 4.4.1, Instruction Synchronize Instruction -- the second paragraph says that isync may complete before storage accesses -- "associated" with a preceding instruction have been performed. The cmp@@ -1224,19 +1203,48 @@  genCCall (PrimTarget (MO_AtomicWrite width)) [] [addr, val] = do     code <- assignMem_IntCode (intFormat width) addr val-    return $ unitOL(HWSYNC) `appOL` code+    return $ unitOL HWSYNC `appOL` code +genCCall (PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new]+  | width == W32 || width == W64+  = do+      (old_reg, old_code) <- getSomeReg old+      (new_reg, new_code) <- getSomeReg new+      (addr_reg, addr_code) <- getSomeReg addr+      lbl_retry <- getBlockIdNat+      lbl_eq    <- getBlockIdNat+      lbl_end   <- getBlockIdNat+      let reg_dst   = getLocalRegReg dst+          code      = toOL+                      [ HWSYNC+                      , BCC ALWAYS lbl_retry Nothing+                      , NEWBLOCK lbl_retry+                      , LDR format reg_dst (AddrRegReg r0 addr_reg)+                      , CMP format reg_dst (RIReg old_reg)+                      , BCC NE lbl_end Nothing+                      , BCC ALWAYS lbl_eq Nothing+                      , NEWBLOCK lbl_eq+                      , STC format new_reg (AddrRegReg r0 addr_reg)+                      , BCC NE lbl_retry Nothing+                      , BCC ALWAYS lbl_end Nothing+                      , NEWBLOCK lbl_end+                      , ISYNC+                      ]+      return $ addr_code `appOL` new_code `appOL` old_code `appOL` code+  where+    format = intFormat width++ genCCall (PrimTarget (MO_Clz width)) [dst] [src]  = do platform <- getPlatform-      let reg_dst = getRegisterReg platform (CmmLocal dst)+      let reg_dst = getLocalRegReg dst       if target32Bit platform && width == W64         then do-          ChildCode64 code vr_lo <- iselExpr64 src+          RegCode64 code vr_hi vr_lo <- iselExpr64 src           lbl1 <- getBlockIdNat           lbl2 <- getBlockIdNat           lbl3 <- getBlockIdNat-          let vr_hi = getHiVRegFromLo vr_lo-              cntlz = toOL [ CMPL II32 vr_hi (RIImm (ImmInt 0))+          let cntlz = toOL [ CMPL II32 vr_hi (RIImm (ImmInt 0))                            , BCC NE lbl2 Nothing                            , BCC ALWAYS lbl1 Nothing @@ -1279,11 +1287,11 @@  genCCall (PrimTarget (MO_Ctz width)) [dst] [src]  = do platform <- getPlatform-      let reg_dst = getRegisterReg platform (CmmLocal dst)+      let reg_dst = getLocalRegReg dst       if target32Bit platform && width == W64         then do           let format = II32-          ChildCode64 code vr_lo <- iselExpr64 src+          RegCode64 code vr_hi vr_lo <- iselExpr64 src           lbl1 <- getBlockIdNat           lbl2 <- getBlockIdNat           lbl3 <- getBlockIdNat@@ -1291,8 +1299,7 @@           x'' <- getNewRegNat format           r' <- getNewRegNat format           cnttzlo <- cnttz format reg_dst vr_lo-          let vr_hi = getHiVRegFromLo vr_lo-              cnttz64 = toOL [ CMPL format vr_lo (RIImm (ImmInt 0))+          let cnttz64 = toOL [ CMPL format vr_lo (RIImm (ImmInt 0))                              , BCC NE lbl2 Nothing                              , BCC ALWAYS lbl1 Nothing @@ -1345,38 +1352,38 @@ genCCall target dest_regs argsAndHints  = do platform <- getPlatform       case target of-        PrimTarget (MO_S_QuotRem  width) -> divOp1 platform True  width+        PrimTarget (MO_S_QuotRem  width) -> divOp1 True  width                                                    dest_regs argsAndHints-        PrimTarget (MO_U_QuotRem  width) -> divOp1 platform False width+        PrimTarget (MO_U_QuotRem  width) -> divOp1 False width                                                    dest_regs argsAndHints-        PrimTarget (MO_U_QuotRem2 width) -> divOp2 platform width dest_regs+        PrimTarget (MO_U_QuotRem2 width) -> divOp2 width dest_regs                                                    argsAndHints-        PrimTarget (MO_U_Mul2 width) -> multOp2 platform width dest_regs+        PrimTarget (MO_U_Mul2 width) -> multOp2 width dest_regs                                                 argsAndHints-        PrimTarget (MO_Add2 _) -> add2Op platform dest_regs argsAndHints-        PrimTarget (MO_AddWordC _) -> addcOp platform dest_regs argsAndHints-        PrimTarget (MO_SubWordC _) -> subcOp platform dest_regs argsAndHints-        PrimTarget (MO_AddIntC width) -> addSubCOp ADDO platform width+        PrimTarget (MO_Add2 _) -> add2Op dest_regs argsAndHints+        PrimTarget (MO_AddWordC _) -> addcOp dest_regs argsAndHints+        PrimTarget (MO_SubWordC _) -> subcOp dest_regs argsAndHints+        PrimTarget (MO_AddIntC width) -> addSubCOp ADDO width                                                    dest_regs argsAndHints-        PrimTarget (MO_SubIntC width) -> addSubCOp SUBFO platform width+        PrimTarget (MO_SubIntC width) -> addSubCOp SUBFO width                                                    dest_regs argsAndHints-        PrimTarget MO_F64_Fabs -> fabs platform dest_regs argsAndHints-        PrimTarget MO_F32_Fabs -> fabs platform dest_regs argsAndHints+        PrimTarget MO_F64_Fabs -> fabs dest_regs argsAndHints+        PrimTarget MO_F32_Fabs -> fabs dest_regs argsAndHints         _ -> do config <- getConfig                 genCCall' config (platformToGCP platform)                        target dest_regs argsAndHints-        where divOp1 platform signed width [res_q, res_r] [arg_x, arg_y]-                = do let reg_q = getRegisterReg platform (CmmLocal res_q)-                         reg_r = getRegisterReg platform (CmmLocal res_r)+        where divOp1 signed width [res_q, res_r] [arg_x, arg_y]+                = do let reg_q = getLocalRegReg res_q+                         reg_r = getLocalRegReg res_r                      remainderCode width signed reg_q arg_x arg_y                        <*> pure reg_r -              divOp1 _ _ _ _ _+              divOp1 _ _ _ _                 = panic "genCCall: Wrong number of arguments for divOp1"-              divOp2 platform width [res_q, res_r]+              divOp2 width [res_q, res_r]                                     [arg_x_high, arg_x_low, arg_y]-                = do let reg_q = getRegisterReg platform (CmmLocal res_q)-                         reg_r = getRegisterReg platform (CmmLocal res_r)+                = do let reg_q = getLocalRegReg res_q+                         reg_r = getLocalRegReg res_r                          fmt   = intFormat width                          half  = 4 * (formatInBytes fmt)                      (xh_reg, xh_code) <- getSomeReg arg_x_high@@ -1513,11 +1520,11 @@                                    , SL fmt reg_q q1 (RIImm (ImmInt half))                                    , ADD reg_q reg_q (RIReg q0)                                    ]-              divOp2 _ _ _ _+              divOp2 _ _ _                 = panic "genCCall: Wrong number of arguments for divOp2"-              multOp2 platform width [res_h, res_l] [arg_x, arg_y]-                = do let reg_h = getRegisterReg platform (CmmLocal res_h)-                         reg_l = getRegisterReg platform (CmmLocal res_l)+              multOp2 width [res_h, res_l] [arg_x, arg_y]+                = do let reg_h = getLocalRegReg res_h+                         reg_l = getLocalRegReg res_l                          fmt = intFormat width                      (x_reg, x_code) <- getSomeReg arg_x                      (y_reg, y_code) <- getSomeReg arg_y@@ -1525,11 +1532,11 @@                             `appOL` toOL [ MULL fmt reg_l x_reg (RIReg y_reg)                                          , MULHU fmt reg_h x_reg y_reg                                          ]-              multOp2 _ _ _ _+              multOp2 _ _ _                 = panic "genCall: Wrong number of arguments for multOp2"-              add2Op platform [res_h, res_l] [arg_x, arg_y]-                = do let reg_h = getRegisterReg platform (CmmLocal res_h)-                         reg_l = getRegisterReg platform (CmmLocal res_l)+              add2Op [res_h, res_l] [arg_x, arg_y]+                = do let reg_h = getLocalRegReg res_h+                         reg_l = getLocalRegReg res_l                      (x_reg, x_code) <- getSomeReg arg_x                      (y_reg, y_code) <- getSomeReg arg_y                      return $ y_code `appOL` x_code@@ -1537,20 +1544,20 @@                                          , ADDC reg_l x_reg y_reg                                          , ADDZE reg_h reg_h                                          ]-              add2Op _ _ _+              add2Op _ _                 = panic "genCCall: Wrong number of arguments/results for add2" -              addcOp platform [res_r, res_c] [arg_x, arg_y]-                = add2Op platform [res_c {-hi-}, res_r {-lo-}] [arg_x, arg_y]-              addcOp _ _ _+              addcOp [res_r, res_c] [arg_x, arg_y]+                = add2Op [res_c {-hi-}, res_r {-lo-}] [arg_x, arg_y]+              addcOp _ _                 = panic "genCCall: Wrong number of arguments/results for addc"                -- PowerPC subfc sets the carry for rT = ~(rA) + rB + 1,               -- which is 0 for borrow and 1 otherwise. We need 1 and 0               -- so xor with 1.-              subcOp platform [res_r, res_c] [arg_x, arg_y]-                = do let reg_r = getRegisterReg platform (CmmLocal res_r)-                         reg_c = getRegisterReg platform (CmmLocal res_c)+              subcOp [res_r, res_c] [arg_x, arg_y]+                = do let reg_r = getLocalRegReg res_r+                         reg_c = getLocalRegReg res_c                      (x_reg, x_code) <- getSomeReg arg_x                      (y_reg, y_code) <- getSomeReg arg_y                      return $ y_code `appOL` x_code@@ -1559,11 +1566,11 @@                                          , ADDZE reg_c reg_c                                          , XOR reg_c reg_c (RIImm (ImmInt 1))                                          ]-              subcOp _ _ _+              subcOp _ _                 = panic "genCCall: Wrong number of arguments/results for subc"-              addSubCOp instr platform width [res_r, res_c] [arg_x, arg_y]-                = do let reg_r = getRegisterReg platform (CmmLocal res_r)-                         reg_c = getRegisterReg platform (CmmLocal res_c)+              addSubCOp instr width [res_r, res_c] [arg_x, arg_y]+                = do let reg_r = getLocalRegReg res_r+                         reg_c = getLocalRegReg res_c                      (x_reg, x_code) <- getSomeReg arg_x                      (y_reg, y_code) <- getSomeReg arg_y                      return $ y_code `appOL` x_code@@ -1571,13 +1578,13 @@                                            -- SUBFO argument order reversed!                                            MFOV (intFormat width) reg_c                                          ]-              addSubCOp _ _ _ _ _+              addSubCOp _ _ _ _                 = panic "genCall: Wrong number of arguments/results for addC"-              fabs platform [res] [arg]-                = do let res_r = getRegisterReg platform (CmmLocal res)+              fabs [res] [arg]+                = do let res_r = getLocalRegReg res                      (arg_reg, arg_code) <- getSomeReg arg                      return $ arg_code `snocOL` FABS res_r arg_reg-              fabs _ _ _+              fabs _ _                 = panic "genCall: Wrong number of arguments/results for fabs"  -- TODO: replace 'Int' by an enum such as 'PPC_64ABI'@@ -1787,8 +1794,7 @@                accumCode accumUsed | isWord64 arg_ty                                      && target32Bit (ncgPlatform config) =             do-                ChildCode64 code vr_lo <- iselExpr64 arg-                let vr_hi = getHiVRegFromLo vr_lo+                RegCode64 code vr_hi vr_lo <- iselExpr64 arg                  case gcp of                     GCPAIX ->@@ -1948,7 +1954,7 @@                                 MR r_dest r4]                     | otherwise -> unitOL (MR r_dest r3)                     where rep = cmmRegType platform (CmmLocal dest)-                          r_dest = getRegisterReg platform (CmmLocal dest)+                          r_dest = getLocalRegReg dest                 _ -> panic "genCCall' moveResult: Bad dest_regs"          outOfLineMachOp mop =@@ -2042,23 +2048,26 @@                     MO_W64_Le    -> (fsLit "hs_leWord64", False)                     MO_W64_Lt    -> (fsLit "hs_ltWord64", False) -                    MO_UF_Conv w -> (fsLit $ word2FloatLabel w, False)+                    MO_UF_Conv w -> (word2FloatLabel w, False)                      MO_Memcpy _  -> (fsLit "memcpy", False)                     MO_Memset _  -> (fsLit "memset", False)                     MO_Memmove _ -> (fsLit "memmove", False)                     MO_Memcmp _  -> (fsLit "memcmp", False) -                    MO_BSwap w   -> (fsLit $ bSwapLabel w, False)-                    MO_BRev w    -> (fsLit $ bRevLabel w, False)-                    MO_PopCnt w  -> (fsLit $ popCntLabel w, False)-                    MO_Pdep w    -> (fsLit $ pdepLabel w, False)-                    MO_Pext w    -> (fsLit $ pextLabel w, False)+                    MO_SuspendThread -> (fsLit "suspendThread", False)+                    MO_ResumeThread  -> (fsLit "resumeThread", False)++                    MO_BSwap w   -> (bSwapLabel w, False)+                    MO_BRev w    -> (bRevLabel w, False)+                    MO_PopCnt w  -> (popCntLabel w, False)+                    MO_Pdep w    -> (pdepLabel w, False)+                    MO_Pext w    -> (pextLabel w, False)                     MO_Clz _     -> unsupported                     MO_Ctz _     -> unsupported                     MO_AtomicRMW {} -> unsupported-                    MO_Cmpxchg w -> (fsLit $ cmpxchgLabel w, False)-                    MO_Xchg w    -> (fsLit $ xchgLabel w, False)+                    MO_Cmpxchg w -> (cmpxchgLabel w, False)+                    MO_Xchg w    -> (xchgLabel w, False)                     MO_AtomicRead _  -> unsupported                     MO_AtomicWrite _ -> unsupported @@ -2086,7 +2095,7 @@ genSwitch config expr targets   | OSAIX <- platformOS platform   = do-        (reg,e_code) <- getSomeReg (cmmOffset platform expr offset)+        (reg,e_code) <- getSomeReg indexExpr         let fmt = archWordFormat $ target32Bit platform             sha = if target32Bit platform then 2 else 3         tmp <- getNewRegNat fmt@@ -2103,7 +2112,7 @@    | (ncgPIC config) || (not $ target32Bit platform)   = do-        (reg,e_code) <- getSomeReg (cmmOffset platform expr offset)+        (reg,e_code) <- getSomeReg indexExpr         let fmt = archWordFormat $ target32Bit platform             sha = if target32Bit platform then 2 else 3         tmp <- getNewRegNat fmt@@ -2120,7 +2129,7 @@         return code   | otherwise   = do-        (reg,e_code) <- getSomeReg (cmmOffset platform expr offset)+        (reg,e_code) <- getSomeReg indexExpr         let fmt = archWordFormat $ target32Bit platform             sha = if target32Bit platform then 2 else 3         tmp <- getNewRegNat fmt@@ -2134,6 +2143,14 @@                     ]         return code   where+    -- See Note [Sub-word subtlety during jump-table indexing] in+    -- GHC.CmmToAsm.X86.CodeGen for why we must first offset, then widen.+    indexExpr0 = cmmOffset platform expr offset+    -- We widen to a native-width register to santize the high bits+    indexExpr = CmmMachOp+      (MO_UU_Conv expr_w (platformWordWidth platform))+      [indexExpr0]+    expr_w = cmmExprWidth platform expr     (offset, ids) = switchTargetsToTable targets     platform      = ncgPlatform config @@ -2498,12 +2515,14 @@ coerceFP2Int' _ _ _ _ = panic "PPC.CodeGen.coerceFP2Int: unknown arch"  -- Note [.LCTOC1 in PPC PIC code]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- The .LCTOC1 label is defined to point 32768 bytes into the GOT table -- to make the most of the PPC's 16-bit displacements. -- As 16-bit signed offset is used (usually via addi/lwz instructions) -- first element will have '-32768' offset against .LCTOC1.  -- Note [implicit register in PPC PIC code]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- PPC generates calls by labels in assembly -- in form of: --     bl puts+32768@plt
compiler/GHC/CmmToAsm/PPC/Instr.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE CPP #-}- {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  -----------------------------------------------------------------------------@@ -10,8 +8,6 @@ -- ----------------------------------------------------------------------------- -#include "GhclibHsVersions.h"- module GHC.CmmToAsm.PPC.Instr    ( Instr(..)    , RI(..)@@ -55,16 +51,16 @@ import GHC.Cmm.Dataflow.Label import GHC.Cmm import GHC.Cmm.Info-import GHC.Data.FastString import GHC.Cmm.CLabel+import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Platform import GHC.Types.Unique.FM (listToUFM, lookupUFM) import GHC.Types.Unique.Supply -import Control.Monad (replicateM) import Data.Maybe (fromMaybe) + -------------------------------------------------------------------------------- -- Format of a PPC memory address. --@@ -101,7 +97,7 @@     immAmount = ImmInt amount  ----- See note [extra spill slots] in X86/Instr.hs+-- See Note [extra spill slots] in X86/Instr.hs -- allocMoreStack   :: Platform@@ -119,7 +115,7 @@                         | entry `elem` infos -> infos                         | otherwise          -> entry : infos -    uniqs <- replicateM (length entries) getUniqueM+    uniqs <- getUniquesM      let         delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up@@ -181,7 +177,7 @@  data Instr     -- comment pseudo-op-    = COMMENT FastString+    = COMMENT SDoc      -- location pseudo-op (file, line, col, name)     | LOCATION Int Int Int String@@ -395,9 +391,6 @@ interesting :: Platform -> Reg -> Bool interesting _        (RegVirtual _)              = True interesting platform (RegReal (RealRegSingle i)) = freeReg platform i-interesting _        (RegReal (RealRegPair{}))-    = panic "PPC.Instr.interesting: no reg pairs on this arch"-   -- | Apply a given mapping to all the register references in this
compiler/GHC/CmmToAsm/PPC/Ppr.hs view
@@ -38,7 +38,6 @@  import GHC.Types.Unique ( pprUniqueAlways, getUnique ) import GHC.Platform-import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic @@ -155,7 +154,7 @@   pprDatas :: Platform -> RawCmmStatics -> SDoc--- See note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel".+-- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". pprDatas platform (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])   | lbl == mkIndStaticInfoLabel   , let labelInd (CmmLabelOff l _) = Just l@@ -200,7 +199,6 @@ pprReg r   = case r of       RegReal    (RealRegSingle i) -> ppr_reg_no i-      RegReal    (RealRegPair{})   -> panic "PPC.pprReg: no reg pairs on this arch"       RegVirtual (VirtualRegI  u)  -> text "%vI_"   <> pprUniqueAlways u       RegVirtual (VirtualRegHi u)  -> text "%vHi_"  <> pprUniqueAlways u       RegVirtual (VirtualRegF  u)  -> text "%vF_"   <> pprUniqueAlways u@@ -217,24 +215,24 @@  pprFormat :: Format -> SDoc pprFormat x- = ptext (case x of-                II8  -> sLit "b"-                II16 -> sLit "h"-                II32 -> sLit "w"-                II64 -> sLit "d"-                FF32 -> sLit "fs"-                FF64 -> sLit "fd")+ = case x of+                II8  -> text "b"+                II16 -> text "h"+                II32 -> text "w"+                II64 -> text "d"+                FF32 -> text "fs"+                FF64 -> text "fd"   pprCond :: Cond -> SDoc pprCond c- = ptext (case c of {-                ALWAYS  -> sLit "";-                EQQ     -> sLit "eq";  NE    -> sLit "ne";-                LTT     -> sLit "lt";  GE    -> sLit "ge";-                GTT     -> sLit "gt";  LE    -> sLit "le";-                LU      -> sLit "lt";  GEU   -> sLit "ge";-                GU      -> sLit "gt";  LEU   -> sLit "le"; })+ = case c of {+                ALWAYS  -> text "";+                EQQ     -> text "eq";  NE    -> text "ne";+                LTT     -> text "lt";  GE    -> text "ge";+                GTT     -> text "gt";  LE    -> text "le";+                LU      -> text "lt";  GEU   -> text "ge";+                GU      -> text "gt";  LEU   -> text "le"; }   pprImm :: Platform -> Imm -> SDoc@@ -284,26 +282,28 @@ pprAlignForSection :: Platform -> SectionType -> SDoc pprAlignForSection platform seg =  let ppc64    = not $ target32Bit platform- in ptext $ case seg of-       Text              -> sLit ".align 2"+ in case seg of+       Text              -> text ".align 2"        Data-        | ppc64          -> sLit ".align 3"-        | otherwise      -> sLit ".align 2"+        | ppc64          -> text ".align 3"+        | otherwise      -> text ".align 2"        ReadOnlyData-        | ppc64          -> sLit ".align 3"-        | otherwise      -> sLit ".align 2"+        | ppc64          -> text ".align 3"+        | otherwise      -> text ".align 2"        RelocatableReadOnlyData-        | ppc64          -> sLit ".align 3"-        | otherwise      -> sLit ".align 2"+        | ppc64          -> text ".align 3"+        | otherwise      -> text ".align 2"        UninitialisedData-        | ppc64          -> sLit ".align 3"-        | otherwise      -> sLit ".align 2"-       ReadOnlyData16    -> sLit ".align 4"+        | ppc64          -> text ".align 3"+        | otherwise      -> text ".align 2"+       ReadOnlyData16    -> text ".align 4"        -- TODO: This is copied from the ReadOnlyData case, but it can likely be        -- made more efficient.+       InitArray         -> text ".align 3"+       FiniArray         -> text ".align 3"        CString-        | ppc64          -> sLit ".align 3"-        | otherwise      -> sLit ".align 2"+        | ppc64          -> text ".align 3"+        | otherwise      -> text ".align 2"        OtherSection _    -> panic "PprMach.pprSectionAlign: unknown section"  pprDataItem :: Platform -> CmmLit -> SDoc@@ -335,22 +335,21 @@                 = panic "PPC.Ppr.pprDataItem: no match"  +asmComment :: SDoc -> SDoc+asmComment c = whenPprDebug $ text "#" <+> c++ pprInstr :: Platform -> Instr -> SDoc pprInstr platform instr = case instr of -   COMMENT _-      -> empty -- nuke 'em--   -- COMMENT s-   --    -> if platformOS platform == OSLinux-   --          then text "# " <> ftext s-   --          else text "; " <> ftext s+   COMMENT s+      -> asmComment s     LOCATION file line col _name       -> text "\t.loc" <+> ppr file <+> ppr line <+> ppr col     DELTA d-      -> pprInstr platform (COMMENT (mkFastString ("\tdelta = " ++ show d)))+      -> asmComment $ text ("\tdelta = " ++ show d)     NEWBLOCK _       -> panic "PprMach.pprInstr: NEWBLOCK"@@ -380,13 +379,13 @@       -> hcat [            char '\t',            text "l",-           ptext (case fmt of-               II8  -> sLit "bz"-               II16 -> sLit "hz"-               II32 -> sLit "wz"-               II64 -> sLit "d"-               FF32 -> sLit "fs"-               FF64 -> sLit "fd"+           (case fmt of+               II8  -> text "bz"+               II16 -> text "hz"+               II32 -> text "wz"+               II64 -> text "d"+               FF32 -> text "fs"+               FF64 -> text "fd"                ),            case addr of AddrRegImm _ _ -> empty                         AddrRegReg _ _ -> char 'x',@@ -422,13 +421,13 @@       -> hcat [            char '\t',            text "l",-           ptext (case fmt of-               II8  -> sLit "ba"-               II16 -> sLit "ha"-               II32 -> sLit "wa"-               II64 -> sLit "d"-               FF32 -> sLit "fs"-               FF64 -> sLit "fd"+           (case fmt of+               II8  -> text "ba"+               II16 -> text "ha"+               II32 -> text "wa"+               II64 -> text "d"+               FF32 -> text "fs"+               FF64 -> text "fd"                ),            case addr of AddrRegImm _ _ -> empty                         AddrRegReg _ _ -> char 'x',@@ -643,7 +642,7 @@          ]     ADD reg1 reg2 ri-      -> pprLogic platform (sLit "add") reg1 reg2 ri+      -> pprLogic platform (text "add") reg1 reg2 ri     ADDIS reg1 reg2 imm       -> hcat [@@ -658,22 +657,22 @@            ]     ADDO reg1 reg2 reg3-      -> pprLogic platform (sLit "addo") reg1 reg2 (RIReg reg3)+      -> pprLogic platform (text "addo") reg1 reg2 (RIReg reg3)     ADDC reg1 reg2 reg3-      -> pprLogic platform (sLit "addc") reg1 reg2 (RIReg reg3)+      -> pprLogic platform (text "addc") reg1 reg2 (RIReg reg3)     ADDE reg1 reg2 reg3-      -> pprLogic platform (sLit "adde") reg1 reg2 (RIReg reg3)+      -> pprLogic platform (text "adde") reg1 reg2 (RIReg reg3)     ADDZE reg1 reg2-      -> pprUnary (sLit "addze") reg1 reg2+      -> pprUnary (text "addze") reg1 reg2     SUBF reg1 reg2 reg3-      -> pprLogic platform (sLit "subf") reg1 reg2 (RIReg reg3)+      -> pprLogic platform (text "subf") reg1 reg2 (RIReg reg3)     SUBFO reg1 reg2 reg3-      -> pprLogic platform (sLit "subfo") reg1 reg2 (RIReg reg3)+      -> pprLogic platform (text "subfo") reg1 reg2 (RIReg reg3)     SUBFC reg1 reg2 ri       -> hcat [@@ -691,7 +690,7 @@            ]     SUBFE reg1 reg2 reg3-      -> pprLogic platform (sLit "subfe") reg1 reg2 (RIReg reg3)+      -> pprLogic platform (text "subfe") reg1 reg2 (RIReg reg3)     MULL fmt reg1 reg2 ri       -> pprMul platform fmt reg1 reg2 ri@@ -773,19 +772,19 @@         ]     AND reg1 reg2 ri-      -> pprLogic platform (sLit "and") reg1 reg2 ri+      -> pprLogic platform (text "and") reg1 reg2 ri     ANDC reg1 reg2 reg3-      -> pprLogic platform (sLit "andc") reg1 reg2 (RIReg reg3)+      -> pprLogic platform (text "andc") reg1 reg2 (RIReg reg3)     NAND reg1 reg2 reg3-      -> pprLogic platform (sLit "nand") reg1 reg2 (RIReg reg3)+      -> pprLogic platform (text "nand") reg1 reg2 (RIReg reg3)     OR reg1 reg2 ri-      -> pprLogic platform (sLit "or") reg1 reg2 ri+      -> pprLogic platform (text "or") reg1 reg2 ri     XOR reg1 reg2 ri-      -> pprLogic platform (sLit "xor") reg1 reg2 ri+      -> pprLogic platform (text "xor") reg1 reg2 ri     ORIS reg1 reg2 imm       -> hcat [@@ -837,10 +836,10 @@          ]     NEG reg1 reg2-      -> pprUnary (sLit "neg") reg1 reg2+      -> pprUnary (text "neg") reg1 reg2     NOT reg1 reg2-      -> pprUnary (sLit "not") reg1 reg2+      -> pprUnary (text "not") reg1 reg2     SR II32 reg1 reg2 (RIImm (ImmInt i))     -- Handle the case where we are asked to shift a 32 bit register by@@ -864,24 +863,24 @@     SL fmt reg1 reg2 ri       -> let op = case fmt of-                       II32 -> "slw"-                       II64 -> "sld"+                       II32 -> text "slw"+                       II64 -> text "sld"                        _    -> panic "PPC.Ppr.pprInstr: shift illegal size"-         in pprLogic platform (sLit op) reg1 reg2 (limitShiftRI fmt ri)+         in pprLogic platform op reg1 reg2 (limitShiftRI fmt ri)     SR fmt reg1 reg2 ri       -> let op = case fmt of-                       II32 -> "srw"-                       II64 -> "srd"+                       II32 -> text "srw"+                       II64 -> text "srd"                        _    -> panic "PPC.Ppr.pprInstr: shift illegal size"-         in pprLogic platform (sLit op) reg1 reg2 (limitShiftRI fmt ri)+         in pprLogic platform op reg1 reg2 (limitShiftRI fmt ri)     SRA fmt reg1 reg2 ri       -> let op = case fmt of-                       II32 -> "sraw"-                       II64 -> "srad"+                       II32 -> text "sraw"+                       II64 -> text "srad"                        _    -> panic "PPC.Ppr.pprInstr: shift illegal size"-         in pprLogic platform (sLit op) reg1 reg2 (limitShiftRI fmt ri)+         in pprLogic platform op reg1 reg2 (limitShiftRI fmt ri)     RLWINM reg1 reg2 sh mb me       -> hcat [@@ -922,22 +921,22 @@         ]     FADD fmt reg1 reg2 reg3-      -> pprBinaryF (sLit "fadd") fmt reg1 reg2 reg3+      -> pprBinaryF (text "fadd") fmt reg1 reg2 reg3     FSUB fmt reg1 reg2 reg3-      -> pprBinaryF (sLit "fsub") fmt reg1 reg2 reg3+      -> pprBinaryF (text "fsub") fmt reg1 reg2 reg3     FMUL fmt reg1 reg2 reg3-      -> pprBinaryF (sLit "fmul") fmt reg1 reg2 reg3+      -> pprBinaryF (text "fmul") fmt reg1 reg2 reg3     FDIV fmt reg1 reg2 reg3-      -> pprBinaryF (sLit "fdiv") fmt reg1 reg2 reg3+      -> pprBinaryF (text "fdiv") fmt reg1 reg2 reg3     FABS reg1 reg2-      -> pprUnary (sLit "fabs") reg1 reg2+      -> pprUnary (text "fabs") reg1 reg2     FNEG reg1 reg2-      -> pprUnary (sLit "fneg") reg1 reg2+      -> pprUnary (text "fneg") reg1 reg2     FCMP reg1 reg2       -> hcat [@@ -956,16 +955,16 @@          ]     FCTIWZ reg1 reg2-      -> pprUnary (sLit "fctiwz") reg1 reg2+      -> pprUnary (text "fctiwz") reg1 reg2     FCTIDZ reg1 reg2-      -> pprUnary (sLit "fctidz") reg1 reg2+      -> pprUnary (text "fctidz") reg1 reg2     FCFID reg1 reg2-      -> pprUnary (sLit "fcfid") reg1 reg2+      -> pprUnary (text "fcfid") reg1 reg2     FRSP reg1 reg2-      -> pprUnary (sLit "frsp") reg1 reg2+      -> pprUnary (text "frsp") reg1 reg2     CRNOR dst src1 src2       -> hcat [@@ -1011,10 +1010,10 @@    NOP       -> text "\tnop" -pprLogic :: Platform -> PtrString -> Reg -> Reg -> RI -> SDoc+pprLogic :: Platform -> SDoc -> Reg -> Reg -> RI -> SDoc pprLogic platform op reg1 reg2 ri = hcat [         char '\t',-        ptext op,+        op,         case ri of             RIReg _ -> empty             RIImm _ -> char 'i',@@ -1064,10 +1063,10 @@     ]  -pprUnary :: PtrString -> Reg -> Reg -> SDoc+pprUnary :: SDoc -> Reg -> Reg -> SDoc pprUnary op reg1 reg2 = hcat [         char '\t',-        ptext op,+        op,         char '\t',         pprReg reg1,         text ", ",@@ -1075,10 +1074,10 @@     ]  -pprBinaryF :: PtrString -> Format -> Reg -> Reg -> Reg -> SDoc+pprBinaryF :: SDoc -> Format -> Reg -> Reg -> Reg -> SDoc pprBinaryF op fmt reg1 reg2 reg3 = hcat [         char '\t',-        ptext op,+        op,         pprFFormat fmt,         char '\t',         pprReg reg1,
compiler/GHC/CmmToAsm/PPC/RegInfo.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-}  ----------------------------------------------------------------------------- --@@ -16,8 +15,6 @@ )  where--#include "GhclibHsVersions.h"  import GHC.Prelude
compiler/GHC/CmmToAsm/PPC/Regs.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE CPP #-}- -- ----------------------------------------------------------------------------- -- -- (c) The University of Glasgow 1994-2004@@ -48,8 +46,6 @@  where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Platform.Reg@@ -104,7 +100,6 @@                         | regNo < 32    -> 1     -- first fp reg is 32                         | otherwise     -> 0 -                RealRegPair{}           -> 0          RcDouble          -> case rr of@@ -112,7 +107,6 @@                         | regNo < 32    -> 0                         | otherwise     -> 1 -                RealRegPair{}           -> 0          _other -> 0 @@ -242,9 +236,6 @@ classOfRealReg (RealRegSingle i)         | i < 32        = RcInteger         | otherwise     = RcDouble--classOfRealReg (RealRegPair{})-        = panic "regClass(ppr): no reg pairs on this architecture"  showReg :: RegNo -> String showReg n
compiler/GHC/CmmToAsm/Ppr.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE CPP, MagicHash #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}  ----------------------------------------------------------------------------- --@@ -10,6 +11,7 @@  module GHC.CmmToAsm.Ppr (         doubleToBytes,+        floatToBytes,         pprASCII,         pprString,         pprFileEmbed,@@ -24,8 +26,8 @@ import GHC.Cmm.CLabel import GHC.Cmm import GHC.CmmToAsm.Config-import GHC.Data.FastString-import GHC.Utils.Outputable+import GHC.Utils.Outputable as SDoc+import qualified GHC.Utils.Ppr as Pretty import GHC.Utils.Panic import GHC.Platform @@ -33,7 +35,6 @@ import Data.Array.ST  import Control.Monad.ST- import Data.Word import Data.ByteString (ByteString) import qualified Data.ByteString as BS@@ -49,39 +50,39 @@ -- ----------------------------------------------------------------------------- -- Converting floating-point literals to integrals for printing --- ToDo: this code is currently shared between SPARC and LLVM.---       Similar functions for (single precision) floats are---       present in the SPARC backend only. We need to fix both---       LLVM and SPARC.+-- | Get bytes of a Float representation+floatToBytes :: Float -> [Word8]+floatToBytes f = runST $ do+  arr <- newArray_ ((0::Int),3)+  writeArray arr 0 f+  let cast :: STUArray s Int Float -> ST s (STUArray s Int Word8)+      cast = U.castSTUArray+  arr <- cast arr+  i0 <- readArray arr 0+  i1 <- readArray arr 1+  i2 <- readArray arr 2+  i3 <- readArray arr 3+  return [i0,i1,i2,i3] -castDoubleToWord8Array :: STUArray s Int Double -> ST s (STUArray s Int Word8)-castDoubleToWord8Array = U.castSTUArray+-- | Get bytes of a Double representation+doubleToBytes :: Double -> [Word8]+doubleToBytes d = runST $ do+  arr <- newArray_ ((0::Int),7)+  writeArray arr 0 d+  let cast :: STUArray s Int Double -> ST s (STUArray s Int Word8)+      cast = U.castSTUArray+  arr <- cast arr+  i0 <- readArray arr 0+  i1 <- readArray arr 1+  i2 <- readArray arr 2+  i3 <- readArray arr 3+  i4 <- readArray arr 4+  i5 <- readArray arr 5+  i6 <- readArray arr 6+  i7 <- readArray arr 7+  return [i0,i1,i2,i3,i4,i5,i6,i7] --- floatToBytes and doubleToBytes convert to the host's byte--- order.  Providing that we're not cross-compiling for a--- target with the opposite endianness, this should work ok--- on all targets. --- ToDo: this stuff is very similar to the shenanigans in PprAbs,--- could they be merged?--doubleToBytes :: Double -> [Int]-doubleToBytes d-   = runST (do-        arr <- newArray_ ((0::Int),7)-        writeArray arr 0 d-        arr <- castDoubleToWord8Array arr-        i0 <- readArray arr 0-        i1 <- readArray arr 1-        i2 <- readArray arr 2-        i3 <- readArray arr 3-        i4 <- readArray arr 4-        i5 <- readArray arr 5-        i6 <- readArray arr 6-        i7 <- readArray arr 7-        return (map fromIntegral [i0,i1,i2,i3,i4,i5,i6,i7])-     )- -- --------------------------------------------------------------------------- -- Printing ASCII strings. --@@ -94,28 +95,34 @@   -- the literal SDoc directly.   -- See #14741   -- and Note [Pretty print ASCII when AsmCodeGen]-  = text $ BS.foldr (\w s -> do1 w ++ s) "" str+  --+  -- We work with a `Doc` instead of an `SDoc` because there is no need to carry+  -- an `SDocContext` that we don't use. It leads to nicer (STG) code.+  = docToSDoc (BS.foldr f Pretty.empty str)     where-       do1 :: Word8 -> String-       do1 w | 0x09 == w = "\\t"-             | 0x0A == w = "\\n"-             | 0x22 == w = "\\\""-             | 0x5C == w = "\\\\"+       f :: Word8 -> Pretty.Doc -> Pretty.Doc+       f w s = do1 w Pretty.<> s++       do1 :: Word8 -> Pretty.Doc+       do1 w | 0x09 == w = Pretty.text "\\t"+             | 0x0A == w = Pretty.text "\\n"+             | 0x22 == w = Pretty.text "\\\""+             | 0x5C == w = Pretty.text "\\\\"                -- ASCII printable characters range-             | w >= 0x20 && w <= 0x7E = [chr' w]-             | otherwise = '\\' : octal w+             | w >= 0x20 && w <= 0x7E = Pretty.char (chr' w)+             | otherwise = Pretty.sizedText 4 xs+                where+                 !xs = [ '\\', x0, x1, x2] -- octal+                 !x0 = chr' (ord0 + (w `unsafeShiftR` 6) .&. 0x07)+                 !x1 = chr' (ord0 + (w `unsafeShiftR` 3) .&. 0x07)+                 !x2 = chr' (ord0 + w .&. 0x07)+                 !ord0 = 0x30 -- = ord '0'         -- we know that the Chars we create are in the ASCII range        -- so we bypass the check in "chr"        chr' :: Word8 -> Char        chr' (W8# w#) = C# (chr# (word2Int# (word8ToWord# w#))) -       octal :: Word8 -> String-       octal w = [ chr' (ord0 + (w `unsafeShiftR` 6) .&. 0x07)-                 , chr' (ord0 + (w `unsafeShiftR` 3) .&. 0x07)-                 , chr' (ord0 + w .&. 0x07)-                 ]-       ord0 = 0x30 -- = ord '0'  -- | Emit a ".string" directive pprString :: ByteString -> SDoc@@ -191,37 +198,47 @@  case platformOS (ncgPlatform config) of    OSAIX     -> pprXcoffSectionHeader t    OSDarwin  -> pprDarwinSectionHeader t-   OSMinGW32 -> pprGNUSectionHeader config (char '$') t suffix-   _         -> pprGNUSectionHeader config (char '.') t suffix+   _         -> pprGNUSectionHeader config t suffix -pprGNUSectionHeader :: NCGConfig -> SDoc -> SectionType -> CLabel -> SDoc-pprGNUSectionHeader config sep t suffix =-  text ".section " <> ptext header <> subsection <> flags+pprGNUSectionHeader :: NCGConfig -> SectionType -> CLabel -> SDoc+pprGNUSectionHeader config t suffix =+  hcat [text ".section ", header, subsection, flags]   where+    sep+      | OSMinGW32 <- platformOS platform = char '$'+      | otherwise                        = char '.'     platform      = ncgPlatform config     splitSections = ncgSplitSections config     subsection       | splitSections = sep <> pdoc platform suffix       | otherwise     = empty     header = case t of-      Text -> sLit ".text"-      Data -> sLit ".data"+      Text -> text ".text"+      Data -> text ".data"       ReadOnlyData  | OSMinGW32 <- platformOS platform-                                -> sLit ".rdata"-                    | otherwise -> sLit ".rodata"+                                -> text ".rdata"+                    | otherwise -> text ".rodata"       RelocatableReadOnlyData | OSMinGW32 <- platformOS platform                                 -- Concept does not exist on Windows,                                 -- So map these to R/O data.-                                          -> sLit ".rdata$rel.ro"-                              | otherwise -> sLit ".data.rel.ro"-      UninitialisedData -> sLit ".bss"+                                          -> text ".rdata$rel.ro"+                              | otherwise -> text ".data.rel.ro"+      UninitialisedData -> text ".bss"       ReadOnlyData16 | OSMinGW32 <- platformOS platform-                                 -> sLit ".rdata$cst16"-                     | otherwise -> sLit ".rodata.cst16"+                                 -> text ".rdata$cst16"+                     | otherwise -> text ".rodata.cst16"+      InitArray+        | OSMinGW32 <- platformOS platform+                    -> text ".ctors"+        | otherwise -> text ".init_array"+      FiniArray+        | OSMinGW32 <- platformOS platform+                    -> text ".dtors"+        | otherwise -> text ".fini_array"       CString         | OSMinGW32 <- platformOS platform-                    -> sLit ".rdata"-        | otherwise -> sLit ".rodata.str"+                    -> text ".rdata"+        | otherwise -> text ".rodata.str"       OtherSection _ ->         panic "PprBase.pprGNUSectionHeader: unknown section type"     flags = case t of@@ -234,26 +251,25 @@ -- XCOFF doesn't support relocating label-differences, so we place all -- RO sections into .text[PR] sections pprXcoffSectionHeader :: SectionType -> SDoc-pprXcoffSectionHeader t = text $ case t of-     Text                    -> ".csect .text[PR]"-     Data                    -> ".csect .data[RW]"-     ReadOnlyData            -> ".csect .text[PR] # ReadOnlyData"-     RelocatableReadOnlyData -> ".csect .text[PR] # RelocatableReadOnlyData"-     ReadOnlyData16          -> ".csect .text[PR] # ReadOnlyData16"-     CString                 -> ".csect .text[PR] # CString"-     UninitialisedData       -> ".csect .data[BS]"-     OtherSection _          ->-       panic "PprBase.pprXcoffSectionHeader: unknown section type"+pprXcoffSectionHeader t = case t of+  Text                    -> text ".csect .text[PR]"+  Data                    -> text ".csect .data[RW]"+  ReadOnlyData            -> text ".csect .text[PR] # ReadOnlyData"+  RelocatableReadOnlyData -> text ".csect .text[PR] # RelocatableReadOnlyData"+  ReadOnlyData16          -> text ".csect .text[PR] # ReadOnlyData16"+  CString                 -> text ".csect .text[PR] # CString"+  UninitialisedData       -> text ".csect .data[BS]"+  _                       -> panic "pprXcoffSectionHeader: unknown section type"  pprDarwinSectionHeader :: SectionType -> SDoc-pprDarwinSectionHeader t =-  ptext $ case t of-     Text -> sLit ".text"-     Data -> sLit ".data"-     ReadOnlyData -> sLit ".const"-     RelocatableReadOnlyData -> sLit ".const_data"-     UninitialisedData -> sLit ".data"-     ReadOnlyData16 -> sLit ".const"-     CString -> sLit ".section\t__TEXT,__cstring,cstring_literals"-     OtherSection _ ->-       panic "PprBase.pprDarwinSectionHeader: unknown section type"+pprDarwinSectionHeader t = case t of+  Text                    -> text ".text"+  Data                    -> text ".data"+  ReadOnlyData            -> text ".const"+  RelocatableReadOnlyData -> text ".const_data"+  UninitialisedData       -> text ".data"+  ReadOnlyData16          -> text ".const"+  InitArray               -> text ".section\t__DATA,__mod_init_func,mod_init_funcs"+  FiniArray               -> panic "pprDarwinSectionHeader: fini not supported"+  CString                 -> text ".section\t__TEXT,__cstring,cstring_literals"+  OtherSection _          -> panic "pprDarwinSectionHeader: unknown section type"
+ compiler/GHC/CmmToAsm/Reg/Graph/Base.hs view
@@ -0,0 +1,164 @@++-- | Utils for calculating general worst, bound, squeese and free, functions.+--+--   as per: "A Generalized Algorithm for Graph-Coloring Register Allocation"+--           Michael Smith, Normal Ramsey, Glenn Holloway.+--           PLDI 2004+--+--   These general versions are not used in GHC proper because they are too slow.+--   Instead, hand written optimised versions are provided for each architecture+--   in MachRegs*.hs+--+--   This code is here because we can test the architecture specific code against+--   it.+--+module GHC.CmmToAsm.Reg.Graph.Base (+        RegClass(..),+        Reg(..),+        RegSub(..),++        worst,+        bound,+        squeese+) where++import GHC.Prelude++import GHC.Types.Unique.Set+import GHC.Types.Unique.FM+import GHC.Types.Unique+import GHC.Builtin.Uniques+import GHC.Utils.Monad (concatMapM)+++-- Some basic register classes.+--      These aren't necessarily in 1-to-1 correspondence with the allocatable+--      RegClasses in MachRegs.hs+data RegClass+        -- general purpose regs+        = ClassG32      -- 32 bit GPRs+        | ClassG16      -- 16 bit GPRs+        | ClassG8       -- 8  bit GPRs++        -- floating point regs+        | ClassF64      -- 64 bit FPRs+        deriving (Show, Eq, Enum)+++-- | A register of some class+data Reg+        -- a register of some class+        = Reg RegClass Int++        -- a sub-component of one of the other regs+        | RegSub RegSub Reg+        deriving (Show, Eq)+++-- | so we can put regs in UniqSets+instance Uniquable Reg where+        getUnique (Reg c i)+         = mkRegSingleUnique+         $ fromEnum c * 1000 + i++        getUnique (RegSub s (Reg c i))+         = mkRegSubUnique+         $ fromEnum s * 10000 + fromEnum c * 1000 + i++        getUnique (RegSub _ (RegSub _ _))+          = error "RegArchBase.getUnique: can't have a sub-reg of a sub-reg."+++-- | A subcomponent of another register+data RegSub+        = SubL16        -- lowest 16 bits+        | SubL8         -- lowest  8 bits+        | SubL8H        -- second lowest 8 bits+        deriving (Show, Enum, Ord, Eq)+++-- | Worst case displacement+--+--      a node N of classN has some number of neighbors,+--      all of which are from classC.+--+--      (worst neighbors classN classC) is the maximum number of potential+--      colors for N that can be lost by coloring its neighbors.+--+-- This should be hand coded/cached for each particular architecture,+--      because the compute time is very long..+worst   :: (RegClass    -> UniqSet Reg)+        -> (Reg         -> UniqSet Reg)+        -> Int -> RegClass -> RegClass -> Int++worst regsOfClass regAlias neighbors classN classC+ = let  regAliasS regs  = unionManyUniqSets+                        $ map regAlias+                        $ nonDetEltsUniqSet regs+                        -- This is non-deterministic but we do not+                        -- currently support deterministic code-generation.+                        -- See Note [Unique Determinism and code generation]++        -- all the regs in classes N, C+        regsN           = regsOfClass classN+        regsC           = regsOfClass classC++        -- all the possible subsets of c which have size < m+        regsS           = filter (\s -> sizeUniqSet s >= 1+                                     && sizeUniqSet s <= neighbors)+                        $ powersetLS regsC++        -- for each of the subsets of C, the regs which conflict+        -- with posiblities for N+        regsS_conflict+                = map (\s -> intersectUniqSets regsN (regAliasS s)) regsS++  in    maximum $ map sizeUniqSet $ regsS_conflict+++-- | For a node N of classN and neighbors of classesC+--      (bound classN classesC) is the maximum number of potential+--      colors for N that can be lost by coloring its neighbors.+bound   :: (RegClass    -> UniqSet Reg)+        -> (Reg         -> UniqSet Reg)+        -> RegClass -> [RegClass] -> Int++bound regsOfClass regAlias classN classesC+ = let  regAliasS regs  = unionManyUniqSets+                        $ map regAlias+                        $ nonDetEltsUFM regs+                        -- See Note [Unique Determinism and code generation]++        regsC_aliases+                = unionManyUniqSets+                $ map (regAliasS . getUniqSet . regsOfClass) classesC++        overlap = intersectUniqSets (regsOfClass classN) regsC_aliases++   in   sizeUniqSet overlap+++-- | The total squeese on a particular node with a list of neighbors.+--+--   A version of this should be constructed for each particular architecture,+--   possibly including uses of bound, so that aliased registers don't get+--   counted twice, as per the paper.+squeese :: (RegClass    -> UniqSet Reg)+        -> (Reg         -> UniqSet Reg)+        -> RegClass -> [(Int, RegClass)] -> Int++squeese regsOfClass regAlias classN countCs+        = sum+        $ map (\(i, classC) -> worst regsOfClass regAlias i classN classC)+        $ countCs+++-- | powerset (for lists)+powersetL :: [a] -> [[a]]+powersetL       = concatMapM (\x -> [[],[x]])+++-- | powersetLS (list of sets)+powersetLS :: Uniquable a => UniqSet a -> [UniqSet a]+powersetLS s    = map mkUniqSet $ powersetL $ nonDetEltsUniqSet s+  -- See Note [Unique Determinism and code generation]
+ compiler/GHC/CmmToAsm/Reg/Graph/Coalesce.hs view
@@ -0,0 +1,99 @@+-- | Register coalescing.+module GHC.CmmToAsm.Reg.Graph.Coalesce (+        regCoalesce,+        slurpJoinMovs+) where+import GHC.Prelude++import GHC.CmmToAsm.Reg.Liveness+import GHC.CmmToAsm.Instr+import GHC.Platform.Reg++import GHC.Cmm+import GHC.Data.Bag+import GHC.Data.Graph.Directed+import GHC.Types.Unique.FM+import GHC.Types.Unique.Set+import GHC.Types.Unique.Supply+++-- | Do register coalescing on this top level thing+--+--   For Reg -> Reg moves, if the first reg dies at the same time the+--   second reg is born then the mov only serves to join live ranges.+--   The two regs can be renamed to be the same and the move instruction+--   safely erased.+regCoalesce+        :: Instruction instr+        => [LiveCmmDecl statics instr]+        -> UniqSM [LiveCmmDecl statics instr]++regCoalesce code+ = do+        let joins       = foldl' unionBags emptyBag+                        $ map slurpJoinMovs code++        let alloc       = foldl' buildAlloc emptyUFM+                        $ bagToList joins++        let patched     = map (patchEraseLive (sinkReg alloc)) code++        return patched+++-- | Add a v1 = v2 register renaming to the map.+--   The register with the lowest lexical name is set as the+--   canonical version.+buildAlloc :: UniqFM Reg Reg -> (Reg, Reg) -> UniqFM Reg Reg+buildAlloc fm (r1, r2)+ = let  rmin    = min r1 r2+        rmax    = max r1 r2+   in   addToUFM fm rmax rmin+++-- | Determine the canonical name for a register by following+--   v1 = v2 renamings in this map.+sinkReg :: UniqFM Reg Reg -> Reg -> Reg+sinkReg fm r+ = case lookupUFM fm r of+        Nothing -> r+        Just r' -> sinkReg fm r'+++-- | Slurp out mov instructions that only serve to join live ranges.+--+--   During a mov, if the source reg dies and the destination reg is+--   born then we can rename the two regs to the same thing and+--   eliminate the move.+slurpJoinMovs+        :: Instruction instr+        => LiveCmmDecl statics instr+        -> Bag (Reg, Reg)++slurpJoinMovs live+        = slurpCmm emptyBag live+ where+        slurpCmm   rs  CmmData{}+         = rs++        slurpCmm   rs (CmmProc _ _ _ sccs)+         = foldl' slurpBlock rs (flattenSCCs sccs)++        slurpBlock rs (BasicBlock _ instrs)+         = foldl' slurpLI    rs instrs++        slurpLI    rs (LiveInstr _      Nothing)    = rs+        slurpLI    rs (LiveInstr instr (Just live))+                | Just (r1, r2) <- takeRegRegMoveInstr instr+                , elementOfUniqSet r1 $ liveDieRead live+                , elementOfUniqSet r2 $ liveBorn live++                -- only coalesce movs between two virtuals for now,+                -- else we end up with allocatable regs in the live+                -- regs list..+                , isVirtualReg r1 && isVirtualReg r2+                = consBag (r1, r2) rs++                | otherwise+                = rs+
compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs view
@@ -18,7 +18,7 @@ import GHC.Cmm.Dataflow.Collections  import GHC.Utils.Monad-import GHC.Utils.Monad.State+import GHC.Utils.Monad.State.Strict import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Unique.Set
compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs view
@@ -45,7 +45,7 @@ import GHC.Types.Unique.FM import GHC.Types.Unique import GHC.Builtin.Uniques-import GHC.Utils.Monad.State+import GHC.Utils.Monad.State.Strict import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Platform@@ -515,9 +515,6 @@     getUnique (SReg  r)         | RegReal (RealRegSingle i)     <- r         = mkRegSingleUnique i--        | RegReal (RealRegPair r1 r2)   <- r-        = mkRegPairUnique (r1 * 65535 + r2)          | otherwise         = error $ "RegSpillClean.getUnique: found virtual reg during spill clean,"
compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs view
@@ -33,7 +33,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Platform-import GHC.Utils.Monad.State+import GHC.Utils.Monad.State.Strict import GHC.CmmToAsm.CFG  import Data.List        (nub, minimumBy)
compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, CPP, DeriveFunctor #-}+{-# LANGUAGE BangPatterns, DeriveFunctor #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-}@@ -38,7 +38,7 @@ import GHC.Types.Unique.FM import GHC.Types.Unique.Set import GHC.Utils.Outputable-import GHC.Utils.Monad.State+import GHC.Utils.Monad.State.Strict  -- | Holds interesting statistics from the register allocator. data RegAllocStats statics instr
compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs view
@@ -1,13 +1,9 @@-{-# LANGUAGE CPP #-}- module GHC.CmmToAsm.Reg.Graph.TrivColorable (         trivColorable, )  where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Platform.Reg.Class@@ -44,7 +40,7 @@ --      TODO: Is that still true? Could we use allocatableRegsInClass --      without losing performance now? -----      Look at includes/stg/MachRegs.h to get the numbers.+--      Look at rts/include/stg/MachRegs.h to get the numbers. --  @@ -111,12 +107,12 @@                             ArchX86       -> 3                             ArchX86_64    -> 5                             ArchPPC       -> 16-                            ArchSPARC     -> 14-                            ArchSPARC64   -> panic "trivColorable ArchSPARC64"                             ArchPPC_64 _  -> 15                             ArchARM _ _ _ -> panic "trivColorable ArchARM"-                            -- N.B. x18 is reserved by the platform on AArch64/Darwin-                            ArchAArch64   -> 17+                            -- We should be able to allocate *a lot* more in princple.+                            -- essentially all 32 - SP, so 31, we'd trash the link reg+                            -- as well as the platform and all others though.+                            ArchAArch64   -> 18                             ArchAlpha     -> panic "trivColorable ArchAlpha"                             ArchMipseb    -> panic "trivColorable ArchMipseb"                             ArchMipsel    -> panic "trivColorable ArchMipsel"@@ -144,8 +140,6 @@                             ArchX86       -> 0                             ArchX86_64    -> 0                             ArchPPC       -> 0-                            ArchSPARC     -> 22-                            ArchSPARC64   -> panic "trivColorable ArchSPARC64"                             ArchPPC_64 _  -> 0                             ArchARM _ _ _ -> panic "trivColorable ArchARM"                             -- we can in princple address all the float regs as@@ -181,8 +175,6 @@                             -- "dont need to solve conflicts" count that                             -- was chosen at some point in the past.                             ArchPPC       -> 26-                            ArchSPARC     -> 11-                            ArchSPARC64   -> panic "trivColorable ArchSPARC64"                             ArchPPC_64 _  -> 20                             ArchARM _ _ _ -> panic "trivColorable ArchARM"                             ArchAArch64   -> 32
+ compiler/GHC/CmmToAsm/Reg/Graph/X86.hs view
@@ -0,0 +1,161 @@++-- | A description of the register set of the X86.+--+--   This isn't used directly in GHC proper.+--+--   See RegArchBase.hs for the reference.+--   See MachRegs.hs for the actual trivColorable function used in GHC.+--+module GHC.CmmToAsm.Reg.Graph.X86 (+        classOfReg,+        regsOfClass,+        regName,+        regAlias,+        worst,+        squeese,+) where++import GHC.Prelude++import GHC.CmmToAsm.Reg.Graph.Base  (Reg(..), RegSub(..), RegClass(..))+import GHC.Types.Unique.Set++import qualified Data.Array as A+++-- | Determine the class of a register+classOfReg :: Reg -> RegClass+classOfReg reg+ = case reg of+        Reg c _         -> c++        RegSub SubL16 _ -> ClassG16+        RegSub SubL8  _ -> ClassG8+        RegSub SubL8H _ -> ClassG8+++-- | Determine all the regs that make up a certain class.+regsOfClass :: RegClass -> UniqSet Reg+regsOfClass c+ = case c of+        ClassG32+         -> mkUniqSet   [ Reg ClassG32  i+                        | i <- [0..7] ]++        ClassG16+         -> mkUniqSet   [ RegSub SubL16 (Reg ClassG32 i)+                        | i <- [0..7] ]++        ClassG8+         -> unionUniqSets+                (mkUniqSet [ RegSub SubL8  (Reg ClassG32 i) | i <- [0..3] ])+                (mkUniqSet [ RegSub SubL8H (Reg ClassG32 i) | i <- [0..3] ])++        ClassF64+         -> mkUniqSet   [ Reg ClassF64  i+                        | i <- [0..5] ]+++-- | Determine the common name of a reg+--      returns Nothing if this reg is not part of the machine.+regName :: Reg -> Maybe String+regName reg+ = case reg of+        Reg ClassG32 i+         | i <= 7 ->+           let names = A.listArray (0,8)+                       [ "eax", "ebx", "ecx", "edx"+                       , "ebp", "esi", "edi", "esp" ]+           in Just $ names A.! i++        RegSub SubL16 (Reg ClassG32 i)+         | i <= 7 ->+           let names = A.listArray (0,8)+                       [ "ax", "bx", "cx", "dx"+                       , "bp", "si", "di", "sp"]+           in Just $ names A.! i++        RegSub SubL8  (Reg ClassG32 i)+         | i <= 3 ->+           let names = A.listArray (0,4) [ "al", "bl", "cl", "dl"]+           in Just $ names A.! i++        RegSub SubL8H (Reg ClassG32 i)+         | i <= 3 ->+           let names = A.listArray (0,4) [ "ah", "bh", "ch", "dh"]+           in Just $ names A.! i++        _         -> Nothing+++-- | Which regs alias what other regs.+regAlias :: Reg -> UniqSet Reg+regAlias reg+ = case reg of++        -- 32 bit regs alias all of the subregs+        Reg ClassG32 i++         -- for eax, ebx, ecx, eds+         |  i <= 3+         -> mkUniqSet+         $ [ Reg ClassG32 i,   RegSub SubL16 reg+           , RegSub SubL8 reg, RegSub SubL8H reg ]++         -- for esi, edi, esp, ebp+         | 4 <= i && i <= 7+         -> mkUniqSet+         $ [ Reg ClassG32 i,   RegSub SubL16 reg ]++        -- 16 bit subregs alias the whole reg+        RegSub SubL16 r@(Reg ClassG32 _)+         ->     regAlias r++        -- 8 bit subregs alias the 32 and 16, but not the other 8 bit subreg+        RegSub SubL8  r@(Reg ClassG32 _)+         -> mkUniqSet $ [ r, RegSub SubL16 r, RegSub SubL8 r ]++        RegSub SubL8H r@(Reg ClassG32 _)+         -> mkUniqSet $ [ r, RegSub SubL16 r, RegSub SubL8H r ]++        -- fp+        Reg ClassF64 _+         -> unitUniqSet reg++        _ -> error "regAlias: invalid register"+++-- | Optimised versions of RegColorBase.{worst, squeese} specific to x86+worst :: Int -> RegClass -> RegClass -> Int+worst n classN classC+ = case classN of+        ClassG32+         -> case classC of+                ClassG32        -> min n 8+                ClassG16        -> min n 8+                ClassG8         -> min n 4+                ClassF64        -> 0++        ClassG16+         -> case classC of+                ClassG32        -> min n 8+                ClassG16        -> min n 8+                ClassG8         -> min n 4+                ClassF64        -> 0++        ClassG8+         -> case classC of+                ClassG32        -> min (n*2) 8+                ClassG16        -> min (n*2) 8+                ClassG8         -> min n 8+                ClassF64        -> 0++        ClassF64+         -> case classC of+                ClassF64        -> min n 6+                _               -> 0++squeese :: RegClass -> [(Int, RegClass)] -> Int+squeese classN countCs+        = sum (map (\(i, classC) -> worst i classN classC) countCs)+
compiler/GHC/CmmToAsm/Reg/Linear.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} {-# LANGUAGE ConstraintKinds #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}@@ -102,9 +102,6 @@         module  GHC.CmmToAsm.Reg.Linear.Stats   ) where -#include "GhclibHsVersions.h"-- import GHC.Prelude  import GHC.CmmToAsm.Reg.Linear.State@@ -114,7 +111,6 @@ import GHC.CmmToAsm.Reg.Linear.Stats import GHC.CmmToAsm.Reg.Linear.JoinToTargets import qualified GHC.CmmToAsm.Reg.Linear.PPC     as PPC-import qualified GHC.CmmToAsm.Reg.Linear.SPARC   as SPARC import qualified GHC.CmmToAsm.Reg.Linear.X86     as X86 import qualified GHC.CmmToAsm.Reg.Linear.X86_64  as X86_64 import qualified GHC.CmmToAsm.Reg.Linear.AArch64 as AArch64@@ -220,8 +216,6 @@       ArchX86        -> go $ (frInitFreeRegs platform :: X86.FreeRegs)       ArchX86_64     -> go $ (frInitFreeRegs platform :: X86_64.FreeRegs)       ArchS390X      -> panic "linearRegAlloc ArchS390X"-      ArchSPARC      -> go $ (frInitFreeRegs platform :: SPARC.FreeRegs)-      ArchSPARC64    -> panic "linearRegAlloc ArchSPARC64"       ArchPPC        -> go $ (frInitFreeRegs platform :: PPC.FreeRegs)       ArchARM _ _ _  -> panic "linearRegAlloc ArchARM"       ArchAArch64    -> go $ (frInitFreeRegs platform :: AArch64.FreeRegs)@@ -391,9 +385,9 @@                 , [NatBasicBlock instr])        --   fresh blocks of fixup code. linearRA block_live block_id = go [] []   where-    go :: [instr]                              -- ^ accumulator for instructions already processed.-       -> [NatBasicBlock instr]                -- ^ accumulator for blocks of fixup code.-       -> [LiveInstr instr]                    -- ^ liveness annotated instructions in this block.+    go :: [instr]                              -- accumulator for instructions already processed.+       -> [NatBasicBlock instr]                -- accumulator for blocks of fixup code.+       -> [LiveInstr instr]                    -- liveness annotated instructions in this block.        -> RegM freeRegs                ( [instr]                       --   instructions after register allocation                , [NatBasicBlock instr] )       --   fresh blocks of fixup code.@@ -679,29 +673,30 @@ saveClobberedTemps clobbered dying  = do         assig   <- getAssigR :: RegM freeRegs (UniqFM Reg Loc)-        -- Unique represents the VirtualReg-        let to_spill :: [(Unique, RealReg)]-            to_spill-                = [ (temp,reg)-                        | (temp, InReg reg) <- nonDetUFMToList assig-                        -- This is non-deterministic but we do not-                        -- currently support deterministic code-generation.-                        -- See Note [Unique Determinism and code generation]-                        , any (realRegsAlias reg) clobbered-                        , temp `notElem` map getUnique dying  ]--        (instrs,assig') <- clobber assig [] to_spill+        (assig',instrs) <- nonDetStrictFoldUFM_DirectlyM maybe_spill (assig,[]) assig         setAssigR assig'         return $ -- mkComment (text "<saveClobberedTemps>") ++                  instrs --              ++ mkComment (text "</saveClobberedTemps>")    where-     -- See Note [UniqFM and the register allocator]-     clobber :: RegMap Loc -> [instr] -> [(Unique,RealReg)] -> RegM freeRegs ([instr], RegMap Loc)-     clobber assig instrs []-            = return (instrs, assig)+     -- Unique represents the VirtualReg+     -- Here we separate the cases which we do want to spill from these we don't.+     maybe_spill :: Unique -> (RegMap Loc,[instr]) -> (Loc) -> RegM freeRegs (RegMap Loc,[instr])+     maybe_spill !temp !(assig,instrs) !loc =+        case loc of+                -- This is non-deterministic but we do not+                -- currently support deterministic code-generation.+                -- See Note [Unique Determinism and code generation]+                InReg reg+                    | any (realRegsAlias reg) clobbered+                    , temp `notElem` map getUnique dying+                    -> clobber temp (assig,instrs) (reg)+                _ -> return (assig,instrs) -     clobber assig instrs ((temp, reg) : rest)++     -- See Note [UniqFM and the register allocator]+     clobber :: Unique -> (RegMap Loc,[instr]) -> (RealReg) -> RegM freeRegs (RegMap Loc,[instr])+     clobber temp (assig,instrs) (reg)        = do platform <- getPlatform              freeRegs <- getFreeRegsR@@ -720,7 +715,7 @@                   let instr = mkRegRegMoveInstr platform                                   (RegReal reg) (RegReal my_reg) -                  clobber new_assign (instr : instrs) rest+                  return (new_assign,(instr : instrs))                -- (2) no free registers: spill the value               [] -> do@@ -731,7 +726,8 @@                    let new_assign  = addToUFM_Directly assig temp (InBoth reg slot) -                  clobber new_assign (spill ++ instrs) rest+                  return (new_assign, (spill ++ instrs))+
compiler/GHC/CmmToAsm/Reg/Linear/AArch64.hs view
@@ -71,7 +71,6 @@     | r < 32 && testBit g r = FreeRegs (clearBit g r) f     | r > 31 = panic $ "Linear.AArch64.allocReg: double allocation of float reg v" ++ show (r - 32) ++ "; " ++ showBits f     | otherwise = pprPanic "Linear.AArch64.allocReg" $ text ("double allocation of gp reg x" ++ show r ++ "; " ++ showBits g)-allocateReg _ _ = panic "Linear.AArch64.allocReg: bad reg"  -- we start from 28 downwards... the logic is similar to the ppc logic. -- 31 is Stack Pointer@@ -134,4 +133,3 @@   | r < 32 && testBit g r = pprPanic "Linear.AArch64.releaseReg" (text "can't release non-allocated reg x" <> int r)   | r > 31 = FreeRegs g (setBit f (r - 32))   | otherwise = FreeRegs (setBit g r) f-releaseReg _ _ = pprPanic "Linear.AArch64.releaseReg" (text "bad reg")
compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs view
@@ -1,12 +1,7 @@-{-# LANGUAGE CPP #-}- module GHC.CmmToAsm.Reg.Linear.FreeRegs (     FR(..),     maxSpillSlots )--#include "GhclibHsVersions.h"- where  import GHC.Prelude@@ -31,13 +26,11 @@ --      allocateReg f r = filter (/= r) f  import qualified GHC.CmmToAsm.Reg.Linear.PPC     as PPC-import qualified GHC.CmmToAsm.Reg.Linear.SPARC   as SPARC import qualified GHC.CmmToAsm.Reg.Linear.X86     as X86 import qualified GHC.CmmToAsm.Reg.Linear.X86_64  as X86_64 import qualified GHC.CmmToAsm.Reg.Linear.AArch64 as AArch64  import qualified GHC.CmmToAsm.PPC.Instr     as PPC.Instr-import qualified GHC.CmmToAsm.SPARC.Instr   as SPARC.Instr import qualified GHC.CmmToAsm.X86.Instr     as X86.Instr import qualified GHC.CmmToAsm.AArch64.Instr as AArch64.Instr @@ -71,20 +64,12 @@     frInitFreeRegs = AArch64.initFreeRegs     frReleaseReg = \_ -> AArch64.releaseReg -instance FR SPARC.FreeRegs where-    frAllocateReg  = SPARC.allocateReg-    frGetFreeRegs  = \_ -> SPARC.getFreeRegs-    frInitFreeRegs = SPARC.initFreeRegs-    frReleaseReg   = SPARC.releaseReg- maxSpillSlots :: NCGConfig -> Int maxSpillSlots config = case platformArch (ncgPlatform config) of    ArchX86       -> X86.Instr.maxSpillSlots config    ArchX86_64    -> X86.Instr.maxSpillSlots config    ArchPPC       -> PPC.Instr.maxSpillSlots config    ArchS390X     -> panic "maxSpillSlots ArchS390X"-   ArchSPARC     -> SPARC.Instr.maxSpillSlots config-   ArchSPARC64   -> panic "maxSpillSlots ArchSPARC64"    ArchARM _ _ _ -> panic "maxSpillSlots ArchARM"    ArchAArch64   -> AArch64.Instr.maxSpillSlots config    ArchPPC_64 _  -> PPC.Instr.maxSpillSlots config
compiler/GHC/CmmToAsm/Reg/Linear/PPC.hs view
@@ -8,7 +8,6 @@ import GHC.Platform.Reg  import GHC.Utils.Outputable-import GHC.Utils.Panic import GHC.Platform  import Data.Word@@ -38,9 +37,6 @@     | r > 31    = FreeRegs g (f .|. (1 `shiftL` (r - 32)))     | otherwise = FreeRegs (g .|. (1 `shiftL` r)) f -releaseReg _ _-        = panic "RegAlloc.Linear.PPC.releaseReg: bad reg"- initFreeRegs :: Platform -> FreeRegs initFreeRegs platform = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform) @@ -59,5 +55,3 @@     | r > 31    = FreeRegs g (f .&. complement (1 `shiftL` (r - 32)))     | otherwise = FreeRegs (g .&. complement (1 `shiftL` r)) f -allocateReg _ _-        = panic "RegAlloc.Linear.PPC.allocateReg: bad reg"
− compiler/GHC/CmmToAsm/Reg/Linear/SPARC.hs 
@@ -1,191 +0,0 @@-{-# LANGUAGE CPP #-}---- | Free regs map for SPARC-module GHC.CmmToAsm.Reg.Linear.SPARC where--import GHC.Prelude--import GHC.CmmToAsm.SPARC.Regs-import GHC.Platform.Reg.Class-import GHC.Platform.Reg--import GHC.Platform.Regs-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Platform--import Data.Word-------------------------------------------------------------------------------------- SPARC is like PPC, except for twinning of floating point regs.---      When we allocate a double reg we must take an even numbered---      float reg, as well as the one after it.----- Holds bitmaps showing what registers are currently allocated.---      The float and double reg bitmaps overlap, but we only alloc---      float regs into the float map, and double regs into the double map.------      Free regs have a bit set in the corresponding bitmap.----data FreeRegs-        = FreeRegs-                !Word32         -- int    reg bitmap    regs  0..31-                !Word32         -- float  reg bitmap    regs 32..63-                !Word32         -- double reg bitmap    regs 32..63--instance Show FreeRegs where-        show = showFreeRegs--instance Outputable FreeRegs where-        ppr = text . showFreeRegs---- | A reg map where no regs are free to be allocated.-noFreeRegs :: FreeRegs-noFreeRegs = FreeRegs 0 0 0----- | The initial set of free regs.-initFreeRegs :: Platform -> FreeRegs-initFreeRegs platform- =      foldl' (flip $ releaseReg platform) noFreeRegs allocatableRegs----- | Get all the free registers of this class.-getFreeRegs :: RegClass -> FreeRegs -> [RealReg]        -- lazily-getFreeRegs cls (FreeRegs g f d)-        | RcInteger <- cls = map RealRegSingle                  $ go 1 g 1 0-        | RcFloat   <- cls = map RealRegSingle                  $ go 1 f 1 32-        | RcDouble  <- cls = map (\i -> RealRegPair i (i+1))    $ go 2 d 1 32-#if __GLASGOW_HASKELL__ <= 810-        | otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad register class " (ppr cls)-#endif-        where-                go _    _      0    _-                        = []--                go step bitmap mask ix-                        | bitmap .&. mask /= 0-                        = ix : (go step bitmap (mask `shiftL` step) $! ix + step)--                        | otherwise-                        = go step bitmap (mask `shiftL` step) $! ix + step----- | Grab a register.-allocateReg :: Platform -> RealReg -> FreeRegs -> FreeRegs-allocateReg platform-         reg@(RealRegSingle r)-             (FreeRegs g f d)--        -- can't allocate free regs-        | not $ freeReg platform r-        = pprPanic "SPARC.FreeRegs.allocateReg: not allocating pinned reg" (ppr reg)--        -- a general purpose reg-        | r <= 31-        = let   mask    = complement (bitMask r)-          in    FreeRegs-                        (g .&. mask)-                        f-                        d--        -- a float reg-        | r >= 32, r <= 63-        = let   mask    = complement (bitMask (r - 32))--                -- the mask of the double this FP reg aliases-                maskLow = if r `mod` 2 == 0-                                then complement (bitMask (r - 32))-                                else complement (bitMask (r - 32 - 1))-          in    FreeRegs-                        g-                        (f .&. mask)-                        (d .&. maskLow)--        | otherwise-        = pprPanic "SPARC.FreeRegs.releaseReg: not allocating bad reg" (ppr reg)--allocateReg _-         reg@(RealRegPair r1 r2)-             (FreeRegs g f d)--        | r1 >= 32, r1 <= 63, r1 `mod` 2 == 0-        , r2 >= 32, r2 <= 63-        = let   mask1   = complement (bitMask (r1 - 32))-                mask2   = complement (bitMask (r2 - 32))-          in-                FreeRegs-                        g-                        ((f .&. mask1) .&. mask2)-                        (d .&. mask1)--        | otherwise-        = pprPanic "SPARC.FreeRegs.releaseReg: not allocating bad reg" (ppr reg)------ | Release a register from allocation.---      The register liveness information says that most regs die after a C call,---      but we still don't want to allocate to some of them.----releaseReg :: Platform -> RealReg -> FreeRegs -> FreeRegs-releaseReg platform-         reg@(RealRegSingle r)-        regs@(FreeRegs g f d)--        -- don't release pinned reg-        | not $ freeReg platform r-        = regs--        -- a general purpose reg-        | r <= 31-        = let   mask    = bitMask r-          in    FreeRegs (g .|. mask) f d--        -- a float reg-        | r >= 32, r <= 63-        = let   mask    = bitMask (r - 32)--                -- the mask of the double this FP reg aliases-                maskLow = if r `mod` 2 == 0-                                then bitMask (r - 32)-                                else bitMask (r - 32 - 1)-          in    FreeRegs-                        g-                        (f .|. mask)-                        (d .|. maskLow)--        | otherwise-        = pprPanic "SPARC.FreeRegs.releaseReg: not releasing bad reg" (ppr reg)--releaseReg _-         reg@(RealRegPair r1 r2)-             (FreeRegs g f d)--        | r1 >= 32, r1 <= 63, r1 `mod` 2 == 0-        , r2 >= 32, r2 <= 63-        = let   mask1   = bitMask (r1 - 32)-                mask2   = bitMask (r2 - 32)-          in-                FreeRegs-                        g-                        ((f .|. mask1) .|. mask2)-                        (d .|. mask1)--        | otherwise-        = pprPanic "SPARC.FreeRegs.releaseReg: not releasing bad reg" (ppr reg)----bitMask :: Int -> Word32-bitMask n       = 1 `shiftL` n---showFreeRegs :: FreeRegs -> String-showFreeRegs regs-        =  "FreeRegs\n"-        ++ "    integer: " ++ (show $ getFreeRegs RcInteger regs)       ++ "\n"-        ++ "      float: " ++ (show $ getFreeRegs RcFloat   regs)       ++ "\n"-        ++ "     double: " ++ (show $ getFreeRegs RcDouble  regs)       ++ "\n"
compiler/GHC/CmmToAsm/Reg/Linear/State.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, PatternSynonyms, DeriveFunctor #-}+{-# LANGUAGE PatternSynonyms, DeriveFunctor #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UnboxedTuples #-} @@ -50,6 +50,7 @@ import GHC.Platform import GHC.Types.Unique import GHC.Types.Unique.Supply+import GHC.Exts (oneShot)  import Control.Monad (ap) @@ -64,16 +65,21 @@         = RegM { unReg :: RA_State freeRegs -> RA_Result freeRegs a }         deriving (Functor) +-- | Smart constructor for 'RegM', as described in Note [The one-shot state+-- monad trick] in GHC.Utils.Monad.+mkRegM :: (RA_State freeRegs -> RA_Result freeRegs a) -> RegM freeRegs a+mkRegM f = RegM (oneShot f)+ instance Applicative (RegM freeRegs) where-      pure a  =  RegM $ \s -> RA_Result s a+      pure a  =  mkRegM $ \s -> RA_Result s a       (<*>) = ap  instance Monad (RegM freeRegs) where-  m >>= k   =  RegM $ \s -> case unReg m s of { RA_Result s a -> unReg (k a) s }+  m >>= k   =  mkRegM $ \s -> case unReg m s of { RA_Result s a -> unReg (k a) s }  -- | Get native code generator configuration getConfig :: RegM a NCGConfig-getConfig = RegM $ \s -> RA_Result s (ra_config s)+getConfig = mkRegM $ \s -> RA_Result s (ra_config s)  -- | Get target platform from native code generator configuration getPlatform :: RegM a Platform@@ -117,7 +123,7 @@ spillR :: Instruction instr        => Reg -> Unique -> RegM freeRegs ([instr], Int) -spillR reg temp = RegM $ \s ->+spillR reg temp = mkRegM $ \s ->   let (stack1,slot) = getStackSlotFor (ra_stack s) temp       instr  = mkSpillInstr (ra_config s) reg (ra_delta s) slot   in@@ -127,42 +133,42 @@ loadR :: Instruction instr       => Reg -> Int -> RegM freeRegs [instr] -loadR reg slot = RegM $ \s ->+loadR reg slot = mkRegM $ \s ->   RA_Result s (mkLoadInstr (ra_config s) reg (ra_delta s) slot)  getFreeRegsR :: RegM freeRegs freeRegs-getFreeRegsR = RegM $ \ s@RA_State{ra_freeregs = freeregs} ->+getFreeRegsR = mkRegM $ \ s@RA_State{ra_freeregs = freeregs} ->   RA_Result s freeregs  setFreeRegsR :: freeRegs -> RegM freeRegs ()-setFreeRegsR regs = RegM $ \ s ->+setFreeRegsR regs = mkRegM $ \ s ->   RA_Result s{ra_freeregs = regs} ()  getAssigR :: RegM freeRegs (RegMap Loc)-getAssigR = RegM $ \ s@RA_State{ra_assig = assig} ->+getAssigR = mkRegM $ \ s@RA_State{ra_assig = assig} ->   RA_Result s assig  setAssigR :: RegMap Loc -> RegM freeRegs ()-setAssigR assig = RegM $ \ s ->+setAssigR assig = mkRegM $ \ s ->   RA_Result s{ra_assig=assig} ()  getBlockAssigR :: RegM freeRegs (BlockAssignment freeRegs)-getBlockAssigR = RegM $ \ s@RA_State{ra_blockassig = assig} ->+getBlockAssigR = mkRegM $ \ s@RA_State{ra_blockassig = assig} ->   RA_Result s assig  setBlockAssigR :: BlockAssignment freeRegs -> RegM freeRegs ()-setBlockAssigR assig = RegM $ \ s ->+setBlockAssigR assig = mkRegM $ \ s ->   RA_Result s{ra_blockassig = assig} ()  setDeltaR :: Int -> RegM freeRegs ()-setDeltaR n = RegM $ \ s ->+setDeltaR n = mkRegM $ \ s ->   RA_Result s{ra_delta = n} ()  getDeltaR :: RegM freeRegs Int-getDeltaR = RegM $ \s -> RA_Result s (ra_delta s)+getDeltaR = mkRegM $ \s -> RA_Result s (ra_delta s)  getUniqueR :: RegM freeRegs Unique-getUniqueR = RegM $ \s ->+getUniqueR = mkRegM $ \s ->   case takeUniqFromSupply (ra_us s) of     (uniq, us) -> RA_Result s{ra_us = us} uniq @@ -170,9 +176,9 @@ -- | Record that a spill instruction was inserted, for profiling. recordSpill :: SpillReason -> RegM freeRegs () recordSpill spill-    = RegM $ \s -> RA_Result (s { ra_spills = spill : ra_spills s }) ()+    = mkRegM $ \s -> RA_Result (s { ra_spills = spill : ra_spills s }) ()  -- | Record a created fixup block recordFixupBlock :: BlockId -> BlockId -> BlockId -> RegM freeRegs () recordFixupBlock from between to-    = RegM $ \s -> RA_Result (s { ra_fixups = (from,between,to) : ra_fixups s }) ()+    = mkRegM $ \s -> RA_Result (s { ra_fixups = (from,between,to) : ra_fixups s }) ()
compiler/GHC/CmmToAsm/Reg/Linear/Stats.hs view
@@ -17,7 +17,7 @@ import GHC.Types.Unique.FM  import GHC.Utils.Outputable-import GHC.Utils.Monad.State+import GHC.Utils.Monad.State.Strict  -- | Build a map of how many times each reg was alloced, clobbered, loaded etc. binSpillReasons
compiler/GHC/CmmToAsm/Reg/Linear/X86.hs view
@@ -8,7 +8,6 @@ import GHC.CmmToAsm.X86.Regs import GHC.Platform.Reg.Class import GHC.Platform.Reg-import GHC.Utils.Panic import GHC.Platform import GHC.Utils.Outputable @@ -24,9 +23,6 @@ releaseReg (RealRegSingle n) (FreeRegs f)         = FreeRegs (f .|. (1 `shiftL` n)) -releaseReg _ _-        = panic "RegAlloc.Linear.X86.FreeRegs.releaseReg: no reg"- initFreeRegs :: Platform -> FreeRegs initFreeRegs platform         = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform)@@ -47,7 +43,4 @@ allocateReg :: RealReg -> FreeRegs -> FreeRegs allocateReg (RealRegSingle r) (FreeRegs f)         = FreeRegs (f .&. complement (1 `shiftL` r))--allocateReg _ _-        = panic "RegAlloc.Linear.X86.FreeRegs.allocateReg: no reg"
compiler/GHC/CmmToAsm/Reg/Linear/X86_64.hs view
@@ -8,7 +8,6 @@ import GHC.CmmToAsm.X86.Regs import GHC.Platform.Reg.Class import GHC.Platform.Reg-import GHC.Utils.Panic import GHC.Platform import GHC.Utils.Outputable @@ -24,9 +23,6 @@ releaseReg (RealRegSingle n) (FreeRegs f)         = FreeRegs (f .|. (1 `shiftL` n)) -releaseReg _ _-        = panic "RegAlloc.Linear.X86_64.FreeRegs.releaseReg: no reg"- initFreeRegs :: Platform -> FreeRegs initFreeRegs platform         = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform)@@ -47,8 +43,4 @@ allocateReg :: RealReg -> FreeRegs -> FreeRegs allocateReg (RealRegSingle r) (FreeRegs f)         = FreeRegs (f .&. complement (1 `shiftL` r))--allocateReg _ _-        = panic "RegAlloc.Linear.X86_64.FreeRegs.allocateReg: no reg"-
compiler/GHC/CmmToAsm/Reg/Liveness.hs view
@@ -65,7 +65,7 @@ import GHC.Types.Unique.FM import GHC.Types.Unique.Supply import GHC.Data.Bag-import GHC.Utils.Monad.State+import GHC.Utils.Monad.State.Strict  import Data.List (mapAccumL, groupBy, partition) import Data.Maybe
compiler/GHC/CmmToAsm/Reg/Target.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ -- | Hard wired things related to registers. --      This is module is preventing the native code generator being able to --      emit code for non-host architectures.@@ -19,8 +19,6 @@  where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Platform.Reg@@ -35,7 +33,6 @@ import qualified GHC.CmmToAsm.X86.Regs       as X86 import qualified GHC.CmmToAsm.X86.RegInfo    as X86 import qualified GHC.CmmToAsm.PPC.Regs       as PPC-import qualified GHC.CmmToAsm.SPARC.Regs     as SPARC import qualified GHC.CmmToAsm.AArch64.Regs   as AArch64  @@ -46,8 +43,6 @@       ArchX86_64    -> X86.virtualRegSqueeze       ArchPPC       -> PPC.virtualRegSqueeze       ArchS390X     -> panic "targetVirtualRegSqueeze ArchS390X"-      ArchSPARC     -> SPARC.virtualRegSqueeze-      ArchSPARC64   -> panic "targetVirtualRegSqueeze ArchSPARC64"       ArchPPC_64 _  -> PPC.virtualRegSqueeze       ArchARM _ _ _ -> panic "targetVirtualRegSqueeze ArchARM"       ArchAArch64   -> AArch64.virtualRegSqueeze@@ -66,8 +61,6 @@       ArchX86_64    -> X86.realRegSqueeze       ArchPPC       -> PPC.realRegSqueeze       ArchS390X     -> panic "targetRealRegSqueeze ArchS390X"-      ArchSPARC     -> SPARC.realRegSqueeze-      ArchSPARC64   -> panic "targetRealRegSqueeze ArchSPARC64"       ArchPPC_64 _  -> PPC.realRegSqueeze       ArchARM _ _ _ -> panic "targetRealRegSqueeze ArchARM"       ArchAArch64   -> AArch64.realRegSqueeze@@ -85,8 +78,6 @@       ArchX86_64    -> X86.classOfRealReg platform       ArchPPC       -> PPC.classOfRealReg       ArchS390X     -> panic "targetClassOfRealReg ArchS390X"-      ArchSPARC     -> SPARC.classOfRealReg-      ArchSPARC64   -> panic "targetClassOfRealReg ArchSPARC64"       ArchPPC_64 _  -> PPC.classOfRealReg       ArchARM _ _ _ -> panic "targetClassOfRealReg ArchARM"       ArchAArch64   -> AArch64.classOfRealReg@@ -104,8 +95,6 @@       ArchX86_64    -> X86.mkVirtualReg       ArchPPC       -> PPC.mkVirtualReg       ArchS390X     -> panic "targetMkVirtualReg ArchS390X"-      ArchSPARC     -> SPARC.mkVirtualReg-      ArchSPARC64   -> panic "targetMkVirtualReg ArchSPARC64"       ArchPPC_64 _  -> PPC.mkVirtualReg       ArchARM _ _ _ -> panic "targetMkVirtualReg ArchARM"       ArchAArch64   -> AArch64.mkVirtualReg@@ -123,8 +112,6 @@       ArchX86_64    -> X86.regDotColor platform       ArchPPC       -> PPC.regDotColor       ArchS390X     -> panic "targetRegDotColor ArchS390X"-      ArchSPARC     -> SPARC.regDotColor-      ArchSPARC64   -> panic "targetRegDotColor ArchSPARC64"       ArchPPC_64 _  -> PPC.regDotColor       ArchARM _ _ _ -> panic "targetRegDotColor ArchARM"       ArchAArch64   -> AArch64.regDotColor
compiler/GHC/CmmToAsm/Reg/Utils.hs view
@@ -4,7 +4,6 @@  {- Note [UniqFM and the register allocator]    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-    Before UniqFM had a key type the register allocator    wasn't picky about key types, using VirtualReg, Reg    and Unique at various use sites for the same map.
− compiler/GHC/CmmToAsm/SPARC.hs 
@@ -1,74 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}---- | Native code generator for SPARC architectures-module GHC.CmmToAsm.SPARC-   ( ncgSPARC-   )-where--import GHC.Prelude-import GHC.Utils.Panic--import GHC.CmmToAsm.Monad-import GHC.CmmToAsm.Config-import GHC.CmmToAsm.Types-import GHC.CmmToAsm.Instr--import qualified GHC.CmmToAsm.SPARC.Instr          as SPARC-import qualified GHC.CmmToAsm.SPARC.Ppr            as SPARC-import qualified GHC.CmmToAsm.SPARC.CodeGen        as SPARC-import qualified GHC.CmmToAsm.SPARC.CodeGen.Expand as SPARC-import qualified GHC.CmmToAsm.SPARC.Regs           as SPARC-import qualified GHC.CmmToAsm.SPARC.ShortcutJump   as SPARC---ncgSPARC :: NCGConfig -> NcgImpl RawCmmStatics SPARC.Instr SPARC.JumpDest-ncgSPARC config = NcgImpl-   { ncgConfig                 = config-   , cmmTopCodeGen             = SPARC.cmmTopCodeGen-   , generateJumpTableForInstr = SPARC.generateJumpTableForInstr platform-   , getJumpDestBlockId        = SPARC.getJumpDestBlockId-   , canShortcut               = SPARC.canShortcut-   , shortcutStatics           = SPARC.shortcutStatics-   , shortcutJump              = SPARC.shortcutJump-   , pprNatCmmDecl             = SPARC.pprNatCmmDecl config-   , maxSpillSlots             = SPARC.maxSpillSlots config-   , allocatableRegs           = SPARC.allocatableRegs-   , ncgExpandTop              = map SPARC.expandTop-   , ncgMakeFarBranches        = const id-   , extractUnwindPoints       = const []-   , invertCondBranches        = \_ _ -> id-   -- Allocating more stack space for spilling isn't currently supported for the-   -- linear register allocator on SPARC, hence the panic below.-   , ncgAllocMoreStack         = noAllocMoreStack-   }-    where-      platform = ncgPlatform config--      noAllocMoreStack amount _-        = panic $   "Register allocator: out of stack slots (need " ++ show amount ++ ")\n"-              ++  "   If you are trying to compile SHA1.hs from the crypto library then this\n"-              ++  "   is a known limitation in the linear allocator.\n"-              ++  "\n"-              ++  "   Try enabling the graph colouring allocator with -fregs-graph instead."-              ++  "   You can still file a bug report if you like.\n"----- | instance for sparc instruction set-instance Instruction SPARC.Instr where-   regUsageOfInstr         = SPARC.regUsageOfInstr-   patchRegsOfInstr        = SPARC.patchRegsOfInstr-   isJumpishInstr          = SPARC.isJumpishInstr-   jumpDestsOfInstr        = SPARC.jumpDestsOfInstr-   patchJumpInstr          = SPARC.patchJumpInstr-   mkSpillInstr            = SPARC.mkSpillInstr-   mkLoadInstr             = SPARC.mkLoadInstr-   takeDeltaInstr          = SPARC.takeDeltaInstr-   isMetaInstr             = SPARC.isMetaInstr-   mkRegRegMoveInstr       = SPARC.mkRegRegMoveInstr-   takeRegRegMoveInstr     = SPARC.takeRegRegMoveInstr-   mkJumpInstr             = SPARC.mkJumpInstr-   pprInstr                = SPARC.pprInstr-   mkComment               = const []-   mkStackAllocInstr       = panic "no sparc_mkStackAllocInstr"-   mkStackDeallocInstr     = panic "no sparc_mkStackDeallocInstr"
− compiler/GHC/CmmToAsm/SPARC/AddrMode.hs 
@@ -1,44 +0,0 @@--module GHC.CmmToAsm.SPARC.AddrMode (-        AddrMode(..),-        addrOffset-)--where--import GHC.Prelude--import GHC.CmmToAsm.SPARC.Imm-import GHC.CmmToAsm.SPARC.Base-import GHC.Platform.Reg---- addressing modes ---------------------------------------------------------------- | Represents a memory address in an instruction.---      Being a RISC machine, the SPARC addressing modes are very regular.----data AddrMode-        = AddrRegReg    Reg Reg         -- addr = r1 + r2-        | AddrRegImm    Reg Imm         -- addr = r1 + imm----- | Add an integer offset to the address in an AddrMode.----addrOffset :: AddrMode -> Int -> Maybe AddrMode-addrOffset addr off-  = case addr of-      AddrRegImm r (ImmInt n)-       | fits13Bits n2 -> Just (AddrRegImm r (ImmInt n2))-       | otherwise     -> Nothing-       where n2 = n + off--      AddrRegImm r (ImmInteger n)-       | fits13Bits n2 -> Just (AddrRegImm r (ImmInt (fromInteger n2)))-       | otherwise     -> Nothing-       where n2 = n + toInteger off--      AddrRegReg r (RegReal (RealRegSingle 0))-       | fits13Bits off -> Just (AddrRegImm r (ImmInt off))-       | otherwise     -> Nothing--      _ -> Nothing
− compiler/GHC/CmmToAsm/SPARC/Base.hs 
@@ -1,70 +0,0 @@---- | Bits and pieces on the bottom of the module dependency tree.---      Also import the required constants, so we know what we're using.------      In the interests of cross-compilation, we want to free ourselves---      from the autoconf generated modules like "GHC.Settings.Constants"--module GHC.CmmToAsm.SPARC.Base (-        wordLength,-        wordLengthInBits,-        spillSlotSize,-        extraStackArgsHere,-        fits13Bits,-        is32BitInteger,-        largeOffsetError-)--where--import GHC.Prelude--import GHC.Utils.Panic--import Data.Int----- On 32 bit SPARC, pointers are 32 bits.-wordLength :: Int-wordLength = 4--wordLengthInBits :: Int-wordLengthInBits-        = wordLength * 8---- | We need 8 bytes because our largest registers are 64 bit.-spillSlotSize :: Int-spillSlotSize = 8----- | We (allegedly) put the first six C-call arguments in registers;---      where do we start putting the rest of them?-extraStackArgsHere :: Int-extraStackArgsHere = 23---{-# SPECIALIZE fits13Bits :: Int -> Bool, Integer -> Bool #-}--- | Check whether an offset is representable with 13 bits.-fits13Bits :: Integral a => a -> Bool-fits13Bits x = x >= -4096 && x < 4096---- | Check whether an integer will fit in 32 bits.---      A CmmInt is intended to be truncated to the appropriate---      number of bits, so here we truncate it to Int64.  This is---      important because e.g. -1 as a CmmInt might be either---      -1 or 18446744073709551615.----is32BitInteger :: Integer -> Bool-is32BitInteger i-        = i64 <= 0x7fffffff && i64 >= -0x80000000-        where i64 = fromIntegral i :: Int64----- | Sadness.-largeOffsetError :: (Show a) => a -> b-largeOffsetError i-  = panic ("ERROR: SPARC native-code generator cannot handle large offset ("-                ++ show i ++ ");\nprobably because of large constant data structures;" ++-                "\nworkaround: use -fllvm on this module.\n")--
− compiler/GHC/CmmToAsm/SPARC/CodeGen.hs 
@@ -1,729 +0,0 @@-{-# LANGUAGE CPP #-}------------------------------------------------------------------------------------- Generating machine code (instruction selection)------ (c) The University of Glasgow 1996-2013-----------------------------------------------------------------------------------{-# LANGUAGE GADTs #-}-module GHC.CmmToAsm.SPARC.CodeGen (-        cmmTopCodeGen,-        generateJumpTableForInstr,-        InstrBlock-)--where--#include "GhclibHsVersions.h"---- NCG stuff:-import GHC.Prelude--import GHC.CmmToAsm.SPARC.Base-import GHC.CmmToAsm.SPARC.CodeGen.Sanity-import GHC.CmmToAsm.SPARC.CodeGen.Amode-import GHC.CmmToAsm.SPARC.CodeGen.CondCode-import GHC.CmmToAsm.SPARC.CodeGen.Gen64-import GHC.CmmToAsm.SPARC.CodeGen.Gen32-import GHC.CmmToAsm.SPARC.CodeGen.Base-import GHC.CmmToAsm.SPARC.Instr-import GHC.CmmToAsm.SPARC.Imm-import GHC.CmmToAsm.SPARC.AddrMode-import GHC.CmmToAsm.SPARC.Regs-import GHC.CmmToAsm.SPARC.Stack-import GHC.CmmToAsm.Types-import GHC.CmmToAsm.Format-import GHC.CmmToAsm.Monad   ( NatM, getNewRegNat, getNewLabelNat, getPlatform, getConfig )-import GHC.CmmToAsm.Config---- Our intermediate code:-import GHC.Cmm.BlockId-import GHC.Cmm-import GHC.Cmm.Utils-import GHC.Cmm.Switch-import GHC.Cmm.Dataflow.Block-import GHC.Cmm.Dataflow.Graph-import GHC.CmmToAsm.PIC-import GHC.Platform.Reg-import GHC.Cmm.CLabel-import GHC.CmmToAsm.CPrim---- The rest:-import GHC.Types.Basic-import GHC.Data.FastString-import GHC.Data.OrdList-import GHC.Utils.Panic-import GHC.Platform--import Control.Monad    ( mapAndUnzipM )---- | Top level code generation-cmmTopCodeGen :: RawCmmDecl-              -> NatM [NatCmmDecl RawCmmStatics Instr]--cmmTopCodeGen (CmmProc info lab live graph)- = do let blocks = toBlockListEntryFirst graph-      (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks--      let proc = CmmProc info lab live (ListGraph $ concat nat_blocks)-      let tops = proc : concat statics--      return tops--cmmTopCodeGen (CmmData sec dat) =-  return [CmmData sec dat]  -- no translation, we just use CmmStatic----- | Do code generation on a single block of CMM code.---      code generation may introduce new basic block boundaries, which---      are indicated by the NEWBLOCK instruction.  We must split up the---      instruction stream into basic blocks again.  Also, we extract---      LDATAs here too.-basicBlockCodeGen :: CmmBlock-                  -> NatM ( [NatBasicBlock Instr]-                          , [NatCmmDecl RawCmmStatics Instr])--basicBlockCodeGen block = do-  let (_, nodes, tail)  = blockSplit block-      id = entryLabel block-      stmts = blockToList nodes-  platform <- getPlatform-  mid_instrs <- stmtsToInstrs stmts-  tail_instrs <- stmtToInstrs tail-  let instrs = mid_instrs `appOL` tail_instrs-  let-        (top,other_blocks,statics)-                = foldrOL mkBlocks ([],[],[]) instrs--        mkBlocks (NEWBLOCK id) (instrs,blocks,statics)-          = ([], BasicBlock id instrs : blocks, statics)--        mkBlocks (LDATA sec dat) (instrs,blocks,statics)-          = (instrs, blocks, CmmData sec dat:statics)--        mkBlocks instr (instrs,blocks,statics)-          = (instr:instrs, blocks, statics)--        -- do intra-block sanity checking-        blocksChecked-                = map (checkBlock platform block)-                $ BasicBlock id top : other_blocks--  return (blocksChecked, statics)----- | Convert some Cmm statements to SPARC instructions.-stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock-stmtsToInstrs stmts-   = do instrss <- mapM stmtToInstrs stmts-        return (concatOL instrss)---stmtToInstrs :: CmmNode e x -> NatM InstrBlock-stmtToInstrs stmt = do-  platform <- getPlatform-  config <- getConfig-  case stmt of-    CmmComment s   -> return (unitOL (COMMENT s))-    CmmTick {}     -> return nilOL-    CmmUnwind {}   -> return nilOL--    CmmAssign reg src-      | isFloatType ty  -> assignReg_FltCode format reg src-      | isWord64 ty     -> assignReg_I64Code        reg src-      | otherwise       -> assignReg_IntCode format reg src-        where ty = cmmRegType platform reg-              format = cmmTypeFormat ty--    CmmStore addr src _-      | isFloatType ty  -> assignMem_FltCode format addr src-      | isWord64 ty     -> assignMem_I64Code      addr src-      | otherwise       -> assignMem_IntCode format addr src-        where ty = cmmExprType platform src-              format = cmmTypeFormat ty--    CmmUnsafeForeignCall target result_regs args-       -> genCCall target result_regs args--    CmmBranch   id              -> genBranch id-    CmmCondBranch arg true false _ -> do-      b1 <- genCondJump true arg-      b2 <- genBranch false-      return (b1 `appOL` b2)-    CmmSwitch arg ids   -> genSwitch config arg ids-    CmmCall { cml_target = arg } -> genJump arg--    _-     -> panic "stmtToInstrs: statement should have been cps'd away"---{--Now, given a tree (the argument to a CmmLoad) that references memory,-produce a suitable addressing mode.--A Rule of the Game (tm) for Amodes: use of the addr bit must-immediately follow use of the code part, since the code part puts-values in registers which the addr then refers to.  So you can't put-anything in between, lest it overwrite some of those registers.  If-you need to do some other computation between the code part and use of-the addr bit, first store the effective address from the amode in a-temporary, then do the other computation, and then use the temporary:--    code-    LEA amode, tmp-    ... other computation ...-    ... (tmp) ...--}------ | Convert a BlockId to some CmmStatic data-jumpTableEntry :: Platform -> Maybe BlockId -> CmmStatic-jumpTableEntry platform Nothing = CmmStaticLit (CmmInt 0 (wordWidth platform))-jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel)-    where blockLabel = blockLbl blockid------ -------------------------------------------------------------------------------- Generating assignments---- Assignments are really at the heart of the whole code generation--- business.  Almost all top-level nodes of any real importance are--- assignments, which correspond to loads, stores, or register--- transfers.  If we're really lucky, some of the register transfers--- will go away, because we can use the destination register to--- complete the code generation for the right hand side.  This only--- fails when the right hand side is forced into a fixed register--- (e.g. the result of a call).--assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock-assignMem_IntCode pk addr src = do-    (srcReg, code) <- getSomeReg src-    Amode dstAddr addr_code <- getAmode addr-    return $ code `appOL` addr_code `snocOL` ST pk srcReg dstAddr---assignReg_IntCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock-assignReg_IntCode _ reg src = do-    platform <- getPlatform-    r <- getRegister src-    let dst = getRegisterReg platform reg-    return $ case r of-        Any _ code         -> code dst-        Fixed _ freg fcode -> fcode `snocOL` OR False g0 (RIReg freg) dst------ Floating point assignment to memory-assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock-assignMem_FltCode pk addr src = do-    platform <- getPlatform-    Amode dst__2 code1 <- getAmode addr-    (src__2, code2) <- getSomeReg src-    tmp1 <- getNewRegNat pk-    let-        pk__2   = cmmExprType platform src-        code__2 = code1 `appOL` code2 `appOL`-            if   formatToWidth pk == typeWidth pk__2-            then unitOL (ST pk src__2 dst__2)-            else toOL   [ FxTOy (cmmTypeFormat pk__2) pk src__2 tmp1-                        , ST    pk tmp1 dst__2]-    return code__2---- Floating point assignment to a register/temporary-assignReg_FltCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock-assignReg_FltCode pk dstCmmReg srcCmmExpr = do-    platform <- getPlatform-    srcRegister <- getRegister srcCmmExpr-    let dstReg  = getRegisterReg platform dstCmmReg--    return $ case srcRegister of-        Any _ code                  -> code dstReg-        Fixed _ srcFixedReg srcCode -> srcCode `snocOL` FMOV pk srcFixedReg dstReg-----genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock--genJump (CmmLit (CmmLabel lbl))-  = return (toOL [CALL (Left target) 0 True, NOP])-  where-    target = ImmCLbl lbl--genJump tree-  = do-        (target, code) <- getSomeReg tree-        return (code `snocOL` JMP (AddrRegReg target g0)  `snocOL` NOP)---- --------------------------------------------------------------------------------  Unconditional branches--genBranch :: BlockId -> NatM InstrBlock-genBranch = return . toOL . mkJumpInstr----- --------------------------------------------------------------------------------  Conditional jumps--{--Conditional jumps are always to local labels, so we can use branch-instructions.  We peek at the arguments to decide what kind of-comparison to do.--SPARC: First, we have to ensure that the condition codes are set-according to the supplied comparison operation.  We generate slightly-different code for floating point comparisons, because a floating-point operation cannot directly precede a @BF@.  We assume the worst-and fill that slot with a @NOP@.--SPARC: Do not fill the delay slots here; you will confuse the register-allocator.--}---genCondJump-    :: BlockId      -- the branch target-    -> CmmExpr      -- the condition on which to branch-    -> NatM InstrBlock----genCondJump bid bool = do-  CondCode is_float cond code <- getCondCode bool-  return (-       code `appOL`-       toOL (-         if   is_float-         then [NOP, BF cond False bid, NOP]-         else [BI cond False bid, NOP]-       )-    )------ -------------------------------------------------------------------------------- Generating a table-branch--genSwitch :: NCGConfig -> CmmExpr -> SwitchTargets -> NatM InstrBlock-genSwitch config expr targets-        | ncgPIC config-        = error "MachCodeGen: sparc genSwitch PIC not finished\n"--        | otherwise-        = do    (e_reg, e_code) <- getSomeReg (cmmOffset (ncgPlatform config) expr offset)--                base_reg        <- getNewRegNat II32-                offset_reg      <- getNewRegNat II32-                dst             <- getNewRegNat II32--                label           <- getNewLabelNat--                return $ e_code `appOL`-                 toOL-                        [ -- load base of jump table-                          SETHI (HI (ImmCLbl label)) base_reg-                        , OR    False base_reg (RIImm $ LO $ ImmCLbl label) base_reg--                        -- the addrs in the table are 32 bits wide..-                        , SLL   e_reg (RIImm $ ImmInt 2) offset_reg--                        -- load and jump to the destination-                        , LD      II32 (AddrRegReg base_reg offset_reg) dst-                        , JMP_TBL (AddrRegImm dst (ImmInt 0)) ids label-                        , NOP ]-  where (offset, ids) = switchTargetsToTable targets--generateJumpTableForInstr :: Platform -> Instr-                          -> Maybe (NatCmmDecl RawCmmStatics Instr)-generateJumpTableForInstr platform (JMP_TBL _ ids label) =-  let jumpTable = map (jumpTableEntry platform) ids-  in Just (CmmData (Section ReadOnlyData label) (CmmStaticsRaw label jumpTable))-generateJumpTableForInstr _ _ = Nothing------ -------------------------------------------------------------------------------- Generating C calls--{--   Now the biggest nightmare---calls.  Most of the nastiness is buried in-   @get_arg@, which moves the arguments to the correct registers/stack-   locations.  Apart from that, the code is easy.--   The SPARC calling convention is an absolute-   nightmare.  The first 6x32 bits of arguments are mapped into-   %o0 through %o5, and the remaining arguments are dumped to the-   stack, beginning at [%sp+92].  (Note that %o6 == %sp.)--   If we have to put args on the stack, move %o6==%sp down by-   the number of words to go on the stack, to ensure there's enough space.--   According to Fraser and Hanson's lcc book, page 478, fig 17.2,-   16 words above the stack pointer is a word for the address of-   a structure return value.  I use this as a temporary location-   for moving values from float to int regs.  Certainly it isn't-   safe to put anything in the 16 words starting at %sp, since-   this area can get trashed at any time due to window overflows-   caused by signal handlers.--   A final complication (if the above isn't enough) is that-   we can't blithely calculate the arguments one by one into-   %o0 .. %o5.  Consider the following nested calls:--       fff a (fff b c)--   Naive code moves a into %o0, and (fff b c) into %o1.  Unfortunately-   the inner call will itself use %o0, which trashes the value put there-   in preparation for the outer call.  Upshot: we need to calculate the-   args into temporary regs, and move those to arg regs or onto the-   stack only immediately prior to the call proper.  Sigh.--}--genCCall-    :: ForeignTarget            -- function to call-    -> [CmmFormal]        -- where to put the result-    -> [CmmActual]        -- arguments (of mixed type)-    -> NatM InstrBlock------ On SPARC under TSO (Total Store Ordering), writes earlier in the instruction stream--- are guaranteed to take place before writes afterwards (unlike on PowerPC).--- Ref: Section 8.4 of the SPARC V9 Architecture manual.------ In the SPARC case we don't need a barrier.----genCCall (PrimTarget MO_ReadBarrier) _ _- = return $ nilOL-genCCall (PrimTarget MO_WriteBarrier) _ _- = return $ nilOL--genCCall (PrimTarget (MO_Prefetch_Data _)) _ _- = return $ nilOL--genCCall target dest_regs args- = do   -- work out the arguments, and assign them to integer regs-        argcode_and_vregs       <- mapM arg_to_int_vregs args-        let (argcodes, vregss)  = unzip argcode_and_vregs-        let vregs               = concat vregss--        let n_argRegs           = length allArgRegs-        let n_argRegs_used      = min (length vregs) n_argRegs---        -- deal with static vs dynamic call targets-        callinsns <- case target of-                ForeignTarget (CmmLit (CmmLabel lbl)) _ ->-                        return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False))--                ForeignTarget expr _-                 -> do  (dyn_c, dyn_rs) <- arg_to_int_vregs expr-                        let dyn_r = case dyn_rs of-                                      [dyn_r'] -> dyn_r'-                                      _ -> panic "SPARC.CodeGen.genCCall: arg_to_int"-                        return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)--                PrimTarget mop-                 -> do  res     <- outOfLineMachOp mop-                        case res of-                                Left lbl ->-                                        return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False))--                                Right mopExpr -> do-                                        (dyn_c, dyn_rs) <- arg_to_int_vregs mopExpr-                                        let dyn_r = case dyn_rs of-                                                      [dyn_r'] -> dyn_r'-                                                      _ -> panic "SPARC.CodeGen.genCCall: arg_to_int"-                                        return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)--        let argcode = concatOL argcodes--        let (move_sp_down, move_sp_up)-                   = let diff = length vregs - n_argRegs-                         nn   = if odd diff then diff + 1 else diff -- keep 8-byte alignment-                     in  if   nn <= 0-                         then (nilOL, nilOL)-                         else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))--        let transfer_code-                = toOL (move_final vregs allArgRegs extraStackArgsHere)--        platform <- getPlatform-        return-         $      argcode                 `appOL`-                move_sp_down            `appOL`-                transfer_code           `appOL`-                callinsns               `appOL`-                unitOL NOP              `appOL`-                move_sp_up              `appOL`-                assign_code platform dest_regs----- | Generate code to calculate an argument, and move it into one---      or two integer vregs.-arg_to_int_vregs :: CmmExpr -> NatM (OrdList Instr, [Reg])-arg_to_int_vregs arg = do platform <- getPlatform-                          arg_to_int_vregs' platform arg--arg_to_int_vregs' :: Platform -> CmmExpr -> NatM (OrdList Instr, [Reg])-arg_to_int_vregs' platform arg--        -- If the expr produces a 64 bit int, then we can just use iselExpr64-        | isWord64 (cmmExprType platform arg)-        = do    (ChildCode64 code r_lo) <- iselExpr64 arg-                let r_hi                = getHiVRegFromLo r_lo-                return (code, [r_hi, r_lo])--        | otherwise-        = do    (src, code)     <- getSomeReg arg-                let pk          = cmmExprType platform arg--                case cmmTypeFormat pk of--                 -- Load a 64 bit float return value into two integer regs.-                 FF64 -> do-                        v1 <- getNewRegNat II32-                        v2 <- getNewRegNat II32--                        let code2 =-                                code                            `snocOL`-                                FMOV FF64 src f0                `snocOL`-                                ST   FF32  f0 (spRel 16)        `snocOL`-                                LD   II32  (spRel 16) v1        `snocOL`-                                ST   FF32  f1 (spRel 16)        `snocOL`-                                LD   II32  (spRel 16) v2--                        return  (code2, [v1,v2])--                 -- Load a 32 bit float return value into an integer reg-                 FF32 -> do-                        v1 <- getNewRegNat II32--                        let code2 =-                                code                            `snocOL`-                                ST   FF32  src (spRel 16)       `snocOL`-                                LD   II32  (spRel 16) v1--                        return (code2, [v1])--                 -- Move an integer return value into its destination reg.-                 _ -> do-                        v1 <- getNewRegNat II32--                        let code2 =-                                code                            `snocOL`-                                OR False g0 (RIReg src) v1--                        return (code2, [v1])----- | Move args from the integer vregs into which they have been---      marshalled, into %o0 .. %o5, and the rest onto the stack.----move_final :: [Reg] -> [Reg] -> Int -> [Instr]---- all args done-move_final [] _ _-        = []---- out of aregs; move to stack-move_final (v:vs) [] offset-        = ST II32 v (spRel offset)-        : move_final vs [] (offset+1)---- move into an arg (%o[0..5]) reg-move_final (v:vs) (a:az) offset-        = OR False g0 (RIReg v) a-        : move_final vs az offset----- | Assign results returned from the call into their---      destination regs.----assign_code :: Platform -> [LocalReg] -> OrdList Instr--assign_code _ [] = nilOL--assign_code platform [dest]- = let  rep     = localRegType dest-        width   = typeWidth rep-        r_dest  = getRegisterReg platform (CmmLocal dest)--        result-                | isFloatType rep-                , W32   <- width-                = unitOL $ FMOV FF32 (regSingle $ fReg 0) r_dest--                | isFloatType rep-                , W64   <- width-                = unitOL $ FMOV FF64 (regSingle $ fReg 0) r_dest--                | not $ isFloatType rep-                , W32   <- width-                = unitOL $ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest--                | not $ isFloatType rep-                , W64           <- width-                , r_dest_hi     <- getHiVRegFromLo r_dest-                = toOL  [ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest_hi-                        , mkRegRegMoveInstr platform (regSingle $ oReg 1) r_dest]--                | otherwise-                = panic "SPARC.CodeGen.GenCCall: no match"--   in   result--assign_code _ _-        = panic "SPARC.CodeGen.GenCCall: no match"------ | Generate a call to implement an out-of-line floating point operation-outOfLineMachOp-        :: CallishMachOp-        -> NatM (Either CLabel CmmExpr)--outOfLineMachOp mop- = do   let functionName-                = outOfLineMachOp_table mop--        config  <- getConfig-        mopExpr <- cmmMakeDynamicReference config CallReference-                $  mkForeignLabel functionName Nothing ForeignLabelInExternalPackage IsFunction--        let mopLabelOrExpr-                = case mopExpr of-                        CmmLit (CmmLabel lbl)   -> Left lbl-                        _                       -> Right mopExpr--        return mopLabelOrExpr----- | Decide what C function to use to implement a CallishMachOp----outOfLineMachOp_table-        :: CallishMachOp-        -> FastString--outOfLineMachOp_table mop- = case mop of-        MO_F32_Exp    -> fsLit "expf"-        MO_F32_ExpM1  -> fsLit "expm1f"-        MO_F32_Log    -> fsLit "logf"-        MO_F32_Log1P  -> fsLit "log1pf"-        MO_F32_Sqrt   -> fsLit "sqrtf"-        MO_F32_Fabs   -> unsupported-        MO_F32_Pwr    -> fsLit "powf"--        MO_F32_Sin    -> fsLit "sinf"-        MO_F32_Cos    -> fsLit "cosf"-        MO_F32_Tan    -> fsLit "tanf"--        MO_F32_Asin   -> fsLit "asinf"-        MO_F32_Acos   -> fsLit "acosf"-        MO_F32_Atan   -> fsLit "atanf"--        MO_F32_Sinh   -> fsLit "sinhf"-        MO_F32_Cosh   -> fsLit "coshf"-        MO_F32_Tanh   -> fsLit "tanhf"--        MO_F32_Asinh  -> fsLit "asinhf"-        MO_F32_Acosh  -> fsLit "acoshf"-        MO_F32_Atanh  -> fsLit "atanhf"--        MO_F64_Exp    -> fsLit "exp"-        MO_F64_ExpM1  -> fsLit "expm1"-        MO_F64_Log    -> fsLit "log"-        MO_F64_Log1P  -> fsLit "log1p"-        MO_F64_Sqrt   -> fsLit "sqrt"-        MO_F64_Fabs   -> unsupported-        MO_F64_Pwr    -> fsLit "pow"--        MO_F64_Sin    -> fsLit "sin"-        MO_F64_Cos    -> fsLit "cos"-        MO_F64_Tan    -> fsLit "tan"--        MO_F64_Asin   -> fsLit "asin"-        MO_F64_Acos   -> fsLit "acos"-        MO_F64_Atan   -> fsLit "atan"--        MO_F64_Sinh   -> fsLit "sinh"-        MO_F64_Cosh   -> fsLit "cosh"-        MO_F64_Tanh   -> fsLit "tanh"--        MO_F64_Asinh  -> fsLit "asinh"-        MO_F64_Acosh  -> fsLit "acosh"-        MO_F64_Atanh  -> fsLit "atanh"--        MO_I64_ToI   -> fsLit "hs_int64ToInt"-        MO_I64_FromI -> fsLit "hs_intToInt64"-        MO_W64_ToW   -> fsLit "hs_word64ToWord"-        MO_W64_FromW -> fsLit "hs_wordToWord64"-        MO_x64_Neg   -> fsLit "hs_neg64"-        MO_x64_Add   -> fsLit "hs_add64"-        MO_x64_Sub   -> fsLit "hs_sub64"-        MO_x64_Mul   -> fsLit "hs_mul64"-        MO_I64_Quot  -> fsLit "hs_quotInt64"-        MO_I64_Rem   -> fsLit "hs_remInt64"-        MO_W64_Quot  -> fsLit "hs_quotWord64"-        MO_W64_Rem   -> fsLit "hs_remWord64"-        MO_x64_And   -> fsLit "hs_and64"-        MO_x64_Or    -> fsLit "hs_or64"-        MO_x64_Xor   -> fsLit "hs_xor64"-        MO_x64_Not   -> fsLit "hs_not64"-        MO_x64_Shl   -> fsLit "hs_uncheckedShiftL64"-        MO_I64_Shr   -> fsLit "hs_uncheckedIShiftRA64"-        MO_W64_Shr   -> fsLit "hs_uncheckedShiftRL64"-        MO_x64_Eq    -> fsLit "hs_eq64"-        MO_x64_Ne    -> fsLit "hs_ne64"-        MO_I64_Ge    -> fsLit "hs_geInt64"-        MO_I64_Gt    -> fsLit "hs_gtInt64"-        MO_I64_Le    -> fsLit "hs_leInt64"-        MO_I64_Lt    -> fsLit "hs_ltInt64"-        MO_W64_Ge    -> fsLit "hs_geWord64"-        MO_W64_Gt    -> fsLit "hs_gtWord64"-        MO_W64_Le    -> fsLit "hs_leWord64"-        MO_W64_Lt    -> fsLit "hs_ltWord64"--        MO_UF_Conv w -> fsLit $ word2FloatLabel w--        MO_Memcpy _  -> fsLit "memcpy"-        MO_Memset _  -> fsLit "memset"-        MO_Memmove _ -> fsLit "memmove"-        MO_Memcmp _  -> fsLit "memcmp"--        MO_BSwap w   -> fsLit $ bSwapLabel w-        MO_BRev w    -> fsLit $ bRevLabel w-        MO_PopCnt w  -> fsLit $ popCntLabel w-        MO_Pdep w    -> fsLit $ pdepLabel w-        MO_Pext w    -> fsLit $ pextLabel w-        MO_Clz w     -> fsLit $ clzLabel w-        MO_Ctz w     -> fsLit $ ctzLabel w-        MO_AtomicRMW w amop -> fsLit $ atomicRMWLabel w amop-        MO_Cmpxchg w -> fsLit $ cmpxchgLabel w-        MO_Xchg w -> fsLit $ xchgLabel w-        MO_AtomicRead w -> fsLit $ atomicReadLabel w-        MO_AtomicWrite w -> fsLit $ atomicWriteLabel w--        MO_S_Mul2    {}  -> unsupported-        MO_S_QuotRem {}  -> unsupported-        MO_U_QuotRem {}  -> unsupported-        MO_U_QuotRem2 {} -> unsupported-        MO_Add2 {}       -> unsupported-        MO_AddWordC {}   -> unsupported-        MO_SubWordC {}   -> unsupported-        MO_AddIntC {}    -> unsupported-        MO_SubIntC {}    -> unsupported-        MO_U_Mul2 {}     -> unsupported-        MO_ReadBarrier   -> unsupported-        MO_WriteBarrier  -> unsupported-        MO_Touch         -> unsupported-        (MO_Prefetch_Data _) -> unsupported-    where unsupported = panic ("outOfLineCmmOp: " ++ show mop-                            ++ " not supported here")-
− compiler/GHC/CmmToAsm/SPARC/CodeGen/Amode.hs 
@@ -1,74 +0,0 @@-module GHC.CmmToAsm.SPARC.CodeGen.Amode (-        getAmode-)--where--import GHC.Prelude--import {-# SOURCE #-} GHC.CmmToAsm.SPARC.CodeGen.Gen32-import GHC.CmmToAsm.SPARC.CodeGen.Base-import GHC.CmmToAsm.SPARC.AddrMode-import GHC.CmmToAsm.SPARC.Imm-import GHC.CmmToAsm.SPARC.Instr-import GHC.CmmToAsm.SPARC.Regs-import GHC.CmmToAsm.SPARC.Base-import GHC.CmmToAsm.Monad-import GHC.CmmToAsm.Format--import GHC.Cmm--import GHC.Data.OrdList----- | Generate code to reference a memory address.-getAmode-        :: CmmExpr      -- ^ expr producing an address-        -> NatM Amode--getAmode tree@(CmmRegOff _ _)-    = do platform <- getPlatform-         getAmode (mangleIndexTree platform tree)--getAmode (CmmMachOp (MO_Sub _) [x, CmmLit (CmmInt i _)])-  | fits13Bits (-i)-  = do-       (reg, code) <- getSomeReg x-       let-         off  = ImmInt (-(fromInteger i))-       return (Amode (AddrRegImm reg off) code)---getAmode (CmmMachOp (MO_Add _) [x, CmmLit (CmmInt i _)])-  | fits13Bits i-  = do-       (reg, code) <- getSomeReg x-       let-         off  = ImmInt (fromInteger i)-       return (Amode (AddrRegImm reg off) code)--getAmode (CmmMachOp (MO_Add _) [x, y])-  = do-    (regX, codeX) <- getSomeReg x-    (regY, codeY) <- getSomeReg y-    let-        code = codeX `appOL` codeY-    return (Amode (AddrRegReg regX regY) code)--getAmode (CmmLit lit)-  = do-        let imm__2      = litToImm lit-        tmp1    <- getNewRegNat II32-        tmp2    <- getNewRegNat II32--        let code = toOL [ SETHI (HI imm__2) tmp1-                        , OR    False tmp1 (RIImm (LO imm__2)) tmp2]--        return (Amode (AddrRegReg tmp2 g0) code)--getAmode other-  = do-       (reg, code) <- getSomeReg other-       let-            off  = ImmInt 0-       return (Amode (AddrRegImm reg off) code)
− compiler/GHC/CmmToAsm/SPARC/CodeGen/Base.hs 
@@ -1,119 +0,0 @@-module GHC.CmmToAsm.SPARC.CodeGen.Base (-        InstrBlock,-        CondCode(..),-        ChildCode64(..),-        Amode(..),--        Register(..),-        setFormatOfRegister,--        getRegisterReg,-        mangleIndexTree-)--where--import GHC.Prelude--import GHC.CmmToAsm.SPARC.Instr-import GHC.CmmToAsm.SPARC.Cond-import GHC.CmmToAsm.SPARC.AddrMode-import GHC.CmmToAsm.SPARC.Regs-import GHC.CmmToAsm.Format-import GHC.Platform.Reg--import GHC.Platform.Regs-import GHC.Cmm-import GHC.Cmm.Ppr.Expr () -- For Outputable instances-import GHC.Platform--import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Data.OrdList------------------------------------------------------------------------------------- | 'InstrBlock's are the insn sequences generated by the insn selectors.---      They are really trees of insns to facilitate fast appending, where a---      left-to-right traversal yields the insns in the correct order.----type InstrBlock-        = OrdList Instr----- | Condition codes passed up the tree.----data CondCode-        = CondCode Bool Cond InstrBlock----- | a.k.a \"Register64\"---      Reg is the lower 32-bit temporary which contains the result.---      Use getHiVRegFromLo to find the other VRegUnique.------      Rules of this simplified insn selection game are therefore that---      the returned Reg may be modified----data ChildCode64-   = ChildCode64-        InstrBlock-        Reg----- | Holds code that references a memory address.-data Amode-        = Amode-                -- the AddrMode we can use in the instruction-                --      that does the real load\/store.-                AddrMode--                -- other setup code we have to run first before we can use the-                --      above AddrMode.-                InstrBlock--------------------------------------------------------------------------------------- | Code to produce a result into a register.---      If the result must go in a specific register, it comes out as Fixed.---      Otherwise, the parent can decide which register to put it in.----data Register-        = Fixed Format Reg InstrBlock-        | Any   Format (Reg -> InstrBlock)----- | Change the format field in a Register.-setFormatOfRegister-        :: Register -> Format -> Register--setFormatOfRegister reg format- = case reg of-        Fixed _ reg code        -> Fixed format reg code-        Any _ codefn            -> Any   format codefn-------------------------------------------------------------------------------------- | Grab the Reg for a CmmReg-getRegisterReg :: Platform -> CmmReg -> Reg--getRegisterReg _ (CmmLocal (LocalReg u pk))-        = RegVirtual $ mkVirtualReg u (cmmTypeFormat pk)--getRegisterReg platform (CmmGlobal mid)-  = case globalRegMaybe platform mid of-        Just reg -> RegReal reg-        Nothing  -> pprPanic-                        "SPARC.CodeGen.Base.getRegisterReg: global is in memory"-                        (ppr $ CmmGlobal mid)----- Expand CmmRegOff.  ToDo: should we do it this way around, or convert--- CmmExprs into CmmRegOff?-mangleIndexTree :: Platform -> CmmExpr -> CmmExpr--mangleIndexTree platform (CmmRegOff reg off)-        = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]-        where width = typeWidth (cmmRegType platform reg)--mangleIndexTree _ _-        = panic "SPARC.CodeGen.Base.mangleIndexTree: no match"
− compiler/GHC/CmmToAsm/SPARC/CodeGen/CondCode.hs 
@@ -1,115 +0,0 @@-module GHC.CmmToAsm.SPARC.CodeGen.CondCode (-        getCondCode,-        condIntCode,-        condFltCode-)--where--import GHC.Prelude--import {-# SOURCE #-} GHC.CmmToAsm.SPARC.CodeGen.Gen32-import GHC.CmmToAsm.SPARC.CodeGen.Base-import GHC.CmmToAsm.SPARC.Instr-import GHC.CmmToAsm.SPARC.Regs-import GHC.CmmToAsm.SPARC.Cond-import GHC.CmmToAsm.SPARC.Imm-import GHC.CmmToAsm.SPARC.Base-import GHC.CmmToAsm.Monad-import GHC.CmmToAsm.Format--import GHC.Cmm--import GHC.Data.OrdList-import GHC.Utils.Outputable-import GHC.Utils.Panic---getCondCode :: CmmExpr -> NatM CondCode-getCondCode (CmmMachOp mop [x, y])-  =-    case mop of-      MO_F_Eq W32 -> condFltCode EQQ x y-      MO_F_Ne W32 -> condFltCode NE  x y-      MO_F_Gt W32 -> condFltCode GTT x y-      MO_F_Ge W32 -> condFltCode GE  x y-      MO_F_Lt W32 -> condFltCode LTT x y-      MO_F_Le W32 -> condFltCode LE  x y--      MO_F_Eq W64 -> condFltCode EQQ x y-      MO_F_Ne W64 -> condFltCode NE  x y-      MO_F_Gt W64 -> condFltCode GTT x y-      MO_F_Ge W64 -> condFltCode GE  x y-      MO_F_Lt W64 -> condFltCode LTT x y-      MO_F_Le W64 -> condFltCode LE  x y--      MO_Eq   _   -> condIntCode EQQ  x y-      MO_Ne   _   -> condIntCode NE   x y--      MO_S_Gt _   -> condIntCode GTT  x y-      MO_S_Ge _   -> condIntCode GE   x y-      MO_S_Lt _   -> condIntCode LTT  x y-      MO_S_Le _   -> condIntCode LE   x y--      MO_U_Gt _   -> condIntCode GU   x y-      MO_U_Ge _   -> condIntCode GEU  x y-      MO_U_Lt _   -> condIntCode LU   x y-      MO_U_Le _   -> condIntCode LEU  x y--      _           -> do-                     platform <- getPlatform-                     pprPanic "SPARC.CodeGen.CondCode.getCondCode" (pdoc platform (CmmMachOp mop [x,y]))--getCondCode other = do-   platform <- getPlatform-   pprPanic "SPARC.CodeGen.CondCode.getCondCode" (pdoc platform other)-------- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be--- passed back up the tree.--condIntCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode-condIntCode cond x (CmmLit (CmmInt y _))-  | fits13Bits y-  = do-       (src1, code) <- getSomeReg x-       let-           src2 = ImmInt (fromInteger y)-           code' = code `snocOL` SUB False True src1 (RIImm src2) g0-       return (CondCode False cond code')--condIntCode cond x y = do-    (src1, code1) <- getSomeReg x-    (src2, code2) <- getSomeReg y-    let-        code__2 = code1 `appOL` code2 `snocOL`-                  SUB False True src1 (RIReg src2) g0-    return (CondCode False cond code__2)---condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode-condFltCode cond x y = do-    platform <- getPlatform-    (src1, code1) <- getSomeReg x-    (src2, code2) <- getSomeReg y-    tmp <- getNewRegNat FF64-    let-        promote x = FxTOy FF32 FF64 x tmp--        pk1   = cmmExprType platform x-        pk2   = cmmExprType platform y--        code__2 =-                if pk1 `cmmEqType` pk2 then-                    code1 `appOL` code2 `snocOL`-                    FCMP True (cmmTypeFormat pk1) src1 src2-                else if typeWidth pk1 == W32 then-                    code1 `snocOL` promote src1 `appOL` code2 `snocOL`-                    FCMP True FF64 tmp src2-                else-                    code1 `appOL` code2 `snocOL` promote src2 `snocOL`-                    FCMP True FF64 src1 tmp-    return (CondCode True cond code__2)
− compiler/GHC/CmmToAsm/SPARC/CodeGen/Expand.hs 
@@ -1,157 +0,0 @@-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}---- | Expand out synthetic instructions into single machine instrs.-module GHC.CmmToAsm.SPARC.CodeGen.Expand (-        expandTop-)--where--import GHC.Prelude--import GHC.CmmToAsm.SPARC.Instr-import GHC.CmmToAsm.SPARC.Imm-import GHC.CmmToAsm.SPARC.AddrMode-import GHC.CmmToAsm.SPARC.Regs-import GHC.CmmToAsm.Format-import GHC.CmmToAsm.Types-import GHC.Cmm--import GHC.Platform.Reg--import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Data.OrdList---- | Expand out synthetic instructions in this top level thing-expandTop :: NatCmmDecl RawCmmStatics Instr -> NatCmmDecl RawCmmStatics Instr-expandTop top@(CmmData{})-        = top--expandTop (CmmProc info lbl live (ListGraph blocks))-        = CmmProc info lbl live (ListGraph $ map expandBlock blocks)----- | Expand out synthetic instructions in this block-expandBlock :: NatBasicBlock Instr -> NatBasicBlock Instr--expandBlock (BasicBlock label instrs)- = let  instrs_ol       = expandBlockInstrs instrs-        instrs'         = fromOL instrs_ol-   in   BasicBlock label instrs'----- | Expand out some instructions-expandBlockInstrs :: [Instr] -> OrdList Instr-expandBlockInstrs []    = nilOL--expandBlockInstrs (ii:is)- = let  ii_doubleRegs   = remapRegPair ii-        is_misaligned   = expandMisalignedDoubles ii_doubleRegs--   in   is_misaligned `appOL` expandBlockInstrs is------ | In the SPARC instruction set the FP register pairs that are used---      to hold 64 bit floats are referred to by just the first reg---      of the pair. Remap our internal reg pairs to the appropriate reg.------      For example:---          ldd [%l1], (%f0 | %f1)------      gets mapped to---          ldd [$l1], %f0----remapRegPair :: Instr -> Instr-remapRegPair instr- = let  patchF reg-         = case reg of-                RegReal (RealRegSingle _)-                        -> reg--                RegReal (RealRegPair r1 r2)--                        -- sanity checking-                        | r1         >= 32-                        , r1         <= 63-                        , r1 `mod` 2 == 0-                        , r2         == r1 + 1-                        -> RegReal (RealRegSingle r1)--                        | otherwise-                        -> pprPanic "SPARC.CodeGen.Expand: not remapping dodgy looking reg pair " (ppr reg)--                RegVirtual _-                        -> pprPanic "SPARC.CodeGen.Expand: not remapping virtual reg " (ppr reg)--   in   patchRegsOfInstr instr patchF------- Expand out 64 bit load/stores into individual instructions to handle---      possible double alignment problems.------      TODO:   It'd be better to use a scratch reg instead of the add/sub thing.---              We might be able to do this faster if we use the UA2007 instr set---              instead of restricting ourselves to SPARC V9.----expandMisalignedDoubles :: Instr -> OrdList Instr-expandMisalignedDoubles instr--        -- Translate to:-        --    add g1,g2,g1-        --    ld  [g1],%fn-        --    ld  [g1+4],%f(n+1)-        --    sub g1,g2,g1           -- to restore g1-        | LD FF64 (AddrRegReg r1 r2) fReg       <- instr-        =       toOL    [ ADD False False r1 (RIReg r2) r1-                        , LD  FF32  (AddrRegReg r1 g0)          fReg-                        , LD  FF32  (AddrRegImm r1 (ImmInt 4))  (fRegHi fReg)-                        , SUB False False r1 (RIReg r2) r1 ]--        -- Translate to-        --    ld  [addr],%fn-        --    ld  [addr+4],%f(n+1)-        | LD FF64 addr fReg                     <- instr-        = let   Just addr'      = addrOffset addr 4-          in    toOL    [ LD  FF32  addr        fReg-                        , LD  FF32  addr'       (fRegHi fReg) ]--        -- Translate to:-        --    add g1,g2,g1-        --    st  %fn,[g1]-        --    st  %f(n+1),[g1+4]-        --    sub g1,g2,g1           -- to restore g1-        | ST FF64 fReg (AddrRegReg r1 r2)       <- instr-        =       toOL    [ ADD False False r1 (RIReg r2) r1-                        , ST  FF32  fReg           (AddrRegReg r1 g0)-                        , ST  FF32  (fRegHi fReg)  (AddrRegImm r1 (ImmInt 4))-                        , SUB False False r1 (RIReg r2) r1 ]--        -- Translate to-        --    ld  [addr],%fn-        --    ld  [addr+4],%f(n+1)-        | ST FF64 fReg addr                     <- instr-        = let   Just addr'      = addrOffset addr 4-          in    toOL    [ ST  FF32  fReg           addr-                        , ST  FF32  (fRegHi fReg)  addr'         ]--        -- some other instr-        | otherwise-        = unitOL instr------ | The high partner for this float reg.-fRegHi :: Reg -> Reg-fRegHi (RegReal (RealRegSingle r1))-        | r1            >= 32-        , r1            <= 63-        , r1 `mod` 2 == 0-        = (RegReal $ RealRegSingle (r1 + 1))---- Can't take high partner for non-low reg.-fRegHi reg-        = pprPanic "SPARC.CodeGen.Expand: can't take fRegHi from " (ppr reg)
− compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs 
@@ -1,690 +0,0 @@--- | Evaluation of 32 bit values.-module GHC.CmmToAsm.SPARC.CodeGen.Gen32 (-        getSomeReg,-        getRegister-)--where--import GHC.Prelude--import GHC.CmmToAsm.SPARC.CodeGen.CondCode-import GHC.CmmToAsm.SPARC.CodeGen.Amode-import GHC.CmmToAsm.SPARC.CodeGen.Gen64-import GHC.CmmToAsm.SPARC.CodeGen.Base-import GHC.CmmToAsm.SPARC.Stack-import GHC.CmmToAsm.SPARC.Instr-import GHC.CmmToAsm.SPARC.Cond-import GHC.CmmToAsm.SPARC.AddrMode-import GHC.CmmToAsm.SPARC.Imm-import GHC.CmmToAsm.SPARC.Regs-import GHC.CmmToAsm.SPARC.Base-import GHC.CmmToAsm.Monad-import GHC.CmmToAsm.Format-import GHC.Platform.Reg--import GHC.Cmm--import Control.Monad (liftM)-import GHC.Data.OrdList-import GHC.Utils.Panic---- | The dual to getAnyReg: compute an expression into a register, but---      we don't mind which one it is.-getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)-getSomeReg expr = do-  r <- getRegister expr-  case r of-    Any rep code -> do-        tmp <- getNewRegNat rep-        return (tmp, code tmp)-    Fixed _ reg code ->-        return (reg, code)------ | Make code to evaluate a 32 bit expression.----getRegister :: CmmExpr -> NatM Register--getRegister (CmmReg reg)-  = do platform <- getPlatform-       return (Fixed (cmmTypeFormat (cmmRegType platform reg))-                     (getRegisterReg platform reg) nilOL)--getRegister tree@(CmmRegOff _ _)-  = do platform <- getPlatform-       getRegister (mangleIndexTree platform tree)--getRegister (CmmMachOp (MO_UU_Conv W64 W32)-             [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do-  ChildCode64 code rlo <- iselExpr64 x-  return $ Fixed II32 (getHiVRegFromLo rlo) code--getRegister (CmmMachOp (MO_SS_Conv W64 W32)-             [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do-  ChildCode64 code rlo <- iselExpr64 x-  return $ Fixed II32 (getHiVRegFromLo rlo) code--getRegister (CmmMachOp (MO_UU_Conv W64 W32) [x]) = do-  ChildCode64 code rlo <- iselExpr64 x-  return $ Fixed II32 rlo code--getRegister (CmmMachOp (MO_SS_Conv W64 W32) [x]) = do-  ChildCode64 code rlo <- iselExpr64 x-  return $ Fixed II32 rlo code----- Load a literal float into a float register.---      The actual literal is stored in a new data area, and we load it---      at runtime.-getRegister (CmmLit (CmmFloat f W32)) = do--    -- a label for the new data area-    lbl <- getNewLabelNat-    tmp <- getNewRegNat II32--    let code dst = toOL [-            -- the data area-            LDATA (Section ReadOnlyData lbl) $ CmmStaticsRaw lbl-                         [CmmStaticLit (CmmFloat f W32)],--            -- load the literal-            SETHI (HI (ImmCLbl lbl)) tmp,-            LD II32 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]--    return (Any FF32 code)--getRegister (CmmLit (CmmFloat d W64)) = do-    lbl <- getNewLabelNat-    tmp <- getNewRegNat II32-    let code dst = toOL [-            LDATA (Section ReadOnlyData lbl) $ CmmStaticsRaw lbl-                         [CmmStaticLit (CmmFloat d W64)],-            SETHI (HI (ImmCLbl lbl)) tmp,-            LD II64 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]-    return (Any FF64 code)----- Unary machine ops-getRegister (CmmMachOp mop [x])-  = case mop of-        -- Floating point negation --------------------------        MO_F_Neg W32            -> trivialUFCode FF32 (FNEG FF32) x-        MO_F_Neg W64            -> trivialUFCode FF64 (FNEG FF64) x---        -- Integer negation ---------------------------------        MO_S_Neg rep            -> trivialUCode (intFormat rep) (SUB False False g0) x-        MO_Not rep              -> trivialUCode (intFormat rep) (XNOR False g0) x---        -- Float word size conversion -----------------------        MO_FF_Conv W64 W32      -> coerceDbl2Flt x-        MO_FF_Conv W32 W64      -> coerceFlt2Dbl x---        -- Float <-> Signed Int conversion ------------------        MO_FS_Conv from to      -> coerceFP2Int from to x-        MO_SF_Conv from to      -> coerceInt2FP from to x---        -- Unsigned integer word size conversions ------------        -- If it's the same size, then nothing needs to be done.-        MO_UU_Conv from to-         | from == to           -> conversionNop (intFormat to)  x--        -- To narrow an unsigned word, mask out the high bits to simulate what would-        --      happen if we copied the value into a smaller register.-        MO_UU_Conv W16 W8       -> trivialCode W8  (AND False) x (CmmLit (CmmInt 255 W8))-        MO_UU_Conv W32 W8       -> trivialCode W8  (AND False) x (CmmLit (CmmInt 255 W8))--        -- for narrowing 32 bit to 16 bit, don't use a literal mask value like the W16->W8-        --      case because the only way we can load it is via SETHI, which needs 2 ops.-        --      Do some shifts to chop out the high bits instead.-        MO_UU_Conv W32 W16-         -> do  tmpReg          <- getNewRegNat II32-                (xReg, xCode)   <- getSomeReg x-                let code dst-                        =       xCode-                        `appOL` toOL-                                [ SLL xReg   (RIImm $ ImmInt 16) tmpReg-                                , SRL tmpReg (RIImm $ ImmInt 16) dst]--                return  $ Any II32 code--                --       trivialCode W16 (AND False) x (CmmLit (CmmInt 65535 W16))--        -- To widen an unsigned word we don't have to do anything.-        --      Just leave it in the same register and mark the result as the new size.-        MO_UU_Conv W8  W16      -> conversionNop (intFormat W16)  x-        MO_UU_Conv W8  W32      -> conversionNop (intFormat W32)  x-        MO_UU_Conv W16 W32      -> conversionNop (intFormat W32)  x---        -- Signed integer word size conversions --------------        -- Mask out high bits when narrowing them-        MO_SS_Conv W16 W8       -> trivialCode W8  (AND False) x (CmmLit (CmmInt 255 W8))-        MO_SS_Conv W32 W8       -> trivialCode W8  (AND False) x (CmmLit (CmmInt 255 W8))-        MO_SS_Conv W32 W16      -> trivialCode W16 (AND False) x (CmmLit (CmmInt 65535 W16))--        -- Sign extend signed words when widening them.-        MO_SS_Conv W8  W16      -> integerExtend W8  W16 x-        MO_SS_Conv W8  W32      -> integerExtend W8  W32 x-        MO_SS_Conv W16 W32      -> integerExtend W16 W32 x--        _                       -> panic ("Unknown unary mach op: " ++ show mop)----- Binary machine ops-getRegister (CmmMachOp mop [x, y])-  = case mop of-      MO_Eq _           -> condIntReg EQQ x y-      MO_Ne _           -> condIntReg NE x y--      MO_S_Gt _         -> condIntReg GTT x y-      MO_S_Ge _         -> condIntReg GE x y-      MO_S_Lt _         -> condIntReg LTT x y-      MO_S_Le _         -> condIntReg LE x y--      MO_U_Gt W32       -> condIntReg GU  x y-      MO_U_Ge W32       -> condIntReg GEU x y-      MO_U_Lt W32       -> condIntReg LU  x y-      MO_U_Le W32       -> condIntReg LEU x y--      MO_U_Gt W16       -> condIntReg GU  x y-      MO_U_Ge W16       -> condIntReg GEU x y-      MO_U_Lt W16       -> condIntReg LU  x y-      MO_U_Le W16       -> condIntReg LEU x y--      MO_Add W32        -> trivialCode W32 (ADD False False) x y-      MO_Sub W32        -> trivialCode W32 (SUB False False) x y--      MO_S_MulMayOflo rep -> imulMayOflo rep x y--      MO_S_Quot W32     -> idiv True  False x y-      MO_U_Quot W32     -> idiv False False x y--      MO_S_Rem  W32     -> irem True  x y-      MO_U_Rem  W32     -> irem False x y--      MO_F_Eq _         -> condFltReg EQQ x y-      MO_F_Ne _         -> condFltReg NE x y--      MO_F_Gt _         -> condFltReg GTT x y-      MO_F_Ge _         -> condFltReg GE x y-      MO_F_Lt _         -> condFltReg LTT x y-      MO_F_Le _         -> condFltReg LE x y--      MO_F_Add  w       -> trivialFCode w FADD x y-      MO_F_Sub  w       -> trivialFCode w FSUB x y-      MO_F_Mul  w       -> trivialFCode w FMUL x y-      MO_F_Quot w       -> trivialFCode w FDIV x y--      MO_And rep        -> trivialCode rep (AND False) x y-      MO_Or  rep        -> trivialCode rep (OR  False) x y-      MO_Xor rep        -> trivialCode rep (XOR False) x y--      MO_Mul rep        -> trivialCode rep (SMUL False) x y--      MO_Shl rep        -> trivialCode rep SLL  x y-      MO_U_Shr rep      -> trivialCode rep SRL x y-      MO_S_Shr rep      -> trivialCode rep SRA x y--      _                 -> pprPanic "getRegister(sparc) - binary CmmMachOp (1)" (pprMachOp mop)--getRegister (CmmLoad mem pk _) = do-    Amode src code <- getAmode mem-    let-        code__2 dst     = code `snocOL` LD (cmmTypeFormat pk) src dst-    return (Any (cmmTypeFormat pk) code__2)--getRegister (CmmLit (CmmInt i _))-  | fits13Bits i-  = let-        src = ImmInt (fromInteger i)-        code dst = unitOL (OR False g0 (RIImm src) dst)-    in-        return (Any II32 code)--getRegister (CmmLit lit)-  = let imm = litToImm lit-        code dst = toOL [-            SETHI (HI imm) dst,-            OR False dst (RIImm (LO imm)) dst]-    in return (Any II32 code)---getRegister _-        = panic "SPARC.CodeGen.Gen32.getRegister: no match"----- | sign extend and widen-integerExtend-        :: Width                -- ^ width of source expression-        -> Width                -- ^ width of result-        -> CmmExpr              -- ^ source expression-        -> NatM Register--integerExtend from to expr- = do   -- load the expr into some register-        (reg, e_code)   <- getSomeReg expr-        tmp             <- getNewRegNat II32-        let bitCount-                = case (from, to) of-                        (W8,  W32)      -> 24-                        (W16, W32)      -> 16-                        (W8,  W16)      -> 24-                        _               -> panic "SPARC.CodeGen.Gen32: no match"-        let code dst-                = e_code--                -- local shift word left to load the sign bit-                `snocOL`  SLL reg (RIImm (ImmInt bitCount)) tmp--                -- arithmetic shift right to sign extend-                `snocOL`  SRA tmp (RIImm (ImmInt bitCount)) dst--        return (Any (intFormat to) code)----- | For nop word format conversions we set the resulting value to have the---      required size, but don't need to generate any actual code.----conversionNop-        :: Format -> CmmExpr -> NatM Register--conversionNop new_rep expr- = do   e_code <- getRegister expr-        return (setFormatOfRegister e_code new_rep)------ | Generate an integer division instruction.-idiv :: Bool -> Bool -> CmmExpr -> CmmExpr -> NatM Register---- For unsigned division with a 32 bit numerator,---              we can just clear the Y register.-idiv False cc x y- = do-        (a_reg, a_code)         <- getSomeReg x-        (b_reg, b_code)         <- getSomeReg y--        let code dst-                =       a_code-                `appOL` b_code-                `appOL` toOL-                        [ WRY  g0 g0-                        , UDIV cc a_reg (RIReg b_reg) dst]--        return (Any II32 code)----- For _signed_ division with a 32 bit numerator,---              we have to sign extend the numerator into the Y register.-idiv True cc x y- = do-        (a_reg, a_code)         <- getSomeReg x-        (b_reg, b_code)         <- getSomeReg y--        tmp                     <- getNewRegNat II32--        let code dst-                =       a_code-                `appOL` b_code-                `appOL` toOL-                        [ SRA  a_reg (RIImm (ImmInt 16)) tmp            -- sign extend-                        , SRA  tmp   (RIImm (ImmInt 16)) tmp--                        , WRY  tmp g0-                        , SDIV cc a_reg (RIReg b_reg) dst]--        return (Any II32 code)----- | Do an integer remainder.------       NOTE:  The SPARC v8 architecture manual says that integer division---              instructions _may_ generate a remainder, depending on the implementation.---              If so it is _recommended_ that the remainder is placed in the Y register.------          The UltraSparc 2007 manual says Y is _undefined_ after division.------              The SPARC T2 doesn't store the remainder, not sure about the others.---              It's probably best not to worry about it, and just generate our own---              remainders.----irem :: Bool -> CmmExpr -> CmmExpr -> NatM Register---- For unsigned operands:---              Division is between a 64 bit numerator and a 32 bit denominator,---              so we still have to clear the Y register.-irem False x y- = do-        (a_reg, a_code) <- getSomeReg x-        (b_reg, b_code) <- getSomeReg y--        tmp_reg         <- getNewRegNat II32--        let code dst-                =       a_code-                `appOL` b_code-                `appOL` toOL-                        [ WRY   g0 g0-                        , UDIV  False         a_reg (RIReg b_reg) tmp_reg-                        , UMUL  False       tmp_reg (RIReg b_reg) tmp_reg-                        , SUB   False False   a_reg (RIReg tmp_reg) dst]--        return  (Any II32 code)------ For signed operands:---              Make sure to sign extend into the Y register, or the remainder---              will have the wrong sign when the numerator is negative.------      TODO:   When sign extending, GCC only shifts the a_reg right by 17 bits,---              not the full 32. Not sure why this is, something to do with overflow?---              If anyone cares enough about the speed of signed remainder they---              can work it out themselves (then tell me). -- BL 2009/01/20-irem True x y- = do-        (a_reg, a_code) <- getSomeReg x-        (b_reg, b_code) <- getSomeReg y--        tmp1_reg        <- getNewRegNat II32-        tmp2_reg        <- getNewRegNat II32--        let code dst-                =       a_code-                `appOL` b_code-                `appOL` toOL-                        [ SRA   a_reg      (RIImm (ImmInt 16)) tmp1_reg -- sign extend-                        , SRA   tmp1_reg   (RIImm (ImmInt 16)) tmp1_reg -- sign extend-                        , WRY   tmp1_reg g0--                        , SDIV  False          a_reg (RIReg b_reg)    tmp2_reg-                        , SMUL  False       tmp2_reg (RIReg b_reg)    tmp2_reg-                        , SUB   False False    a_reg (RIReg tmp2_reg) dst]--        return (Any II32 code)---imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register-imulMayOflo rep a b- = do-        (a_reg, a_code) <- getSomeReg a-        (b_reg, b_code) <- getSomeReg b-        res_lo <- getNewRegNat II32-        res_hi <- getNewRegNat II32--        let shift_amt  = case rep of-                          W32 -> 31-                          W64 -> 63-                          _ -> panic "shift_amt"--        let code dst = a_code `appOL` b_code `appOL`-                       toOL [-                           SMUL False a_reg (RIReg b_reg) res_lo,-                           RDY res_hi,-                           SRA res_lo (RIImm (ImmInt shift_amt)) res_lo,-                           SUB False False res_lo (RIReg res_hi) dst-                        ]-        return (Any II32 code)----- -------------------------------------------------------------------------------- 'trivial*Code': deal with trivial instructions---- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode',--- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions.--- Only look for constants on the right hand side, because that's--- where the generic optimizer will have put them.---- Similarly, for unary instructions, we don't have to worry about--- matching an StInt as the argument, because genericOpt will already--- have handled the constant-folding.--trivialCode-        :: Width-        -> (Reg -> RI -> Reg -> Instr)-        -> CmmExpr-        -> CmmExpr-        -> NatM Register--trivialCode _ instr x (CmmLit (CmmInt y _))-  | fits13Bits y-  = do-      (src1, code) <- getSomeReg x-      let-        src2 = ImmInt (fromInteger y)-        code__2 dst = code `snocOL` instr src1 (RIImm src2) dst-      return (Any II32 code__2)---trivialCode _ instr x y = do-    (src1, code1) <- getSomeReg x-    (src2, code2) <- getSomeReg y-    let-        code__2 dst = code1 `appOL` code2 `snocOL`-                      instr src1 (RIReg src2) dst-    return (Any II32 code__2)---trivialFCode-        :: Width-        -> (Format -> Reg -> Reg -> Reg -> Instr)-        -> CmmExpr-        -> CmmExpr-        -> NatM Register--trivialFCode pk instr x y = do-    platform <- getPlatform-    (src1, code1) <- getSomeReg x-    (src2, code2) <- getSomeReg y-    tmp <- getNewRegNat FF64-    let-        promote x = FxTOy FF32 FF64 x tmp--        pk1   = cmmExprType platform x-        pk2   = cmmExprType platform y--        code__2 dst =-                if pk1 `cmmEqType` pk2 then-                    code1 `appOL` code2 `snocOL`-                    instr (floatFormat pk) src1 src2 dst-                else if typeWidth pk1 == W32 then-                    code1 `snocOL` promote src1 `appOL` code2 `snocOL`-                    instr FF64 tmp src2 dst-                else-                    code1 `appOL` code2 `snocOL` promote src2 `snocOL`-                    instr FF64 src1 tmp dst-    return (Any (cmmTypeFormat $ if pk1 `cmmEqType` pk2 then pk1 else cmmFloat W64)-                code__2)----trivialUCode-        :: Format-        -> (RI -> Reg -> Instr)-        -> CmmExpr-        -> NatM Register--trivialUCode format instr x = do-    (src, code) <- getSomeReg x-    let-        code__2 dst = code `snocOL` instr (RIReg src) dst-    return (Any format code__2)---trivialUFCode-        :: Format-        -> (Reg -> Reg -> Instr)-        -> CmmExpr-        -> NatM Register--trivialUFCode pk instr x = do-    (src, code) <- getSomeReg x-    let-        code__2 dst = code `snocOL` instr src dst-    return (Any pk code__2)------- Coercions ----------------------------------------------------------------------- | Coerce a integer value to floating point-coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register-coerceInt2FP width1 width2 x = do-    (src, code) <- getSomeReg x-    let-        code__2 dst = code `appOL` toOL [-            ST (intFormat width1) src (spRel (-2)),-            LD (intFormat width1) (spRel (-2)) dst,-            FxTOy (intFormat width1) (floatFormat width2) dst dst]-    return (Any (floatFormat $ width2) code__2)------ | Coerce a floating point value to integer------   NOTE: On sparc v9 there are no instructions to move a value from an---         FP register directly to an int register, so we have to use a load/store.----coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register-coerceFP2Int width1 width2 x- = do   let fformat1      = floatFormat width1-            fformat2      = floatFormat width2--            iformat2      = intFormat   width2--        (fsrc, code)    <- getSomeReg x-        fdst            <- getNewRegNat fformat2--        let code2 dst-                =       code-                `appOL` toOL-                        -- convert float to int format, leaving it in a float reg.-                        [ FxTOy fformat1 iformat2 fsrc fdst--                        -- store the int into mem, then load it back to move-                        --      it into an actual int reg.-                        , ST    fformat2 fdst (spRel (-2))-                        , LD    iformat2 (spRel (-2)) dst]--        return (Any iformat2 code2)----- | Coerce a double precision floating point value to single precision.-coerceDbl2Flt :: CmmExpr -> NatM Register-coerceDbl2Flt x = do-    (src, code) <- getSomeReg x-    return (Any FF32 (\dst -> code `snocOL` FxTOy FF64 FF32 src dst))----- | Coerce a single precision floating point value to double precision-coerceFlt2Dbl :: CmmExpr -> NatM Register-coerceFlt2Dbl x = do-    (src, code) <- getSomeReg x-    return (Any FF64 (\dst -> code `snocOL` FxTOy FF32 FF64 src dst))------- Condition Codes ------------------------------------------------------------------- Evaluate a comparison, and get the result into a register.------ Do not fill the delay slots here. you will confuse the register allocator.----condIntReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register-condIntReg EQQ x (CmmLit (CmmInt 0 _)) = do-    (src, code) <- getSomeReg x-    let-        code__2 dst = code `appOL` toOL [-            SUB False True g0 (RIReg src) g0,-            SUB True False g0 (RIImm (ImmInt (-1))) dst]-    return (Any II32 code__2)--condIntReg EQQ x y = do-    (src1, code1) <- getSomeReg x-    (src2, code2) <- getSomeReg y-    let-        code__2 dst = code1 `appOL` code2 `appOL` toOL [-            XOR False src1 (RIReg src2) dst,-            SUB False True g0 (RIReg dst) g0,-            SUB True False g0 (RIImm (ImmInt (-1))) dst]-    return (Any II32 code__2)--condIntReg NE x (CmmLit (CmmInt 0 _)) = do-    (src, code) <- getSomeReg x-    let-        code__2 dst = code `appOL` toOL [-            SUB False True g0 (RIReg src) g0,-            ADD True False g0 (RIImm (ImmInt 0)) dst]-    return (Any II32 code__2)--condIntReg NE x y = do-    (src1, code1) <- getSomeReg x-    (src2, code2) <- getSomeReg y-    let-        code__2 dst = code1 `appOL` code2 `appOL` toOL [-            XOR False src1 (RIReg src2) dst,-            SUB False True g0 (RIReg dst) g0,-            ADD True False g0 (RIImm (ImmInt 0)) dst]-    return (Any II32 code__2)--condIntReg cond x y = do-    bid1 <- liftM (\a -> seq a a) getBlockIdNat-    bid2 <- liftM (\a -> seq a a) getBlockIdNat-    CondCode _ cond cond_code <- condIntCode cond x y-    let-        code__2 dst-         =      cond_code-          `appOL` toOL-                [ BI cond False bid1-                , NOP--                , OR False g0 (RIImm (ImmInt 0)) dst-                , BI ALWAYS False bid2-                , NOP--                , NEWBLOCK bid1-                , OR False g0 (RIImm (ImmInt 1)) dst-                , BI ALWAYS False bid2-                , NOP--                , NEWBLOCK bid2]--    return (Any II32 code__2)---condFltReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register-condFltReg cond x y = do-    bid1 <- liftM (\a -> seq a a) getBlockIdNat-    bid2 <- liftM (\a -> seq a a) getBlockIdNat--    CondCode _ cond cond_code <- condFltCode cond x y-    let-        code__2 dst-         =      cond_code-          `appOL` toOL-                [ NOP-                , BF cond False bid1-                , NOP--                , OR False g0 (RIImm (ImmInt 0)) dst-                , BI ALWAYS False bid2-                , NOP--                , NEWBLOCK bid1-                , OR False g0 (RIImm (ImmInt 1)) dst-                , BI ALWAYS False bid2-                , NOP--                , NEWBLOCK bid2 ]--    return (Any II32 code__2)
− compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs-boot 
@@ -1,16 +0,0 @@--module GHC.CmmToAsm.SPARC.CodeGen.Gen32 (-        getSomeReg,-        getRegister-)--where--import GHC.CmmToAsm.SPARC.CodeGen.Base-import GHC.CmmToAsm.Monad-import GHC.Platform.Reg--import GHC.Cmm--getSomeReg  :: CmmExpr -> NatM (Reg, InstrBlock)-getRegister :: CmmExpr -> NatM Register
− compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen64.hs 
@@ -1,215 +0,0 @@--- | Evaluation of 64 bit values on 32 bit platforms.-module GHC.CmmToAsm.SPARC.CodeGen.Gen64 (-        assignMem_I64Code,-        assignReg_I64Code,-        iselExpr64-)--where--import GHC.Prelude--import {-# SOURCE #-} GHC.CmmToAsm.SPARC.CodeGen.Gen32-import GHC.CmmToAsm.SPARC.CodeGen.Base-import GHC.CmmToAsm.SPARC.CodeGen.Amode-import GHC.CmmToAsm.SPARC.Regs-import GHC.CmmToAsm.SPARC.AddrMode-import GHC.CmmToAsm.SPARC.Imm-import GHC.CmmToAsm.SPARC.Instr-import GHC.CmmToAsm.Monad-import GHC.CmmToAsm.Format-import GHC.Platform.Reg--import GHC.Cmm--import GHC.Data.OrdList-import GHC.Utils.Outputable-import GHC.Utils.Panic---- | Code to assign a 64 bit value to memory.-assignMem_I64Code-        :: CmmExpr              -- ^ expr producing the destination address-        -> CmmExpr              -- ^ expr producing the source value.-        -> NatM InstrBlock--assignMem_I64Code addrTree valueTree- = do-     ChildCode64 vcode rlo      <- iselExpr64 valueTree--     (src, acode) <- getSomeReg addrTree-     let-         rhi = getHiVRegFromLo rlo--         -- Big-endian store-         mov_hi = ST II32 rhi (AddrRegImm src (ImmInt 0))-         mov_lo = ST II32 rlo (AddrRegImm src (ImmInt 4))--         code   = vcode `appOL` acode `snocOL` mov_hi `snocOL` mov_lo--{-     pprTrace "assignMem_I64Code"-        (vcat   [ text "addrTree:  " <+> ppr addrTree-                , text "valueTree: " <+> ppr valueTree-                , text "vcode:"-                , vcat $ map ppr $ fromOL vcode-                , text ""-                , text "acode:"-                , vcat $ map ppr $ fromOL acode ])-       $ -}-     return code----- | Code to assign a 64 bit value to a register.-assignReg_I64Code-        :: CmmReg               -- ^ the destination register-        -> CmmExpr              -- ^ expr producing the source value-        -> NatM InstrBlock--assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree- = do-     ChildCode64 vcode r_src_lo <- iselExpr64 valueTree-     let-         r_dst_lo = RegVirtual $ mkVirtualReg u_dst (cmmTypeFormat pk)-         r_dst_hi = getHiVRegFromLo r_dst_lo-         r_src_hi = getHiVRegFromLo r_src_lo-         mov_lo = mkMOV r_src_lo r_dst_lo-         mov_hi = mkMOV r_src_hi r_dst_hi-         mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg--     return (vcode `snocOL` mov_hi `snocOL` mov_lo)--assignReg_I64Code _ _-   = panic "assignReg_I64Code(sparc): invalid lvalue"------- | Get the value of an expression into a 64 bit register.--iselExpr64 :: CmmExpr -> NatM ChildCode64---- Load a 64 bit word--- TODO: Check Ben-iselExpr64 (CmmLoad addrTree ty _)- | isWord64 ty- = do   Amode amode addr_code   <- getAmode addrTree-        let result--                | AddrRegReg r1 r2      <- amode-                = do    rlo     <- getNewRegNat II32-                        tmp     <- getNewRegNat II32-                        let rhi = getHiVRegFromLo rlo--                        return  $ ChildCode64-                                (        addr_code-                                `appOL`  toOL-                                         [ ADD False False r1 (RIReg r2) tmp-                                         , LD II32 (AddrRegImm tmp (ImmInt 0)) rhi-                                         , LD II32 (AddrRegImm tmp (ImmInt 4)) rlo ])-                                rlo--                | AddrRegImm r1 (ImmInt i) <- amode-                = do    rlo     <- getNewRegNat II32-                        let rhi = getHiVRegFromLo rlo--                        return  $ ChildCode64-                                (        addr_code-                                `appOL`  toOL-                                         [ LD II32 (AddrRegImm r1 (ImmInt $ 0 + i)) rhi-                                         , LD II32 (AddrRegImm r1 (ImmInt $ 4 + i)) rlo ])-                                rlo--                | otherwise-                = panic "SPARC.CodeGen.Gen64: no match"--        result----- Add a literal to a 64 bit integer-iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)])- = do   ChildCode64 code1 r1_lo <- iselExpr64 e1-        let r1_hi       = getHiVRegFromLo r1_lo--        r_dst_lo        <- getNewRegNat II32-        let r_dst_hi    =  getHiVRegFromLo r_dst_lo--        let code =      code1-                `appOL` toOL-                        [ ADD False True  r1_lo (RIImm (ImmInteger i)) r_dst_lo-                        , ADD True  False r1_hi (RIReg g0)         r_dst_hi ]--        return  $ ChildCode64 code r_dst_lo----- Addition of II64-iselExpr64 (CmmMachOp (MO_Add _) [e1, e2])- = do   ChildCode64 code1 r1_lo <- iselExpr64 e1-        let r1_hi       = getHiVRegFromLo r1_lo--        ChildCode64 code2 r2_lo <- iselExpr64 e2-        let r2_hi       = getHiVRegFromLo r2_lo--        r_dst_lo        <- getNewRegNat II32-        let r_dst_hi    = getHiVRegFromLo r_dst_lo--        let code =      code1-                `appOL` code2-                `appOL` toOL-                        [ ADD False True  r1_lo (RIReg r2_lo) r_dst_lo-                        , ADD True  False r1_hi (RIReg r2_hi) r_dst_hi ]--        return  $ ChildCode64 code r_dst_lo---iselExpr64 (CmmReg (CmmLocal (LocalReg uq ty)))- | isWord64 ty- = do-     r_dst_lo <-  getNewRegNat II32-     let r_dst_hi = getHiVRegFromLo r_dst_lo-         r_src_lo = RegVirtual $ mkVirtualReg uq II32-         r_src_hi = getHiVRegFromLo r_src_lo-         mov_lo = mkMOV r_src_lo r_dst_lo-         mov_hi = mkMOV r_src_hi r_dst_hi-         mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg-     return (-            ChildCode64 (toOL [mov_hi, mov_lo]) r_dst_lo-         )---- Convert something into II64-iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr])- = do-        r_dst_lo        <- getNewRegNat II32-        let r_dst_hi    = getHiVRegFromLo r_dst_lo--        -- compute expr and load it into r_dst_lo-        (a_reg, a_code) <- getSomeReg expr--        platform        <- getPlatform-        let code        = a_code-                `appOL` toOL-                        [ mkRegRegMoveInstr platform g0    r_dst_hi     -- clear high 32 bits-                        , mkRegRegMoveInstr platform a_reg r_dst_lo ]--        return  $ ChildCode64 code r_dst_lo---- only W32 supported for now-iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr])- = do-        r_dst_lo        <- getNewRegNat II32-        let r_dst_hi    = getHiVRegFromLo r_dst_lo--        -- compute expr and load it into r_dst_lo-        (a_reg, a_code) <- getSomeReg expr--        platform        <- getPlatform-        let code        = a_code-                `appOL` toOL-                        [ SRA a_reg (RIImm (ImmInt 31)) r_dst_hi-                        , mkRegRegMoveInstr platform a_reg r_dst_lo ]--        return  $ ChildCode64 code r_dst_lo---iselExpr64 expr-   = do-      platform <- getPlatform-      pprPanic "iselExpr64(sparc)" (pdoc platform expr)
− compiler/GHC/CmmToAsm/SPARC/CodeGen/Sanity.hs 
@@ -1,72 +0,0 @@--- | One ounce of sanity checking is worth 10000000000000000 ounces--- of staring blindly at assembly code trying to find the problem..-module GHC.CmmToAsm.SPARC.CodeGen.Sanity (-        checkBlock-)--where--import GHC.Prelude-import GHC.Platform--import GHC.CmmToAsm.SPARC.Instr-import GHC.CmmToAsm.SPARC.Ppr        () -- For Outputable instances-import GHC.CmmToAsm.Types--import GHC.Cmm--import GHC.Utils.Outputable-import GHC.Utils.Panic----- | Enforce intra-block invariants.----checkBlock :: Platform-           -> CmmBlock-           -> NatBasicBlock Instr-           -> NatBasicBlock Instr--checkBlock platform cmm block@(BasicBlock _ instrs)-        | checkBlockInstrs instrs-        = block--        | otherwise-        = pprPanic-                ("SPARC.CodeGen: bad block\n")-                ( vcat  [ text " -- cmm -----------------\n"-                        , pdoc platform cmm-                        , text " -- native code ---------\n"-                        , pdoc platform block ])---checkBlockInstrs :: [Instr] -> Bool-checkBlockInstrs ii--        -- An unconditional jumps end the block.-        --      There must be an unconditional jump in the block, otherwise-        --      the register liveness determinator will get the liveness-        --      information wrong.-        ---        --      If the block ends with a cmm call that never returns-        --      then there can be unreachable instructions after the jump,-        --      but we don't mind here.-        ---        | instr : NOP : _       <- ii-        , isUnconditionalJump instr-        = True--        -- All jumps must have a NOP in their branch delay slot.-        --      The liveness determinator and register allocators aren't smart-        --      enough to handle branch delay slots.-        ---        | instr : NOP : is      <- ii-        , isJumpishInstr instr-        = checkBlockInstrs is--        -- keep checking-        | _:i2:is               <- ii-        = checkBlockInstrs (i2:is)--        -- this block is no good-        | otherwise-        = False
− compiler/GHC/CmmToAsm/SPARC/Cond.hs 
@@ -1,27 +0,0 @@-module GHC.CmmToAsm.SPARC.Cond (-        Cond(..),-)--where--import GHC.Prelude---- | Branch condition codes.-data Cond-        = ALWAYS-        | EQQ-        | GE-        | GEU-        | GTT-        | GU-        | LE-        | LEU-        | LTT-        | LU-        | NE-        | NEG-        | NEVER-        | POS-        | VC-        | VS-        deriving Eq
− compiler/GHC/CmmToAsm/SPARC/Imm.hs 
@@ -1,68 +0,0 @@-module GHC.CmmToAsm.SPARC.Imm (-        -- immediate values-        Imm(..),-        strImmLit,-        litToImm-)--where--import GHC.Prelude--import GHC.Cmm-import GHC.Cmm.CLabel--import GHC.Utils.Outputable-import GHC.Utils.Panic---- | An immediate value.---      Not all of these are directly representable by the machine.---      Things like ImmLit are slurped out and put in a data segment instead.----data Imm-        = ImmInt        Int--        -- Sigh.-        | ImmInteger    Integer--        -- AbstractC Label (with baggage)-        | ImmCLbl       CLabel--        -- Simple string-        | ImmLit        SDoc-        | ImmIndex      CLabel Int-        | ImmFloat      Rational-        | ImmDouble     Rational--        | ImmConstantSum  Imm Imm-        | ImmConstantDiff Imm Imm--        | LO    Imm-        | HI    Imm----- | Create a ImmLit containing this string.-strImmLit :: String -> Imm-strImmLit s = ImmLit (text s)----- | Convert a CmmLit to an Imm.---      Narrow to the width: a CmmInt might be out of---      range, but we assume that ImmInteger only contains---      in-range values.  A signed value should be fine here.----litToImm :: CmmLit -> Imm-litToImm lit- = case lit of-        CmmInt i w              -> ImmInteger (narrowS w i)-        CmmFloat f W32          -> ImmFloat f-        CmmFloat f W64          -> ImmDouble f-        CmmLabel l              -> ImmCLbl l-        CmmLabelOff l off       -> ImmIndex l off--        CmmLabelDiffOff l1 l2 off _-         -> ImmConstantSum-                (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2))-                (ImmInt off)--        _               -> panic "SPARC.Regs.litToImm: no match"
− compiler/GHC/CmmToAsm/SPARC/Instr.hs 
@@ -1,472 +0,0 @@-{-# LANGUAGE CPP #-}------------------------------------------------------------------------------------- Machine-dependent assembly language------ (c) The University of Glasgow 1993-2004----------------------------------------------------------------------------------#include "GhclibHsVersions.h"--module GHC.CmmToAsm.SPARC.Instr-   ( Instr(..)-   , RI(..)-   , riZero-   , fpRelEA-   , moveSp-   , isUnconditionalJump-   , maxSpillSlots-   , patchRegsOfInstr-   , patchJumpInstr-   , mkRegRegMoveInstr-   , mkLoadInstr-   , mkSpillInstr-   , mkJumpInstr-   , takeDeltaInstr-   , isMetaInstr-   , isJumpishInstr-   , jumpDestsOfInstr-   , takeRegRegMoveInstr-   , regUsageOfInstr-   )-where--import GHC.Prelude-import GHC.Platform--import GHC.CmmToAsm.SPARC.Stack-import GHC.CmmToAsm.SPARC.Imm-import GHC.CmmToAsm.SPARC.AddrMode-import GHC.CmmToAsm.SPARC.Cond-import GHC.CmmToAsm.SPARC.Regs-import GHC.CmmToAsm.SPARC.Base-import GHC.CmmToAsm.Reg.Target-import GHC.CmmToAsm.Format-import GHC.CmmToAsm.Config-import GHC.CmmToAsm.Instr (RegUsage(..), noUsage)--import GHC.Platform.Reg.Class-import GHC.Platform.Reg-import GHC.Platform.Regs--import GHC.Cmm.CLabel-import GHC.Cmm.BlockId-import GHC.Cmm-import GHC.Data.FastString-import GHC.Utils.Panic----- | Register or immediate-data RI-        = RIReg Reg-        | RIImm Imm---- | Check if a RI represents a zero value.---      - a literal zero---      - register %g0, which is always zero.----riZero :: RI -> Bool-riZero (RIImm (ImmInt 0))                       = True-riZero (RIImm (ImmInteger 0))                   = True-riZero (RIReg (RegReal (RealRegSingle 0)))      = True-riZero _                                        = False----- | Calculate the effective address which would be used by the---      corresponding fpRel sequence.-fpRelEA :: Int -> Reg -> Instr-fpRelEA n dst-   = ADD False False fp (RIImm (ImmInt (n * wordLength))) dst----- | Code to shift the stack pointer by n words.-moveSp :: Int -> Instr-moveSp n-   = ADD False False sp (RIImm (ImmInt (n * wordLength))) sp---- | An instruction that will cause the one after it never to be exectuted-isUnconditionalJump :: Instr -> Bool-isUnconditionalJump ii- = case ii of-        CALL{}          -> True-        JMP{}           -> True-        JMP_TBL{}       -> True-        BI ALWAYS _ _   -> True-        BF ALWAYS _ _   -> True-        _               -> False----- | SPARC instruction set.---      Not complete. This is only the ones we need.----data Instr--        -- meta ops ---------------------------------------------------        -- comment pseudo-op-        = COMMENT FastString--        -- some static data spat out during code generation.-        -- Will be extracted before pretty-printing.-        | LDATA   Section RawCmmStatics--        -- Start a new basic block.  Useful during codegen, removed later.-        -- Preceding instruction should be a jump, as per the invariants-        -- for a BasicBlock (see Cmm).-        | NEWBLOCK BlockId--        -- specify current stack offset for benefit of subsequent passes.-        | DELTA   Int--        -- real instrs ------------------------------------------------        -- Loads and stores.-        | LD            Format AddrMode Reg             -- format, src, dst-        | ST            Format Reg AddrMode             -- format, src, dst--        -- Int Arithmetic.-        --      x:   add/sub with carry bit.-        --              In SPARC V9 addx and friends were renamed addc.-        ---        --      cc:  modify condition codes-        ---        | ADD           Bool Bool Reg RI Reg            -- x?, cc?, src1, src2, dst-        | SUB           Bool Bool Reg RI Reg            -- x?, cc?, src1, src2, dst--        | UMUL          Bool Reg RI Reg                 --     cc?, src1, src2, dst-        | SMUL          Bool Reg RI Reg                 --     cc?, src1, src2, dst---        -- The SPARC divide instructions perform 64bit by 32bit division-        --   The Y register is xored into the first operand.--        --   On _some implementations_ the Y register is overwritten by-        --   the remainder, so we have to make sure it is 0 each time.--        --   dst <- ((Y `shiftL` 32) `or` src1) `div` src2-        | UDIV          Bool Reg RI Reg                 --     cc?, src1, src2, dst-        | SDIV          Bool Reg RI Reg                 --     cc?, src1, src2, dst--        | RDY           Reg                             -- move contents of Y register to reg-        | WRY           Reg  Reg                        -- Y <- src1 `xor` src2--        -- Logic operations.-        | AND           Bool Reg RI Reg                 -- cc?, src1, src2, dst-        | ANDN          Bool Reg RI Reg                 -- cc?, src1, src2, dst-        | OR            Bool Reg RI Reg                 -- cc?, src1, src2, dst-        | ORN           Bool Reg RI Reg                 -- cc?, src1, src2, dst-        | XOR           Bool Reg RI Reg                 -- cc?, src1, src2, dst-        | XNOR          Bool Reg RI Reg                 -- cc?, src1, src2, dst-        | SLL           Reg RI Reg                      -- src1, src2, dst-        | SRL           Reg RI Reg                      -- src1, src2, dst-        | SRA           Reg RI Reg                      -- src1, src2, dst--        -- Load immediates.-        | SETHI         Imm Reg                         -- src, dst--        -- Do nothing.-        -- Implemented by the assembler as SETHI 0, %g0, but worth an alias-        | NOP--        -- Float Arithmetic.-        -- Note that we cheat by treating F{ABS,MOV,NEG} of doubles as single-        -- instructions right up until we spit them out.-        ---        | FABS          Format Reg Reg                  -- src dst-        | FADD          Format Reg Reg Reg              -- src1, src2, dst-        | FCMP          Bool Format Reg Reg             -- exception?, src1, src2, dst-        | FDIV          Format Reg Reg Reg              -- src1, src2, dst-        | FMOV          Format Reg Reg                  -- src, dst-        | FMUL          Format Reg Reg Reg              -- src1, src2, dst-        | FNEG          Format Reg Reg                  -- src, dst-        | FSQRT         Format Reg Reg                  -- src, dst-        | FSUB          Format Reg Reg Reg              -- src1, src2, dst-        | FxTOy         Format Format Reg Reg           -- src, dst--        -- Jumping around.-        | BI            Cond Bool BlockId               -- cond, annul?, target-        | BF            Cond Bool BlockId               -- cond, annul?, target--        | JMP           AddrMode                        -- target--        -- With a tabled jump we know all the possible destinations.-        -- We also need this info so we can work out what regs are live across the jump.-        ---        | JMP_TBL       AddrMode [Maybe BlockId] CLabel--        | CALL          (Either Imm Reg) Int Bool       -- target, args, terminal----- | regUsage returns the sets of src and destination registers used---      by a particular instruction.  Machine registers that are---      pre-allocated to stgRegs are filtered out, because they are---      uninteresting from a register allocation standpoint.  (We wouldn't---      want them to end up on the free list!)  As far as we are concerned,---      the fixed registers simply don't exist (for allocation purposes,---      anyway).----      regUsage doesn't need to do any trickery for jumps and such.  Just---      state precisely the regs read and written by that insn.  The---      consequences of control flow transfers, as far as register---      allocation goes, are taken care of by the register allocator.----regUsageOfInstr :: Platform -> Instr -> RegUsage-regUsageOfInstr platform instr- = case instr of-    LD    _ addr reg            -> usage (regAddr addr,         [reg])-    ST    _ reg addr            -> usage (reg : regAddr addr,   [])-    ADD   _ _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])-    SUB   _ _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])-    UMUL    _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])-    SMUL    _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])-    UDIV    _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])-    SDIV    _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])-    RDY       rd                -> usage ([],                   [rd])-    WRY       r1 r2             -> usage ([r1, r2],             [])-    AND     _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])-    ANDN    _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])-    OR      _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])-    ORN     _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])-    XOR     _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])-    XNOR    _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])-    SLL       r1 ar r2          -> usage (r1 : regRI ar,        [r2])-    SRL       r1 ar r2          -> usage (r1 : regRI ar,        [r2])-    SRA       r1 ar r2          -> usage (r1 : regRI ar,        [r2])-    SETHI   _ reg               -> usage ([],                   [reg])-    FABS    _ r1 r2             -> usage ([r1],                 [r2])-    FADD    _ r1 r2 r3          -> usage ([r1, r2],             [r3])-    FCMP    _ _  r1 r2          -> usage ([r1, r2],             [])-    FDIV    _ r1 r2 r3          -> usage ([r1, r2],             [r3])-    FMOV    _ r1 r2             -> usage ([r1],                 [r2])-    FMUL    _ r1 r2 r3          -> usage ([r1, r2],             [r3])-    FNEG    _ r1 r2             -> usage ([r1],                 [r2])-    FSQRT   _ r1 r2             -> usage ([r1],                 [r2])-    FSUB    _ r1 r2 r3          -> usage ([r1, r2],             [r3])-    FxTOy   _ _  r1 r2          -> usage ([r1],                 [r2])--    JMP     addr                -> usage (regAddr addr, [])-    JMP_TBL addr _ _            -> usage (regAddr addr, [])--    CALL  (Left _  )  _ True    -> noUsage-    CALL  (Left _  )  n False   -> usage (argRegs n, callClobberedRegs)-    CALL  (Right reg) _ True    -> usage ([reg], [])-    CALL  (Right reg) n False   -> usage (reg : (argRegs n), callClobberedRegs)-    _                           -> noUsage--  where-    usage (src, dst)-     = RU (filter (interesting platform) src)-          (filter (interesting platform) dst)--    regAddr (AddrRegReg r1 r2)  = [r1, r2]-    regAddr (AddrRegImm r1 _)   = [r1]--    regRI (RIReg r)             = [r]-    regRI  _                    = []----- | Interesting regs are virtuals, or ones that are allocatable---      by the register allocator.-interesting :: Platform -> Reg -> Bool-interesting platform reg- = case reg of-        RegVirtual _                    -> True-        RegReal (RealRegSingle r1)      -> freeReg platform r1-        RegReal (RealRegPair r1 _)      -> freeReg platform r1------ | Apply a given mapping to tall the register references in this instruction.-patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr-patchRegsOfInstr instr env = case instr of-    LD    fmt addr reg          -> LD fmt (fixAddr addr) (env reg)-    ST    fmt reg addr          -> ST fmt (env reg) (fixAddr addr)--    ADD   x cc r1 ar r2         -> ADD   x cc  (env r1) (fixRI ar) (env r2)-    SUB   x cc r1 ar r2         -> SUB   x cc  (env r1) (fixRI ar) (env r2)-    UMUL    cc r1 ar r2         -> UMUL    cc  (env r1) (fixRI ar) (env r2)-    SMUL    cc r1 ar r2         -> SMUL    cc  (env r1) (fixRI ar) (env r2)-    UDIV    cc r1 ar r2         -> UDIV    cc  (env r1) (fixRI ar) (env r2)-    SDIV    cc r1 ar r2         -> SDIV    cc  (env r1) (fixRI ar) (env r2)-    RDY   rd                    -> RDY         (env rd)-    WRY   r1 r2                 -> WRY         (env r1) (env r2)-    AND   b r1 ar r2            -> AND   b     (env r1) (fixRI ar) (env r2)-    ANDN  b r1 ar r2            -> ANDN  b     (env r1) (fixRI ar) (env r2)-    OR    b r1 ar r2            -> OR    b     (env r1) (fixRI ar) (env r2)-    ORN   b r1 ar r2            -> ORN   b     (env r1) (fixRI ar) (env r2)-    XOR   b r1 ar r2            -> XOR   b     (env r1) (fixRI ar) (env r2)-    XNOR  b r1 ar r2            -> XNOR  b     (env r1) (fixRI ar) (env r2)-    SLL   r1 ar r2              -> SLL         (env r1) (fixRI ar) (env r2)-    SRL   r1 ar r2              -> SRL         (env r1) (fixRI ar) (env r2)-    SRA   r1 ar r2              -> SRA         (env r1) (fixRI ar) (env r2)--    SETHI imm reg               -> SETHI imm (env reg)--    FABS  s r1 r2               -> FABS    s   (env r1) (env r2)-    FADD  s r1 r2 r3            -> FADD    s   (env r1) (env r2) (env r3)-    FCMP  e s r1 r2             -> FCMP e  s   (env r1) (env r2)-    FDIV  s r1 r2 r3            -> FDIV    s   (env r1) (env r2) (env r3)-    FMOV  s r1 r2               -> FMOV    s   (env r1) (env r2)-    FMUL  s r1 r2 r3            -> FMUL    s   (env r1) (env r2) (env r3)-    FNEG  s r1 r2               -> FNEG    s   (env r1) (env r2)-    FSQRT s r1 r2               -> FSQRT   s   (env r1) (env r2)-    FSUB  s r1 r2 r3            -> FSUB    s   (env r1) (env r2) (env r3)-    FxTOy s1 s2 r1 r2           -> FxTOy s1 s2 (env r1) (env r2)--    JMP     addr                -> JMP     (fixAddr addr)-    JMP_TBL addr ids l          -> JMP_TBL (fixAddr addr) ids l--    CALL  (Left i) n t          -> CALL (Left i) n t-    CALL  (Right r) n t         -> CALL (Right (env r)) n t-    _                           -> instr--  where-    fixAddr (AddrRegReg r1 r2)  = AddrRegReg   (env r1) (env r2)-    fixAddr (AddrRegImm r1 i)   = AddrRegImm   (env r1) i--    fixRI (RIReg r)             = RIReg (env r)-    fixRI other                 = other------------------------------------------------------------------------------------isJumpishInstr :: Instr -> Bool-isJumpishInstr instr- = case instr of-        BI{}            -> True-        BF{}            -> True-        JMP{}           -> True-        JMP_TBL{}       -> True-        CALL{}          -> True-        _               -> False--jumpDestsOfInstr :: Instr -> [BlockId]-jumpDestsOfInstr insn-  = case insn of-        BI   _ _ id     -> [id]-        BF   _ _ id     -> [id]-        JMP_TBL _ ids _ -> [id | Just id <- ids]-        _               -> []---patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr-patchJumpInstr insn patchF-  = case insn of-        BI cc annul id  -> BI cc annul (patchF id)-        BF cc annul id  -> BF cc annul (patchF id)-        JMP_TBL n ids l -> JMP_TBL n (map (fmap patchF) ids) l-        _               -> insn-------------------------------------------------------------------------------------- | Make a spill instruction.---      On SPARC we spill below frame pointer leaving 2 words/spill-mkSpillInstr-    :: NCGConfig-    -> Reg      -- ^ register to spill-    -> Int      -- ^ current stack delta-    -> Int      -- ^ spill slot to use-    -> [Instr]--mkSpillInstr config reg _ slot- = let  platform = ncgPlatform config-        off      = spillSlotToOffset config slot-        off_w    = 1 + (off `div` 4)-        fmt      = case targetClassOfReg platform reg of-                        RcInteger -> II32-                        RcFloat   -> FF32-                        RcDouble  -> FF64--    in [ST fmt reg (fpRel (negate off_w))]----- | Make a spill reload instruction.-mkLoadInstr-    :: NCGConfig-    -> Reg      -- ^ register to load into-    -> Int      -- ^ current stack delta-    -> Int      -- ^ spill slot to use-    -> [Instr]--mkLoadInstr config reg _ slot-  = let platform = ncgPlatform config-        off      = spillSlotToOffset config slot-        off_w    = 1 + (off `div` 4)-        fmt      = case targetClassOfReg platform reg of-                        RcInteger -> II32-                        RcFloat   -> FF32-                        RcDouble  -> FF64--        in [LD fmt (fpRel (- off_w)) reg]-------------------------------------------------------------------------------------- | See if this instruction is telling us the current C stack delta-takeDeltaInstr-        :: Instr-        -> Maybe Int--takeDeltaInstr instr- = case instr of-        DELTA i         -> Just i-        _               -> Nothing---isMetaInstr-        :: Instr-        -> Bool--isMetaInstr instr- = case instr of-        COMMENT{}       -> True-        LDATA{}         -> True-        NEWBLOCK{}      -> True-        DELTA{}         -> True-        _               -> False----- | Make a reg-reg move instruction.---      On SPARC v8 there are no instructions to move directly between---      floating point and integer regs. If we need to do that then we---      have to go via memory.----mkRegRegMoveInstr-    :: Platform-    -> Reg-    -> Reg-    -> Instr--mkRegRegMoveInstr platform src dst-        | srcClass      <- targetClassOfReg platform src-        , dstClass      <- targetClassOfReg platform dst-        , srcClass == dstClass-        = case srcClass of-                RcInteger -> ADD  False False src (RIReg g0) dst-                RcDouble  -> FMOV FF64 src dst-                RcFloat   -> FMOV FF32 src dst--        | otherwise-        = panic "SPARC.Instr.mkRegRegMoveInstr: classes of src and dest not the same"----- | Check whether an instruction represents a reg-reg move.---      The register allocator attempts to eliminate reg->reg moves whenever it can,---      by assigning the src and dest temporaries to the same real register.----takeRegRegMoveInstr :: Instr -> Maybe (Reg,Reg)-takeRegRegMoveInstr instr- = case instr of-        ADD False False src (RIReg src2) dst-         | g0 == src2           -> Just (src, dst)--        FMOV FF64 src dst       -> Just (src, dst)-        FMOV FF32  src dst      -> Just (src, dst)-        _                       -> Nothing----- | Make an unconditional branch instruction.-mkJumpInstr-        :: BlockId-        -> [Instr]--mkJumpInstr id- =       [BI ALWAYS False id-        , NOP]                  -- fill the branch delay slot.
− compiler/GHC/CmmToAsm/SPARC/Ppr.hs 
@@ -1,667 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-------------------------------------------------------------------------------------- Pretty-printing assembly language------ (c) The University of Glasgow 1993-2005-----------------------------------------------------------------------------------{-# OPTIONS_GHC -fno-warn-orphans #-}-module GHC.CmmToAsm.SPARC.Ppr (-        pprNatCmmDecl,-        pprBasicBlock,-        pprData,-        pprInstr,-        pprFormat,-        pprImm,-        pprDataItem-)--where--#include "GhclibHsVersions.h"--import GHC.Prelude--import Data.Word-import qualified Data.Array.Unsafe as U ( castSTUArray )-import Data.Array.ST--import Control.Monad.ST--import GHC.CmmToAsm.SPARC.Regs-import GHC.CmmToAsm.SPARC.Instr-import GHC.CmmToAsm.SPARC.Cond-import GHC.CmmToAsm.SPARC.Imm-import GHC.CmmToAsm.SPARC.AddrMode-import GHC.CmmToAsm.SPARC.Base-import GHC.Platform.Reg-import GHC.CmmToAsm.Format-import GHC.CmmToAsm.Ppr-import GHC.CmmToAsm.Config-import GHC.CmmToAsm.Types-import GHC.CmmToAsm.Utils--import GHC.Cmm hiding (topInfoTable)-import GHC.Cmm.Ppr() -- For Outputable instances-import GHC.Cmm.BlockId-import GHC.Cmm.CLabel-import GHC.Cmm.Dataflow.Label-import GHC.Cmm.Dataflow.Collections--import GHC.Types.Unique ( pprUniqueAlways )-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Platform-import GHC.Data.FastString---- -------------------------------------------------------------------------------- Printing this stuff out--pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> SDoc-pprNatCmmDecl config (CmmData section dats) =-  pprSectionAlign config section-  $$ pprDatas (ncgPlatform config) dats--pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =-  let platform = ncgPlatform config in-  case topInfoTable proc of-    Nothing ->-        -- special case for code without info table:-        pprSectionAlign config (Section Text lbl) $$-        pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed-        vcat (map (pprBasicBlock platform top_info) blocks)--    Just (CmmStaticsRaw info_lbl _) ->-      (if platformHasSubsectionsViaSymbols platform-          then pprSectionAlign config dspSection $$-               pdoc platform (mkDeadStripPreventer info_lbl) <> char ':'-          else empty) $$-      vcat (map (pprBasicBlock platform top_info) blocks) $$-      -- above: Even the first block gets a label, because with branch-chain-      -- elimination, it might be the target of a goto.-      (if platformHasSubsectionsViaSymbols platform-       then-       -- See Note [Subsections Via Symbols] in X86/Ppr.hs-                text "\t.long "-            <+> pdoc platform info_lbl-            <+> char '-'-            <+> pdoc platform (mkDeadStripPreventer info_lbl)-       else empty)--dspSection :: Section-dspSection = Section Text $-    panic "subsections-via-symbols doesn't combine with split-sections"--pprBasicBlock :: Platform -> LabelMap RawCmmStatics -> NatBasicBlock Instr -> SDoc-pprBasicBlock platform info_env (BasicBlock blockid instrs)-  = maybe_infotable $$-    pprLabel platform (blockLbl blockid) $$-    vcat (map (pprInstr platform) instrs)-  where-    maybe_infotable = case mapLookup blockid info_env of-       Nothing   -> empty-       Just (CmmStaticsRaw info_lbl info) ->-           pprAlignForSection Text $$-           vcat (map (pprData platform) info) $$-           pprLabel platform info_lbl---pprDatas :: Platform -> RawCmmStatics -> SDoc--- See note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel".-pprDatas platform (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])-  | lbl == mkIndStaticInfoLabel-  , let labelInd (CmmLabelOff l _) = Just l-        labelInd (CmmLabel l) = Just l-        labelInd _ = Nothing-  , Just ind' <- labelInd ind-  , alias `mayRedirectTo` ind'-  = pprGloblDecl platform alias-    $$ text ".equiv" <+> pdoc platform alias <> comma <> pdoc platform (CmmLabel ind')-pprDatas platform (CmmStaticsRaw lbl dats) = vcat (pprLabel platform lbl : map (pprData platform) dats)--pprData :: Platform -> CmmStatic -> SDoc-pprData platform d = case d of-   CmmString str          -> pprString str-   CmmFileEmbed path      -> pprFileEmbed path-   CmmUninitialised bytes -> text ".skip " <> int bytes-   CmmStaticLit lit       -> pprDataItem platform lit--pprGloblDecl :: Platform -> CLabel -> SDoc-pprGloblDecl platform lbl-  | not (externallyVisibleCLabel lbl) = empty-  | otherwise = text ".global " <> pdoc platform lbl--pprTypeAndSizeDecl :: Platform -> CLabel -> SDoc-pprTypeAndSizeDecl platform lbl-    = if platformOS platform == OSLinux && externallyVisibleCLabel lbl-      then text ".type " <> pdoc platform lbl <> ptext (sLit ", @object")-      else empty--pprLabel :: Platform -> CLabel -> SDoc-pprLabel platform lbl =-   pprGloblDecl platform lbl-   $$ pprTypeAndSizeDecl platform lbl-   $$ (pdoc platform lbl <> char ':')---- -------------------------------------------------------------------------------- pprInstr: print an 'Instr'--instance OutputableP Platform Instr where-    pdoc = pprInstr----- | Pretty print a register.-pprReg :: Reg -> SDoc-pprReg reg- = case reg of-        RegVirtual vr-         -> case vr of-                VirtualRegI   u -> text "%vI_"   <> pprUniqueAlways u-                VirtualRegHi  u -> text "%vHi_"  <> pprUniqueAlways u-                VirtualRegF   u -> text "%vF_"   <> pprUniqueAlways u-                VirtualRegD   u -> text "%vD_"   <> pprUniqueAlways u---        RegReal rr-         -> case rr of-                RealRegSingle r1-                 -> pprReg_ofRegNo r1--                RealRegPair r1 r2-                 -> text "(" <> pprReg_ofRegNo r1-                 <> vbar     <> pprReg_ofRegNo r2-                 <> text ")"------ | Pretty print a register name, based on this register number.---   The definition has been unfolded so we get a jump-table in the---   object code. This function is called quite a lot when emitting---   the asm file..----pprReg_ofRegNo :: Int -> SDoc-pprReg_ofRegNo i- = ptext-    (case i of {-         0 -> sLit "%g0";   1 -> sLit "%g1";-         2 -> sLit "%g2";   3 -> sLit "%g3";-         4 -> sLit "%g4";   5 -> sLit "%g5";-         6 -> sLit "%g6";   7 -> sLit "%g7";-         8 -> sLit "%o0";   9 -> sLit "%o1";-        10 -> sLit "%o2";  11 -> sLit "%o3";-        12 -> sLit "%o4";  13 -> sLit "%o5";-        14 -> sLit "%o6";  15 -> sLit "%o7";-        16 -> sLit "%l0";  17 -> sLit "%l1";-        18 -> sLit "%l2";  19 -> sLit "%l3";-        20 -> sLit "%l4";  21 -> sLit "%l5";-        22 -> sLit "%l6";  23 -> sLit "%l7";-        24 -> sLit "%i0";  25 -> sLit "%i1";-        26 -> sLit "%i2";  27 -> sLit "%i3";-        28 -> sLit "%i4";  29 -> sLit "%i5";-        30 -> sLit "%i6";  31 -> sLit "%i7";-        32 -> sLit "%f0";  33 -> sLit "%f1";-        34 -> sLit "%f2";  35 -> sLit "%f3";-        36 -> sLit "%f4";  37 -> sLit "%f5";-        38 -> sLit "%f6";  39 -> sLit "%f7";-        40 -> sLit "%f8";  41 -> sLit "%f9";-        42 -> sLit "%f10"; 43 -> sLit "%f11";-        44 -> sLit "%f12"; 45 -> sLit "%f13";-        46 -> sLit "%f14"; 47 -> sLit "%f15";-        48 -> sLit "%f16"; 49 -> sLit "%f17";-        50 -> sLit "%f18"; 51 -> sLit "%f19";-        52 -> sLit "%f20"; 53 -> sLit "%f21";-        54 -> sLit "%f22"; 55 -> sLit "%f23";-        56 -> sLit "%f24"; 57 -> sLit "%f25";-        58 -> sLit "%f26"; 59 -> sLit "%f27";-        60 -> sLit "%f28"; 61 -> sLit "%f29";-        62 -> sLit "%f30"; 63 -> sLit "%f31";-        _  -> sLit "very naughty sparc register" })----- | Pretty print a format for an instruction suffix.-pprFormat :: Format -> SDoc-pprFormat x- = ptext-    (case x of-        II8     -> sLit "ub"-        II16    -> sLit "uh"-        II32    -> sLit ""-        II64    -> sLit "d"-        FF32    -> sLit ""-        FF64    -> sLit "d")----- | Pretty print a format for an instruction suffix.---      eg LD is 32bit on sparc, but LDD is 64 bit.-pprStFormat :: Format -> SDoc-pprStFormat x- = ptext-    (case x of-        II8   -> sLit "b"-        II16  -> sLit "h"-        II32  -> sLit ""-        II64  -> sLit "x"-        FF32  -> sLit ""-        FF64  -> sLit "d")------ | Pretty print a condition code.-pprCond :: Cond -> SDoc-pprCond c- = ptext-    (case c of-        ALWAYS  -> sLit ""-        NEVER   -> sLit "n"-        GEU     -> sLit "geu"-        LU      -> sLit "lu"-        EQQ     -> sLit "e"-        GTT     -> sLit "g"-        GE      -> sLit "ge"-        GU      -> sLit "gu"-        LTT     -> sLit "l"-        LE      -> sLit "le"-        LEU     -> sLit "leu"-        NE      -> sLit "ne"-        NEG     -> sLit "neg"-        POS     -> sLit "pos"-        VC      -> sLit "vc"-        VS      -> sLit "vs")----- | Pretty print an address mode.-pprAddr :: Platform -> AddrMode -> SDoc-pprAddr platform am- = case am of-        AddrRegReg r1 (RegReal (RealRegSingle 0))-         -> pprReg r1--        AddrRegReg r1 r2-         -> hcat [ pprReg r1, char '+', pprReg r2 ]--        AddrRegImm r1 (ImmInt i)-         | i == 0               -> pprReg r1-         | not (fits13Bits i)   -> largeOffsetError i-         | otherwise            -> hcat [ pprReg r1, pp_sign, int i ]-         where-                pp_sign = if i > 0 then char '+' else empty--        AddrRegImm r1 (ImmInteger i)-         | i == 0               -> pprReg r1-         | not (fits13Bits i)   -> largeOffsetError i-         | otherwise            -> hcat [ pprReg r1, pp_sign, integer i ]-         where-                pp_sign = if i > 0 then char '+' else empty--        AddrRegImm r1 imm-         -> hcat [ pprReg r1, char '+', pprImm platform imm ]----- | Pretty print an immediate value.-pprImm :: Platform -> Imm -> SDoc-pprImm platform imm- = case imm of-        ImmInt i        -> int i-        ImmInteger i    -> integer i-        ImmCLbl l       -> pdoc platform l-        ImmIndex l i    -> pdoc platform l <> char '+' <> int i-        ImmLit s        -> s--        ImmConstantSum a b-         -> pprImm platform a <> char '+' <> pprImm platform b--        ImmConstantDiff a b-         -> pprImm platform a <> char '-' <> lparen <> pprImm platform b <> rparen--        LO i-         -> hcat [ text "%lo(", pprImm platform i, rparen ]--        HI i-         -> hcat [ text "%hi(", pprImm platform i, rparen ]--        -- these should have been converted to bytes and placed-        --      in the data section.-        ImmFloat _      -> text "naughty float immediate"-        ImmDouble _     -> text "naughty double immediate"----- | Pretty print a section \/ segment header.---      On SPARC all the data sections must be at least 8 byte aligned---      incase we store doubles in them.----pprSectionAlign :: NCGConfig -> Section -> SDoc-pprSectionAlign config sec@(Section seg _) =-    pprSectionHeader config sec $$-    pprAlignForSection seg---- | Print appropriate alignment for the given section type.-pprAlignForSection :: SectionType -> SDoc-pprAlignForSection seg =-    ptext (case seg of-      Text              -> sLit ".align 4"-      Data              -> sLit ".align 8"-      ReadOnlyData      -> sLit ".align 8"-      RelocatableReadOnlyData-                        -> sLit ".align 8"-      UninitialisedData -> sLit ".align 8"-      ReadOnlyData16    -> sLit ".align 16"-      -- TODO: This is copied from the ReadOnlyData case, but it can likely be-      -- made more efficient.-      CString           -> sLit ".align 8"-      OtherSection _    -> panic "PprMach.pprSectionHeader: unknown section")---- | Pretty print a data item.-pprDataItem :: Platform -> CmmLit -> SDoc-pprDataItem platform lit-  = vcat (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit)-    where-        imm = litToImm lit--        ppr_item II8   _        = [text "\t.byte\t" <> pprImm platform imm]-        ppr_item II32  _        = [text "\t.long\t" <> pprImm platform imm]--        ppr_item FF32  (CmmFloat r _)-         = let bs = floatToBytes (fromRational r)-           in  map (\b -> text "\t.byte\t" <> pprImm platform (ImmInt b)) bs--        ppr_item FF64 (CmmFloat r _)-         = let bs = doubleToBytes (fromRational r)-           in  map (\b -> text "\t.byte\t" <> pprImm platform (ImmInt b)) bs--        ppr_item II16  _        = [text "\t.short\t" <> pprImm platform imm]-        ppr_item II64  _        = [text "\t.quad\t"  <> pprImm platform imm]-        ppr_item _ _            = panic "SPARC.Ppr.pprDataItem: no match"--floatToBytes :: Float -> [Int]-floatToBytes f-   = runST (do-        arr <- newArray_ ((0::Int),3)-        writeArray arr 0 f-        arr <- castFloatToWord8Array arr-        i0 <- readArray arr 0-        i1 <- readArray arr 1-        i2 <- readArray arr 2-        i3 <- readArray arr 3-        return (map fromIntegral [i0,i1,i2,i3])-     )--castFloatToWord8Array :: STUArray s Int Float -> ST s (STUArray s Int Word8)-castFloatToWord8Array = U.castSTUArray----- | Pretty print an instruction.-pprInstr :: Platform -> Instr -> SDoc-pprInstr platform = \case-   COMMENT _ -> empty -- nuke comments.-   DELTA d   -> pprInstr platform (COMMENT (mkFastString ("\tdelta = " ++ show d)))--   -- Newblocks and LData should have been slurped out before producing the .s file.-   NEWBLOCK _ -> panic "X86.Ppr.pprInstr: NEWBLOCK"-   LDATA _ _  -> panic "PprMach.pprInstr: LDATA"--   -- 64 bit FP loads are expanded into individual instructions in CodeGen.Expand-   LD FF64 _ reg-        | RegReal (RealRegSingle{})     <- reg-        -> panic "SPARC.Ppr: not emitting potentially misaligned LD FF64 instr"--   LD format addr reg-        -> hcat [-               text "\tld",-               pprFormat format,-               char '\t',-               lbrack,-               pprAddr platform addr,-               pp_rbracket_comma,-               pprReg reg-            ]--   -- 64 bit FP stores are expanded into individual instructions in CodeGen.Expand-   ST FF64 reg _-        | RegReal (RealRegSingle{}) <- reg-        -> panic "SPARC.Ppr: not emitting potentially misaligned ST FF64 instr"--   -- no distinction is made between signed and unsigned bytes on stores for the-   -- Sparc opcodes (at least I cannot see any, and gas is nagging me --SOF),-   -- so we call a special-purpose pprFormat for ST..-   ST format reg addr-        -> hcat [-               text "\tst",-               pprStFormat format,-               char '\t',-               pprReg reg,-               pp_comma_lbracket,-               pprAddr platform addr,-               rbrack-            ]---   ADD x cc reg1 ri reg2-        | not x && not cc && riZero ri-        -> hcat [ text "\tmov\t", pprReg reg1, comma, pprReg reg2 ]--        | otherwise-        -> pprRegRIReg platform (if x then sLit "addx" else sLit "add") cc reg1 ri reg2---   SUB x cc reg1 ri reg2-        | not x && cc && reg2 == g0-        -> hcat [ text "\tcmp\t", pprReg reg1, comma, pprRI platform ri ]--        | not x && not cc && riZero ri-        -> hcat [ text "\tmov\t", pprReg reg1, comma, pprReg reg2 ]--        | otherwise-        -> pprRegRIReg platform (if x then sLit "subx" else sLit "sub") cc reg1 ri reg2--   AND  b reg1 ri reg2 -> pprRegRIReg platform (sLit "and")  b reg1 ri reg2--   ANDN b reg1 ri reg2 -> pprRegRIReg platform (sLit "andn") b reg1 ri reg2--   OR b reg1 ri reg2-        | not b && reg1 == g0-        -> let doit = hcat [ text "\tmov\t", pprRI platform ri, comma, pprReg reg2 ]-           in  case ri of-                   RIReg rrr | rrr == reg2 -> empty-                   _                       -> doit--        | otherwise-        -> pprRegRIReg platform (sLit "or") b reg1 ri reg2--   ORN b reg1 ri reg2 -> pprRegRIReg platform (sLit "orn") b reg1 ri reg2--   XOR  b reg1 ri reg2 -> pprRegRIReg platform (sLit "xor")  b reg1 ri reg2-   XNOR b reg1 ri reg2 -> pprRegRIReg platform (sLit "xnor") b reg1 ri reg2--   SLL reg1 ri reg2 -> pprRegRIReg platform (sLit "sll") False reg1 ri reg2-   SRL reg1 ri reg2 -> pprRegRIReg platform (sLit "srl") False reg1 ri reg2-   SRA reg1 ri reg2 -> pprRegRIReg platform (sLit "sra") False reg1 ri reg2--   RDY rd -> text "\trd\t%y," <> pprReg rd-   WRY reg1 reg2-        -> text "\twr\t"-                <> pprReg reg1-                <> char ','-                <> pprReg reg2-                <> char ','-                <> text "%y"--   SMUL b reg1 ri reg2 -> pprRegRIReg platform (sLit "smul")  b reg1 ri reg2-   UMUL b reg1 ri reg2 -> pprRegRIReg platform (sLit "umul")  b reg1 ri reg2-   SDIV b reg1 ri reg2 -> pprRegRIReg platform (sLit "sdiv")  b reg1 ri reg2-   UDIV b reg1 ri reg2 -> pprRegRIReg platform (sLit "udiv")  b reg1 ri reg2--   SETHI imm reg-      -> hcat [-            text "\tsethi\t",-            pprImm platform imm,-            comma,-            pprReg reg-         ]--   NOP -> text "\tnop"--   FABS format reg1 reg2-        -> pprFormatRegReg (sLit "fabs") format reg1 reg2--   FADD format reg1 reg2 reg3-        -> pprFormatRegRegReg (sLit "fadd") format reg1 reg2 reg3--   FCMP e format reg1 reg2-        -> pprFormatRegReg (if e then sLit "fcmpe" else sLit "fcmp")-                           format reg1 reg2--   FDIV format reg1 reg2 reg3-        -> pprFormatRegRegReg (sLit "fdiv") format reg1 reg2 reg3--   FMOV format reg1 reg2-        -> pprFormatRegReg (sLit "fmov") format reg1 reg2--   FMUL format reg1 reg2 reg3-        -> pprFormatRegRegReg (sLit "fmul") format reg1 reg2 reg3--   FNEG format reg1 reg2-        -> pprFormatRegReg (sLit "fneg") format reg1 reg2--   FSQRT format reg1 reg2-        -> pprFormatRegReg (sLit "fsqrt") format reg1 reg2--   FSUB format reg1 reg2 reg3-        -> pprFormatRegRegReg (sLit "fsub") format reg1 reg2 reg3--   FxTOy format1 format2 reg1 reg2-      -> hcat [-            text "\tf",-            ptext-            (case format1 of-                II32  -> sLit "ito"-                FF32  -> sLit "sto"-                FF64  -> sLit "dto"-                _     -> panic "SPARC.Ppr.pprInstr.FxToY: no match"),-            ptext-            (case format2 of-                II32  -> sLit "i\t"-                II64  -> sLit "x\t"-                FF32  -> sLit "s\t"-                FF64  -> sLit "d\t"-                _     -> panic "SPARC.Ppr.pprInstr.FxToY: no match"),-            pprReg reg1, comma, pprReg reg2-         ]---   BI cond b blockid-      -> hcat [-            text "\tb", pprCond cond,-            if b then pp_comma_a else empty,-            char '\t',-            pdoc platform (blockLbl blockid)-         ]--   BF cond b blockid-      -> hcat [-            text "\tfb", pprCond cond,-            if b then pp_comma_a else empty,-            char '\t',-            pdoc platform (blockLbl blockid)-         ]--   JMP addr -> text "\tjmp\t" <> pprAddr platform addr-   JMP_TBL op _ _ -> pprInstr platform (JMP op)--   CALL (Left imm) n _-      -> hcat [ text "\tcall\t", pprImm platform imm, comma, int n ]--   CALL (Right reg) n _-      -> hcat [ text "\tcall\t", pprReg reg, comma, int n ]----- | Pretty print a RI-pprRI :: Platform -> RI -> SDoc-pprRI platform = \case-   RIReg r -> pprReg r-   RIImm r -> pprImm platform r----- | Pretty print a two reg instruction.-pprFormatRegReg :: PtrString -> Format -> Reg -> Reg -> SDoc-pprFormatRegReg name format reg1 reg2-  = hcat [-        char '\t',-        ptext name,-        (case format of-            FF32 -> text "s\t"-            FF64 -> text "d\t"-            _    -> panic "SPARC.Ppr.pprFormatRegReg: no match"),--        pprReg reg1,-        comma,-        pprReg reg2-    ]----- | Pretty print a three reg instruction.-pprFormatRegRegReg :: PtrString -> Format -> Reg -> Reg -> Reg -> SDoc-pprFormatRegRegReg name format reg1 reg2 reg3-  = hcat [-        char '\t',-        ptext name,-        (case format of-            FF32  -> text "s\t"-            FF64  -> text "d\t"-            _    -> panic "SPARC.Ppr.pprFormatRegReg: no match"),-        pprReg reg1,-        comma,-        pprReg reg2,-        comma,-        pprReg reg3-    ]----- | Pretty print an instruction of two regs and a ri.-pprRegRIReg :: Platform -> PtrString -> Bool -> Reg -> RI -> Reg -> SDoc-pprRegRIReg platform name b reg1 ri reg2-  = hcat [-        char '\t',-        ptext name,-        if b then text "cc\t" else char '\t',-        pprReg reg1,-        comma,-        pprRI platform ri,-        comma,-        pprReg reg2-    ]--{--pprRIReg :: PtrString -> Bool -> RI -> Reg -> SDoc-pprRIReg name b ri reg1-  = hcat [-        char '\t',-        ptext name,-        if b then text "cc\t" else char '\t',-        pprRI ri,-        comma,-        pprReg reg1-    ]--}--{--pp_ld_lbracket :: SDoc-pp_ld_lbracket    = text "\tld\t["--}--pp_rbracket_comma :: SDoc-pp_rbracket_comma = text "],"---pp_comma_lbracket :: SDoc-pp_comma_lbracket = text ",["---pp_comma_a :: SDoc-pp_comma_a        = text ",a"
− compiler/GHC/CmmToAsm/SPARC/Regs.hs 
@@ -1,260 +0,0 @@--- ----------------------------------------------------------------------------------- (c) The University of Glasgow 1994-2004------ -------------------------------------------------------------------------------module GHC.CmmToAsm.SPARC.Regs (-        -- registers-        showReg,-        virtualRegSqueeze,-        realRegSqueeze,-        classOfRealReg,-        allRealRegs,--        -- machine specific info-        gReg, iReg, lReg, oReg, fReg,-        fp, sp, g0, g1, g2, o0, o1, f0, f1, f6, f8, f22, f26, f27,--        -- allocatable-        allocatableRegs,--        -- args-        argRegs,-        allArgRegs,-        callClobberedRegs,--        ---        mkVirtualReg,-        regDotColor-)--where---import GHC.Prelude--import GHC.Platform.SPARC-import GHC.Platform.Reg-import GHC.Platform.Reg.Class-import GHC.CmmToAsm.Format--import GHC.Types.Unique-import GHC.Utils.Outputable-import GHC.Utils.Panic--{--        The SPARC has 64 registers of interest; 32 integer registers and 32-        floating point registers.  The mapping of STG registers to SPARC-        machine registers is defined in StgRegs.h.  We are, of course,-        prepared for any eventuality.--        The whole fp-register pairing thing on sparcs is a huge nuisance.  See-        includes/stg/MachRegs.h for a description of what's going on-        here.--}----- | Get the standard name for the register with this number.-showReg :: RegNo -> String-showReg n-        | n >= 0  && n < 8   = "%g" ++ show n-        | n >= 8  && n < 16  = "%o" ++ show (n-8)-        | n >= 16 && n < 24  = "%l" ++ show (n-16)-        | n >= 24 && n < 32  = "%i" ++ show (n-24)-        | n >= 32 && n < 64  = "%f" ++ show (n-32)-        | otherwise          = panic "SPARC.Regs.showReg: unknown sparc register"----- Get the register class of a certain real reg-classOfRealReg :: RealReg -> RegClass-classOfRealReg reg- = case reg of-        RealRegSingle i-                | i < 32        -> RcInteger-                | otherwise     -> RcFloat--        RealRegPair{}           -> RcDouble----- | regSqueeze_class reg---      Calculate the maximum number of register colors that could be---      denied to a node of this class due to having this reg---      as a neighbour.----{-# INLINE virtualRegSqueeze #-}-virtualRegSqueeze :: RegClass -> VirtualReg -> Int--virtualRegSqueeze cls vr- = case cls of-        RcInteger-         -> case vr of-                VirtualRegI{}           -> 1-                VirtualRegHi{}          -> 1-                _other                  -> 0--        RcFloat-         -> case vr of-                VirtualRegF{}           -> 1-                VirtualRegD{}           -> 2-                _other                  -> 0--        RcDouble-         -> case vr of-                VirtualRegF{}           -> 1-                VirtualRegD{}           -> 1-                _other                  -> 0---{-# INLINE realRegSqueeze #-}-realRegSqueeze :: RegClass -> RealReg -> Int--realRegSqueeze cls rr- = case cls of-        RcInteger-         -> case rr of-                RealRegSingle regNo-                        | regNo < 32    -> 1-                        | otherwise     -> 0--                RealRegPair{}           -> 0--        RcFloat-         -> case rr of-                RealRegSingle regNo-                        | regNo < 32    -> 0-                        | otherwise     -> 1--                RealRegPair{}           -> 2--        RcDouble-         -> case rr of-                RealRegSingle regNo-                        | regNo < 32    -> 0-                        | otherwise     -> 1--                RealRegPair{}           -> 1----- | All the allocatable registers in the machine,---      including register pairs.-allRealRegs :: [RealReg]-allRealRegs-        =  [ (RealRegSingle i)          | i <- [0..63] ]-        ++ [ (RealRegPair   i (i+1))    | i <- [32, 34 .. 62 ] ]----- | Get the regno for this sort of reg-gReg, lReg, iReg, oReg, fReg :: Int -> RegNo--gReg x  = x             -- global regs-oReg x  = (8 + x)       -- output regs-lReg x  = (16 + x)      -- local regs-iReg x  = (24 + x)      -- input regs-fReg x  = (32 + x)      -- float regs----- | Some specific regs used by the code generator.-g0, g1, g2, fp, sp, o0, o1, f0, f1, f6, f8, f22, f26, f27 :: Reg--f6  = RegReal (RealRegSingle (fReg 6))-f8  = RegReal (RealRegSingle (fReg 8))-f22 = RegReal (RealRegSingle (fReg 22))-f26 = RegReal (RealRegSingle (fReg 26))-f27 = RegReal (RealRegSingle (fReg 27))---- g0 is always zero, and writes to it vanish.-g0  = RegReal (RealRegSingle (gReg 0))-g1  = RegReal (RealRegSingle (gReg 1))-g2  = RegReal (RealRegSingle (gReg 2))---- FP, SP, int and float return (from C) regs.-fp  = RegReal (RealRegSingle (iReg 6))-sp  = RegReal (RealRegSingle (oReg 6))-o0  = RegReal (RealRegSingle (oReg 0))-o1  = RegReal (RealRegSingle (oReg 1))-f0  = RegReal (RealRegSingle (fReg 0))-f1  = RegReal (RealRegSingle (fReg 1))---- | Produce the second-half-of-a-double register given the first half.-{--fPair :: Reg -> Maybe Reg-fPair (RealReg n)-        | n >= 32 && n `mod` 2 == 0  = Just (RealReg (n+1))--fPair (VirtualRegD u)-        = Just (VirtualRegHi u)--fPair reg-        = trace ("MachInstrs.fPair: can't get high half of supposed double reg " ++ showPpr reg)-                Nothing--}----- | All the regs that the register allocator can allocate to,---      with the fixed use regs removed.----allocatableRegs :: [RealReg]-allocatableRegs-   = let isFree rr-           = case rr of-                RealRegSingle r     -> freeReg r-                RealRegPair   r1 r2 -> freeReg r1 && freeReg r2-     in filter isFree allRealRegs----- | The registers to place arguments for function calls,---      for some number of arguments.----argRegs :: RegNo -> [Reg]-argRegs r- = case r of-        0       -> []-        1       -> map (RegReal . RealRegSingle . oReg) [0]-        2       -> map (RegReal . RealRegSingle . oReg) [0,1]-        3       -> map (RegReal . RealRegSingle . oReg) [0,1,2]-        4       -> map (RegReal . RealRegSingle . oReg) [0,1,2,3]-        5       -> map (RegReal . RealRegSingle . oReg) [0,1,2,3,4]-        6       -> map (RegReal . RealRegSingle . oReg) [0,1,2,3,4,5]-        _       -> panic "MachRegs.argRegs(sparc): don't know about >6 arguments!"----- | All the regs that could possibly be returned by argRegs----allArgRegs :: [Reg]-allArgRegs-        = map (RegReal . RealRegSingle) [oReg i | i <- [0..5]]----- These are the regs that we cannot assume stay alive over a C call.---      TODO: Why can we assume that o6 isn't clobbered? -- BL 2009/02----callClobberedRegs :: [Reg]-callClobberedRegs-        = map (RegReal . RealRegSingle)-                (  oReg 7 :-                  [oReg i | i <- [0..5]] ++-                  [gReg i | i <- [1..7]] ++-                  [fReg i | i <- [0..31]] )------ | Make a virtual reg with this format.-mkVirtualReg :: Unique -> Format -> VirtualReg-mkVirtualReg u format-        | not (isFloatFormat format)-        = VirtualRegI u--        | otherwise-        = case format of-                FF32    -> VirtualRegF u-                FF64    -> VirtualRegD u-                _       -> panic "mkVReg"---regDotColor :: RealReg -> SDoc-regDotColor reg- = case classOfRealReg reg of-        RcInteger       -> text "blue"-        RcFloat         -> text "red"-        _other          -> text "green"
− compiler/GHC/CmmToAsm/SPARC/ShortcutJump.hs 
@@ -1,74 +0,0 @@-module GHC.CmmToAsm.SPARC.ShortcutJump (-        JumpDest(..), getJumpDestBlockId,-        canShortcut,-        shortcutJump,-        shortcutStatics,-        shortBlockId-)--where--import GHC.Prelude--import GHC.CmmToAsm.SPARC.Instr-import GHC.CmmToAsm.SPARC.Imm--import GHC.Cmm.CLabel-import GHC.Cmm.BlockId-import GHC.Cmm--import GHC.Utils.Panic-import GHC.Utils.Outputable--data JumpDest-        = DestBlockId BlockId-        | DestImm Imm---- Debug Instance-instance Outputable JumpDest where-  ppr (DestBlockId bid) = text "blk:" <> ppr bid-  ppr (DestImm _bid)    = text "imm:?"--getJumpDestBlockId :: JumpDest -> Maybe BlockId-getJumpDestBlockId (DestBlockId bid) = Just bid-getJumpDestBlockId _                 = Nothing---canShortcut :: Instr -> Maybe JumpDest-canShortcut _ = Nothing---shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr-shortcutJump _ other = other----shortcutStatics :: (BlockId -> Maybe JumpDest) -> RawCmmStatics -> RawCmmStatics-shortcutStatics fn (CmmStaticsRaw lbl statics)-  = CmmStaticsRaw lbl $ map (shortcutStatic fn) statics-  -- we need to get the jump tables, so apply the mapping to the entries-  -- of a CmmData too.--shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel-shortcutLabel fn lab-  | Just blkId <- maybeLocalBlockLabel lab = shortBlockId fn blkId-  | otherwise                              = lab--shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic-shortcutStatic fn (CmmStaticLit (CmmLabel lab))-        = CmmStaticLit (CmmLabel (shortcutLabel fn lab))-shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off w))-        = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off w)--- slightly dodgy, we're ignoring the second label, but this--- works with the way we use CmmLabelDiffOff for jump tables now.-shortcutStatic _ other_static-        = other_static---shortBlockId :: (BlockId -> Maybe JumpDest) -> BlockId -> CLabel-shortBlockId fn blockid =-   case fn blockid of-      Nothing -> blockLbl blockid-      Just (DestBlockId blockid')  -> shortBlockId fn blockid'-      Just (DestImm (ImmCLbl lbl)) -> lbl-      _other -> panic "shortBlockId"
− compiler/GHC/CmmToAsm/SPARC/Stack.hs 
@@ -1,60 +0,0 @@-module GHC.CmmToAsm.SPARC.Stack (-        spRel,-        fpRel,-        spillSlotToOffset,-        maxSpillSlots-)--where--import GHC.Prelude--import GHC.CmmToAsm.SPARC.AddrMode-import GHC.CmmToAsm.SPARC.Regs-import GHC.CmmToAsm.SPARC.Base-import GHC.CmmToAsm.SPARC.Imm-import GHC.CmmToAsm.Config--import GHC.Utils.Outputable-import GHC.Utils.Panic---- | Get an AddrMode relative to the address in sp.---      This gives us a stack relative addressing mode for volatile---      temporaries and for excess call arguments.----spRel :: Int            -- ^ stack offset in words, positive or negative-      -> AddrMode--spRel n = AddrRegImm sp (ImmInt (n * wordLength))----- | Get an address relative to the frame pointer.---      This doesn't work work for offsets greater than 13 bits; we just hope for the best----fpRel :: Int -> AddrMode-fpRel n-        = AddrRegImm fp (ImmInt (n * wordLength))----- | Convert a spill slot number to a *byte* offset, with no sign.----spillSlotToOffset :: NCGConfig -> Int -> Int-spillSlotToOffset config slot-        | slot >= 0 && slot < maxSpillSlots config-        = 64 + spillSlotSize * slot--        | otherwise-        = pprPanic "spillSlotToOffset:"-                      (   text "invalid spill location: " <> int slot-                      $$  text "maxSpillSlots:          " <> int (maxSpillSlots config))----- | The maximum number of spill slots available on the C stack.---      If we use up all of the slots, then we're screwed.------      Why do we reserve 64 bytes, instead of using the whole thing??---              -- BL 2009/02/15----maxSpillSlots :: NCGConfig -> Int-maxSpillSlots config-        = ((ncgSpillPreallocSize config - 64) `div` spillSlotSize) - 1
compiler/GHC/CmmToAsm/X86.hs view
@@ -37,7 +37,6 @@    , maxSpillSlots             = X86.maxSpillSlots config    , allocatableRegs           = X86.allocatableRegs platform    , ncgAllocMoreStack         = X86.allocMoreStack platform-   , ncgExpandTop              = id    , ncgMakeFarBranches        = const id    , extractUnwindPoints       = X86.extractUnwindPoints    , invertCondBranches        = X86.invertCondBranches@@ -62,4 +61,4 @@    mkStackAllocInstr       = X86.mkStackAllocInstr    mkStackDeallocInstr     = X86.mkStackDeallocInstr    pprInstr                = X86.pprInstr-   mkComment               = const []+   mkComment               = pure . X86.COMMENT
compiler/GHC/CmmToAsm/X86/CodeGen.hs view
@@ -1,3977 +1,4395 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE TupleSections #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}------------------------------------------------------------------------------------- Generating machine code (instruction selection)------ (c) The University of Glasgow 1996-2004------------------------------------------------------------------------------------- This is a big module, but, if you pay attention to--- (a) the sectioning, and (b) the type signatures, the--- structure should not be too overwhelming.--module GHC.CmmToAsm.X86.CodeGen (-        cmmTopCodeGen,-        generateJumpTableForInstr,-        extractUnwindPoints,-        invertCondBranches,-        InstrBlock-)--where--#include "GhclibHsVersions.h"---- NCG stuff:-import GHC.Prelude--import GHC.CmmToAsm.X86.Instr-import GHC.CmmToAsm.X86.Cond-import GHC.CmmToAsm.X86.Regs-import GHC.CmmToAsm.X86.Ppr-import GHC.CmmToAsm.X86.RegInfo--import GHC.Platform.Regs-import GHC.CmmToAsm.CPrim-import GHC.CmmToAsm.Types-import GHC.Cmm.DebugBlock-   ( DebugBlock(..), UnwindPoint(..), UnwindTable-   , UnwindExpr(UwReg), toUnwindExpr-   )-import GHC.CmmToAsm.PIC-import GHC.CmmToAsm.Monad-   ( NatM, getNewRegNat, getNewLabelNat, setDeltaNat-   , getDeltaNat, getBlockIdNat, getPicBaseNat, getNewRegPairNat-   , getPicBaseMaybeNat, getDebugBlock, getFileId-   , addImmediateSuccessorNat, updateCfgNat, getConfig, getPlatform-   , getCfgWeights-   )-import GHC.CmmToAsm.CFG-import GHC.CmmToAsm.Format-import GHC.CmmToAsm.Config-import GHC.Platform.Reg-import GHC.Platform---- Our intermediate code:-import GHC.Types.Basic-import GHC.Cmm.BlockId-import GHC.Unit.Types ( primUnitId )-import GHC.Cmm.Utils-import GHC.Cmm.Switch-import GHC.Cmm-import GHC.Cmm.Dataflow.Block-import GHC.Cmm.Dataflow.Collections-import GHC.Cmm.Dataflow.Graph-import GHC.Cmm.Dataflow.Label-import GHC.Cmm.CLabel-import GHC.Types.Tickish ( GenTickish(..) )-import GHC.Types.SrcLoc  ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )---- The rest:-import GHC.Types.ForeignCall ( CCallConv(..) )-import GHC.Data.OrdList-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Data.FastString-import GHC.Driver.Session-import GHC.Utils.Misc-import GHC.Types.Unique.Supply ( getUniqueM )--import Control.Monad-import Data.Foldable (fold)-import Data.Int-import Data.Maybe-import Data.Word--import qualified Data.Map as M--is32BitPlatform :: NatM Bool-is32BitPlatform = do-    platform <- getPlatform-    return $ target32Bit platform--sse2Enabled :: NatM Bool-sse2Enabled = do-  config <- getConfig-  return (ncgSseVersion config >= Just SSE2)--sse4_2Enabled :: NatM Bool-sse4_2Enabled = do-  config <- getConfig-  return (ncgSseVersion config >= Just SSE42)--cmmTopCodeGen-        :: RawCmmDecl-        -> NatM [NatCmmDecl (Alignment, RawCmmStatics) Instr]--cmmTopCodeGen (CmmProc info lab live graph) = do-  let blocks = toBlockListEntryFirst graph-  (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks-  picBaseMb <- getPicBaseMaybeNat-  platform <- getPlatform-  let proc = CmmProc info lab live (ListGraph $ concat nat_blocks)-      tops = proc : concat statics-      os   = platformOS platform--  case picBaseMb of-      Just picBase -> initializePicBase_x86 ArchX86 os picBase tops-      Nothing -> return tops--cmmTopCodeGen (CmmData sec dat) =-  return [CmmData sec (mkAlignment 1, dat)]  -- no translation, we just use CmmStatic--{- Note [Verifying basic blocks]-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--   We want to guarantee a few things about the results-   of instruction selection.--   Namely that each basic blocks consists of:-    * A (potentially empty) sequence of straight line instructions-  followed by-    * A (potentially empty) sequence of jump like instructions.--    We can verify this by going through the instructions and-    making sure that any non-jumpish instruction can't appear-    after a jumpish instruction.--    There are gotchas however:-    * CALLs are strictly speaking control flow but here we care-      not about them. Hence we treat them as regular instructions.--      It's safe for them to appear inside a basic block-      as (ignoring side effects inside the call) they will result in-      straight line code.--    * NEWBLOCK marks the start of a new basic block so can-      be followed by any instructions.--}---- Verifying basic blocks is cheap, but not cheap enough to enable it unconditionally.-verifyBasicBlock :: Platform -> [Instr] -> ()-verifyBasicBlock platform instrs-  | debugIsOn     = go False instrs-  | otherwise     = ()-  where-    go _     [] = ()-    go atEnd (i:instr)-        = case i of-            -- Start a new basic block-            NEWBLOCK {} -> go False instr-            -- Calls are not viable block terminators-            CALL {}     | atEnd -> faultyBlockWith i-                        | not atEnd -> go atEnd instr-            -- All instructions ok, check if we reached the end and continue.-            _ | not atEnd -> go (isJumpishInstr i) instr-              -- Only jumps allowed at the end of basic blocks.-              | otherwise -> if isJumpishInstr i-                                then go True instr-                                else faultyBlockWith i-    faultyBlockWith i-        = pprPanic "Non control flow instructions after end of basic block."-                   (pprInstr platform i <+> text "in:" $$ vcat (map (pprInstr platform) instrs))--basicBlockCodeGen-        :: CmmBlock-        -> NatM ( [NatBasicBlock Instr]-                , [NatCmmDecl (Alignment, RawCmmStatics) Instr])--basicBlockCodeGen block = do-  let (_, nodes, tail)  = blockSplit block-      id = entryLabel block-      stmts = blockToList nodes-  -- Generate location directive-  dbg <- getDebugBlock (entryLabel block)-  loc_instrs <- case dblSourceTick =<< dbg of-    Just (SourceNote span name)-      -> do fileId <- getFileId (srcSpanFile span)-            let line = srcSpanStartLine span; col = srcSpanStartCol span-            return $ unitOL $ LOCATION fileId line col name-    _ -> return nilOL-  (mid_instrs,mid_bid) <- stmtsToInstrs id stmts-  (!tail_instrs,_) <- stmtToInstrs mid_bid tail-  let instrs = loc_instrs `appOL` mid_instrs `appOL` tail_instrs-  platform <- getPlatform-  return $! verifyBasicBlock platform (fromOL instrs)-  instrs' <- fold <$> traverse addSpUnwindings instrs-  -- code generation may introduce new basic block boundaries, which-  -- are indicated by the NEWBLOCK instruction.  We must split up the-  -- instruction stream into basic blocks again.  Also, we extract-  -- LDATAs here too.-  let-        (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs'--        mkBlocks (NEWBLOCK id) (instrs,blocks,statics)-          = ([], BasicBlock id instrs : blocks, statics)-        mkBlocks (LDATA sec dat) (instrs,blocks,statics)-          = (instrs, blocks, CmmData sec dat:statics)-        mkBlocks instr (instrs,blocks,statics)-          = (instr:instrs, blocks, statics)-  return (BasicBlock id top : other_blocks, statics)---- | Convert 'DELTA' instructions into 'UNWIND' instructions to capture changes--- in the @sp@ register. See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock"--- for details.-addSpUnwindings :: Instr -> NatM (OrdList Instr)-addSpUnwindings instr@(DELTA d) = do-    config <- getConfig-    if ncgDwarfUnwindings config-        then do lbl <- mkAsmTempLabel <$> getUniqueM-                let unwind = M.singleton MachSp (Just $ UwReg MachSp $ negate d)-                return $ toOL [ instr, UNWIND lbl unwind ]-        else return (unitOL instr)-addSpUnwindings instr = return $ unitOL instr--{- Note [Keeping track of the current block]-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--When generating instructions for Cmm we sometimes require-the current block for things like retry loops.--We also sometimes change the current block, if a MachOP-results in branching control flow.--Issues arise if we have two statements in the same block,-which both depend on the current block id *and* change the-basic block after them. This happens for atomic primops-in the X86 backend where we want to update the CFG data structure-when introducing new basic blocks.--For example in #17334 we got this Cmm code:--        c3Bf: // global-            (_s3t1::I64) = call MO_AtomicRMW W64 AMO_And(_s3sQ::P64 + 88, 18);-            (_s3t4::I64) = call MO_AtomicRMW W64 AMO_Or(_s3sQ::P64 + 88, 0);-            _s3sT::I64 = _s3sV::I64;-            goto c3B1;--This resulted in two new basic blocks being inserted:--        c3Bf:-                movl $18,%vI_n3Bo-                movq 88(%vI_s3sQ),%rax-                jmp _n3Bp-        n3Bp:-                ...-                cmpxchgq %vI_n3Bq,88(%vI_s3sQ)-                jne _n3Bp-                ...-                jmp _n3Bs-        n3Bs:-                ...-                cmpxchgq %vI_n3Bt,88(%vI_s3sQ)-                jne _n3Bs-                ...-                jmp _c3B1-        ...--Based on the Cmm we called stmtToInstrs we translated both atomic operations under-the assumption they would be placed into their Cmm basic block `c3Bf`.-However for the retry loop we introduce new labels, so this is not the case-for the second statement.-This resulted in a desync between the explicit control flow graph-we construct as a separate data type and the actual control flow graph in the code.--Instead we now return the new basic block if a statement causes a change-in the current block and use the block for all following statements.--For this reason genCCall is also split into two parts.  One for calls which-*won't* change the basic blocks in which successive instructions will be-placed (since they only evaluate CmmExpr, which can only contain MachOps, which-cannot introduce basic blocks in their lowerings).  A different one for calls-which *are* known to change the basic block.---}---- See Note [Keeping track of the current block] for why--- we pass the BlockId.-stmtsToInstrs :: BlockId -- ^ Basic block these statement will start to be placed in.-              -> [CmmNode O O] -- ^ Cmm Statement-              -> NatM (InstrBlock, BlockId) -- ^ Resulting instruction-stmtsToInstrs bid stmts =-    go bid stmts nilOL-  where-    go bid  []        instrs = return (instrs,bid)-    go bid (s:stmts)  instrs = do-      (instrs',bid') <- stmtToInstrs bid s-      -- If the statement introduced a new block, we use that one-      let !newBid = fromMaybe bid bid'-      go newBid stmts (instrs `appOL` instrs')---- | `bid` refers to the current block and is used to update the CFG---   if new blocks are inserted in the control flow.--- See Note [Keeping track of the current block] for more details.-stmtToInstrs :: BlockId -- ^ Basic block this statement will start to be placed in.-             -> CmmNode e x-             -> NatM (InstrBlock, Maybe BlockId)-             -- ^ Instructions, and bid of new block if successive-             -- statements are placed in a different basic block.-stmtToInstrs bid stmt = do-  is32Bit <- is32BitPlatform-  platform <- getPlatform-  case stmt of-    CmmUnsafeForeignCall target result_regs args-       -> genCCall is32Bit target result_regs args bid--    _ -> (,Nothing) <$> case stmt of-      CmmComment s   -> return (unitOL (COMMENT s))-      CmmTick {}     -> return nilOL--      CmmUnwind regs -> do-        let to_unwind_entry :: (GlobalReg, Maybe CmmExpr) -> UnwindTable-            to_unwind_entry (reg, expr) = M.singleton reg (fmap (toUnwindExpr platform) expr)-        case foldMap to_unwind_entry regs of-          tbl | M.null tbl -> return nilOL-              | otherwise  -> do-                  lbl <- mkAsmTempLabel <$> getUniqueM-                  return $ unitOL $ UNWIND lbl tbl--      CmmAssign reg src-        | isFloatType ty         -> assignReg_FltCode format reg src-        | is32Bit && isWord64 ty -> assignReg_I64Code      reg src-        | otherwise              -> assignReg_IntCode format reg src-          where ty = cmmRegType platform reg-                format = cmmTypeFormat ty--      CmmStore addr src _alignment-        | isFloatType ty         -> assignMem_FltCode format addr src-        | is32Bit && isWord64 ty -> assignMem_I64Code      addr src-        | otherwise              -> assignMem_IntCode format addr src-          where ty = cmmExprType platform src-                format = cmmTypeFormat ty--      CmmBranch id          -> return $ genBranch id--      --We try to arrange blocks such that the likely branch is the fallthrough-      --in GHC.Cmm.ContFlowOpt. So we can assume the condition is likely false here.-      CmmCondBranch arg true false _ -> genCondBranch bid true false arg-      CmmSwitch arg ids -> genSwitch arg ids-      CmmCall { cml_target = arg-              , cml_args_regs = gregs } -> genJump arg (jumpRegs platform gregs)-      _ ->-        panic "stmtToInstrs: statement should have been cps'd away"---jumpRegs :: Platform -> [GlobalReg] -> [Reg]-jumpRegs platform gregs = [ RegReal r | Just r <- map (globalRegMaybe platform) gregs ]------------------------------------------------------------------------------------- | 'InstrBlock's are the insn sequences generated by the insn selectors.---      They are really trees of insns to facilitate fast appending, where a---      left-to-right traversal yields the insns in the correct order.----type InstrBlock-        = OrdList Instr----- | Condition codes passed up the tree.----data CondCode-        = CondCode Bool Cond InstrBlock----- | a.k.a "Register64"---      Reg is the lower 32-bit temporary which contains the result.---      Use getHiVRegFromLo to find the other VRegUnique.------      Rules of this simplified insn selection game are therefore that---      the returned Reg may be modified----data ChildCode64-   = ChildCode64-        InstrBlock-        Reg----- | Register's passed up the tree.  If the stix code forces the register---      to live in a pre-decided machine register, it comes out as @Fixed@;---      otherwise, it comes out as @Any@, and the parent can decide which---      register to put it in.----data Register-        = Fixed Format Reg InstrBlock-        | Any   Format (Reg -> InstrBlock)---swizzleRegisterRep :: Register -> Format -> Register-swizzleRegisterRep (Fixed _ reg code) format = Fixed format reg code-swizzleRegisterRep (Any _ codefn)     format = Any   format codefn----- | Grab the Reg for a CmmReg-getRegisterReg :: Platform  -> CmmReg -> Reg--getRegisterReg _   (CmmLocal (LocalReg u pk))-  = -- by Assuming SSE2, Int,Word,Float,Double all can be register allocated-   let fmt = cmmTypeFormat pk in-        RegVirtual (mkVirtualReg u fmt)--getRegisterReg platform  (CmmGlobal mid)-  = case globalRegMaybe platform mid of-        Just reg -> RegReal $ reg-        Nothing  -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)-        -- By this stage, the only MagicIds remaining should be the-        -- ones which map to a real machine register on this-        -- platform.  Hence ...----- | Memory addressing modes passed up the tree.-data Amode-        = Amode AddrMode InstrBlock--{--Now, given a tree (the argument to a CmmLoad) that references memory,-produce a suitable addressing mode.--A Rule of the Game (tm) for Amodes: use of the addr bit must-immediately follow use of the code part, since the code part puts-values in registers which the addr then refers to.  So you can't put-anything in between, lest it overwrite some of those registers.  If-you need to do some other computation between the code part and use of-the addr bit, first store the effective address from the amode in a-temporary, then do the other computation, and then use the temporary:--    code-    LEA amode, tmp-    ... other computation ...-    ... (tmp) ...--}----- | Check whether an integer will fit in 32 bits.---      A CmmInt is intended to be truncated to the appropriate---      number of bits, so here we truncate it to Int64.  This is---      important because e.g. -1 as a CmmInt might be either---      -1 or 18446744073709551615.----is32BitInteger :: Integer -> Bool-is32BitInteger i = i64 <= 0x7fffffff && i64 >= -0x80000000-  where i64 = fromIntegral i :: Int64----- | Convert a BlockId to some CmmStatic data-jumpTableEntry :: NCGConfig -> Maybe BlockId -> CmmStatic-jumpTableEntry config Nothing = CmmStaticLit (CmmInt 0 (ncgWordWidth config))-jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel)-    where blockLabel = blockLbl blockid----- -------------------------------------------------------------------------------- General things for putting together code sequences---- Expand CmmRegOff.  ToDo: should we do it this way around, or convert--- CmmExprs into CmmRegOff?-mangleIndexTree :: Platform -> CmmReg -> Int -> CmmExpr-mangleIndexTree platform reg off-  = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]-  where width = typeWidth (cmmRegType platform reg)---- | The dual to getAnyReg: compute an expression into a register, but---      we don't mind which one it is.-getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)-getSomeReg expr = do-  r <- getRegister expr-  case r of-    Any rep code -> do-        tmp <- getNewRegNat rep-        return (tmp, code tmp)-    Fixed _ reg code ->-        return (reg, code)---assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock-assignMem_I64Code addrTree valueTree = do-  Amode addr addr_code <- getAmode addrTree-  ChildCode64 vcode rlo <- iselExpr64 valueTree-  let-        rhi = getHiVRegFromLo rlo--        -- Little-endian store-        mov_lo = MOV II32 (OpReg rlo) (OpAddr addr)-        mov_hi = MOV II32 (OpReg rhi) (OpAddr (fromJust (addrOffset addr 4)))-  return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi)---assignReg_I64Code :: CmmReg  -> CmmExpr -> NatM InstrBlock-assignReg_I64Code (CmmLocal (LocalReg u_dst _)) valueTree = do-   ChildCode64 vcode r_src_lo <- iselExpr64 valueTree-   let-         r_dst_lo = RegVirtual $ mkVirtualReg u_dst II32-         r_dst_hi = getHiVRegFromLo r_dst_lo-         r_src_hi = getHiVRegFromLo r_src_lo-         mov_lo = MOV II32 (OpReg r_src_lo) (OpReg r_dst_lo)-         mov_hi = MOV II32 (OpReg r_src_hi) (OpReg r_dst_hi)-   return (-        vcode `snocOL` mov_lo `snocOL` mov_hi-     )--assignReg_I64Code _ _-   = panic "assignReg_I64Code(i386): invalid lvalue"---iselExpr64        :: CmmExpr -> NatM ChildCode64-iselExpr64 (CmmLit (CmmInt i _)) = do-  (rlo,rhi) <- getNewRegPairNat II32-  let-        r = fromIntegral (fromIntegral i :: Word32)-        q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32)-        code = toOL [-                MOV II32 (OpImm (ImmInteger r)) (OpReg rlo),-                MOV II32 (OpImm (ImmInteger q)) (OpReg rhi)-                ]-  return (ChildCode64 code rlo)--iselExpr64 (CmmLoad addrTree ty _) | isWord64 ty = do-   Amode addr addr_code <- getAmode addrTree-   (rlo,rhi) <- getNewRegPairNat II32-   let-        mov_lo = MOV II32 (OpAddr addr) (OpReg rlo)-        mov_hi = MOV II32 (OpAddr (fromJust (addrOffset addr 4))) (OpReg rhi)-   return (-            ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi)-                        rlo-     )--iselExpr64 (CmmReg (CmmLocal (LocalReg vu ty))) | isWord64 ty-   = return (ChildCode64 nilOL (RegVirtual $ mkVirtualReg vu II32))---- we handle addition, but rather badly-iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)]) = do-   ChildCode64 code1 r1lo <- iselExpr64 e1-   (rlo,rhi) <- getNewRegPairNat II32-   let-        r = fromIntegral (fromIntegral i :: Word32)-        q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32)-        r1hi = getHiVRegFromLo r1lo-        code =  code1 `appOL`-                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),-                       ADD II32 (OpImm (ImmInteger r)) (OpReg rlo),-                       MOV II32 (OpReg r1hi) (OpReg rhi),-                       ADC II32 (OpImm (ImmInteger q)) (OpReg rhi) ]-   return (ChildCode64 code rlo)--iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do-   ChildCode64 code1 r1lo <- iselExpr64 e1-   ChildCode64 code2 r2lo <- iselExpr64 e2-   (rlo,rhi) <- getNewRegPairNat II32-   let-        r1hi = getHiVRegFromLo r1lo-        r2hi = getHiVRegFromLo r2lo-        code =  code1 `appOL`-                code2 `appOL`-                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),-                       ADD II32 (OpReg r2lo) (OpReg rlo),-                       MOV II32 (OpReg r1hi) (OpReg rhi),-                       ADC II32 (OpReg r2hi) (OpReg rhi) ]-   return (ChildCode64 code rlo)--iselExpr64 (CmmMachOp (MO_Sub _) [e1,e2]) = do-   ChildCode64 code1 r1lo <- iselExpr64 e1-   ChildCode64 code2 r2lo <- iselExpr64 e2-   (rlo,rhi) <- getNewRegPairNat II32-   let-        r1hi = getHiVRegFromLo r1lo-        r2hi = getHiVRegFromLo r2lo-        code =  code1 `appOL`-                code2 `appOL`-                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),-                       SUB II32 (OpReg r2lo) (OpReg rlo),-                       MOV II32 (OpReg r1hi) (OpReg rhi),-                       SBB II32 (OpReg r2hi) (OpReg rhi) ]-   return (ChildCode64 code rlo)--iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) = do-     fn <- getAnyReg expr-     r_dst_lo <-  getNewRegNat II32-     let r_dst_hi = getHiVRegFromLo r_dst_lo-         code = fn r_dst_lo-     return (-             ChildCode64 (code `snocOL`-                          MOV II32 (OpImm (ImmInt 0)) (OpReg r_dst_hi))-                          r_dst_lo-            )--iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr]) = do-     fn <- getAnyReg expr-     r_dst_lo <-  getNewRegNat II32-     let r_dst_hi = getHiVRegFromLo r_dst_lo-         code = fn r_dst_lo-     return (-             ChildCode64 (code `snocOL`-                          MOV II32 (OpReg r_dst_lo) (OpReg eax) `snocOL`-                          CLTD II32 `snocOL`-                          MOV II32 (OpReg eax) (OpReg r_dst_lo) `snocOL`-                          MOV II32 (OpReg edx) (OpReg r_dst_hi))-                          r_dst_lo-            )--iselExpr64 expr-   = do-      platform <- getPlatform-      pprPanic "iselExpr64(i386)" (pdoc platform expr)------------------------------------------------------------------------------------getRegister :: CmmExpr -> NatM Register-getRegister e = do platform <- getPlatform-                   is32Bit <- is32BitPlatform-                   getRegister' platform is32Bit e--getRegister' :: Platform -> Bool -> CmmExpr -> NatM Register--getRegister' platform is32Bit (CmmReg reg)-  = case reg of-        CmmGlobal PicBaseReg-         | is32Bit ->-            -- on x86_64, we have %rip for PicBaseReg, but it's not-            -- a full-featured register, it can only be used for-            -- rip-relative addressing.-            do reg' <- getPicBaseNat (archWordFormat is32Bit)-               return (Fixed (archWordFormat is32Bit) reg' nilOL)-        _ ->-            do-               let-                 fmt = cmmTypeFormat (cmmRegType platform reg)-                 format  = fmt-               ---               platform <- ncgPlatform <$> getConfig-               return (Fixed format-                             (getRegisterReg platform reg)-                             nilOL)---getRegister' platform is32Bit (CmmRegOff r n)-  = getRegister' platform is32Bit $ mangleIndexTree platform r n--getRegister' platform is32Bit (CmmMachOp (MO_AlignmentCheck align _) [e])-  = addAlignmentCheck align <$> getRegister' platform is32Bit e---- for 32-bit architectures, support some 64 -> 32 bit conversions:--- TO_W_(x), TO_W_(x >> 32)--getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32)-                     [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])- | is32Bit = do-  ChildCode64 code rlo <- iselExpr64 x-  return $ Fixed II32 (getHiVRegFromLo rlo) code--getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32)-                     [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])- | is32Bit = do-  ChildCode64 code rlo <- iselExpr64 x-  return $ Fixed II32 (getHiVRegFromLo rlo) code--getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32) [x])- | is32Bit = do-  ChildCode64 code rlo <- iselExpr64 x-  return $ Fixed II32 rlo code--getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32) [x])- | is32Bit = do-  ChildCode64 code rlo <- iselExpr64 x-  return $ Fixed II32 rlo code--getRegister' _ _ (CmmLit lit@(CmmFloat f w)) =-  float_const_sse2  where-  float_const_sse2-    | f == 0.0 = do-      let-          format = floatFormat w-          code dst = unitOL  (XOR format (OpReg dst) (OpReg dst))-        -- I don't know why there are xorpd, xorps, and pxor instructions.-        -- They all appear to do the same thing --SDM-      return (Any format code)--   | otherwise = do-      Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit-      loadFloatAmode w addr code---- catch simple cases of zero- or sign-extended load-getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad addr _ _]) = do-  code <- intLoadCode (MOVZxL II8) addr-  return (Any II32 code)--getRegister' _ _ (CmmMachOp (MO_SS_Conv W8 W32) [CmmLoad addr _ _]) = do-  code <- intLoadCode (MOVSxL II8) addr-  return (Any II32 code)--getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad addr _ _]) = do-  code <- intLoadCode (MOVZxL II16) addr-  return (Any II32 code)--getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad addr _ _]) = do-  code <- intLoadCode (MOVSxL II16) addr-  return (Any II32 code)---- catch simple cases of zero- or sign-extended load-getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad addr _ _])- | not is32Bit = do-  code <- intLoadCode (MOVZxL II8) addr-  return (Any II64 code)--getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W8 W64) [CmmLoad addr _ _])- | not is32Bit = do-  code <- intLoadCode (MOVSxL II8) addr-  return (Any II64 code)--getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad addr _ _])- | not is32Bit = do-  code <- intLoadCode (MOVZxL II16) addr-  return (Any II64 code)--getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad addr _ _])- | not is32Bit = do-  code <- intLoadCode (MOVSxL II16) addr-  return (Any II64 code)--getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad addr _ _])- | not is32Bit = do-  code <- intLoadCode (MOV II32) addr -- 32-bit loads zero-extend-  return (Any II64 code)--getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad addr _ _])- | not is32Bit = do-  code <- intLoadCode (MOVSxL II32) addr-  return (Any II64 code)--getRegister' _ is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg),-                                     CmmLit displacement])- | not is32Bit =-      return $ Any II64 (\dst -> unitOL $-        LEA II64 (OpAddr (ripRel (litToImm displacement))) (OpReg dst))--getRegister' platform is32Bit (CmmMachOp mop [x]) = -- unary MachOps-    case mop of-      MO_F_Neg w  -> sse2NegCode w x---      MO_S_Neg w -> triv_ucode NEGI (intFormat w)-      MO_Not w   -> triv_ucode NOT  (intFormat w)--      -- Nop conversions-      MO_UU_Conv W32 W8  -> toI8Reg  W32 x-      MO_SS_Conv W32 W8  -> toI8Reg  W32 x-      MO_XX_Conv W32 W8  -> toI8Reg  W32 x-      MO_UU_Conv W16 W8  -> toI8Reg  W16 x-      MO_SS_Conv W16 W8  -> toI8Reg  W16 x-      MO_XX_Conv W16 W8  -> toI8Reg  W16 x-      MO_UU_Conv W32 W16 -> toI16Reg W32 x-      MO_SS_Conv W32 W16 -> toI16Reg W32 x-      MO_XX_Conv W32 W16 -> toI16Reg W32 x--      MO_UU_Conv W64 W32 | not is32Bit -> conversionNop II64 x-      MO_SS_Conv W64 W32 | not is32Bit -> conversionNop II64 x-      MO_XX_Conv W64 W32 | not is32Bit -> conversionNop II64 x-      MO_UU_Conv W64 W16 | not is32Bit -> toI16Reg W64 x-      MO_SS_Conv W64 W16 | not is32Bit -> toI16Reg W64 x-      MO_XX_Conv W64 W16 | not is32Bit -> toI16Reg W64 x-      MO_UU_Conv W64 W8  | not is32Bit -> toI8Reg  W64 x-      MO_SS_Conv W64 W8  | not is32Bit -> toI8Reg  W64 x-      MO_XX_Conv W64 W8  | not is32Bit -> toI8Reg  W64 x--      MO_UU_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x-      MO_SS_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x-      MO_XX_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x--      -- widenings-      MO_UU_Conv W8  W32 -> integerExtend W8  W32 MOVZxL x-      MO_UU_Conv W16 W32 -> integerExtend W16 W32 MOVZxL x-      MO_UU_Conv W8  W16 -> integerExtend W8  W16 MOVZxL x--      MO_SS_Conv W8  W32 -> integerExtend W8  W32 MOVSxL x-      MO_SS_Conv W16 W32 -> integerExtend W16 W32 MOVSxL x-      MO_SS_Conv W8  W16 -> integerExtend W8  W16 MOVSxL x--      -- We don't care about the upper bits for MO_XX_Conv, so MOV is enough. However, on 32-bit we-      -- have 8-bit registers only for a few registers (as opposed to x86-64 where every register-      -- has 8-bit version). So for 32-bit code, we'll just zero-extend.-      MO_XX_Conv W8  W32-          | is32Bit   -> integerExtend W8 W32 MOVZxL x-          | otherwise -> integerExtend W8 W32 MOV x-      MO_XX_Conv W8  W16-          | is32Bit   -> integerExtend W8 W16 MOVZxL x-          | otherwise -> integerExtend W8 W16 MOV x-      MO_XX_Conv W16 W32 -> integerExtend W16 W32 MOV x--      MO_UU_Conv W8  W64 | not is32Bit -> integerExtend W8  W64 MOVZxL x-      MO_UU_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVZxL x-      MO_UU_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVZxL x-      MO_SS_Conv W8  W64 | not is32Bit -> integerExtend W8  W64 MOVSxL x-      MO_SS_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVSxL x-      MO_SS_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVSxL x-      -- For 32-to-64 bit zero extension, amd64 uses an ordinary movl.-      -- However, we don't want the register allocator to throw it-      -- away as an unnecessary reg-to-reg move, so we keep it in-      -- the form of a movzl and print it as a movl later.-      -- This doesn't apply to MO_XX_Conv since in this case we don't care about-      -- the upper bits. So we can just use MOV.-      MO_XX_Conv W8  W64 | not is32Bit -> integerExtend W8  W64 MOV x-      MO_XX_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOV x-      MO_XX_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOV x--      MO_FF_Conv W32 W64 -> coerceFP2FP W64 x---      MO_FF_Conv W64 W32 -> coerceFP2FP W32 x--      MO_FS_Conv from to -> coerceFP2Int from to x-      MO_SF_Conv from to -> coerceInt2FP from to x--      MO_V_Insert {}   -> needLlvm-      MO_V_Extract {}  -> needLlvm-      MO_V_Add {}      -> needLlvm-      MO_V_Sub {}      -> needLlvm-      MO_V_Mul {}      -> needLlvm-      MO_VS_Quot {}    -> needLlvm-      MO_VS_Rem {}     -> needLlvm-      MO_VS_Neg {}     -> needLlvm-      MO_VU_Quot {}    -> needLlvm-      MO_VU_Rem {}     -> needLlvm-      MO_VF_Insert {}  -> needLlvm-      MO_VF_Extract {} -> needLlvm-      MO_VF_Add {}     -> needLlvm-      MO_VF_Sub {}     -> needLlvm-      MO_VF_Mul {}     -> needLlvm-      MO_VF_Quot {}    -> needLlvm-      MO_VF_Neg {}     -> needLlvm--      _other -> pprPanic "getRegister" (pprMachOp mop)-   where-        triv_ucode :: (Format -> Operand -> Instr) -> Format -> NatM Register-        triv_ucode instr format = trivialUCode format (instr format) x--        -- signed or unsigned extension.-        integerExtend :: Width -> Width-                      -> (Format -> Operand -> Operand -> Instr)-                      -> CmmExpr -> NatM Register-        integerExtend from to instr expr = do-            (reg,e_code) <- if from == W8 then getByteReg expr-                                          else getSomeReg expr-            let-                code dst =-                  e_code `snocOL`-                  instr (intFormat from) (OpReg reg) (OpReg dst)-            return (Any (intFormat to) code)--        toI8Reg :: Width -> CmmExpr -> NatM Register-        toI8Reg new_rep expr-            = do codefn <- getAnyReg expr-                 return (Any (intFormat new_rep) codefn)-                -- HACK: use getAnyReg to get a byte-addressable register.-                -- If the source was a Fixed register, this will add the-                -- mov instruction to put it into the desired destination.-                -- We're assuming that the destination won't be a fixed-                -- non-byte-addressable register; it won't be, because all-                -- fixed registers are word-sized.--        toI16Reg = toI8Reg -- for now--        conversionNop :: Format -> CmmExpr -> NatM Register-        conversionNop new_format expr-            = do e_code <- getRegister' platform is32Bit expr-                 return (swizzleRegisterRep e_code new_format)---getRegister' _ is32Bit (CmmMachOp mop [x, y]) = -- dyadic MachOps-  case mop of-      MO_F_Eq _ -> condFltReg is32Bit EQQ x y-      MO_F_Ne _ -> condFltReg is32Bit NE  x y-      MO_F_Gt _ -> condFltReg is32Bit GTT x y-      MO_F_Ge _ -> condFltReg is32Bit GE  x y-      -- Invert comparison condition and swap operands-      -- See Note [SSE Parity Checks]-      MO_F_Lt _ -> condFltReg is32Bit GTT  y x-      MO_F_Le _ -> condFltReg is32Bit GE   y x--      MO_Eq _   -> condIntReg EQQ x y-      MO_Ne _   -> condIntReg NE  x y--      MO_S_Gt _ -> condIntReg GTT x y-      MO_S_Ge _ -> condIntReg GE  x y-      MO_S_Lt _ -> condIntReg LTT x y-      MO_S_Le _ -> condIntReg LE  x y--      MO_U_Gt _ -> condIntReg GU  x y-      MO_U_Ge _ -> condIntReg GEU x y-      MO_U_Lt _ -> condIntReg LU  x y-      MO_U_Le _ -> condIntReg LEU x y--      MO_F_Add w   -> trivialFCode_sse2 w ADD  x y--      MO_F_Sub w   -> trivialFCode_sse2 w SUB  x y--      MO_F_Quot w  -> trivialFCode_sse2 w FDIV x y--      MO_F_Mul w   -> trivialFCode_sse2 w MUL x y---      MO_Add rep -> add_code rep x y-      MO_Sub rep -> sub_code rep x y--      MO_S_Quot rep -> div_code rep True  True  x y-      MO_S_Rem  rep -> div_code rep True  False x y-      MO_U_Quot rep -> div_code rep False True  x y-      MO_U_Rem  rep -> div_code rep False False x y--      MO_S_MulMayOflo rep -> imulMayOflo rep x y--      MO_Mul W8  -> imulW8 x y-      MO_Mul rep -> triv_op rep IMUL-      MO_And rep -> triv_op rep AND-      MO_Or  rep -> triv_op rep OR-      MO_Xor rep -> triv_op rep XOR--        {- Shift ops on x86s have constraints on their source, it-           either has to be Imm, CL or 1-            => trivialCode is not restrictive enough (sigh.)-        -}-      MO_Shl rep   -> shift_code rep SHL x y {-False-}-      MO_U_Shr rep -> shift_code rep SHR x y {-False-}-      MO_S_Shr rep -> shift_code rep SAR x y {-False-}--      MO_V_Insert {}   -> needLlvm-      MO_V_Extract {}  -> needLlvm-      MO_V_Add {}      -> needLlvm-      MO_V_Sub {}      -> needLlvm-      MO_V_Mul {}      -> needLlvm-      MO_VS_Quot {}    -> needLlvm-      MO_VS_Rem {}     -> needLlvm-      MO_VS_Neg {}     -> needLlvm-      MO_VF_Insert {}  -> needLlvm-      MO_VF_Extract {} -> needLlvm-      MO_VF_Add {}     -> needLlvm-      MO_VF_Sub {}     -> needLlvm-      MO_VF_Mul {}     -> needLlvm-      MO_VF_Quot {}    -> needLlvm-      MO_VF_Neg {}     -> needLlvm--      _other -> pprPanic "getRegister(x86) - binary CmmMachOp (1)" (pprMachOp mop)-  where-    ---------------------    triv_op width instr = trivialCode width op (Just op) x y-                        where op   = instr (intFormat width)--    -- Special case for IMUL for bytes, since the result of IMULB will be in-    -- %ax, the split to %dx/%edx/%rdx and %ax/%eax/%rax happens only for wider-    -- values.-    imulW8 :: CmmExpr -> CmmExpr -> NatM Register-    imulW8 arg_a arg_b = do-        (a_reg, a_code) <- getNonClobberedReg arg_a-        b_code <- getAnyReg arg_b--        let code = a_code `appOL` b_code eax `appOL`-                   toOL [ IMUL2 format (OpReg a_reg) ]-            format = intFormat W8--        return (Fixed format eax code)---    imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register-    imulMayOflo rep a b = do-         (a_reg, a_code) <- getNonClobberedReg a-         b_code <- getAnyReg b-         let-             shift_amt  = case rep of-                           W32 -> 31-                           W64 -> 63-                           _ -> panic "shift_amt"--             format = intFormat rep-             code = a_code `appOL` b_code eax `appOL`-                        toOL [-                           IMUL2 format (OpReg a_reg),   -- result in %edx:%eax-                           SAR format (OpImm (ImmInt shift_amt)) (OpReg eax),-                                -- sign extend lower part-                           SUB format (OpReg edx) (OpReg eax)-                                -- compare against upper-                           -- eax==0 if high part == sign extended low part-                        ]-         return (Fixed format eax code)--    ---------------------    shift_code :: Width-               -> (Format -> Operand -> Operand -> Instr)-               -> CmmExpr-               -> CmmExpr-               -> NatM Register--    {- Case1: shift length as immediate -}-    shift_code width instr x (CmmLit lit)-      -- Handle the case of a shift larger than the width of the shifted value.-      -- This is necessary since x86 applies a mask of 0x1f to the shift-      -- amount, meaning that, e.g., `shr 47, $eax` will actually shift by-      -- `47 & 0x1f == 15`. See #20626.-      | CmmInt n _ <- lit-      , n >= fromIntegral (widthInBits width)-      = getRegister $ CmmLit $ CmmInt 0 width--      | otherwise = do-          x_code <- getAnyReg x-          let-               format = intFormat width-               code dst-                  = x_code dst `snocOL`-                    instr format (OpImm (litToImm lit)) (OpReg dst)-          return (Any format code)--    {- Case2: shift length is complex (non-immediate)-      * y must go in %ecx.-      * we cannot do y first *and* put its result in %ecx, because-        %ecx might be clobbered by x.-      * if we do y second, then x cannot be-        in a clobbered reg.  Also, we cannot clobber x's reg-        with the instruction itself.-      * so we can either:-        - do y first, put its result in a fresh tmp, then copy it to %ecx later-        - do y second and put its result into %ecx.  x gets placed in a fresh-          tmp.  This is likely to be better, because the reg alloc can-          eliminate this reg->reg move here (it won't eliminate the other one,-          because the move is into the fixed %ecx).-      * in the case of C calls the use of ecx here can interfere with arguments.-        We avoid this with the hack described in Note [Evaluate C-call-        arguments before placing in destination registers]-    -}-    shift_code width instr x y{-amount-} = do-        x_code <- getAnyReg x-        let format = intFormat width-        tmp <- getNewRegNat format-        y_code <- getAnyReg y-        let-           code = x_code tmp `appOL`-                  y_code ecx `snocOL`-                  instr format (OpReg ecx) (OpReg tmp)-        return (Fixed format tmp code)--    ---------------------    add_code :: Width -> CmmExpr -> CmmExpr -> NatM Register-    add_code rep x (CmmLit (CmmInt y _))-        | is32BitInteger y-        , rep /= W8 -- LEA doesn't support byte size (#18614)-        = add_int rep x y-    add_code rep x y = trivialCode rep (ADD format) (Just (ADD format)) x y-      where format = intFormat rep-    -- TODO: There are other interesting patterns we want to replace-    --     with a LEA, e.g. `(x + offset) + (y << shift)`.--    ---------------------    sub_code :: Width -> CmmExpr -> CmmExpr -> NatM Register-    sub_code rep x (CmmLit (CmmInt y _))-        | is32BitInteger (-y)-        , rep /= W8 -- LEA doesn't support byte size (#18614)-        = add_int rep x (-y)-    sub_code rep x y = trivialCode rep (SUB (intFormat rep)) Nothing x y--    -- our three-operand add instruction:-    add_int width x y = do-        (x_reg, x_code) <- getSomeReg x-        let-            format = intFormat width-            imm = ImmInt (fromInteger y)-            code dst-               = x_code `snocOL`-                 LEA format-                        (OpAddr (AddrBaseIndex (EABaseReg x_reg) EAIndexNone imm))-                        (OpReg dst)-        ---        return (Any format code)--    ------------------------    -- See Note [DIV/IDIV for bytes]-    div_code W8 signed quotient x y = do-        let widen | signed    = MO_SS_Conv W8 W16-                  | otherwise = MO_UU_Conv W8 W16-        div_code-            W16-            signed-            quotient-            (CmmMachOp widen [x])-            (CmmMachOp widen [y])--    div_code width signed quotient x y = do-           (y_op, y_code) <- getRegOrMem y -- cannot be clobbered-           x_code <- getAnyReg x-           let-             format = intFormat width-             widen | signed    = CLTD format-                   | otherwise = XOR format (OpReg edx) (OpReg edx)--             instr | signed    = IDIV-                   | otherwise = DIV--             code = y_code `appOL`-                    x_code eax `appOL`-                    toOL [widen, instr format y_op]--             result | quotient  = eax-                    | otherwise = edx--           return (Fixed format result code)---getRegister' _ _ (CmmLoad mem pk _)-  | isFloatType pk-  = do-    Amode addr mem_code <- getAmode mem-    loadFloatAmode  (typeWidth pk) addr mem_code--getRegister' _ is32Bit (CmmLoad mem pk _)-  | is32Bit && not (isWord64 pk)-  = do-    code <- intLoadCode instr mem-    return (Any format code)-  where-    width = typeWidth pk-    format = intFormat width-    instr = case width of-                W8     -> MOVZxL II8-                _other -> MOV format-        -- We always zero-extend 8-bit loads, if we-        -- can't think of anything better.  This is because-        -- we can't guarantee access to an 8-bit variant of every register-        -- (esi and edi don't have 8-bit variants), so to make things-        -- simpler we do our 8-bit arithmetic with full 32-bit registers.---- Simpler memory load code on x86_64-getRegister' _ is32Bit (CmmLoad mem pk _)- | not is32Bit-  = do-    code <- intLoadCode (MOV format) mem-    return (Any format code)-  where format = intFormat $ typeWidth pk--getRegister' _ is32Bit (CmmLit (CmmInt 0 width))-  = let-        format = intFormat width--        -- x86_64: 32-bit xor is one byte shorter, and zero-extends to 64 bits-        format1 = if is32Bit then format-                           else case format of-                                II64 -> II32-                                _ -> format-        code dst-           = unitOL (XOR format1 (OpReg dst) (OpReg dst))-    in-        return (Any format code)--  -- optimisation for loading small literals on x86_64: take advantage-  -- of the automatic zero-extension from 32 to 64 bits, because the 32-bit-  -- instruction forms are shorter.-getRegister' platform is32Bit (CmmLit lit)-  | not is32Bit, isWord64 (cmmLitType platform lit), not (isBigLit lit)-  = let-        imm = litToImm lit-        code dst = unitOL (MOV II32 (OpImm imm) (OpReg dst))-    in-        return (Any II64 code)-  where-   isBigLit (CmmInt i _) = i < 0 || i > 0xffffffff-   isBigLit _ = False-        -- note1: not the same as (not.is32BitLit), because that checks for-        -- signed literals that fit in 32 bits, but we want unsigned-        -- literals here.-        -- note2: all labels are small, because we're assuming the-        -- small memory model (see gcc docs, -mcmodel=small).--getRegister' platform _ (CmmLit lit)-  = do let format = cmmTypeFormat (cmmLitType platform lit)-           imm = litToImm lit-           code dst = unitOL (MOV format (OpImm imm) (OpReg dst))-       return (Any format code)--getRegister' platform _ other-    | isVecExpr other  = needLlvm-    | otherwise        = pprPanic "getRegister(x86)" (pdoc platform other)---intLoadCode :: (Operand -> Operand -> Instr) -> CmmExpr-   -> NatM (Reg -> InstrBlock)-intLoadCode instr mem = do-  Amode src mem_code <- getAmode mem-  return (\dst -> mem_code `snocOL` instr (OpAddr src) (OpReg dst))---- Compute an expression into *any* register, adding the appropriate--- move instruction if necessary.-getAnyReg :: CmmExpr -> NatM (Reg -> InstrBlock)-getAnyReg expr = do-  r <- getRegister expr-  anyReg r--anyReg :: Register -> NatM (Reg -> InstrBlock)-anyReg (Any _ code)          = return code-anyReg (Fixed rep reg fcode) = return (\dst -> fcode `snocOL` reg2reg rep reg dst)---- A bit like getSomeReg, but we want a reg that can be byte-addressed.--- Fixed registers might not be byte-addressable, so we make sure we've--- got a temporary, inserting an extra reg copy if necessary.-getByteReg :: CmmExpr -> NatM (Reg, InstrBlock)-getByteReg expr = do-  is32Bit <- is32BitPlatform-  if is32Bit-      then do r <- getRegister expr-              case r of-                Any rep code -> do-                    tmp <- getNewRegNat rep-                    return (tmp, code tmp)-                Fixed rep reg code-                    | isVirtualReg reg -> return (reg,code)-                    | otherwise -> do-                        tmp <- getNewRegNat rep-                        return (tmp, code `snocOL` reg2reg rep reg tmp)-                    -- ToDo: could optimise slightly by checking for-                    -- byte-addressable real registers, but that will-                    -- happen very rarely if at all.-      else getSomeReg expr -- all regs are byte-addressable on x86_64---- Another variant: this time we want the result in a register that cannot--- be modified by code to evaluate an arbitrary expression.-getNonClobberedReg :: CmmExpr -> NatM (Reg, InstrBlock)-getNonClobberedReg expr = do-  r <- getRegister expr-  platform <- ncgPlatform <$> getConfig-  case r of-    Any rep code -> do-        tmp <- getNewRegNat rep-        return (tmp, code tmp)-    Fixed rep reg code-        -- only certain regs can be clobbered-        | reg `elem` instrClobberedRegs platform-        -> do-                tmp <- getNewRegNat rep-                return (tmp, code `snocOL` reg2reg rep reg tmp)-        | otherwise ->-                return (reg, code)--reg2reg :: Format -> Reg -> Reg -> Instr-reg2reg format src dst = MOV format (OpReg src) (OpReg dst)--------------------------------------------------------------------------------------- | Convert a 'CmmExpr' representing a memory address into an 'Amode'.------ An 'Amode' is a datatype representing a valid address form for the target--- (e.g. "Base + Index + disp" or immediate) and the code to compute it.-getAmode :: CmmExpr -> NatM Amode-getAmode e = do-   platform <- getPlatform-   let is32Bit = target32Bit platform--   case e of-      CmmRegOff r n-         -> getAmode $ mangleIndexTree platform r n--      CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg), CmmLit displacement]-         | not is32Bit-         -> return $ Amode (ripRel (litToImm displacement)) nilOL--      -- This is all just ridiculous, since it carefully undoes-      -- what mangleIndexTree has just done.-      CmmMachOp (MO_Sub _rep) [x, CmmLit lit@(CmmInt i _)]-         | is32BitLit is32Bit lit-         -- ASSERT(rep == II32)???-         -> do-            (x_reg, x_code) <- getSomeReg x-            let off = ImmInt (-(fromInteger i))-            return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code)--      CmmMachOp (MO_Add _rep) [x, CmmLit lit]-         | is32BitLit is32Bit lit-         -- ASSERT(rep == II32)???-         -> do-            (x_reg, x_code) <- getSomeReg x-            let off = litToImm lit-            return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code)--      -- Turn (lit1 << n  + lit2) into  (lit2 + lit1 << n) so it will be-      -- recognised by the next rule.-      CmmMachOp (MO_Add rep) [a@(CmmMachOp (MO_Shl _) _), b@(CmmLit _)]-         -> getAmode (CmmMachOp (MO_Add rep) [b,a])--      -- Matches: (x + offset) + (y << shift)-      CmmMachOp (MO_Add _) [CmmRegOff x offset, CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)]]-         | shift == 0 || shift == 1 || shift == 2 || shift == 3-         -> x86_complex_amode (CmmReg x) y shift (fromIntegral offset)--      CmmMachOp (MO_Add _) [x, CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)]]-         | shift == 0 || shift == 1 || shift == 2 || shift == 3-         -> x86_complex_amode x y shift 0--      CmmMachOp (MO_Add _) [x, CmmMachOp (MO_Add _) [CmmMachOp (MO_Shl _)-                                                    [y, CmmLit (CmmInt shift _)], CmmLit (CmmInt offset _)]]-         | shift == 0 || shift == 1 || shift == 2 || shift == 3-         && is32BitInteger offset-         -> x86_complex_amode x y shift offset--      CmmMachOp (MO_Add _) [x,y]-         | not (isLit y) -- we already handle valid literals above.-         -> x86_complex_amode x y 0 0--      CmmLit lit-         | is32BitLit is32Bit lit-         -> return (Amode (ImmAddr (litToImm lit) 0) nilOL)--      -- Literal with offsets too big (> 32 bits) fails during the linking phase-      -- (#15570). We already handled valid literals above so we don't have to-      -- test anything here.-      CmmLit (CmmLabelOff l off)-         -> getAmode (CmmMachOp (MO_Add W64) [ CmmLit (CmmLabel l)-                                             , CmmLit (CmmInt (fromIntegral off) W64)-                                             ])-      CmmLit (CmmLabelDiffOff l1 l2 off w)-         -> getAmode (CmmMachOp (MO_Add W64) [ CmmLit (CmmLabelDiffOff l1 l2 0 w)-                                             , CmmLit (CmmInt (fromIntegral off) W64)-                                             ])--      -- in case we can't do something better, we just compute the expression-      -- and put the result in a register-      _ -> do-        (reg,code) <- getSomeReg e-        return (Amode (AddrBaseIndex (EABaseReg reg) EAIndexNone (ImmInt 0)) code)------ | Like 'getAmode', but on 32-bit use simple register addressing--- (i.e. no index register). This stops us from running out of--- registers on x86 when using instructions such as cmpxchg, which can--- use up to three virtual registers and one fixed register.-getSimpleAmode :: Bool -> CmmExpr -> NatM Amode-getSimpleAmode is32Bit addr-    | is32Bit = do-        addr_code <- getAnyReg addr-        config <- getConfig-        addr_r <- getNewRegNat (intFormat (ncgWordWidth config))-        let amode = AddrBaseIndex (EABaseReg addr_r) EAIndexNone (ImmInt 0)-        return $! Amode amode (addr_code addr_r)-    | otherwise = getAmode addr--x86_complex_amode :: CmmExpr -> CmmExpr -> Integer -> Integer -> NatM Amode-x86_complex_amode base index shift offset-  = do (x_reg, x_code) <- getNonClobberedReg base-        -- x must be in a temp, because it has to stay live over y_code-        -- we could compare x_reg and y_reg and do something better here...-       (y_reg, y_code) <- getSomeReg index-       let-           code = x_code `appOL` y_code-           base = case shift of 0 -> 1; 1 -> 2; 2 -> 4; 3 -> 8;-                                n -> panic $ "x86_complex_amode: unhandled shift! (" ++ show n ++ ")"-       return (Amode (AddrBaseIndex (EABaseReg x_reg) (EAIndex y_reg base) (ImmInt (fromIntegral offset)))-               code)------- -------------------------------------------------------------------------------- getOperand: sometimes any operand will do.---- getNonClobberedOperand: the value of the operand will remain valid across--- the computation of an arbitrary expression, unless the expression--- is computed directly into a register which the operand refers to--- (see trivialCode where this function is used for an example).--getNonClobberedOperand :: CmmExpr -> NatM (Operand, InstrBlock)-getNonClobberedOperand (CmmLit lit) =-  if isSuitableFloatingPointLit lit-  then do-    let CmmFloat _ w = lit-    Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit-    return (OpAddr addr, code)-  else do-    is32Bit <- is32BitPlatform-    platform <- getPlatform-    if is32BitLit is32Bit lit && not (isFloatType (cmmLitType platform lit))-    then return (OpImm (litToImm lit), nilOL)-    else getNonClobberedOperand_generic (CmmLit lit)--getNonClobberedOperand (CmmLoad mem pk _) = do-  is32Bit <- is32BitPlatform-  -- this logic could be simplified-  -- TODO FIXME-  if   (if is32Bit then not (isWord64 pk) else True)-      -- if 32bit and pk is at float/double/simd value-      -- or if 64bit-      --  this could use some eyeballs or i'll need to stare at it more later-    then do-      platform <- ncgPlatform <$> getConfig-      Amode src mem_code <- getAmode mem-      (src',save_code) <--        if (amodeCouldBeClobbered platform src)-                then do-                   tmp <- getNewRegNat (archWordFormat is32Bit)-                   return (AddrBaseIndex (EABaseReg tmp) EAIndexNone (ImmInt 0),-                           unitOL (LEA (archWordFormat is32Bit)-                                       (OpAddr src)-                                       (OpReg tmp)))-                else-                   return (src, nilOL)-      return (OpAddr src', mem_code `appOL` save_code)-    else-      -- if its a word or gcptr on 32bit?-      getNonClobberedOperand_generic (CmmLoad mem pk NaturallyAligned)--getNonClobberedOperand e = getNonClobberedOperand_generic e--getNonClobberedOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock)-getNonClobberedOperand_generic e = do-  (reg, code) <- getNonClobberedReg e-  return (OpReg reg, code)--amodeCouldBeClobbered :: Platform -> AddrMode -> Bool-amodeCouldBeClobbered platform amode = any (regClobbered platform) (addrModeRegs amode)--regClobbered :: Platform -> Reg -> Bool-regClobbered platform (RegReal (RealRegSingle rr)) = freeReg platform rr-regClobbered _ _ = False---- getOperand: the operand is not required to remain valid across the--- computation of an arbitrary expression.-getOperand :: CmmExpr -> NatM (Operand, InstrBlock)--getOperand (CmmLit lit) = do-  use_sse2 <- sse2Enabled-  if (use_sse2 && isSuitableFloatingPointLit lit)-    then do-      let CmmFloat _ w = lit-      Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit-      return (OpAddr addr, code)-    else do--  is32Bit <- is32BitPlatform-  platform <- getPlatform-  if is32BitLit is32Bit lit && not (isFloatType (cmmLitType platform lit))-    then return (OpImm (litToImm lit), nilOL)-    else getOperand_generic (CmmLit lit)--getOperand (CmmLoad mem pk _) = do-  is32Bit <- is32BitPlatform-  use_sse2 <- sse2Enabled-  if (not (isFloatType pk) || use_sse2) && (if is32Bit then not (isWord64 pk) else True)-     then do-       Amode src mem_code <- getAmode mem-       return (OpAddr src, mem_code)-     else-       getOperand_generic (CmmLoad mem pk NaturallyAligned)--getOperand e = getOperand_generic e--getOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock)-getOperand_generic e = do-    (reg, code) <- getSomeReg e-    return (OpReg reg, code)--isOperand :: Bool -> CmmExpr -> Bool-isOperand _ (CmmLoad _ _ _) = True-isOperand is32Bit (CmmLit lit)  = is32BitLit is32Bit lit-                          || isSuitableFloatingPointLit lit-isOperand _ _            = False---- | Given a 'Register', produce a new 'Register' with an instruction block--- which will check the value for alignment. Used for @-falignment-sanitisation@.-addAlignmentCheck :: Int -> Register -> Register-addAlignmentCheck align reg =-    case reg of-      Fixed fmt reg code -> Fixed fmt reg (code `appOL` check fmt reg)-      Any fmt f          -> Any fmt (\reg -> f reg `appOL` check fmt reg)-  where-    check :: Format -> Reg -> InstrBlock-    check fmt reg =-        ASSERT(not $ isFloatFormat fmt)-        toOL [ TEST fmt (OpImm $ ImmInt $ align-1) (OpReg reg)-             , JXX_GBL NE $ ImmCLbl mkBadAlignmentLabel-             ]--memConstant :: Alignment -> CmmLit -> NatM Amode-memConstant align lit = do-  lbl <- getNewLabelNat-  let rosection = Section ReadOnlyData lbl-  config <- getConfig-  platform <- getPlatform-  (addr, addr_code) <- if target32Bit platform-                       then do dynRef <- cmmMakeDynamicReference-                                             config-                                             DataReference-                                             lbl-                               Amode addr addr_code <- getAmode dynRef-                               return (addr, addr_code)-                       else return (ripRel (ImmCLbl lbl), nilOL)-  let code =-        LDATA rosection (align, CmmStaticsRaw lbl [CmmStaticLit lit])-        `consOL` addr_code-  return (Amode addr code)---loadFloatAmode :: Width -> AddrMode -> InstrBlock -> NatM Register-loadFloatAmode w addr addr_code = do-  let format = floatFormat w-      code dst = addr_code `snocOL`-                    MOV format (OpAddr addr) (OpReg dst)--  return (Any format code)----- if we want a floating-point literal as an operand, we can--- use it directly from memory.  However, if the literal is--- zero, we're better off generating it into a register using--- xor.-isSuitableFloatingPointLit :: CmmLit -> Bool-isSuitableFloatingPointLit (CmmFloat f _) = f /= 0.0-isSuitableFloatingPointLit _ = False--getRegOrMem :: CmmExpr -> NatM (Operand, InstrBlock)-getRegOrMem e@(CmmLoad mem pk _) = do-  is32Bit <- is32BitPlatform-  use_sse2 <- sse2Enabled-  if (not (isFloatType pk) || use_sse2) && (if is32Bit then not (isWord64 pk) else True)-     then do-       Amode src mem_code <- getAmode mem-       return (OpAddr src, mem_code)-     else do-       (reg, code) <- getNonClobberedReg e-       return (OpReg reg, code)-getRegOrMem e = do-    (reg, code) <- getNonClobberedReg e-    return (OpReg reg, code)--is32BitLit :: Bool -> CmmLit -> Bool-is32BitLit is32Bit lit-   | not is32Bit = case lit of-      CmmInt i W64              -> is32BitInteger i-      -- assume that labels are in the range 0-2^31-1: this assumes the-      -- small memory model (see gcc docs, -mcmodel=small).-      CmmLabel _                -> True-      -- however we can't assume that label offsets are in this range-      -- (see #15570)-      CmmLabelOff _ off         -> is32BitInteger (fromIntegral off)-      CmmLabelDiffOff _ _ off _ -> is32BitInteger (fromIntegral off)-      _                         -> True-is32BitLit _ _ = True------- Set up a condition code for a conditional branch.--getCondCode :: CmmExpr -> NatM CondCode---- yes, they really do seem to want exactly the same!--getCondCode (CmmMachOp mop [x, y])-  =-    case mop of-      MO_F_Eq W32 -> condFltCode EQQ x y-      MO_F_Ne W32 -> condFltCode NE  x y-      MO_F_Gt W32 -> condFltCode GTT x y-      MO_F_Ge W32 -> condFltCode GE  x y-      -- Invert comparison condition and swap operands-      -- See Note [SSE Parity Checks]-      MO_F_Lt W32 -> condFltCode GTT  y x-      MO_F_Le W32 -> condFltCode GE   y x--      MO_F_Eq W64 -> condFltCode EQQ x y-      MO_F_Ne W64 -> condFltCode NE  x y-      MO_F_Gt W64 -> condFltCode GTT x y-      MO_F_Ge W64 -> condFltCode GE  x y-      MO_F_Lt W64 -> condFltCode GTT y x-      MO_F_Le W64 -> condFltCode GE  y x--      _ -> condIntCode (machOpToCond mop) x y--getCondCode other = do-   platform <- getPlatform-   pprPanic "getCondCode(2)(x86,x86_64)" (pdoc platform other)--machOpToCond :: MachOp -> Cond-machOpToCond mo = case mo of-  MO_Eq _   -> EQQ-  MO_Ne _   -> NE-  MO_S_Gt _ -> GTT-  MO_S_Ge _ -> GE-  MO_S_Lt _ -> LTT-  MO_S_Le _ -> LE-  MO_U_Gt _ -> GU-  MO_U_Ge _ -> GEU-  MO_U_Lt _ -> LU-  MO_U_Le _ -> LEU-  _other -> pprPanic "machOpToCond" (pprMachOp mo)----- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be--- passed back up the tree.--condIntCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode-condIntCode cond x y = do is32Bit <- is32BitPlatform-                          condIntCode' is32Bit cond x y--condIntCode' :: Bool -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode---- memory vs immediate-condIntCode' is32Bit cond (CmmLoad x pk _) (CmmLit lit)- | is32BitLit is32Bit lit = do-    Amode x_addr x_code <- getAmode x-    let-        imm  = litToImm lit-        code = x_code `snocOL`-                  CMP (cmmTypeFormat pk) (OpImm imm) (OpAddr x_addr)-    ---    return (CondCode False cond code)---- anything vs zero, using a mask--- TODO: Add some sanity checking!!!!-condIntCode' is32Bit cond (CmmMachOp (MO_And _) [x,o2]) (CmmLit (CmmInt 0 pk))-    | (CmmLit lit@(CmmInt mask _)) <- o2, is32BitLit is32Bit lit-    = do-      (x_reg, x_code) <- getSomeReg x-      let-         code = x_code `snocOL`-                TEST (intFormat pk) (OpImm (ImmInteger mask)) (OpReg x_reg)-      ---      return (CondCode False cond code)---- anything vs zero-condIntCode' _ cond x (CmmLit (CmmInt 0 pk)) = do-    (x_reg, x_code) <- getSomeReg x-    let-        code = x_code `snocOL`-                  TEST (intFormat pk) (OpReg x_reg) (OpReg x_reg)-    ---    return (CondCode False cond code)---- anything vs operand-condIntCode' is32Bit cond x y- | isOperand is32Bit y = do-    platform <- getPlatform-    (x_reg, x_code) <- getNonClobberedReg x-    (y_op,  y_code) <- getOperand y-    let-        code = x_code `appOL` y_code `snocOL`-                  CMP (cmmTypeFormat (cmmExprType platform x)) y_op (OpReg x_reg)-    return (CondCode False cond code)--- operand vs. anything: invert the comparison so that we can use a--- single comparison instruction.- | isOperand is32Bit x- , Just revcond <- maybeFlipCond cond = do-    platform <- getPlatform-    (y_reg, y_code) <- getNonClobberedReg y-    (x_op,  x_code) <- getOperand x-    let-        code = y_code `appOL` x_code `snocOL`-                  CMP (cmmTypeFormat (cmmExprType platform x)) x_op (OpReg y_reg)-    return (CondCode False revcond code)---- anything vs anything-condIntCode' _ cond x y = do-  platform <- getPlatform-  (y_reg, y_code) <- getNonClobberedReg y-  (x_op, x_code) <- getRegOrMem x-  let-        code = y_code `appOL`-               x_code `snocOL`-                  CMP (cmmTypeFormat (cmmExprType platform x)) (OpReg y_reg) x_op-  return (CondCode False cond code)-------------------------------------------------------------------------------------condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode--condFltCode cond x y-  =  condFltCode_sse2-  where---  -- in the SSE2 comparison ops (ucomiss, ucomisd) the left arg may be-  -- an operand, but the right must be a reg.  We can probably do better-  -- than this general case...-  condFltCode_sse2 = do-    platform <- getPlatform-    (x_reg, x_code) <- getNonClobberedReg x-    (y_op, y_code) <- getOperand y-    let-        code = x_code `appOL`-               y_code `snocOL`-                  CMP (floatFormat $ cmmExprWidth platform x) y_op (OpReg x_reg)-        -- NB(1): we need to use the unsigned comparison operators on the-        -- result of this comparison.-    return (CondCode True (condToUnsigned cond) code)---- -------------------------------------------------------------------------------- Generating assignments---- Assignments are really at the heart of the whole code generation--- business.  Almost all top-level nodes of any real importance are--- assignments, which correspond to loads, stores, or register--- transfers.  If we're really lucky, some of the register transfers--- will go away, because we can use the destination register to--- complete the code generation for the right hand side.  This only--- fails when the right hand side is forced into a fixed register--- (e.g. the result of a call).--assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock-assignReg_IntCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock--assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock-assignReg_FltCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock----- integer assignment to memory---- specific case of adding/subtracting an integer to a particular address.--- ToDo: catch other cases where we can use an operation directly on a memory--- address.-assignMem_IntCode pk addr (CmmMachOp op [CmmLoad addr2 _ _,-                                                 CmmLit (CmmInt i _)])-   | addr == addr2, pk /= II64 || is32BitInteger i,-     Just instr <- check op-   = do Amode amode code_addr <- getAmode addr-        let code = code_addr `snocOL`-                   instr pk (OpImm (ImmInt (fromIntegral i))) (OpAddr amode)-        return code-   where-        check (MO_Add _) = Just ADD-        check (MO_Sub _) = Just SUB-        check _ = Nothing-        -- ToDo: more?---- general case-assignMem_IntCode pk addr src = do-    is32Bit <- is32BitPlatform-    Amode addr code_addr <- getAmode addr-    (code_src, op_src)   <- get_op_RI is32Bit src-    let-        code = code_src `appOL`-               code_addr `snocOL`-                  MOV pk op_src (OpAddr addr)-        -- NOTE: op_src is stable, so it will still be valid-        -- after code_addr.  This may involve the introduction-        -- of an extra MOV to a temporary register, but we hope-        -- the register allocator will get rid of it.-    ---    return code-  where-    get_op_RI :: Bool -> CmmExpr -> NatM (InstrBlock,Operand)   -- code, operator-    get_op_RI is32Bit (CmmLit lit) | is32BitLit is32Bit lit-      = return (nilOL, OpImm (litToImm lit))-    get_op_RI _ op-      = do (reg,code) <- getNonClobberedReg op-           return (code, OpReg reg)----- Assign; dst is a reg, rhs is mem-assignReg_IntCode pk reg (CmmLoad src _ _) = do-  load_code <- intLoadCode (MOV pk) src-  platform <- ncgPlatform <$> getConfig-  return (load_code (getRegisterReg platform reg))---- dst is a reg, but src could be anything-assignReg_IntCode _ reg src = do-  platform <- ncgPlatform <$> getConfig-  code <- getAnyReg src-  return (code (getRegisterReg platform reg))----- Floating point assignment to memory-assignMem_FltCode pk addr src = do-  (src_reg, src_code) <- getNonClobberedReg src-  Amode addr addr_code <- getAmode addr-  let-        code = src_code `appOL`-               addr_code `snocOL`-               MOV pk (OpReg src_reg) (OpAddr addr)--  return code---- Floating point assignment to a register/temporary-assignReg_FltCode _ reg src = do-  src_code <- getAnyReg src-  platform <- ncgPlatform <$> getConfig-  return (src_code (getRegisterReg platform reg))---genJump :: CmmExpr{-the branch target-} -> [Reg] -> NatM InstrBlock--genJump (CmmLoad mem _ _) regs = do-  Amode target code <- getAmode mem-  return (code `snocOL` JMP (OpAddr target) regs)--genJump (CmmLit lit) regs =-  return (unitOL (JMP (OpImm (litToImm lit)) regs))--genJump expr regs = do-  (reg,code) <- getSomeReg expr-  return (code `snocOL` JMP (OpReg reg) regs)----- --------------------------------------------------------------------------------  Unconditional branches--genBranch :: BlockId -> InstrBlock-genBranch = toOL . mkJumpInstr------ --------------------------------------------------------------------------------  Conditional jumps/branches--{--Conditional jumps are always to local labels, so we can use branch-instructions.  We peek at the arguments to decide what kind of-comparison to do.--I386: First, we have to ensure that the condition-codes are set according to the supplied comparison operation.--}--{-  Note [64-bit integer comparisons on 32-bit]-    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--    When doing these comparisons there are 2 kinds of-    comparisons.--    * Comparison for equality (or lack thereof)--    We use xor to check if high/low bits are-    equal. Then combine the results using or and-    perform a single conditional jump based on the-    result.--    * Other comparisons:--    We map all other comparisons to the >= operation.-    Why? Because it's easy to encode it with a single-    conditional jump.--    We do this by first computing [r1_lo - r2_lo]-    and use the carry flag to compute-    [r1_high - r2_high - CF].--    At which point if r1 >= r2 then the result will be-    positive. Otherwise negative so we can branch on this-    condition.---}---genCondBranch-    :: BlockId      -- the source of the jump-    -> BlockId      -- the true branch target-    -> BlockId      -- the false branch target-    -> CmmExpr      -- the condition on which to branch-    -> NatM InstrBlock -- Instructions--genCondBranch bid id false expr = do-  is32Bit <- is32BitPlatform-  genCondBranch' is32Bit bid id false expr---- | We return the instructions generated.-genCondBranch' :: Bool -> BlockId -> BlockId -> BlockId -> CmmExpr-               -> NatM InstrBlock---- 64-bit integer comparisons on 32-bit--- See Note [64-bit integer comparisons on 32-bit]-genCondBranch' is32Bit _bid true false (CmmMachOp mop [e1,e2])-  | is32Bit, Just W64 <- maybeIntComparison mop = do--  -- The resulting registers here are both the lower part of-  -- the register as well as a way to get at the higher part.-  ChildCode64 code1 r1 <- iselExpr64 e1-  ChildCode64 code2 r2 <- iselExpr64 e2-  let cond = machOpToCond mop :: Cond--  let cmpCode = intComparison cond true false r1 r2-  return $ code1 `appOL` code2 `appOL` cmpCode--  where-    intComparison :: Cond -> BlockId -> BlockId -> Reg -> Reg -> InstrBlock-    intComparison cond true false r1_lo r2_lo =-      case cond of-        -- Impossible results of machOpToCond-        ALWAYS  -> panic "impossible"-        NEG     -> panic "impossible"-        POS     -> panic "impossible"-        CARRY   -> panic "impossible"-        OFLO    -> panic "impossible"-        PARITY  -> panic "impossible"-        NOTPARITY -> panic "impossible"-        -- Special case #1 x == y and x != y-        EQQ -> cmpExact-        NE  -> cmpExact-        -- [x >= y]-        GE  -> cmpGE-        GEU -> cmpGE-        -- [x >  y] <==> ![y >= x]-        GTT -> intComparison GE  false true r2_lo r1_lo-        GU  -> intComparison GEU false true r2_lo r1_lo-        -- [x <= y] <==> [y >= x]-        LE  -> intComparison GE  true false r2_lo r1_lo-        LEU -> intComparison GEU true false r2_lo r1_lo-        -- [x <  y] <==> ![x >= x]-        LTT -> intComparison GE  false true r1_lo r2_lo-        LU  -> intComparison GEU false true r1_lo r2_lo-      where-        r1_hi = getHiVRegFromLo r1_lo-        r2_hi = getHiVRegFromLo r2_lo-        cmpExact :: OrdList Instr-        cmpExact =-          toOL-            [ XOR II32 (OpReg r2_hi) (OpReg r1_hi)-            , XOR II32 (OpReg r2_lo) (OpReg r1_lo)-            , OR  II32 (OpReg r1_hi)  (OpReg r1_lo)-            , JXX cond true-            , JXX ALWAYS false-            ]-        cmpGE = toOL-            [ CMP II32 (OpReg r2_lo) (OpReg r1_lo)-            , SBB II32 (OpReg r2_hi) (OpReg r1_hi)-            , JXX cond true-            , JXX ALWAYS false ]--genCondBranch' _ bid id false bool = do-  CondCode is_float cond cond_code <- getCondCode bool-  use_sse2 <- sse2Enabled-  if not is_float || not use_sse2-    then-        return (cond_code `snocOL` JXX cond id `appOL` genBranch false)-    else do-        -- See Note [SSE Parity Checks]-        let jmpFalse = genBranch false-            code-                = case cond of-                  NE  -> or_unordered-                  GU  -> plain_test-                  GEU -> plain_test-                  -- Use ASSERT so we don't break releases if-                  -- LTT/LE creep in somehow.-                  LTT ->-                    ASSERT2(False, ppr "Should have been turned into >")-                    and_ordered-                  LE  ->-                    ASSERT2(False, ppr "Should have been turned into >=")-                    and_ordered-                  _   -> and_ordered--            plain_test = unitOL (-                  JXX cond id-                ) `appOL` jmpFalse-            or_unordered = toOL [-                  JXX cond id,-                  JXX PARITY id-                ] `appOL` jmpFalse-            and_ordered = toOL [-                  JXX PARITY false,-                  JXX cond id,-                  JXX ALWAYS false-                ]-        updateCfgNat (\cfg -> adjustEdgeWeight cfg (+3) bid false)-        return (cond_code `appOL` code)--{-  Note [Introducing cfg edges inside basic blocks]-    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--    During instruction selection a statement `s`-    in a block B with control of the sort: B -> C-    will sometimes result in control-    flow of the sort:--            ┌ < ┐-            v   ^-      B ->  B1  ┴ -> C--    as is the case for some atomic operations.--    Now to keep the CFG in sync when introducing B1 we clearly-    want to insert it between B and C. However there is-    a catch when we have to deal with self loops.--    We might start with code and a CFG of these forms:--    loop:-        stmt1               ┌ < ┐-        ....                v   ^-        stmtX              loop ┘-        stmtY-        ....-        goto loop:--    Now we introduce B1:-                            ┌ ─ ─ ─ ─ ─┐-        loop:               │   ┌ <  ┐ │-        instrs              v   │    │ ^-        ....               loop ┴ B1 ┴ ┘-        instrsFromX-        stmtY-        goto loop:--    This is simple, all outgoing edges from loop now simply-    start from B1 instead and the code generator knows which-    new edges it introduced for the self loop of B1.--    Disaster strikes if the statement Y follows the same pattern.-    If we apply the same rule that all outgoing edges change then-    we end up with:--        loop ─> B1 ─> B2 ┬─┐-          │      │    └─<┤ │-          │      └───<───┘ │-          └───────<────────┘--    This is problematic. The edge B1->B1 is modified as expected.-    However the modification is wrong!--    The assembly in this case looked like this:--    _loop:-        <instrs>-    _B1:-        ...-        cmpxchgq ...-        jne _B1-        <instrs>-        <end _B1>-    _B2:-        ...-        cmpxchgq ...-        jne _B2-        <instrs>-        jmp loop--    There is no edge _B2 -> _B1 here. It's still a self loop onto _B1.--    The problem here is that really B1 should be two basic blocks.-    Otherwise we have control flow in the *middle* of a basic block.-    A contradiction!--    So to account for this we add yet another basic block marker:--    _B:-        <instrs>-    _B1:-        ...-        cmpxchgq ...-        jne _B1-        jmp _B1'-    _B1':-        <instrs>-        <end _B1>-    _B2:-        ...--    Now when inserting B2 we will only look at the outgoing edges of B1' and-    everything will work out nicely.--    You might also wonder why we don't insert jumps at the end of _B1'. There is-    no way another block ends up jumping to the labels _B1 or _B2 since they are-    essentially invisible to other blocks. View them as control flow labels local-    to the basic block if you'd like.--    Not doing this ultimately caused (part 2 of) #17334.--}----- --------------------------------------------------------------------------------  Generating C calls---- Now the biggest nightmare---calls.  Most of the nastiness is buried in--- @get_arg@, which moves the arguments to the correct registers/stack--- locations.  Apart from that, the code is easy.------ (If applicable) Do not fill the delay slots here; you will confuse the--- register allocator.------ See Note [Keeping track of the current block] for information why we need--- to take/return a block id.--genCCall-    :: Bool                     -- 32 bit platform?-    -> ForeignTarget            -- function to call-    -> [CmmFormal]        -- where to put the result-    -> [CmmActual]        -- arguments (of mixed type)-    -> BlockId      -- The block we are in-    -> NatM (InstrBlock, Maybe BlockId)---- First we deal with cases which might introduce new blocks in the stream.--genCCall is32Bit (PrimTarget (MO_AtomicRMW width amop))-                                           [dst] [addr, n] bid = do-    Amode amode addr_code <--        if amop `elem` [AMO_Add, AMO_Sub]-        then getAmode addr-        else getSimpleAmode is32Bit addr  -- See genCCall for MO_Cmpxchg-    arg <- getNewRegNat format-    arg_code <- getAnyReg n-    platform <- ncgPlatform <$> getConfig--    let dst_r    = getRegisterReg platform  (CmmLocal dst)-    (code, lbl) <- op_code dst_r arg amode-    return (addr_code `appOL` arg_code arg `appOL` code, Just lbl)-  where-    -- Code for the operation-    op_code :: Reg       -- Destination reg-            -> Reg       -- Register containing argument-            -> AddrMode  -- Address of location to mutate-            -> NatM (OrdList Instr,BlockId) -- TODO: Return Maybe BlockId-    op_code dst_r arg amode = case amop of-        -- In the common case where dst_r is a virtual register the-        -- final move should go away, because it's the last use of arg-        -- and the first use of dst_r.-        AMO_Add  -> return $ (toOL [ LOCK (XADD format (OpReg arg) (OpAddr amode))-                                   , MOV format (OpReg arg) (OpReg dst_r)-                                   ], bid)-        AMO_Sub  -> return $ (toOL [ NEGI format (OpReg arg)-                                   , LOCK (XADD format (OpReg arg) (OpAddr amode))-                                   , MOV format (OpReg arg) (OpReg dst_r)-                                   ], bid)-        -- In these cases we need a new block id, and have to return it so-        -- that later instruction selection can reference it.-        AMO_And  -> cmpxchg_code (\ src dst -> unitOL $ AND format src dst)-        AMO_Nand -> cmpxchg_code (\ src dst -> toOL [ AND format src dst-                                                    , NOT format dst-                                                    ])-        AMO_Or   -> cmpxchg_code (\ src dst -> unitOL $ OR format src dst)-        AMO_Xor  -> cmpxchg_code (\ src dst -> unitOL $ XOR format src dst)-      where-        -- Simulate operation that lacks a dedicated instruction using-        -- cmpxchg.-        cmpxchg_code :: (Operand -> Operand -> OrdList Instr)-                     -> NatM (OrdList Instr, BlockId)-        cmpxchg_code instrs = do-            lbl1 <- getBlockIdNat-            lbl2 <- getBlockIdNat-            tmp <- getNewRegNat format--            --Record inserted blocks-            --  We turn A -> B into A -> A' -> A'' -> B-            --  with a self loop on A'.-            addImmediateSuccessorNat bid lbl1-            addImmediateSuccessorNat lbl1 lbl2-            updateCfgNat (addWeightEdge lbl1 lbl1 0)--            return $ (toOL-                [ MOV format (OpAddr amode) (OpReg eax)-                , JXX ALWAYS lbl1-                , NEWBLOCK lbl1-                  -- Keep old value so we can return it:-                , MOV format (OpReg eax) (OpReg dst_r)-                , MOV format (OpReg eax) (OpReg tmp)-                ]-                `appOL` instrs (OpReg arg) (OpReg tmp) `appOL` toOL-                [ LOCK (CMPXCHG format (OpReg tmp) (OpAddr amode))-                , JXX NE lbl1-                -- See Note [Introducing cfg edges inside basic blocks]-                -- why this basic block is required.-                , JXX ALWAYS lbl2-                , NEWBLOCK lbl2-                ],-                lbl2)-    format = intFormat width--genCCall is32Bit (PrimTarget (MO_Ctz width)) [dst] [src] bid-  | is32Bit, width == W64 = do-      ChildCode64 vcode rlo <- iselExpr64 src-      platform <- ncgPlatform <$> getConfig-      let rhi     = getHiVRegFromLo rlo-          dst_r   = getRegisterReg platform  (CmmLocal dst)-      lbl1 <- getBlockIdNat-      lbl2 <- getBlockIdNat-      let format = if width == W8 then II16 else intFormat width-      tmp_r <- getNewRegNat format--      -- New CFG Edges:-      --  bid -> lbl2-      --  bid -> lbl1 -> lbl2-      --  We also changes edges originating at bid to start at lbl2 instead.-      weights <- getCfgWeights-      updateCfgNat (addWeightEdge bid lbl1 110 .-                    addWeightEdge lbl1 lbl2 110 .-                    addImmediateSuccessor weights bid lbl2)--      -- The following instruction sequence corresponds to the pseudo-code-      ---      --  if (src) {-      --    dst = src.lo32 ? BSF(src.lo32) : (BSF(src.hi32) + 32);-      --  } else {-      --    dst = 64;-      --  }-      let !instrs = vcode `appOL` toOL-               ([ MOV      II32 (OpReg rhi)         (OpReg tmp_r)-                , OR       II32 (OpReg rlo)         (OpReg tmp_r)-                , MOV      II32 (OpImm (ImmInt 64)) (OpReg dst_r)-                , JXX EQQ    lbl2-                , JXX ALWAYS lbl1--                , NEWBLOCK   lbl1-                , BSF     II32 (OpReg rhi)         dst_r-                , ADD     II32 (OpImm (ImmInt 32)) (OpReg dst_r)-                , BSF     II32 (OpReg rlo)         tmp_r-                , CMOV NE II32 (OpReg tmp_r)       dst_r-                , JXX ALWAYS lbl2--                , NEWBLOCK   lbl2-                ])-      return (instrs, Just lbl2)--  | otherwise = do-    code_src <- getAnyReg src-    config <- getConfig-    let platform = ncgPlatform config-    let dst_r = getRegisterReg platform (CmmLocal dst)-    if ncgBmiVersion config >= Just BMI2-    then do-        src_r <- getNewRegNat (intFormat width)-        let instrs = appOL (code_src src_r) $ case width of-                W8 -> toOL-                    [ OR    II32 (OpImm (ImmInteger 0xFFFFFF00)) (OpReg src_r)-                    , TZCNT II32 (OpReg src_r)        dst_r-                    ]-                W16 -> toOL-                    [ TZCNT  II16 (OpReg src_r) dst_r-                    , MOVZxL II16 (OpReg dst_r) (OpReg dst_r)-                    ]-                _ -> unitOL $ TZCNT (intFormat width) (OpReg src_r) dst_r-        return (instrs, Nothing)-    else do-        -- The following insn sequence makes sure 'ctz 0' has a defined value.-        -- starting with Haswell, one could use the TZCNT insn instead.-        let format = if width == W8 then II16 else intFormat width-        src_r <- getNewRegNat format-        tmp_r <- getNewRegNat format-        let !instrs = code_src src_r `appOL` toOL-                 ([ MOVZxL  II8    (OpReg src_r) (OpReg src_r) | width == W8 ] ++-                  [ BSF     format (OpReg src_r) tmp_r-                  , MOV     II32   (OpImm (ImmInt bw)) (OpReg dst_r)-                  , CMOV NE format (OpReg tmp_r) dst_r-                  ]) -- NB: We don't need to zero-extend the result for the-                     -- W8/W16 cases because the 'MOV' insn already-                     -- took care of implicitly clearing the upper bits-        return (instrs, Nothing)-  where-    bw = widthInBits width--genCCall bits mop dst args bid = do-  config <- getConfig-  instr <- genCCall' config bits mop dst args bid-  return (instr, Nothing)---- genCCall' handles cases not introducing new code blocks.-genCCall'-    :: NCGConfig-    -> Bool                     -- 32 bit platform?-    -> ForeignTarget            -- function to call-    -> [CmmFormal]        -- where to put the result-    -> [CmmActual]        -- arguments (of mixed type)-    -> BlockId      -- The block we are in-    -> NatM InstrBlock---- Unroll memcpy calls if the number of bytes to copy isn't too--- large.  Otherwise, call C's memcpy.-genCCall' config _ (PrimTarget (MO_Memcpy align)) _-         [dst, src, CmmLit (CmmInt n _)] _-    | fromInteger insns <= ncgInlineThresholdMemcpy config = do-        code_dst <- getAnyReg dst-        dst_r <- getNewRegNat format-        code_src <- getAnyReg src-        src_r <- getNewRegNat format-        tmp_r <- getNewRegNat format-        return $ code_dst dst_r `appOL` code_src src_r `appOL`-            go dst_r src_r tmp_r (fromInteger n)-  where-    platform = ncgPlatform config-    -- The number of instructions we will generate (approx). We need 2-    -- instructions per move.-    insns = 2 * ((n + sizeBytes - 1) `div` sizeBytes)--    maxAlignment = wordAlignment platform -- only machine word wide MOVs are supported-    effectiveAlignment = min (alignmentOf align) maxAlignment-    format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment--    -- The size of each move, in bytes.-    sizeBytes :: Integer-    sizeBytes = fromIntegral (formatInBytes format)--    go :: Reg -> Reg -> Reg -> Integer -> OrdList Instr-    go dst src tmp i-        | i >= sizeBytes =-            unitOL (MOV format (OpAddr src_addr) (OpReg tmp)) `appOL`-            unitOL (MOV format (OpReg tmp) (OpAddr dst_addr)) `appOL`-            go dst src tmp (i - sizeBytes)-        -- Deal with remaining bytes.-        | i >= 4 =  -- Will never happen on 32-bit-            unitOL (MOV II32 (OpAddr src_addr) (OpReg tmp)) `appOL`-            unitOL (MOV II32 (OpReg tmp) (OpAddr dst_addr)) `appOL`-            go dst src tmp (i - 4)-        | i >= 2 =-            unitOL (MOVZxL II16 (OpAddr src_addr) (OpReg tmp)) `appOL`-            unitOL (MOV II16 (OpReg tmp) (OpAddr dst_addr)) `appOL`-            go dst src tmp (i - 2)-        | i >= 1 =-            unitOL (MOVZxL II8 (OpAddr src_addr) (OpReg tmp)) `appOL`-            unitOL (MOV II8 (OpReg tmp) (OpAddr dst_addr)) `appOL`-            go dst src tmp (i - 1)-        | otherwise = nilOL-      where-        src_addr = AddrBaseIndex (EABaseReg src) EAIndexNone-                   (ImmInteger (n - i))-        dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone-                   (ImmInteger (n - i))--genCCall' config _ (PrimTarget (MO_Memset align)) _-         [dst,-          CmmLit (CmmInt c _),-          CmmLit (CmmInt n _)]-         _-    | fromInteger insns <= ncgInlineThresholdMemset config = do-        code_dst <- getAnyReg dst-        dst_r <- getNewRegNat format-        if format == II64 && n >= 8 then do-          code_imm8byte <- getAnyReg (CmmLit (CmmInt c8 W64))-          imm8byte_r <- getNewRegNat II64-          return $ code_dst dst_r `appOL`-                   code_imm8byte imm8byte_r `appOL`-                   go8 dst_r imm8byte_r (fromInteger n)-        else-          return $ code_dst dst_r `appOL`-                   go4 dst_r (fromInteger n)-  where-    platform = ncgPlatform config-    maxAlignment = wordAlignment platform -- only machine word wide MOVs are supported-    effectiveAlignment = min (alignmentOf align) maxAlignment-    format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment-    c2 = c `shiftL` 8 .|. c-    c4 = c2 `shiftL` 16 .|. c2-    c8 = c4 `shiftL` 32 .|. c4--    -- The number of instructions we will generate (approx). We need 1-    -- instructions per move.-    insns = (n + sizeBytes - 1) `div` sizeBytes--    -- The size of each move, in bytes.-    sizeBytes :: Integer-    sizeBytes = fromIntegral (formatInBytes format)--    -- Depending on size returns the widest MOV instruction and its-    -- width.-    gen4 :: AddrMode -> Integer -> (InstrBlock, Integer)-    gen4 addr size-        | size >= 4 =-            (unitOL (MOV II32 (OpImm (ImmInteger c4)) (OpAddr addr)), 4)-        | size >= 2 =-            (unitOL (MOV II16 (OpImm (ImmInteger c2)) (OpAddr addr)), 2)-        | size >= 1 =-            (unitOL (MOV II8 (OpImm (ImmInteger c)) (OpAddr addr)), 1)-        | otherwise = (nilOL, 0)--    -- Generates a 64-bit wide MOV instruction from REG to MEM.-    gen8 :: AddrMode -> Reg -> InstrBlock-    gen8 addr reg8byte =-      unitOL (MOV format (OpReg reg8byte) (OpAddr addr))--    -- Unrolls memset when the widest MOV is <= 4 bytes.-    go4 :: Reg -> Integer -> InstrBlock-    go4 dst left =-      if left <= 0 then nilOL-      else curMov `appOL` go4 dst (left - curWidth)-      where-        possibleWidth = minimum [left, sizeBytes]-        dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - left))-        (curMov, curWidth) = gen4 dst_addr possibleWidth--    -- Unrolls memset when the widest MOV is 8 bytes (thus another Reg-    -- argument). Falls back to go4 when all 8 byte moves are-    -- exhausted.-    go8 :: Reg -> Reg -> Integer -> InstrBlock-    go8 dst reg8byte left =-      if possibleWidth >= 8 then-        let curMov = gen8 dst_addr reg8byte-        in  curMov `appOL` go8 dst reg8byte (left - 8)-      else go4 dst left-      where-        possibleWidth = minimum [left, sizeBytes]-        dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - left))--genCCall' _ _ (PrimTarget MO_ReadBarrier) _ _ _  = return nilOL-genCCall' _ _ (PrimTarget MO_WriteBarrier) _ _ _ = return nilOL-        -- barriers compile to no code on x86/x86-64;-        -- we keep it this long in order to prevent earlier optimisations.--genCCall' _ _ (PrimTarget MO_Touch) _ _ _ = return nilOL--genCCall' _ is32bit (PrimTarget (MO_Prefetch_Data n )) _  [src] _ =-        case n of-            0 -> genPrefetch src $ PREFETCH NTA  format-            1 -> genPrefetch src $ PREFETCH Lvl2 format-            2 -> genPrefetch src $ PREFETCH Lvl1 format-            3 -> genPrefetch src $ PREFETCH Lvl0 format-            l -> panic $ "unexpected prefetch level in genCCall MO_Prefetch_Data: " ++ (show l)-            -- the c / llvm prefetch convention is 0, 1, 2, and 3-            -- the x86 corresponding names are : NTA, 2 , 1, and 0-   where-        format = archWordFormat is32bit-        -- need to know what register width for pointers!-        genPrefetch inRegSrc prefetchCTor =-            do-                code_src <- getAnyReg inRegSrc-                src_r <- getNewRegNat format-                return $ code_src src_r `appOL`-                  (unitOL (prefetchCTor  (OpAddr-                              ((AddrBaseIndex (EABaseReg src_r )   EAIndexNone (ImmInt 0))))  ))-                  -- prefetch always takes an address--genCCall' _ is32Bit (PrimTarget (MO_BSwap width)) [dst] [src] _ = do-    platform <- ncgPlatform <$> getConfig-    let dst_r = getRegisterReg platform (CmmLocal dst)-    case width of-        W64 | is32Bit -> do-               ChildCode64 vcode rlo <- iselExpr64 src-               let dst_rhi = getHiVRegFromLo dst_r-                   rhi     = getHiVRegFromLo rlo-               return $ vcode `appOL`-                        toOL [ MOV II32 (OpReg rlo) (OpReg dst_rhi),-                               MOV II32 (OpReg rhi) (OpReg dst_r),-                               BSWAP II32 dst_rhi,-                               BSWAP II32 dst_r ]-        W16 -> do code_src <- getAnyReg src-                  return $ code_src dst_r `appOL`-                           unitOL (BSWAP II32 dst_r) `appOL`-                           unitOL (SHR II32 (OpImm $ ImmInt 16) (OpReg dst_r))-        _   -> do code_src <- getAnyReg src-                  return $ code_src dst_r `appOL` unitOL (BSWAP format dst_r)-  where-    format = intFormat width--genCCall' config is32Bit (PrimTarget (MO_PopCnt width)) dest_regs@[dst]-         args@[src] bid = do-    sse4_2 <- sse4_2Enabled-    let platform = ncgPlatform config-    if sse4_2-        then do code_src <- getAnyReg src-                src_r <- getNewRegNat format-                let dst_r = getRegisterReg platform  (CmmLocal dst)-                return $ code_src src_r `appOL`-                    (if width == W8 then-                         -- The POPCNT instruction doesn't take a r/m8-                         unitOL (MOVZxL II8 (OpReg src_r) (OpReg src_r)) `appOL`-                         unitOL (POPCNT II16 (OpReg src_r) dst_r)-                     else-                         unitOL (POPCNT format (OpReg src_r) dst_r)) `appOL`-                    (if width == W8 || width == W16 then-                         -- We used a 16-bit destination register above,-                         -- so zero-extend-                         unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r))-                     else nilOL)-        else do-            targetExpr <- cmmMakeDynamicReference config-                          CallReference lbl-            let target = ForeignTarget targetExpr (ForeignConvention CCallConv-                                                           [NoHint] [NoHint]-                                                           CmmMayReturn)-            genCCall' config is32Bit target dest_regs args bid-  where-    format = intFormat width-    lbl = mkCmmCodeLabel primUnitId (fsLit (popCntLabel width))--genCCall' config is32Bit (PrimTarget (MO_Pdep width)) dest_regs@[dst]-         args@[src, mask] bid = do-    let platform = ncgPlatform config-    if ncgBmiVersion config >= Just BMI2-        then do code_src  <- getAnyReg src-                code_mask <- getAnyReg mask-                src_r     <- getNewRegNat format-                mask_r    <- getNewRegNat format-                let dst_r = getRegisterReg platform  (CmmLocal dst)-                return $ code_src src_r `appOL` code_mask mask_r `appOL`-                    (if width == W8 then-                         -- The PDEP instruction doesn't take a r/m8-                         unitOL (MOVZxL II8  (OpReg src_r ) (OpReg src_r )) `appOL`-                         unitOL (MOVZxL II8  (OpReg mask_r) (OpReg mask_r)) `appOL`-                         unitOL (PDEP   II16 (OpReg mask_r) (OpReg src_r ) dst_r)-                     else-                         unitOL (PDEP format (OpReg mask_r) (OpReg src_r) dst_r)) `appOL`-                    (if width == W8 || width == W16 then-                         -- We used a 16-bit destination register above,-                         -- so zero-extend-                         unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r))-                     else nilOL)-        else do-            targetExpr <- cmmMakeDynamicReference config-                          CallReference lbl-            let target = ForeignTarget targetExpr (ForeignConvention CCallConv-                                                           [NoHint] [NoHint]-                                                           CmmMayReturn)-            genCCall' config is32Bit target dest_regs args bid-  where-    format = intFormat width-    lbl = mkCmmCodeLabel primUnitId (fsLit (pdepLabel width))--genCCall' config is32Bit (PrimTarget (MO_Pext width)) dest_regs@[dst]-         args@[src, mask] bid = do-    let platform = ncgPlatform config-    if ncgBmiVersion config >= Just BMI2-        then do code_src  <- getAnyReg src-                code_mask <- getAnyReg mask-                src_r     <- getNewRegNat format-                mask_r    <- getNewRegNat format-                let dst_r = getRegisterReg platform  (CmmLocal dst)-                return $ code_src src_r `appOL` code_mask mask_r `appOL`-                    (if width == W8 then-                         -- The PEXT instruction doesn't take a r/m8-                         unitOL (MOVZxL II8 (OpReg src_r ) (OpReg src_r )) `appOL`-                         unitOL (MOVZxL II8 (OpReg mask_r) (OpReg mask_r)) `appOL`-                         unitOL (PEXT II16 (OpReg mask_r) (OpReg src_r) dst_r)-                     else-                         unitOL (PEXT format (OpReg mask_r) (OpReg src_r) dst_r)) `appOL`-                    (if width == W8 || width == W16 then-                         -- We used a 16-bit destination register above,-                         -- so zero-extend-                         unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r))-                     else nilOL)-        else do-            targetExpr <- cmmMakeDynamicReference config-                          CallReference lbl-            let target = ForeignTarget targetExpr (ForeignConvention CCallConv-                                                           [NoHint] [NoHint]-                                                           CmmMayReturn)-            genCCall' config is32Bit target dest_regs args bid-  where-    format = intFormat width-    lbl = mkCmmCodeLabel primUnitId (fsLit (pextLabel width))--genCCall' config is32Bit (PrimTarget (MO_Clz width)) dest_regs@[dst] args@[src] bid-  | is32Bit && width == W64 = do-    -- Fallback to `hs_clz64` on i386-    targetExpr <- cmmMakeDynamicReference config CallReference lbl-    let target = ForeignTarget targetExpr (ForeignConvention CCallConv-                                           [NoHint] [NoHint]-                                           CmmMayReturn)-    genCCall' config is32Bit target dest_regs args bid--  | otherwise = do-    code_src <- getAnyReg src-    config <- getConfig-    let platform = ncgPlatform config-    let dst_r = getRegisterReg platform (CmmLocal dst)-    if ncgBmiVersion config >= Just BMI2-        then do-            src_r <- getNewRegNat (intFormat width)-            return $ appOL (code_src src_r) $ case width of-                W8 -> toOL-                    [ MOVZxL II8  (OpReg src_r)       (OpReg src_r) -- zero-extend to 32 bit-                    , LZCNT  II32 (OpReg src_r)       dst_r         -- lzcnt with extra 24 zeros-                    , SUB    II32 (OpImm (ImmInt 24)) (OpReg dst_r) -- compensate for extra zeros-                    ]-                W16 -> toOL-                    [ LZCNT  II16 (OpReg src_r) dst_r-                    , MOVZxL II16 (OpReg dst_r) (OpReg dst_r) -- zero-extend from 16 bit-                    ]-                _ -> unitOL (LZCNT (intFormat width) (OpReg src_r) dst_r)-        else do-            let format = if width == W8 then II16 else intFormat width-            src_r <- getNewRegNat format-            tmp_r <- getNewRegNat format-            return $ code_src src_r `appOL` toOL-                     ([ MOVZxL  II8    (OpReg src_r) (OpReg src_r) | width == W8 ] ++-                      [ BSR     format (OpReg src_r) tmp_r-                      , MOV     II32   (OpImm (ImmInt (2*bw-1))) (OpReg dst_r)-                      , CMOV NE format (OpReg tmp_r) dst_r-                      , XOR     format (OpImm (ImmInt (bw-1))) (OpReg dst_r)-                      ]) -- NB: We don't need to zero-extend the result for the-                         -- W8/W16 cases because the 'MOV' insn already-                         -- took care of implicitly clearing the upper bits-  where-    bw = widthInBits width-    lbl = mkCmmCodeLabel primUnitId (fsLit (clzLabel width))--genCCall' config is32Bit (PrimTarget (MO_UF_Conv width)) dest_regs args bid = do-    targetExpr <- cmmMakeDynamicReference config-                  CallReference lbl-    let target = ForeignTarget targetExpr (ForeignConvention CCallConv-                                           [NoHint] [NoHint]-                                           CmmMayReturn)-    genCCall' config is32Bit target dest_regs args bid-  where-    lbl = mkCmmCodeLabel primUnitId (fsLit (word2FloatLabel width))--genCCall' _ _ (PrimTarget (MO_AtomicRead width)) [dst] [addr] _ = do-  load_code <- intLoadCode (MOV (intFormat width)) addr-  platform <- ncgPlatform <$> getConfig--  return (load_code (getRegisterReg platform  (CmmLocal dst)))--genCCall' _ _ (PrimTarget (MO_AtomicWrite width)) [] [addr, val] _ = do-    code <- assignMem_IntCode (intFormat width) addr val-    return $ code `snocOL` MFENCE--genCCall' _ is32Bit (PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] _ = do-    -- On x86 we don't have enough registers to use cmpxchg with a-    -- complicated addressing mode, so on that architecture we-    -- pre-compute the address first.-    Amode amode addr_code <- getSimpleAmode is32Bit addr-    newval <- getNewRegNat format-    newval_code <- getAnyReg new-    oldval <- getNewRegNat format-    oldval_code <- getAnyReg old-    platform <- getPlatform-    let dst_r    = getRegisterReg platform  (CmmLocal dst)-        code     = toOL-                   [ MOV format (OpReg oldval) (OpReg eax)-                   , LOCK (CMPXCHG format (OpReg newval) (OpAddr amode))-                   , MOV format (OpReg eax) (OpReg dst_r)-                   ]-    return $ addr_code `appOL` newval_code newval `appOL` oldval_code oldval-        `appOL` code-  where-    format = intFormat width--genCCall' config is32Bit (PrimTarget (MO_Xchg width)) [dst] [addr, value] _-  | (is32Bit && width == W64) = panic "gencCall: 64bit atomic exchange not supported on 32bit platforms"-  | otherwise = do-    let dst_r = getRegisterReg platform (CmmLocal dst)-    Amode amode addr_code <- getSimpleAmode is32Bit addr-    (newval, newval_code) <- getSomeReg value-    -- Copy the value into the target register, perform the exchange.-    let code     = toOL-                   [ MOV format (OpReg newval) (OpReg dst_r)-                    -- On X86 xchg implies a lock prefix if we use a memory argument.-                    -- so this is atomic.-                   , XCHG format (OpAddr amode) dst_r-                   ]-    return $ addr_code `appOL` newval_code `appOL` code-  where-    format = intFormat width-    platform = ncgPlatform config--genCCall' _ is32Bit target dest_regs args bid = do-  platform <- ncgPlatform <$> getConfig-  case (target, dest_regs) of-    -- void return type prim op-    (PrimTarget op, []) ->-        outOfLineCmmOp bid op Nothing args-    -- we only cope with a single result for foreign calls-    (PrimTarget op, [r])  -> case op of-          MO_F32_Fabs -> case args of-            [x] -> sse2FabsCode W32 x-            _ -> panic "genCCall: Wrong number of arguments for fabs"-          MO_F64_Fabs -> case args of-            [x] -> sse2FabsCode W64 x-            _ -> panic "genCCall: Wrong number of arguments for fabs"--          MO_F32_Sqrt -> actuallyInlineSSE2Op (\fmt r -> SQRT fmt (OpReg r)) FF32 args-          MO_F64_Sqrt -> actuallyInlineSSE2Op (\fmt r -> SQRT fmt (OpReg r)) FF64 args-          _other_op -> outOfLineCmmOp bid op (Just r) args--       where-        actuallyInlineSSE2Op = actuallyInlineFloatOp'--        actuallyInlineFloatOp'  instr format [x]-              = do res <- trivialUFCode format (instr format) x-                   any <- anyReg res-                   return (any (getRegisterReg platform  (CmmLocal r)))--        actuallyInlineFloatOp' _ _ args-              = panic $ "genCCall.actuallyInlineFloatOp': bad number of arguments! ("-                      ++ show (length args) ++ ")"--        sse2FabsCode :: Width -> CmmExpr -> NatM InstrBlock-        sse2FabsCode w x = do-          let fmt = floatFormat w-          x_code <- getAnyReg x-          let-            const | FF32 <- fmt = CmmInt 0x7fffffff W32-                  | otherwise   = CmmInt 0x7fffffffffffffff W64-          Amode amode amode_code <- memConstant (mkAlignment $ widthInBytes w) const-          tmp <- getNewRegNat fmt-          let-            code dst = x_code dst `appOL` amode_code `appOL` toOL [-                MOV fmt (OpAddr amode) (OpReg tmp),-                AND fmt (OpReg tmp) (OpReg dst)-                ]--          return $ code (getRegisterReg platform (CmmLocal r))--    (PrimTarget (MO_S_QuotRem  width), _) -> divOp1 platform True  width dest_regs args-    (PrimTarget (MO_U_QuotRem  width), _) -> divOp1 platform False width dest_regs args-    (PrimTarget (MO_U_QuotRem2 width), _) -> divOp2 platform False width dest_regs args-    (PrimTarget (MO_Add2 width), [res_h, res_l]) ->-        case args of-        [arg_x, arg_y] ->-            do hCode <- getAnyReg (CmmLit (CmmInt 0 width))-               let format = intFormat width-               lCode <- anyReg =<< trivialCode width (ADD_CC format)-                                     (Just (ADD_CC format)) arg_x arg_y-               let reg_l = getRegisterReg platform (CmmLocal res_l)-                   reg_h = getRegisterReg platform (CmmLocal res_h)-                   code = hCode reg_h `appOL`-                          lCode reg_l `snocOL`-                          ADC format (OpImm (ImmInteger 0)) (OpReg reg_h)-               return code-        _ -> panic "genCCall: Wrong number of arguments/results for add2"-    (PrimTarget (MO_AddWordC width), [res_r, res_c]) ->-        addSubIntC platform ADD_CC (const Nothing) CARRY width res_r res_c args-    (PrimTarget (MO_SubWordC width), [res_r, res_c]) ->-        addSubIntC platform SUB_CC (const Nothing) CARRY width res_r res_c args-    (PrimTarget (MO_AddIntC width), [res_r, res_c]) ->-        addSubIntC platform ADD_CC (Just . ADD_CC) OFLO width res_r res_c args-    (PrimTarget (MO_SubIntC width), [res_r, res_c]) ->-        addSubIntC platform SUB_CC (const Nothing) OFLO width res_r res_c args-    (PrimTarget (MO_U_Mul2 width), [res_h, res_l]) ->-        case args of-        [arg_x, arg_y] ->-            do (y_reg, y_code) <- getRegOrMem arg_y-               x_code <- getAnyReg arg_x-               let format = intFormat width-                   reg_h = getRegisterReg platform (CmmLocal res_h)-                   reg_l = getRegisterReg platform (CmmLocal res_l)-                   code = y_code `appOL`-                          x_code rax `appOL`-                          toOL [MUL2 format y_reg,-                                MOV format (OpReg rdx) (OpReg reg_h),-                                MOV format (OpReg rax) (OpReg reg_l)]-               return code-        _ -> panic "genCCall: Wrong number of arguments/results for mul2"-    (PrimTarget (MO_S_Mul2 width), [res_c, res_h, res_l]) ->-        case args of-        [arg_x, arg_y] ->-            do (y_reg, y_code) <- getRegOrMem arg_y-               x_code <- getAnyReg arg_x-               reg_tmp <- getNewRegNat II8-               let format = intFormat width-                   reg_h = getRegisterReg platform (CmmLocal res_h)-                   reg_l = getRegisterReg platform (CmmLocal res_l)-                   reg_c = getRegisterReg platform (CmmLocal res_c)-                   code = y_code `appOL`-                          x_code rax `appOL`-                          toOL [ IMUL2 format y_reg-                               , MOV format (OpReg rdx) (OpReg reg_h)-                               , MOV format (OpReg rax) (OpReg reg_l)-                               , SETCC CARRY (OpReg reg_tmp)-                               , MOVZxL II8 (OpReg reg_tmp) (OpReg reg_c)-                               ]-               return code-        _ -> panic "genCCall: Wrong number of arguments/results for imul2"--    _ -> do-        (instrs0, args') <- evalArgs bid args-        instrs1 <- if is32Bit-          then genCCall32' target dest_regs args'-          else genCCall64' target dest_regs args'-        return (instrs0 `appOL` instrs1)--  where divOp1 platform signed width results [arg_x, arg_y]-            = divOp platform signed width results Nothing arg_x arg_y-        divOp1 _ _ _ _ _-            = panic "genCCall: Wrong number of arguments for divOp1"-        divOp2 platform signed width results [arg_x_high, arg_x_low, arg_y]-            = divOp platform signed width results (Just arg_x_high) arg_x_low arg_y-        divOp2 _ _ _ _ _-            = panic "genCCall: Wrong number of arguments for divOp2"--        -- See Note [DIV/IDIV for bytes]-        divOp platform signed W8 [res_q, res_r] m_arg_x_high arg_x_low arg_y =-            let widen | signed = MO_SS_Conv W8 W16-                      | otherwise = MO_UU_Conv W8 W16-                arg_x_low_16 = CmmMachOp widen [arg_x_low]-                arg_y_16 = CmmMachOp widen [arg_y]-                m_arg_x_high_16 = (\p -> CmmMachOp widen [p]) <$> m_arg_x_high-            in divOp-                  platform signed W16 [res_q, res_r]-                  m_arg_x_high_16 arg_x_low_16 arg_y_16--        divOp platform signed width [res_q, res_r]-              m_arg_x_high arg_x_low arg_y-            = do let format = intFormat width-                     reg_q = getRegisterReg platform (CmmLocal res_q)-                     reg_r = getRegisterReg platform (CmmLocal res_r)-                     widen | signed    = CLTD format-                           | otherwise = XOR format (OpReg rdx) (OpReg rdx)-                     instr | signed    = IDIV-                           | otherwise = DIV-                 (y_reg, y_code) <- getRegOrMem arg_y-                 x_low_code <- getAnyReg arg_x_low-                 x_high_code <- case m_arg_x_high of-                                Just arg_x_high ->-                                    getAnyReg arg_x_high-                                Nothing ->-                                    return $ const $ unitOL widen-                 return $ y_code `appOL`-                          x_low_code rax `appOL`-                          x_high_code rdx `appOL`-                          toOL [instr format y_reg,-                                MOV format (OpReg rax) (OpReg reg_q),-                                MOV format (OpReg rdx) (OpReg reg_r)]-        divOp _ _ _ _ _ _ _-            = panic "genCCall: Wrong number of results for divOp"--        addSubIntC platform instr mrevinstr cond width-                   res_r res_c [arg_x, arg_y]-            = do let format = intFormat width-                 rCode <- anyReg =<< trivialCode width (instr format)-                                       (mrevinstr format) arg_x arg_y-                 reg_tmp <- getNewRegNat II8-                 let reg_c = getRegisterReg platform  (CmmLocal res_c)-                     reg_r = getRegisterReg platform  (CmmLocal res_r)-                     code = rCode reg_r `snocOL`-                            SETCC cond (OpReg reg_tmp) `snocOL`-                            MOVZxL II8 (OpReg reg_tmp) (OpReg reg_c)--                 return code-        addSubIntC _ _ _ _ _ _ _ _-            = panic "genCCall: Wrong number of arguments/results for addSubIntC"--{--Note [Evaluate C-call arguments before placing in destination registers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--When producing code for C calls we must take care when placing arguments-in their final registers. Specifically, we must ensure that temporary register-usage due to evaluation of one argument does not clobber a register in which we-already placed a previous argument (e.g. as the code generation logic for-MO_Shl can clobber %rcx due to x86 instruction limitations).--This is precisely what happened in #18527. Consider this C--:--    (result::I64) = call "ccall" doSomething(_s2hp::I64, 2244, _s2hq::I64, _s2hw::I64 | (1 << _s2hz::I64));--Here we are calling the C function `doSomething` with three arguments, the last-involving a non-trivial expression involving MO_Shl. In this case the NCG could-naively generate the following assembly (where $tmp denotes some temporary-register and $argN denotes the register for argument N, as dictated by the-platform's calling convention):--    mov _s2hp, $arg1   # place first argument-    mov _s2hq, $arg2   # place second argument--    # Compute 1 << _s2hz-    mov _s2hz, %rcx-    shl %cl, $tmp--    # Compute (_s2hw | (1 << _s2hz))-    mov _s2hw, $arg3-    or $tmp, $arg3--    # Perform the call-    call func--This code is outright broken on Windows which assigns $arg1 to %rcx. This means-that the evaluation of the last argument clobbers the first argument.--To avoid this we use a rather awful hack: when producing code for a C call with-at least one non-trivial argument, we first evaluate all of the arguments into-local registers before moving them into their final calling-convention-defined-homes.  This is performed by 'evalArgs'. Here we define "non-trivial" to be an-expression which might contain a MachOp since these are the only cases which-might clobber registers. Furthermore, we use a conservative approximation of-this condition (only looking at the top-level of CmmExprs) to avoid spending-too much effort trying to decide whether we want to take the fast path.--Note that this hack *also* applies to calls to out-of-line PrimTargets (which-are lowered via a C call) since outOfLineCmmOp produces the call via-(stmtToInstrs (CmmUnsafeForeignCall ...)), which will ultimately end up-back in genCCall{32,64}.--}---- | See Note [Evaluate C-call arguments before placing in destination registers]-evalArgs :: BlockId -> [CmmActual] -> NatM (InstrBlock, [CmmActual])-evalArgs bid actuals-  | any mightContainMachOp actuals = do-      regs_blks <- mapM evalArg actuals-      return (concatOL $ map fst regs_blks, map snd regs_blks)-  | otherwise = return (nilOL, actuals)-  where-    mightContainMachOp (CmmReg _)      = False-    mightContainMachOp (CmmRegOff _ _) = False-    mightContainMachOp (CmmLit _)      = False-    mightContainMachOp _               = True--    evalArg :: CmmActual -> NatM (InstrBlock, CmmExpr)-    evalArg actual = do-        platform <- getPlatform-        lreg <- newLocalReg $ cmmExprType platform actual-        (instrs, bid1) <- stmtToInstrs bid $ CmmAssign (CmmLocal lreg) actual-        -- The above assignment shouldn't change the current block-        MASSERT(isNothing bid1)-        return (instrs, CmmReg $ CmmLocal lreg)--    newLocalReg :: CmmType -> NatM LocalReg-    newLocalReg ty = LocalReg <$> getUniqueM <*> pure ty---- Note [DIV/IDIV for bytes]------ IDIV reminder:---   Size    Dividend   Divisor   Quotient    Remainder---   byte    %ax         r/m8      %al          %ah---   word    %dx:%ax     r/m16     %ax          %dx---   dword   %edx:%eax   r/m32     %eax         %edx---   qword   %rdx:%rax   r/m64     %rax         %rdx------ We do a special case for the byte division because the current--- codegen doesn't deal well with accessing %ah register (also,--- accessing %ah in 64-bit mode is complicated because it cannot be an--- operand of many instructions). So we just widen operands to 16 bits--- and get the results from %al, %dl. This is not optimal, but a few--- register moves are probably not a huge deal when doing division.--genCCall32' :: ForeignTarget            -- function to call-            -> [CmmFormal]        -- where to put the result-            -> [CmmActual]        -- arguments (of mixed type)-            -> NatM InstrBlock-genCCall32' target dest_regs args = do-        config <- getConfig-        let platform = ncgPlatform config-            prom_args = map (maybePromoteCArg platform W32) args--            -- If the size is smaller than the word, we widen things (see maybePromoteCArg)-            arg_size_bytes :: CmmType -> Int-            arg_size_bytes ty = max (widthInBytes (typeWidth ty)) (widthInBytes (wordWidth platform))--            roundTo a x | x `mod` a == 0 = x-                        | otherwise = x + a - (x `mod` a)--            push_arg :: CmmActual {-current argument-}-                            -> NatM InstrBlock  -- code--            push_arg  arg -- we don't need the hints on x86-              | isWord64 arg_ty = do-                ChildCode64 code r_lo <- iselExpr64 arg-                delta <- getDeltaNat-                setDeltaNat (delta - 8)-                let r_hi = getHiVRegFromLo r_lo-                return (       code `appOL`-                               toOL [PUSH II32 (OpReg r_hi), DELTA (delta - 4),-                                     PUSH II32 (OpReg r_lo), DELTA (delta - 8),-                                     DELTA (delta-8)]-                    )--              | isFloatType arg_ty = do-                (reg, code) <- getSomeReg arg-                delta <- getDeltaNat-                setDeltaNat (delta-size)-                return (code `appOL`-                                toOL [SUB II32 (OpImm (ImmInt size)) (OpReg esp),-                                      DELTA (delta-size),-                                      let addr = AddrBaseIndex (EABaseReg esp)-                                                                EAIndexNone-                                                                (ImmInt 0)-                                          format = floatFormat (typeWidth arg_ty)-                                      in--                                      -- assume SSE2-                                       MOV format (OpReg reg) (OpAddr addr)--                                     ]-                               )--              | otherwise = do-                -- Arguments can be smaller than 32-bit, but we still use @PUSH-                -- II32@ - the usual calling conventions expect integers to be-                -- 4-byte aligned.-                ASSERT((typeWidth arg_ty) <= W32) return ()-                (operand, code) <- getOperand arg-                delta <- getDeltaNat-                setDeltaNat (delta-size)-                return (code `snocOL`-                        PUSH II32 operand `snocOL`-                        DELTA (delta-size))--              where-                 arg_ty = cmmExprType platform arg-                 size = arg_size_bytes arg_ty -- Byte size--        let-            -- Align stack to 16n for calls, assuming a starting stack-            -- alignment of 16n - word_size on procedure entry. Which we-            -- maintiain. See Note [rts/StgCRun.c : Stack Alignment on X86]-            sizes               = map (arg_size_bytes . cmmExprType platform) (reverse args)-            raw_arg_size        = sum sizes + platformWordSizeInBytes platform-            arg_pad_size        = (roundTo 16 $ raw_arg_size) - raw_arg_size-            tot_arg_size        = raw_arg_size + arg_pad_size - platformWordSizeInBytes platform---        delta0 <- getDeltaNat-        setDeltaNat (delta0 - arg_pad_size)--        push_codes <- mapM push_arg (reverse prom_args)-        delta <- getDeltaNat-        MASSERT(delta == delta0 - tot_arg_size)--        -- deal with static vs dynamic call targets-        (callinsns,cconv) <--          case target of-            ForeignTarget (CmmLit (CmmLabel lbl)) conv-               -> -- ToDo: stdcall arg sizes-                  return (unitOL (CALL (Left fn_imm) []), conv)-               where fn_imm = ImmCLbl lbl-            ForeignTarget expr conv-               -> do { (dyn_r, dyn_c) <- getSomeReg expr-                     ; ASSERT( isWord32 (cmmExprType platform expr) )-                       return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) }-            PrimTarget _-                -> panic $ "genCCall: Can't handle PrimTarget call type here, error "-                            ++ "probably because too many return values."--        let push_code-                | arg_pad_size /= 0-                = toOL [SUB II32 (OpImm (ImmInt arg_pad_size)) (OpReg esp),-                        DELTA (delta0 - arg_pad_size)]-                  `appOL` concatOL push_codes-                | otherwise-                = concatOL push_codes--              -- Deallocate parameters after call for ccall;-              -- but not for stdcall (callee does it)-              ---              -- We have to pop any stack padding we added-              -- even if we are doing stdcall, though (#5052)-            pop_size-               | ForeignConvention StdCallConv _ _ _ <- cconv = arg_pad_size-               | otherwise = tot_arg_size--            call = callinsns `appOL`-                   toOL (-                      (if pop_size==0 then [] else-                       [ADD II32 (OpImm (ImmInt pop_size)) (OpReg esp)])-                      ++-                      [DELTA delta0]-                   )-        setDeltaNat delta0--        let-            -- assign the results, if necessary-            assign_code []     = nilOL-            assign_code [dest]-              | isFloatType ty =-                  -- we assume SSE2-                  let tmp_amode = AddrBaseIndex (EABaseReg esp)-                                                       EAIndexNone-                                                       (ImmInt 0)-                      fmt = floatFormat w-                         in toOL [ SUB II32 (OpImm (ImmInt b)) (OpReg esp),-                                   DELTA (delta0 - b),-                                   X87Store fmt  tmp_amode,-                                   -- X87Store only supported for the CDECL ABI-                                   -- NB: This code will need to be-                                   -- revisited once GHC does more work around-                                   -- SIGFPE f-                                   MOV fmt (OpAddr tmp_amode) (OpReg r_dest),-                                   ADD II32 (OpImm (ImmInt b)) (OpReg esp),-                                   DELTA delta0]-              | isWord64 ty    = toOL [MOV II32 (OpReg eax) (OpReg r_dest),-                                        MOV II32 (OpReg edx) (OpReg r_dest_hi)]-              | otherwise      = unitOL (MOV (intFormat w)-                                             (OpReg eax)-                                             (OpReg r_dest))-              where-                    ty = localRegType dest-                    w  = typeWidth ty-                    b  = widthInBytes w-                    r_dest_hi = getHiVRegFromLo r_dest-                    r_dest    = getRegisterReg platform (CmmLocal dest)-            assign_code many = pprPanic "genCCall.assign_code - too many return values:" (ppr many)--        return (push_code `appOL`-                call `appOL`-                assign_code dest_regs)--genCCall64' :: ForeignTarget      -- function to call-            -> [CmmFormal]        -- where to put the result-            -> [CmmActual]        -- arguments (of mixed type)-            -> NatM InstrBlock-genCCall64' target dest_regs args = do-    platform <- getPlatform-    -- load up the register arguments-    let prom_args = map (maybePromoteCArg platform W32) args--    let load_args :: [CmmExpr]-                  -> [Reg]         -- int regs avail for args-                  -> [Reg]         -- FP regs avail for args-                  -> InstrBlock    -- code computing args-                  -> InstrBlock    -- code assigning args to ABI regs-                  -> NatM ([CmmExpr],[Reg],[Reg],InstrBlock,InstrBlock)-        -- no more regs to use-        load_args args [] [] code acode     =-            return (args, [], [], code, acode)--        -- no more args to push-        load_args [] aregs fregs code acode =-            return ([], aregs, fregs, code, acode)--        load_args (arg : rest) aregs fregs code acode-            | isFloatType arg_rep = case fregs of-                 []     -> push_this_arg-                 (r:rs) -> do-                    (code',acode') <- reg_this_arg r-                    load_args rest aregs rs code' acode'-            | otherwise           = case aregs of-                 []     -> push_this_arg-                 (r:rs) -> do-                    (code',acode') <- reg_this_arg r-                    load_args rest rs fregs code' acode'-            where--              -- put arg into the list of stack pushed args-              push_this_arg = do-                 (args',ars,frs,code',acode')-                     <- load_args rest aregs fregs code acode-                 return (arg:args', ars, frs, code', acode')--              -- pass the arg into the given register-              reg_this_arg r-                -- "operand" args can be directly assigned into r-                | isOperand False arg = do-                    arg_code <- getAnyReg arg-                    return (code, (acode `appOL` arg_code r))-                -- The last non-operand arg can be directly assigned after its-                -- computation without going into a temporary register-                | all (isOperand False) rest = do-                    arg_code   <- getAnyReg arg-                    return (code `appOL` arg_code r,acode)--                -- other args need to be computed beforehand to avoid clobbering-                -- previously assigned registers used to pass parameters (see-                -- #11792, #12614). They are assigned into temporary registers-                -- and get assigned to proper call ABI registers after they all-                -- have been computed.-                | otherwise     = do-                    arg_code <- getAnyReg arg-                    tmp      <- getNewRegNat arg_fmt-                    let-                      code'  = code `appOL` arg_code tmp-                      acode' = acode `snocOL` reg2reg arg_fmt tmp r-                    return (code',acode')--              arg_rep = cmmExprType platform arg-              arg_fmt = cmmTypeFormat arg_rep--        load_args_win :: [CmmExpr]-                      -> [Reg]        -- used int regs-                      -> [Reg]        -- used FP regs-                      -> [(Reg, Reg)] -- (int, FP) regs avail for args-                      -> InstrBlock-                      -> NatM ([CmmExpr],[Reg],[Reg],InstrBlock,InstrBlock)-        load_args_win args usedInt usedFP [] code-            = return (args, usedInt, usedFP, code, nilOL)-            -- no more regs to use-        load_args_win [] usedInt usedFP _ code-            = return ([], usedInt, usedFP, code, nilOL)-            -- no more args to push-        load_args_win (arg : rest) usedInt usedFP-                      ((ireg, freg) : regs) code-            | isFloatType arg_rep = do-                 arg_code <- getAnyReg arg-                 load_args_win rest (ireg : usedInt) (freg : usedFP) regs-                               (code `appOL`-                                arg_code freg `snocOL`-                                -- If we are calling a varargs function-                                -- then we need to define ireg as well-                                -- as freg-                                MOV II64 (OpReg freg) (OpReg ireg))-            | otherwise = do-                 arg_code <- getAnyReg arg-                 load_args_win rest (ireg : usedInt) usedFP regs-                               (code `appOL` arg_code ireg)-            where-              arg_rep = cmmExprType platform arg--        arg_size = 8 -- always, at the mo--        push_args [] code = return code-        push_args (arg:rest) code-           | isFloatType arg_rep = do-             (arg_reg, arg_code) <- getSomeReg arg-             delta <- getDeltaNat-             setDeltaNat (delta-arg_size)-             let code' = code `appOL` arg_code `appOL` toOL [-                            SUB (intFormat (wordWidth platform)) (OpImm (ImmInt arg_size)) (OpReg rsp),-                            DELTA (delta-arg_size),-                            MOV (floatFormat width) (OpReg arg_reg) (OpAddr (spRel platform 0))]-             push_args rest code'--           | otherwise = do-             -- Arguments can be smaller than 64-bit, but we still use @PUSH-             -- II64@ - the usual calling conventions expect integers to be-             -- 8-byte aligned.-             ASSERT(width <= W64) return ()-             (arg_op, arg_code) <- getOperand arg-             delta <- getDeltaNat-             setDeltaNat (delta-arg_size)-             let code' = code `appOL` arg_code `appOL` toOL [-                                    PUSH II64 arg_op,-                                    DELTA (delta-arg_size)]-             push_args rest code'-            where-              arg_rep = cmmExprType platform arg-              width = typeWidth arg_rep--        leaveStackSpace n = do-             delta <- getDeltaNat-             setDeltaNat (delta - n * arg_size)-             return $ toOL [-                         SUB II64 (OpImm (ImmInt (n * platformWordSizeInBytes platform))) (OpReg rsp),-                         DELTA (delta - n * arg_size)]--    (stack_args, int_regs_used, fp_regs_used, load_args_code, assign_args_code)-         <--        if platformOS platform == OSMinGW32-        then load_args_win prom_args [] [] (allArgRegs platform) nilOL-        else do-           (stack_args, aregs, fregs, load_args_code, assign_args_code)-               <- load_args prom_args (allIntArgRegs platform)-                                      (allFPArgRegs platform)-                                      nilOL nilOL-           let used_regs rs as = reverse (drop (length rs) (reverse as))-               fregs_used      = used_regs fregs (allFPArgRegs platform)-               aregs_used      = used_regs aregs (allIntArgRegs platform)-           return (stack_args, aregs_used, fregs_used, load_args_code-                                                      , assign_args_code)--    let-        arg_regs_used = int_regs_used ++ fp_regs_used-        arg_regs = [eax] ++ arg_regs_used-                -- for annotating the call instruction with-        sse_regs = length fp_regs_used-        arg_stack_slots = if platformOS platform == OSMinGW32-                          then length stack_args + length (allArgRegs platform)-                          else length stack_args-        tot_arg_size = arg_size * arg_stack_slots---    -- Align stack to 16n for calls, assuming a starting stack-    -- alignment of 16n - word_size on procedure entry. Which we-    -- maintain. See Note [rts/StgCRun.c : Stack Alignment on X86]-    let word_size = platformWordSizeInBytes platform-    (real_size, adjust_rsp) <--        if (tot_arg_size + word_size) `rem` 16 == 0-            then return (tot_arg_size, nilOL)-            else do -- we need to adjust...-                delta <- getDeltaNat-                setDeltaNat (delta - word_size)-                return (tot_arg_size + word_size, toOL [-                                SUB II64 (OpImm (ImmInt word_size)) (OpReg rsp),-                                DELTA (delta - word_size) ])--    -- push the stack args, right to left-    push_code <- push_args (reverse stack_args) nilOL-    -- On Win64, we also have to leave stack space for the arguments-    -- that we are passing in registers-    lss_code <- if platformOS platform == OSMinGW32-                then leaveStackSpace (length (allArgRegs platform))-                else return nilOL-    delta <- getDeltaNat--    -- deal with static vs dynamic call targets-    (callinsns,_cconv) <--      case target of-        ForeignTarget (CmmLit (CmmLabel lbl)) conv-           -> -- ToDo: stdcall arg sizes-              return (unitOL (CALL (Left fn_imm) arg_regs), conv)-           where fn_imm = ImmCLbl lbl-        ForeignTarget expr conv-           -> do (dyn_r, dyn_c) <- getSomeReg expr-                 return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv)-        PrimTarget _-            -> panic $ "genCCall: Can't handle PrimTarget call type here, error "-                        ++ "probably because too many return values."--    let-        -- The x86_64 ABI requires us to set %al to the number of SSE2-        -- registers that contain arguments, if the called routine-        -- is a varargs function.  We don't know whether it's a-        -- varargs function or not, so we have to assume it is.-        ---        -- It's not safe to omit this assignment, even if the number-        -- of SSE2 regs in use is zero.  If %al is larger than 8-        -- on entry to a varargs function, seg faults ensue.-        assign_eax n = unitOL (MOV II32 (OpImm (ImmInt n)) (OpReg eax))--    let call = callinsns `appOL`-               toOL (-                    -- Deallocate parameters after call for ccall;-                    -- stdcall has callee do it, but is not supported on-                    -- x86_64 target (see #3336)-                  (if real_size==0 then [] else-                   [ADD (intFormat (platformWordWidth platform)) (OpImm (ImmInt real_size)) (OpReg esp)])-                  ++-                  [DELTA (delta + real_size)]-               )-    setDeltaNat (delta + real_size)--    let-        -- assign the results, if necessary-        assign_code []     = nilOL-        assign_code [dest] =-          case typeWidth rep of-                W32 | isFloatType rep -> unitOL (MOV (floatFormat W32)-                                                     (OpReg xmm0)-                                                     (OpReg r_dest))-                W64 | isFloatType rep -> unitOL (MOV (floatFormat W64)-                                                     (OpReg xmm0)-                                                     (OpReg r_dest))-                _ -> unitOL (MOV (cmmTypeFormat rep) (OpReg rax) (OpReg r_dest))-          where-                rep = localRegType dest-                r_dest = getRegisterReg platform  (CmmLocal dest)-        assign_code _many = panic "genCCall.assign_code many"--    return (adjust_rsp          `appOL`-            push_code           `appOL`-            load_args_code      `appOL`-            assign_args_code    `appOL`-            lss_code            `appOL`-            assign_eax sse_regs `appOL`-            call                `appOL`-            assign_code dest_regs)---maybePromoteCArg :: Platform -> Width -> CmmExpr -> CmmExpr-maybePromoteCArg platform wto arg- | wfrom < wto = CmmMachOp (MO_UU_Conv wfrom wto) [arg]- | otherwise   = arg- where-   wfrom = cmmExprWidth platform arg--outOfLineCmmOp :: BlockId -> CallishMachOp -> Maybe CmmFormal -> [CmmActual]-               -> NatM InstrBlock-outOfLineCmmOp bid mop res args-  = do-      config <- getConfig-      targetExpr <- cmmMakeDynamicReference config CallReference lbl-      let target = ForeignTarget targetExpr-                           (ForeignConvention CCallConv [] [] CmmMayReturn)--      -- We know foreign calls results in no new basic blocks, so we can ignore-      -- the returned block id.-      (instrs, _) <- stmtToInstrs bid (CmmUnsafeForeignCall target (catMaybes [res]) args)-      return instrs-  where-        -- Assume we can call these functions directly, and that they're not in a dynamic library.-        -- TODO: Why is this ok? Under linux this code will be in libm.so-        --       Is it because they're really implemented as a primitive instruction by the assembler??  -- BL 2009/12/31-        lbl = mkForeignLabel fn Nothing ForeignLabelInThisPackage IsFunction--        fn = case mop of-              MO_F32_Sqrt  -> fsLit "sqrtf"-              MO_F32_Fabs  -> fsLit "fabsf"-              MO_F32_Sin   -> fsLit "sinf"-              MO_F32_Cos   -> fsLit "cosf"-              MO_F32_Tan   -> fsLit "tanf"-              MO_F32_Exp   -> fsLit "expf"-              MO_F32_ExpM1 -> fsLit "expm1f"-              MO_F32_Log   -> fsLit "logf"-              MO_F32_Log1P -> fsLit "log1pf"--              MO_F32_Asin  -> fsLit "asinf"-              MO_F32_Acos  -> fsLit "acosf"-              MO_F32_Atan  -> fsLit "atanf"--              MO_F32_Sinh  -> fsLit "sinhf"-              MO_F32_Cosh  -> fsLit "coshf"-              MO_F32_Tanh  -> fsLit "tanhf"-              MO_F32_Pwr   -> fsLit "powf"--              MO_F32_Asinh -> fsLit "asinhf"-              MO_F32_Acosh -> fsLit "acoshf"-              MO_F32_Atanh -> fsLit "atanhf"--              MO_F64_Sqrt  -> fsLit "sqrt"-              MO_F64_Fabs  -> fsLit "fabs"-              MO_F64_Sin   -> fsLit "sin"-              MO_F64_Cos   -> fsLit "cos"-              MO_F64_Tan   -> fsLit "tan"-              MO_F64_Exp   -> fsLit "exp"-              MO_F64_ExpM1 -> fsLit "expm1"-              MO_F64_Log   -> fsLit "log"-              MO_F64_Log1P -> fsLit "log1p"--              MO_F64_Asin  -> fsLit "asin"-              MO_F64_Acos  -> fsLit "acos"-              MO_F64_Atan  -> fsLit "atan"--              MO_F64_Sinh  -> fsLit "sinh"-              MO_F64_Cosh  -> fsLit "cosh"-              MO_F64_Tanh  -> fsLit "tanh"-              MO_F64_Pwr   -> fsLit "pow"--              MO_F64_Asinh  -> fsLit "asinh"-              MO_F64_Acosh  -> fsLit "acosh"-              MO_F64_Atanh  -> fsLit "atanh"--              MO_I64_ToI   -> fsLit "hs_int64ToInt"-              MO_I64_FromI -> fsLit "hs_intToInt64"-              MO_W64_ToW   -> fsLit "hs_word64ToWord"-              MO_W64_FromW -> fsLit "hs_wordToWord64"-              MO_x64_Neg   -> fsLit "hs_neg64"-              MO_x64_Add   -> fsLit "hs_add64"-              MO_x64_Sub   -> fsLit "hs_sub64"-              MO_x64_Mul   -> fsLit "hs_mul64"-              MO_I64_Quot  -> fsLit "hs_quotInt64"-              MO_I64_Rem   -> fsLit "hs_remInt64"-              MO_W64_Quot  -> fsLit "hs_quotWord64"-              MO_W64_Rem   -> fsLit "hs_remWord64"-              MO_x64_And   -> fsLit "hs_and64"-              MO_x64_Or    -> fsLit "hs_or64"-              MO_x64_Xor   -> fsLit "hs_xor64"-              MO_x64_Not   -> fsLit "hs_not64"-              MO_x64_Shl   -> fsLit "hs_uncheckedShiftL64"-              MO_I64_Shr   -> fsLit "hs_uncheckedIShiftRA64"-              MO_W64_Shr   -> fsLit "hs_uncheckedShiftRL64"-              MO_x64_Eq    -> fsLit "hs_eq64"-              MO_x64_Ne    -> fsLit "hs_ne64"-              MO_I64_Ge    -> fsLit "hs_geInt64"-              MO_I64_Gt    -> fsLit "hs_gtInt64"-              MO_I64_Le    -> fsLit "hs_leInt64"-              MO_I64_Lt    -> fsLit "hs_ltInt64"-              MO_W64_Ge    -> fsLit "hs_geWord64"-              MO_W64_Gt    -> fsLit "hs_gtWord64"-              MO_W64_Le    -> fsLit "hs_leWord64"-              MO_W64_Lt    -> fsLit "hs_ltWord64"--              MO_Memcpy _  -> fsLit "memcpy"-              MO_Memset _  -> fsLit "memset"-              MO_Memmove _ -> fsLit "memmove"-              MO_Memcmp _  -> fsLit "memcmp"--              MO_PopCnt _  -> fsLit "popcnt"-              MO_BSwap _   -> fsLit "bswap"-              {- Here the C implementation is used as there is no x86-              instruction to reverse a word's bit order.-              -}-              MO_BRev w    -> fsLit $ bRevLabel w-              MO_Clz w     -> fsLit $ clzLabel w-              MO_Ctz _     -> unsupported--              MO_Pdep w    -> fsLit $ pdepLabel w-              MO_Pext w    -> fsLit $ pextLabel w--              MO_AtomicRMW _ _ -> fsLit "atomicrmw"-              MO_AtomicRead _  -> fsLit "atomicread"-              MO_AtomicWrite _ -> fsLit "atomicwrite"-              MO_Cmpxchg _     -> fsLit "cmpxchg"-              MO_Xchg _        -> should_be_inline--              MO_UF_Conv _ -> unsupported--              MO_S_Mul2    {}  -> unsupported-              MO_S_QuotRem {}  -> unsupported-              MO_U_QuotRem {}  -> unsupported-              MO_U_QuotRem2 {} -> unsupported-              MO_Add2 {}       -> unsupported-              MO_AddIntC {}    -> unsupported-              MO_SubIntC {}    -> unsupported-              MO_AddWordC {}   -> unsupported-              MO_SubWordC {}   -> unsupported-              MO_U_Mul2 {}     -> unsupported-              MO_ReadBarrier   -> unsupported-              MO_WriteBarrier  -> unsupported-              MO_Touch         -> unsupported-              (MO_Prefetch_Data _ ) -> unsupported-        unsupported = panic ("outOfLineCmmOp: " ++ show mop-                          ++ " not supported here")-        -- If we generate a call for the given primop-        -- something went wrong.-        should_be_inline = panic ("outOfLineCmmOp: " ++ show mop-                          ++ " should be handled inline")----- -------------------------------------------------------------------------------- Generating a table-branch--genSwitch :: CmmExpr -> SwitchTargets -> NatM InstrBlock--genSwitch expr targets = do-  config <- getConfig-  let platform = ncgPlatform config-  if ncgPIC config-  then do-        (reg,e_code) <- getNonClobberedReg (cmmOffset platform expr offset)-           -- getNonClobberedReg because it needs to survive across t_code-        lbl <- getNewLabelNat-        let is32bit = target32Bit platform-            os = platformOS platform-            -- Might want to use .rodata.<function we're in> instead, but as-            -- long as it's something unique it'll work out since the-            -- references to the jump table are in the appropriate section.-            rosection = case os of-              -- on Mac OS X/x86_64, put the jump table in the text section to-              -- work around a limitation of the linker.-              -- ld64 is unable to handle the relocations for-              --     .quad L1 - L0-              -- if L0 is not preceded by a non-anonymous label in its section.-              OSDarwin | not is32bit -> Section Text lbl-              _ -> Section ReadOnlyData lbl-        dynRef <- cmmMakeDynamicReference config DataReference lbl-        (tableReg,t_code) <- getSomeReg $ dynRef-        let op = OpAddr (AddrBaseIndex (EABaseReg tableReg)-                                       (EAIndex reg (platformWordSizeInBytes platform)) (ImmInt 0))--        offsetReg <- getNewRegNat (intFormat (platformWordWidth platform))-        return $ if is32bit || os == OSDarwin-                 then e_code `appOL` t_code `appOL` toOL [-                                ADD (intFormat (platformWordWidth platform)) op (OpReg tableReg),-                                JMP_TBL (OpReg tableReg) ids rosection lbl-                       ]-                 else -- HACK: On x86_64 binutils<2.17 is only able to generate-                      -- PC32 relocations, hence we only get 32-bit offsets in-                      -- the jump table. As these offsets are always negative-                      -- we need to properly sign extend them to 64-bit. This-                      -- hack should be removed in conjunction with the hack in-                      -- PprMach.hs/pprDataItem once binutils 2.17 is standard.-                      e_code `appOL` t_code `appOL` toOL [-                               MOVSxL II32 op (OpReg offsetReg),-                               ADD (intFormat (platformWordWidth platform))-                                   (OpReg offsetReg)-                                   (OpReg tableReg),-                               JMP_TBL (OpReg tableReg) ids rosection lbl-                       ]-  else do-        (reg,e_code) <- getSomeReg (cmmOffset platform expr offset)-        lbl <- getNewLabelNat-        let op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg (platformWordSizeInBytes platform)) (ImmCLbl lbl))-            code = e_code `appOL` toOL [-                    JMP_TBL op ids (Section ReadOnlyData lbl) lbl-                 ]-        return code-  where-    (offset, blockIds) = switchTargetsToTable targets-    ids = map (fmap DestBlockId) blockIds--generateJumpTableForInstr :: NCGConfig -> Instr -> Maybe (NatCmmDecl (Alignment, RawCmmStatics) Instr)-generateJumpTableForInstr config (JMP_TBL _ ids section lbl)-    = let getBlockId (DestBlockId id) = id-          getBlockId _ = panic "Non-Label target in Jump Table"-          blockIds = map (fmap getBlockId) ids-      in Just (createJumpTable config blockIds section lbl)-generateJumpTableForInstr _ _ = Nothing--createJumpTable :: NCGConfig -> [Maybe BlockId] -> Section -> CLabel-                -> GenCmmDecl (Alignment, RawCmmStatics) h g-createJumpTable config ids section lbl-    = let jumpTable-            | ncgPIC config =-                  let ww = ncgWordWidth config-                      jumpTableEntryRel Nothing-                          = CmmStaticLit (CmmInt 0 ww)-                      jumpTableEntryRel (Just blockid)-                          = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0 ww)-                          where blockLabel = blockLbl blockid-                  in map jumpTableEntryRel ids-            | otherwise = map (jumpTableEntry config) ids-      in CmmData section (mkAlignment 1, CmmStaticsRaw lbl jumpTable)--extractUnwindPoints :: [Instr] -> [UnwindPoint]-extractUnwindPoints instrs =-    [ UnwindPoint lbl unwinds | UNWIND lbl unwinds <- instrs]---- -------------------------------------------------------------------------------- 'condIntReg' and 'condFltReg': condition codes into registers---- Turn those condition codes into integers now (when they appear on--- the right hand side of an assignment).------ (If applicable) Do not fill the delay slots here; you will confuse the--- register allocator.--condIntReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register--condIntReg cond x y = do-  CondCode _ cond cond_code <- condIntCode cond x y-  tmp <- getNewRegNat II8-  let-        code dst = cond_code `appOL` toOL [-                    SETCC cond (OpReg tmp),-                    MOVZxL II8 (OpReg tmp) (OpReg dst)-                  ]-  return (Any II32 code)------------------------------------------------------------------          Note [SSE Parity Checks]                   ------------------------------------------------------------------- We have to worry about unordered operands (eg. comparisons--- against NaN).  If the operands are unordered, the comparison--- sets the parity flag, carry flag and zero flag.--- All comparisons are supposed to return false for unordered--- operands except for !=, which returns true.------ Optimisation: we don't have to test the parity flag if we--- know the test has already excluded the unordered case: eg >--- and >= test for a zero carry flag, which can only occur for--- ordered operands.------ By reversing comparisons we can avoid testing the parity--- for < and <= as well. If any of the arguments is an NaN we--- return false either way. If both arguments are valid then--- x <= y  <->  y >= x  holds. So it's safe to swap these.------ We invert the condition inside getRegister'and  getCondCode--- which should cover all invertable cases.--- All other functions translating FP comparisons to assembly--- use these to two generate the comparison code.------ As an example consider a simple check:------ func :: Float -> Float -> Int--- func x y = if x < y then 1 else 0------ Which in Cmm gives the floating point comparison.------  if (%MO_F_Lt_W32(F1, F2)) goto c2gg; else goto c2gf;------ We used to compile this to an assembly code block like this:--- _c2gh:---  ucomiss %xmm2,%xmm1---  jp _c2gf---  jb _c2gg---  jmp _c2gf------ Where we have to introduce an explicit--- check for unordered results (using jmp parity):------ We can avoid this by exchanging the arguments and inverting the direction--- of the comparison. This results in the sequence of:------  ucomiss %xmm1,%xmm2---  ja _c2g2---  jmp _c2g1------ Removing the jump reduces the pressure on the branch predidiction system--- and plays better with the uOP cache.--condFltReg :: Bool -> Cond -> CmmExpr -> CmmExpr -> NatM Register-condFltReg is32Bit cond x y = condFltReg_sse2- where---  condFltReg_sse2 = do-    CondCode _ cond cond_code <- condFltCode cond x y-    tmp1 <- getNewRegNat (archWordFormat is32Bit)-    tmp2 <- getNewRegNat (archWordFormat is32Bit)-    let -- See Note [SSE Parity Checks]-        code dst =-           cond_code `appOL`-             (case cond of-                NE  -> or_unordered dst-                GU  -> plain_test   dst-                GEU -> plain_test   dst-                -- Use ASSERT so we don't break releases if these creep in.-                LTT -> ASSERT2(False, ppr "Should have been turned into >")-                       and_ordered  dst-                LE  -> ASSERT2(False, ppr "Should have been turned into >=")-                       and_ordered  dst-                _   -> and_ordered  dst)--        plain_test dst = toOL [-                    SETCC cond (OpReg tmp1),-                    MOVZxL II8 (OpReg tmp1) (OpReg dst)-                 ]-        or_unordered dst = toOL [-                    SETCC cond (OpReg tmp1),-                    SETCC PARITY (OpReg tmp2),-                    OR II8 (OpReg tmp1) (OpReg tmp2),-                    MOVZxL II8 (OpReg tmp2) (OpReg dst)-                  ]-        and_ordered dst = toOL [-                    SETCC cond (OpReg tmp1),-                    SETCC NOTPARITY (OpReg tmp2),-                    AND II8 (OpReg tmp1) (OpReg tmp2),-                    MOVZxL II8 (OpReg tmp2) (OpReg dst)-                  ]-    return (Any II32 code)----- -------------------------------------------------------------------------------- 'trivial*Code': deal with trivial instructions---- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode',--- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions.--- Only look for constants on the right hand side, because that's--- where the generic optimizer will have put them.---- Similarly, for unary instructions, we don't have to worry about--- matching an StInt as the argument, because genericOpt will already--- have handled the constant-folding.---{--The Rules of the Game are:--* You cannot assume anything about the destination register dst;-  it may be anything, including a fixed reg.--* You may compute an operand into a fixed reg, but you may not-  subsequently change the contents of that fixed reg.  If you-  want to do so, first copy the value either to a temporary-  or into dst.  You are free to modify dst even if it happens-  to be a fixed reg -- that's not your problem.--* You cannot assume that a fixed reg will stay live over an-  arbitrary computation.  The same applies to the dst reg.--* Temporary regs obtained from getNewRegNat are distinct from-  each other and from all other regs, and stay live over-  arbitrary computations.------------------------SDM's version of The Rules:--* If getRegister returns Any, that means it can generate correct-  code which places the result in any register, period.  Even if that-  register happens to be read during the computation.--  Corollary #1: this means that if you are generating code for an-  operation with two arbitrary operands, you cannot assign the result-  of the first operand into the destination register before computing-  the second operand.  The second operand might require the old value-  of the destination register.--  Corollary #2: A function might be able to generate more efficient-  code if it knows the destination register is a new temporary (and-  therefore not read by any of the sub-computations).--* If getRegister returns Any, then the code it generates may modify only:-        (a) fresh temporaries-        (b) the destination register-        (c) known registers (eg. %ecx is used by shifts)-  In particular, it may *not* modify global registers, unless the global-  register happens to be the destination register.--}--trivialCode :: Width -> (Operand -> Operand -> Instr)-            -> Maybe (Operand -> Operand -> Instr)-            -> CmmExpr -> CmmExpr -> NatM Register-trivialCode width instr m a b-    = do is32Bit <- is32BitPlatform-         trivialCode' is32Bit width instr m a b--trivialCode' :: Bool -> Width -> (Operand -> Operand -> Instr)-             -> Maybe (Operand -> Operand -> Instr)-             -> CmmExpr -> CmmExpr -> NatM Register-trivialCode' is32Bit width _ (Just revinstr) (CmmLit lit_a) b-  | is32BitLit is32Bit lit_a = do-  b_code <- getAnyReg b-  let-       code dst-         = b_code dst `snocOL`-           revinstr (OpImm (litToImm lit_a)) (OpReg dst)-  return (Any (intFormat width) code)--trivialCode' _ width instr _ a b-  = genTrivialCode (intFormat width) instr a b---- This is re-used for floating pt instructions too.-genTrivialCode :: Format -> (Operand -> Operand -> Instr)-               -> CmmExpr -> CmmExpr -> NatM Register-genTrivialCode rep instr a b = do-  (b_op, b_code) <- getNonClobberedOperand b-  a_code <- getAnyReg a-  tmp <- getNewRegNat rep-  let-     -- We want the value of b to stay alive across the computation of a.-     -- But, we want to calculate a straight into the destination register,-     -- because the instruction only has two operands (dst := dst `op` src).-     -- The troublesome case is when the result of b is in the same register-     -- as the destination reg.  In this case, we have to save b in a-     -- new temporary across the computation of a.-     code dst-        | dst `regClashesWithOp` b_op =-                b_code `appOL`-                unitOL (MOV rep b_op (OpReg tmp)) `appOL`-                a_code dst `snocOL`-                instr (OpReg tmp) (OpReg dst)-        | otherwise =-                b_code `appOL`-                a_code dst `snocOL`-                instr b_op (OpReg dst)-  return (Any rep code)--regClashesWithOp :: Reg -> Operand -> Bool-reg `regClashesWithOp` OpReg reg2   = reg == reg2-reg `regClashesWithOp` OpAddr amode = any (==reg) (addrModeRegs amode)-_   `regClashesWithOp` _            = False---------------trivialUCode :: Format -> (Operand -> Instr)-             -> CmmExpr -> NatM Register-trivialUCode rep instr x = do-  x_code <- getAnyReg x-  let-     code dst =-        x_code dst `snocOL`-        instr (OpReg dst)-  return (Any rep code)----------------trivialFCode_sse2 :: Width -> (Format -> Operand -> Operand -> Instr)-                  -> CmmExpr -> CmmExpr -> NatM Register-trivialFCode_sse2 pk instr x y-    = genTrivialCode format (instr format) x y-    where format = floatFormat pk---trivialUFCode :: Format -> (Reg -> Reg -> Instr) -> CmmExpr -> NatM Register-trivialUFCode format instr x = do-  (x_reg, x_code) <- getSomeReg x-  let-     code dst =-        x_code `snocOL`-        instr x_reg dst-  return (Any format code)------------------------------------------------------------------------------------coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register-coerceInt2FP from to x =  coerce_sse2- where--   coerce_sse2 = do-     (x_op, x_code) <- getOperand x  -- ToDo: could be a safe operand-     let-           opc  = case to of W32 -> CVTSI2SS; W64 -> CVTSI2SD-                             n -> panic $ "coerceInt2FP.sse: unhandled width ("-                                         ++ show n ++ ")"-           code dst = x_code `snocOL` opc (intFormat from) x_op dst-     return (Any (floatFormat to) code)-        -- works even if the destination rep is <II32-----------------------------------------------------------------------------------coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register-coerceFP2Int from to x =  coerceFP2Int_sse2- where-   coerceFP2Int_sse2 = do-     (x_op, x_code) <- getOperand x  -- ToDo: could be a safe operand-     let-           opc  = case from of W32 -> CVTTSS2SIQ; W64 -> CVTTSD2SIQ;-                               n -> panic $ "coerceFP2Init.sse: unhandled width ("-                                           ++ show n ++ ")"-           code dst = x_code `snocOL` opc (intFormat to) x_op dst-     return (Any (intFormat to) code)-         -- works even if the destination rep is <II32------------------------------------------------------------------------------------coerceFP2FP :: Width -> CmmExpr -> NatM Register-coerceFP2FP to x = do-  (x_reg, x_code) <- getSomeReg x-  let-        opc  = case to of W32 -> CVTSD2SS; W64 -> CVTSS2SD;-                                     n -> panic $ "coerceFP2FP: unhandled width ("-                                                 ++ show n ++ ")"-        code dst = x_code `snocOL` opc x_reg dst-  return (Any ( floatFormat to) code)------------------------------------------------------------------------------------sse2NegCode :: Width -> CmmExpr -> NatM Register-sse2NegCode w x = do-  let fmt = floatFormat w-  x_code <- getAnyReg x-  -- This is how gcc does it, so it can't be that bad:-  let-    const = case fmt of-      FF32 -> CmmInt 0x80000000 W32-      FF64 -> CmmInt 0x8000000000000000 W64-      x@II8  -> wrongFmt x-      x@II16 -> wrongFmt x-      x@II32 -> wrongFmt x-      x@II64 -> wrongFmt x--      where-        wrongFmt x = panic $ "sse2NegCode: " ++ show x-  Amode amode amode_code <- memConstant (mkAlignment $ widthInBytes w) const-  tmp <- getNewRegNat fmt-  let-    code dst = x_code dst `appOL` amode_code `appOL` toOL [-        MOV fmt (OpAddr amode) (OpReg tmp),-        XOR fmt (OpReg tmp) (OpReg dst)-        ]-  ---  return (Any fmt code)--isVecExpr :: CmmExpr -> Bool-isVecExpr (CmmMachOp (MO_V_Insert {}) _)   = True-isVecExpr (CmmMachOp (MO_V_Extract {}) _)  = True-isVecExpr (CmmMachOp (MO_V_Add {}) _)      = True-isVecExpr (CmmMachOp (MO_V_Sub {}) _)      = True-isVecExpr (CmmMachOp (MO_V_Mul {}) _)      = True-isVecExpr (CmmMachOp (MO_VS_Quot {}) _)    = True-isVecExpr (CmmMachOp (MO_VS_Rem {}) _)     = True-isVecExpr (CmmMachOp (MO_VS_Neg {}) _)     = True-isVecExpr (CmmMachOp (MO_VF_Insert {}) _)  = True-isVecExpr (CmmMachOp (MO_VF_Extract {}) _) = True-isVecExpr (CmmMachOp (MO_VF_Add {}) _)     = True-isVecExpr (CmmMachOp (MO_VF_Sub {}) _)     = True-isVecExpr (CmmMachOp (MO_VF_Mul {}) _)     = True-isVecExpr (CmmMachOp (MO_VF_Quot {}) _)    = True-isVecExpr (CmmMachOp (MO_VF_Neg {}) _)     = True-isVecExpr (CmmMachOp _ [e])                = isVecExpr e-isVecExpr _                                = False--needLlvm :: NatM a-needLlvm =-    sorry $ unlines ["The native code generator does not support vector"-                    ,"instructions. Please use -fllvm."]---- | This works on the invariant that all jumps in the given blocks are required.---   Starting from there we try to make a few more jumps redundant by reordering---   them.---   We depend on the information in the CFG to do so so without a given CFG---   we do nothing.-invertCondBranches :: Maybe CFG  -- ^ CFG if present-                   -> LabelMap a -- ^ Blocks with info tables-                   -> [NatBasicBlock Instr] -- ^ List of basic blocks-                   -> [NatBasicBlock Instr]-invertCondBranches Nothing _       bs = bs-invertCondBranches (Just cfg) keep bs =-    invert bs-  where-    invert :: [NatBasicBlock Instr] -> [NatBasicBlock Instr]-    invert ((BasicBlock lbl1 ins@(_:_:_xs)):b2@(BasicBlock lbl2 _):bs)-      | --pprTrace "Block" (ppr lbl1) True,-        (jmp1,jmp2) <- last2 ins-      , JXX cond1 target1 <- jmp1-      , target1 == lbl2-      --, pprTrace "CutChance" (ppr b1) True-      , JXX ALWAYS target2 <- jmp2-      -- We have enough information to check if we can perform the inversion-      -- TODO: We could also check for the last asm instruction which sets-      -- status flags instead. Which I suspect is worse in terms of compiler-      -- performance, but might be applicable to more cases-      , Just edgeInfo1 <- getEdgeInfo lbl1 target1 cfg-      , Just edgeInfo2 <- getEdgeInfo lbl1 target2 cfg-      -- Both jumps come from the same cmm statement-      , transitionSource edgeInfo1 == transitionSource edgeInfo2-      , CmmSource {trans_cmmNode = cmmCondBranch} <- transitionSource edgeInfo1--      --Int comparisons are invertable-      , CmmCondBranch (CmmMachOp op _args) _ _ _ <- cmmCondBranch-      , Just _ <- maybeIntComparison op-      , Just invCond <- maybeInvertCond cond1--      --Swap the last two jumps, invert the conditional jumps condition.-      = let jumps =-              case () of-                -- We are free the eliminate the jmp. So we do so.-                _ | not (mapMember target1 keep)-                    -> [JXX invCond target2]-                -- If the conditional target is unlikely we put the other-                -- target at the front.-                  | edgeWeight edgeInfo2 > edgeWeight edgeInfo1-                    -> [JXX invCond target2, JXX ALWAYS target1]-                -- Keep things as-is otherwise-                  | otherwise-                    -> [jmp1, jmp2]-        in --pprTrace "Cutable" (ppr [jmp1,jmp2] <+> text "=>" <+> ppr jumps) $-           (BasicBlock lbl1-            (dropTail 2 ins ++ jumps))-            : invert (b2:bs)-    invert (b:bs) = b : invert bs-    invert [] = []+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE TupleSections #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++-----------------------------------------------------------------------------+--+-- Generating machine code (instruction selection)+--+-- (c) The University of Glasgow 1996-2004+--+-----------------------------------------------------------------------------++-- This is a big module, but, if you pay attention to+-- (a) the sectioning, and (b) the type signatures, the+-- structure should not be too overwhelming.++module GHC.CmmToAsm.X86.CodeGen (+        cmmTopCodeGen,+        generateJumpTableForInstr,+        extractUnwindPoints,+        invertCondBranches,+        InstrBlock+)++where++-- NCG stuff:+import GHC.Prelude++import GHC.CmmToAsm.X86.Instr+import GHC.CmmToAsm.X86.Cond+import GHC.CmmToAsm.X86.Regs+import GHC.CmmToAsm.X86.Ppr+import GHC.CmmToAsm.X86.RegInfo++import GHC.Platform.Regs+import GHC.CmmToAsm.CPrim+import GHC.CmmToAsm.Types+import GHC.Cmm.DebugBlock+   ( DebugBlock(..), UnwindPoint(..), UnwindTable+   , UnwindExpr(UwReg), toUnwindExpr+   )+import GHC.CmmToAsm.PIC+import GHC.CmmToAsm.Monad+   ( NatM, getNewRegNat, getNewLabelNat, setDeltaNat+   , getDeltaNat, getBlockIdNat, getPicBaseNat+   , Reg64(..), RegCode64(..), getNewReg64, localReg64+   , getPicBaseMaybeNat, getDebugBlock, getFileId+   , addImmediateSuccessorNat, updateCfgNat, getConfig, getPlatform+   , getCfgWeights+   )+import GHC.CmmToAsm.CFG+import GHC.CmmToAsm.Format+import GHC.CmmToAsm.Config+import GHC.Platform.Reg+import GHC.Platform++-- Our intermediate code:+import GHC.Types.Basic+import GHC.Cmm.BlockId+import GHC.Unit.Types ( primUnitId )+import GHC.Cmm.Utils+import GHC.Cmm.Switch+import GHC.Cmm+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Graph+import GHC.Cmm.Dataflow.Label+import GHC.Cmm.CLabel+import GHC.Types.Tickish ( GenTickish(..) )+import GHC.Types.SrcLoc  ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )++-- The rest:+import GHC.Types.ForeignCall ( CCallConv(..) )+import GHC.Data.OrdList+import GHC.Utils.Outputable+import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Data.FastString+import GHC.Utils.Misc+import GHC.Types.Unique.Supply ( getUniqueM )++import Control.Monad+import Data.Foldable (fold)+import Data.Int+import Data.Maybe+import Data.Word++import qualified Data.Map as M++is32BitPlatform :: NatM Bool+is32BitPlatform = do+    platform <- getPlatform+    return $ target32Bit platform++expect32BitPlatform :: SDoc -> NatM ()+expect32BitPlatform doc = do+  is32Bit <- is32BitPlatform+  when (not is32Bit) $+    pprPanic "Expecting 32-bit platform" doc++sse2Enabled :: NatM Bool+sse2Enabled = do+  config <- getConfig+  return (ncgSseVersion config >= Just SSE2)++sse4_2Enabled :: NatM Bool+sse4_2Enabled = do+  config <- getConfig+  return (ncgSseVersion config >= Just SSE42)++cmmTopCodeGen+        :: RawCmmDecl+        -> NatM [NatCmmDecl (Alignment, RawCmmStatics) Instr]++cmmTopCodeGen (CmmProc info lab live graph) = do+  let blocks = toBlockListEntryFirst graph+  (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks+  picBaseMb <- getPicBaseMaybeNat+  platform <- getPlatform+  let proc = CmmProc info lab live (ListGraph $ concat nat_blocks)+      tops = proc : concat statics+      os   = platformOS platform++  case picBaseMb of+      Just picBase -> initializePicBase_x86 ArchX86 os picBase tops+      Nothing -> return tops++cmmTopCodeGen (CmmData sec dat) =+  return [CmmData sec (mkAlignment 1, dat)]  -- no translation, we just use CmmStatic++{- Note [Verifying basic blocks]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+   We want to guarantee a few things about the results+   of instruction selection.++   Namely that each basic blocks consists of:+    * A (potentially empty) sequence of straight line instructions+  followed by+    * A (potentially empty) sequence of jump like instructions.++    We can verify this by going through the instructions and+    making sure that any non-jumpish instruction can't appear+    after a jumpish instruction.++    There are gotchas however:+    * CALLs are strictly speaking control flow but here we care+      not about them. Hence we treat them as regular instructions.++      It's safe for them to appear inside a basic block+      as (ignoring side effects inside the call) they will result in+      straight line code.++    * NEWBLOCK marks the start of a new basic block so can+      be followed by any instructions.+-}++-- Verifying basic blocks is cheap, but not cheap enough to enable it unconditionally.+verifyBasicBlock :: Platform -> [Instr] -> ()+verifyBasicBlock platform instrs+  | debugIsOn     = go False instrs+  | otherwise     = ()+  where+    go _     [] = ()+    go atEnd (i:instr)+        = case i of+            -- Start a new basic block+            NEWBLOCK {} -> go False instr+            -- Calls are not viable block terminators+            CALL {}     | atEnd -> faultyBlockWith i+                        | not atEnd -> go atEnd instr+            -- All instructions ok, check if we reached the end and continue.+            _ | not atEnd -> go (isJumpishInstr i) instr+              -- Only jumps allowed at the end of basic blocks.+              | otherwise -> if isJumpishInstr i+                                then go True instr+                                else faultyBlockWith i+    faultyBlockWith i+        = pprPanic "Non control flow instructions after end of basic block."+                   (pprInstr platform i <+> text "in:" $$ vcat (map (pprInstr platform) instrs))++basicBlockCodeGen+        :: CmmBlock+        -> NatM ( [NatBasicBlock Instr]+                , [NatCmmDecl (Alignment, RawCmmStatics) Instr])++basicBlockCodeGen block = do+  let (_, nodes, tail)  = blockSplit block+      id = entryLabel block+      stmts = blockToList nodes+  -- Generate location directive+  dbg <- getDebugBlock (entryLabel block)+  loc_instrs <- case dblSourceTick =<< dbg of+    Just (SourceNote span name)+      -> do fileId <- getFileId (srcSpanFile span)+            let line = srcSpanStartLine span; col = srcSpanStartCol span+            return $ unitOL $ LOCATION fileId line col name+    _ -> return nilOL+  (mid_instrs,mid_bid) <- stmtsToInstrs id stmts+  (!tail_instrs,_) <- stmtToInstrs mid_bid tail+  let instrs = loc_instrs `appOL` mid_instrs `appOL` tail_instrs+  platform <- getPlatform+  return $! verifyBasicBlock platform (fromOL instrs)+  instrs' <- fold <$> traverse addSpUnwindings instrs+  -- code generation may introduce new basic block boundaries, which+  -- are indicated by the NEWBLOCK instruction.  We must split up the+  -- instruction stream into basic blocks again.  Also, we extract+  -- LDATAs here too.+  let+        (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs'++        mkBlocks (NEWBLOCK id) (instrs,blocks,statics)+          = ([], BasicBlock id instrs : blocks, statics)+        mkBlocks (LDATA sec dat) (instrs,blocks,statics)+          = (instrs, blocks, CmmData sec dat:statics)+        mkBlocks instr (instrs,blocks,statics)+          = (instr:instrs, blocks, statics)+  return (BasicBlock id top : other_blocks, statics)++-- | Convert 'DELTA' instructions into 'UNWIND' instructions to capture changes+-- in the @sp@ register. See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock"+-- for details.+addSpUnwindings :: Instr -> NatM (OrdList Instr)+addSpUnwindings instr@(DELTA d) = do+    config <- getConfig+    if ncgDwarfUnwindings config+        then do lbl <- mkAsmTempLabel <$> getUniqueM+                let unwind = M.singleton MachSp (Just $ UwReg MachSp $ negate d)+                return $ toOL [ instr, UNWIND lbl unwind ]+        else return (unitOL instr)+addSpUnwindings instr = return $ unitOL instr++{- Note [Keeping track of the current block]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When generating instructions for Cmm we sometimes require+the current block for things like retry loops.++We also sometimes change the current block, if a MachOP+results in branching control flow.++Issues arise if we have two statements in the same block,+which both depend on the current block id *and* change the+basic block after them. This happens for atomic primops+in the X86 backend where we want to update the CFG data structure+when introducing new basic blocks.++For example in #17334 we got this Cmm code:++        c3Bf: // global+            (_s3t1::I64) = call MO_AtomicRMW W64 AMO_And(_s3sQ::P64 + 88, 18);+            (_s3t4::I64) = call MO_AtomicRMW W64 AMO_Or(_s3sQ::P64 + 88, 0);+            _s3sT::I64 = _s3sV::I64;+            goto c3B1;++This resulted in two new basic blocks being inserted:++        c3Bf:+                movl $18,%vI_n3Bo+                movq 88(%vI_s3sQ),%rax+                jmp _n3Bp+        n3Bp:+                ...+                cmpxchgq %vI_n3Bq,88(%vI_s3sQ)+                jne _n3Bp+                ...+                jmp _n3Bs+        n3Bs:+                ...+                cmpxchgq %vI_n3Bt,88(%vI_s3sQ)+                jne _n3Bs+                ...+                jmp _c3B1+        ...++Based on the Cmm we called stmtToInstrs we translated both atomic operations under+the assumption they would be placed into their Cmm basic block `c3Bf`.+However for the retry loop we introduce new labels, so this is not the case+for the second statement.+This resulted in a desync between the explicit control flow graph+we construct as a separate data type and the actual control flow graph in the code.++Instead we now return the new basic block if a statement causes a change+in the current block and use the block for all following statements.++For this reason genForeignCall is also split into two parts.  One for calls which+*won't* change the basic blocks in which successive instructions will be+placed (since they only evaluate CmmExpr, which can only contain MachOps, which+cannot introduce basic blocks in their lowerings).  A different one for calls+which *are* known to change the basic block.++-}++-- See Note [Keeping track of the current block] for why+-- we pass the BlockId.+stmtsToInstrs :: BlockId -- ^ Basic block these statement will start to be placed in.+              -> [CmmNode O O] -- ^ Cmm Statement+              -> NatM (InstrBlock, BlockId) -- ^ Resulting instruction+stmtsToInstrs bid stmts =+    go bid stmts nilOL+  where+    go bid  []        instrs = return (instrs,bid)+    go bid (s:stmts)  instrs = do+      (instrs',bid') <- stmtToInstrs bid s+      -- If the statement introduced a new block, we use that one+      let !newBid = fromMaybe bid bid'+      go newBid stmts (instrs `appOL` instrs')++-- | `bid` refers to the current block and is used to update the CFG+--   if new blocks are inserted in the control flow.+-- See Note [Keeping track of the current block] for more details.+stmtToInstrs :: BlockId -- ^ Basic block this statement will start to be placed in.+             -> CmmNode e x+             -> NatM (InstrBlock, Maybe BlockId)+             -- ^ Instructions, and bid of new block if successive+             -- statements are placed in a different basic block.+stmtToInstrs bid stmt = do+  is32Bit <- is32BitPlatform+  platform <- getPlatform+  case stmt of+    CmmUnsafeForeignCall target result_regs args+       -> genForeignCall target result_regs args bid++    _ -> (,Nothing) <$> case stmt of+      CmmComment s   -> return (unitOL (COMMENT $ ftext s))+      CmmTick {}     -> return nilOL++      CmmUnwind regs -> do+        let to_unwind_entry :: (GlobalReg, Maybe CmmExpr) -> UnwindTable+            to_unwind_entry (reg, expr) = M.singleton reg (fmap (toUnwindExpr platform) expr)+        case foldMap to_unwind_entry regs of+          tbl | M.null tbl -> return nilOL+              | otherwise  -> do+                  lbl <- mkAsmTempLabel <$> getUniqueM+                  return $ unitOL $ UNWIND lbl tbl++      CmmAssign reg src+        | isFloatType ty         -> assignReg_FltCode format reg src+        | is32Bit && isWord64 ty -> assignReg_I64Code      reg src+        | otherwise              -> assignReg_IntCode format reg src+          where ty = cmmRegType platform reg+                format = cmmTypeFormat ty++      CmmStore addr src _alignment+        | isFloatType ty         -> assignMem_FltCode format addr src+        | is32Bit && isWord64 ty -> assignMem_I64Code      addr src+        | otherwise              -> assignMem_IntCode format addr src+          where ty = cmmExprType platform src+                format = cmmTypeFormat ty++      CmmBranch id          -> return $ genBranch id++      --We try to arrange blocks such that the likely branch is the fallthrough+      --in GHC.Cmm.ContFlowOpt. So we can assume the condition is likely false here.+      CmmCondBranch arg true false _ -> genCondBranch bid true false arg+      CmmSwitch arg ids -> genSwitch arg ids+      CmmCall { cml_target = arg+              , cml_args_regs = gregs } -> genJump arg (jumpRegs platform gregs)+      _ ->+        panic "stmtToInstrs: statement should have been cps'd away"+++jumpRegs :: Platform -> [GlobalReg] -> [Reg]+jumpRegs platform gregs = [ RegReal r | Just r <- map (globalRegMaybe platform) gregs ]++--------------------------------------------------------------------------------+-- | 'InstrBlock's are the insn sequences generated by the insn selectors.+--      They are really trees of insns to facilitate fast appending, where a+--      left-to-right traversal yields the insns in the correct order.+--+type InstrBlock+        = OrdList Instr+++-- | Condition codes passed up the tree.+--+data CondCode+        = CondCode Bool Cond InstrBlock+++-- | Register's passed up the tree.  If the stix code forces the register+--      to live in a pre-decided machine register, it comes out as @Fixed@;+--      otherwise, it comes out as @Any@, and the parent can decide which+--      register to put it in.+--+data Register+        = Fixed Format Reg InstrBlock+        | Any   Format (Reg -> InstrBlock)+++swizzleRegisterRep :: Register -> Format -> Register+swizzleRegisterRep (Fixed _ reg code) format = Fixed format reg code+swizzleRegisterRep (Any _ codefn)     format = Any   format codefn++getLocalRegReg :: LocalReg -> Reg+getLocalRegReg (LocalReg u pk)+  = -- by Assuming SSE2, Int,Word,Float,Double all can be register allocated+    RegVirtual (mkVirtualReg u (cmmTypeFormat pk))++-- | Grab the Reg for a CmmReg+getRegisterReg :: Platform  -> CmmReg -> Reg++getRegisterReg _   (CmmLocal lreg) = getLocalRegReg lreg++getRegisterReg platform  (CmmGlobal mid)+  = case globalRegMaybe platform mid of+        Just reg -> RegReal $ reg+        Nothing  -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)+        -- By this stage, the only MagicIds remaining should be the+        -- ones which map to a real machine register on this+        -- platform.  Hence ...+++-- | Memory addressing modes passed up the tree.+data Amode+        = Amode AddrMode InstrBlock++{-+Now, given a tree (the argument to a CmmLoad) that references memory,+produce a suitable addressing mode.++A Rule of the Game (tm) for Amodes: use of the addr bit must+immediately follow use of the code part, since the code part puts+values in registers which the addr then refers to.  So you can't put+anything in between, lest it overwrite some of those registers.  If+you need to do some other computation between the code part and use of+the addr bit, first store the effective address from the amode in a+temporary, then do the other computation, and then use the temporary:++    code+    LEA amode, tmp+    ... other computation ...+    ... (tmp) ...+-}++{-+Note [%rip-relative addressing on x86-64]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+On x86-64 GHC produces code for use in the "small" or, when `-fPIC` is set,+"small PIC" code models defined by the x86-64 System V ABI (section 3.5.1 of+specification version 0.99).++In general the small code model would allow us to assume that code is located+between 0 and 2^31 - 1. However, this is not true on Windows which, due to+high-entropy ASLR, may place the executable image anywhere in 64-bit address+space. This is problematic since immediate operands in x86-64 are generally+32-bit sign-extended values (with the exception of the 64-bit MOVABS encoding).+Consequently, to avoid overflowing we use %rip-relative addressing universally.+Since %rip-relative addressing comes essentially for free and makes linking far+easier, we use it even on non-Windows platforms.++See also: the documentation for GCC's `-mcmodel=small` flag.+-}+++-- | Check whether an integer will fit in 32 bits.+--      A CmmInt is intended to be truncated to the appropriate+--      number of bits, so here we truncate it to Int64.  This is+--      important because e.g. -1 as a CmmInt might be either+--      -1 or 18446744073709551615.+--+is32BitInteger :: Integer -> Bool+is32BitInteger i = i64 <= 0x7fffffff && i64 >= -0x80000000+  where i64 = fromIntegral i :: Int64+++-- | Convert a BlockId to some CmmStatic data+jumpTableEntry :: NCGConfig -> Maybe BlockId -> CmmStatic+jumpTableEntry config Nothing = CmmStaticLit (CmmInt 0 (ncgWordWidth config))+jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel)+    where blockLabel = blockLbl blockid+++-- -----------------------------------------------------------------------------+-- General things for putting together code sequences++-- Expand CmmRegOff.  ToDo: should we do it this way around, or convert+-- CmmExprs into CmmRegOff?+mangleIndexTree :: Platform -> CmmReg -> Int -> CmmExpr+mangleIndexTree platform reg off+  = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]+  where width = typeWidth (cmmRegType platform reg)++-- | The dual to getAnyReg: compute an expression into a register, but+--      we don't mind which one it is.+getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)+getSomeReg expr = do+  r <- getRegister expr+  case r of+    Any rep code -> do+        tmp <- getNewRegNat rep+        return (tmp, code tmp)+    Fixed _ reg code ->+        return (reg, code)+++assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock+assignMem_I64Code addrTree valueTree = do+  Amode addr addr_code <- getAmode addrTree+  RegCode64 vcode rhi rlo <- iselExpr64 valueTree+  let+        -- Little-endian store+        mov_lo = MOV II32 (OpReg rlo) (OpAddr addr)+        mov_hi = MOV II32 (OpReg rhi) (OpAddr (fromJust (addrOffset addr 4)))+  return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi)+++assignReg_I64Code :: CmmReg  -> CmmExpr -> NatM InstrBlock+assignReg_I64Code (CmmLocal dst) valueTree = do+   RegCode64 vcode r_src_hi r_src_lo <- iselExpr64 valueTree+   let+         Reg64 r_dst_hi r_dst_lo = localReg64 dst+         mov_lo = MOV II32 (OpReg r_src_lo) (OpReg r_dst_lo)+         mov_hi = MOV II32 (OpReg r_src_hi) (OpReg r_dst_hi)+   return (+        vcode `snocOL` mov_lo `snocOL` mov_hi+     )++assignReg_I64Code _ _+   = panic "assignReg_I64Code(i386): invalid lvalue"+++iselExpr64 :: HasDebugCallStack => CmmExpr -> NatM (RegCode64 InstrBlock)+iselExpr64 (CmmLit (CmmInt i _)) = do+  Reg64 rhi rlo <- getNewReg64+  let+        r = fromIntegral (fromIntegral i :: Word32)+        q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32)+        code = toOL [+                MOV II32 (OpImm (ImmInteger r)) (OpReg rlo),+                MOV II32 (OpImm (ImmInteger q)) (OpReg rhi)+                ]+  return (RegCode64 code rhi rlo)++iselExpr64 (CmmLoad addrTree ty _) | isWord64 ty = do+   Amode addr addr_code <- getAmode addrTree+   Reg64 rhi rlo <- getNewReg64+   let+        mov_lo = MOV II32 (OpAddr addr) (OpReg rlo)+        mov_hi = MOV II32 (OpAddr (fromJust (addrOffset addr 4))) (OpReg rhi)+   return (+            RegCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi) rhi rlo+     )++iselExpr64 (CmmReg (CmmLocal local_reg)) = do+  let Reg64 hi lo = localReg64 local_reg+  return (RegCode64 nilOL hi lo)++-- we handle addition, but rather badly+iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)]) = do+   RegCode64 code1 r1hi r1lo <- iselExpr64 e1+   Reg64 rhi rlo <- getNewReg64+   let+        r = fromIntegral (fromIntegral i :: Word32)+        q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32)+        code =  code1 `appOL`+                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),+                       ADD II32 (OpImm (ImmInteger r)) (OpReg rlo),+                       MOV II32 (OpReg r1hi) (OpReg rhi),+                       ADC II32 (OpImm (ImmInteger q)) (OpReg rhi) ]+   return (RegCode64 code rhi rlo)++iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do+   RegCode64 code1 r1hi r1lo <- iselExpr64 e1+   RegCode64 code2 r2hi r2lo <- iselExpr64 e2+   Reg64 rhi rlo <- getNewReg64+   let+        code =  code1 `appOL`+                code2 `appOL`+                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),+                       ADD II32 (OpReg r2lo) (OpReg rlo),+                       MOV II32 (OpReg r1hi) (OpReg rhi),+                       ADC II32 (OpReg r2hi) (OpReg rhi) ]+   return (RegCode64 code rhi rlo)++iselExpr64 (CmmMachOp (MO_Sub _) [e1,e2]) = do+   RegCode64 code1 r1hi r1lo <- iselExpr64 e1+   RegCode64 code2 r2hi r2lo <- iselExpr64 e2+   Reg64 rhi rlo <- getNewReg64+   let+        code =  code1 `appOL`+                code2 `appOL`+                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),+                       SUB II32 (OpReg r2lo) (OpReg rlo),+                       MOV II32 (OpReg r1hi) (OpReg rhi),+                       SBB II32 (OpReg r2hi) (OpReg rhi) ]+   return (RegCode64 code rhi rlo)++iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) = do+     code <- getAnyReg expr+     Reg64 r_dst_hi r_dst_lo <- getNewReg64+     return $ RegCode64 (code r_dst_lo `snocOL`+                          MOV II32 (OpImm (ImmInt 0)) (OpReg r_dst_hi))+                          r_dst_hi+                          r_dst_lo++iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr]) = do+     code <- getAnyReg expr+     Reg64 r_dst_hi r_dst_lo <- getNewReg64+     return $ RegCode64 (code r_dst_lo `snocOL`+                          MOV II32 (OpReg r_dst_lo) (OpReg eax) `snocOL`+                          CLTD II32 `snocOL`+                          MOV II32 (OpReg eax) (OpReg r_dst_lo) `snocOL`+                          MOV II32 (OpReg edx) (OpReg r_dst_hi))+                          r_dst_hi+                          r_dst_lo++iselExpr64 expr+   = do+      platform <- getPlatform+      pprPanic "iselExpr64(i386)" (pdoc platform expr)+++--------------------------------------------------------------------------------+getRegister :: CmmExpr -> NatM Register+getRegister e = do platform <- getPlatform+                   is32Bit <- is32BitPlatform+                   getRegister' platform is32Bit e++getRegister' :: Platform -> Bool -> CmmExpr -> NatM Register++getRegister' platform is32Bit (CmmReg reg)+  = case reg of+        CmmGlobal PicBaseReg+         | is32Bit ->+            -- on x86_64, we have %rip for PicBaseReg, but it's not+            -- a full-featured register, it can only be used for+            -- rip-relative addressing.+            do reg' <- getPicBaseNat (archWordFormat is32Bit)+               return (Fixed (archWordFormat is32Bit) reg' nilOL)+        _ ->+            do+               let+                 fmt = cmmTypeFormat (cmmRegType platform reg)+                 format  = fmt+               --+               platform <- ncgPlatform <$> getConfig+               return (Fixed format+                             (getRegisterReg platform reg)+                             nilOL)+++getRegister' platform is32Bit (CmmRegOff r n)+  = getRegister' platform is32Bit $ mangleIndexTree platform r n++getRegister' platform is32Bit (CmmMachOp (MO_AlignmentCheck align _) [e])+  = addAlignmentCheck align <$> getRegister' platform is32Bit e++-- for 32-bit architectures, support some 64 -> 32 bit conversions:+-- TO_W_(x), TO_W_(x >> 32)++getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32)+                     [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])+ | is32Bit = do+  RegCode64 code rhi _rlo <- iselExpr64 x+  return $ Fixed II32 rhi code++getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32)+                     [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])+ | is32Bit = do+  RegCode64 code rhi _rlo <- iselExpr64 x+  return $ Fixed II32 rhi code++getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32) [x])+ | is32Bit = do+  RegCode64 code _rhi rlo <- iselExpr64 x+  return $ Fixed II32 rlo code++getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32) [x])+ | is32Bit = do+  RegCode64 code _rhi rlo <- iselExpr64 x+  return $ Fixed II32 rlo code++getRegister' _ _ (CmmLit lit@(CmmFloat f w)) =+  float_const_sse2  where+  float_const_sse2+    | f == 0.0 = do+      let+          format = floatFormat w+          code dst = unitOL  (XOR format (OpReg dst) (OpReg dst))+        -- I don't know why there are xorpd, xorps, and pxor instructions.+        -- They all appear to do the same thing --SDM+      return (Any format code)++   | otherwise = do+      Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit+      loadFloatAmode w addr code++-- catch simple cases of zero- or sign-extended load+getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad addr _ _]) = do+  code <- intLoadCode (MOVZxL II8) addr+  return (Any II32 code)++getRegister' _ _ (CmmMachOp (MO_SS_Conv W8 W32) [CmmLoad addr _ _]) = do+  code <- intLoadCode (MOVSxL II8) addr+  return (Any II32 code)++getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad addr _ _]) = do+  code <- intLoadCode (MOVZxL II16) addr+  return (Any II32 code)++getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad addr _ _]) = do+  code <- intLoadCode (MOVSxL II16) addr+  return (Any II32 code)++-- catch simple cases of zero- or sign-extended load+getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad addr _ _])+ | not is32Bit = do+  code <- intLoadCode (MOVZxL II8) addr+  return (Any II64 code)++getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W8 W64) [CmmLoad addr _ _])+ | not is32Bit = do+  code <- intLoadCode (MOVSxL II8) addr+  return (Any II64 code)++getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad addr _ _])+ | not is32Bit = do+  code <- intLoadCode (MOVZxL II16) addr+  return (Any II64 code)++getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad addr _ _])+ | not is32Bit = do+  code <- intLoadCode (MOVSxL II16) addr+  return (Any II64 code)++getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad addr _ _])+ | not is32Bit = do+  code <- intLoadCode (MOV II32) addr -- 32-bit loads zero-extend+  return (Any II64 code)++getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad addr _ _])+ | not is32Bit = do+  code <- intLoadCode (MOVSxL II32) addr+  return (Any II64 code)++getRegister' _ is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg),+                                     CmmLit displacement])+ | not is32Bit =+      return $ Any II64 (\dst -> unitOL $+        LEA II64 (OpAddr (ripRel (litToImm displacement))) (OpReg dst))++getRegister' platform is32Bit (CmmMachOp mop [x]) = -- unary MachOps+    case mop of+      MO_F_Neg w  -> sse2NegCode w x+++      MO_S_Neg w -> triv_ucode NEGI (intFormat w)+      MO_Not w   -> triv_ucode NOT  (intFormat w)++      -- Nop conversions+      MO_UU_Conv W32 W8  -> toI8Reg  W32 x+      MO_SS_Conv W32 W8  -> toI8Reg  W32 x+      MO_XX_Conv W32 W8  -> toI8Reg  W32 x+      MO_UU_Conv W16 W8  -> toI8Reg  W16 x+      MO_SS_Conv W16 W8  -> toI8Reg  W16 x+      MO_XX_Conv W16 W8  -> toI8Reg  W16 x+      MO_UU_Conv W32 W16 -> toI16Reg W32 x+      MO_SS_Conv W32 W16 -> toI16Reg W32 x+      MO_XX_Conv W32 W16 -> toI16Reg W32 x++      MO_UU_Conv W64 W32 | not is32Bit -> conversionNop II64 x+      MO_SS_Conv W64 W32 | not is32Bit -> conversionNop II64 x+      MO_XX_Conv W64 W32 | not is32Bit -> conversionNop II64 x+      MO_UU_Conv W64 W16 | not is32Bit -> toI16Reg W64 x+      MO_SS_Conv W64 W16 | not is32Bit -> toI16Reg W64 x+      MO_XX_Conv W64 W16 | not is32Bit -> toI16Reg W64 x+      MO_UU_Conv W64 W8  | not is32Bit -> toI8Reg  W64 x+      MO_SS_Conv W64 W8  | not is32Bit -> toI8Reg  W64 x+      MO_XX_Conv W64 W8  | not is32Bit -> toI8Reg  W64 x++      MO_UU_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x+      MO_SS_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x+      MO_XX_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x++      -- widenings+      MO_UU_Conv W8  W32 -> integerExtend W8  W32 MOVZxL x+      MO_UU_Conv W16 W32 -> integerExtend W16 W32 MOVZxL x+      MO_UU_Conv W8  W16 -> integerExtend W8  W16 MOVZxL x++      MO_SS_Conv W8  W32 -> integerExtend W8  W32 MOVSxL x+      MO_SS_Conv W16 W32 -> integerExtend W16 W32 MOVSxL x+      MO_SS_Conv W8  W16 -> integerExtend W8  W16 MOVSxL x++      -- We don't care about the upper bits for MO_XX_Conv, so MOV is enough. However, on 32-bit we+      -- have 8-bit registers only for a few registers (as opposed to x86-64 where every register+      -- has 8-bit version). So for 32-bit code, we'll just zero-extend.+      MO_XX_Conv W8  W32+          | is32Bit   -> integerExtend W8 W32 MOVZxL x+          | otherwise -> integerExtend W8 W32 MOV x+      MO_XX_Conv W8  W16+          | is32Bit   -> integerExtend W8 W16 MOVZxL x+          | otherwise -> integerExtend W8 W16 MOV x+      MO_XX_Conv W16 W32 -> integerExtend W16 W32 MOV x++      MO_UU_Conv W8  W64 | not is32Bit -> integerExtend W8  W64 MOVZxL x+      MO_UU_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVZxL x+      MO_UU_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVZxL x+      MO_SS_Conv W8  W64 | not is32Bit -> integerExtend W8  W64 MOVSxL x+      MO_SS_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVSxL x+      MO_SS_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVSxL x+      -- For 32-to-64 bit zero extension, amd64 uses an ordinary movl.+      -- However, we don't want the register allocator to throw it+      -- away as an unnecessary reg-to-reg move, so we keep it in+      -- the form of a movzl and print it as a movl later.+      -- This doesn't apply to MO_XX_Conv since in this case we don't care about+      -- the upper bits. So we can just use MOV.+      MO_XX_Conv W8  W64 | not is32Bit -> integerExtend W8  W64 MOV x+      MO_XX_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOV x+      MO_XX_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOV x++      MO_FF_Conv W32 W64 -> coerceFP2FP W64 x+++      MO_FF_Conv W64 W32 -> coerceFP2FP W32 x++      MO_FS_Conv from to -> coerceFP2Int from to x+      MO_SF_Conv from to -> coerceInt2FP from to x++      MO_V_Insert {}   -> needLlvm+      MO_V_Extract {}  -> needLlvm+      MO_V_Add {}      -> needLlvm+      MO_V_Sub {}      -> needLlvm+      MO_V_Mul {}      -> needLlvm+      MO_VS_Quot {}    -> needLlvm+      MO_VS_Rem {}     -> needLlvm+      MO_VS_Neg {}     -> needLlvm+      MO_VU_Quot {}    -> needLlvm+      MO_VU_Rem {}     -> needLlvm+      MO_VF_Insert {}  -> needLlvm+      MO_VF_Extract {} -> needLlvm+      MO_VF_Add {}     -> needLlvm+      MO_VF_Sub {}     -> needLlvm+      MO_VF_Mul {}     -> needLlvm+      MO_VF_Quot {}    -> needLlvm+      MO_VF_Neg {}     -> needLlvm++      _other -> pprPanic "getRegister" (pprMachOp mop)+   where+        triv_ucode :: (Format -> Operand -> Instr) -> Format -> NatM Register+        triv_ucode instr format = trivialUCode format (instr format) x++        -- signed or unsigned extension.+        integerExtend :: Width -> Width+                      -> (Format -> Operand -> Operand -> Instr)+                      -> CmmExpr -> NatM Register+        integerExtend from to instr expr = do+            (reg,e_code) <- if from == W8 then getByteReg expr+                                          else getSomeReg expr+            let+                code dst =+                  e_code `snocOL`+                  instr (intFormat from) (OpReg reg) (OpReg dst)+            return (Any (intFormat to) code)++        toI8Reg :: Width -> CmmExpr -> NatM Register+        toI8Reg new_rep expr+            = do codefn <- getAnyReg expr+                 return (Any (intFormat new_rep) codefn)+                -- HACK: use getAnyReg to get a byte-addressable register.+                -- If the source was a Fixed register, this will add the+                -- mov instruction to put it into the desired destination.+                -- We're assuming that the destination won't be a fixed+                -- non-byte-addressable register; it won't be, because all+                -- fixed registers are word-sized.++        toI16Reg = toI8Reg -- for now++        conversionNop :: Format -> CmmExpr -> NatM Register+        conversionNop new_format expr+            = do e_code <- getRegister' platform is32Bit expr+                 return (swizzleRegisterRep e_code new_format)+++getRegister' _ is32Bit (CmmMachOp mop [x, y]) = -- dyadic MachOps+  case mop of+      MO_F_Eq _ -> condFltReg is32Bit EQQ x y+      MO_F_Ne _ -> condFltReg is32Bit NE  x y+      MO_F_Gt _ -> condFltReg is32Bit GTT x y+      MO_F_Ge _ -> condFltReg is32Bit GE  x y+      -- Invert comparison condition and swap operands+      -- See Note [SSE Parity Checks]+      MO_F_Lt _ -> condFltReg is32Bit GTT  y x+      MO_F_Le _ -> condFltReg is32Bit GE   y x++      MO_Eq _   -> condIntReg EQQ x y+      MO_Ne _   -> condIntReg NE  x y++      MO_S_Gt _ -> condIntReg GTT x y+      MO_S_Ge _ -> condIntReg GE  x y+      MO_S_Lt _ -> condIntReg LTT x y+      MO_S_Le _ -> condIntReg LE  x y++      MO_U_Gt _ -> condIntReg GU  x y+      MO_U_Ge _ -> condIntReg GEU x y+      MO_U_Lt _ -> condIntReg LU  x y+      MO_U_Le _ -> condIntReg LEU x y++      MO_F_Add w   -> trivialFCode_sse2 w ADD  x y++      MO_F_Sub w   -> trivialFCode_sse2 w SUB  x y++      MO_F_Quot w  -> trivialFCode_sse2 w FDIV x y++      MO_F_Mul w   -> trivialFCode_sse2 w MUL x y+++      MO_Add rep -> add_code rep x y+      MO_Sub rep -> sub_code rep x y++      MO_S_Quot rep -> div_code rep True  True  x y+      MO_S_Rem  rep -> div_code rep True  False x y+      MO_U_Quot rep -> div_code rep False True  x y+      MO_U_Rem  rep -> div_code rep False False x y++      MO_S_MulMayOflo rep -> imulMayOflo rep x y++      MO_Mul W8  -> imulW8 x y+      MO_Mul rep -> triv_op rep IMUL+      MO_And rep -> triv_op rep AND+      MO_Or  rep -> triv_op rep OR+      MO_Xor rep -> triv_op rep XOR++        {- Shift ops on x86s have constraints on their source, it+           either has to be Imm, CL or 1+            => trivialCode is not restrictive enough (sigh.)+        -}+      MO_Shl rep   -> shift_code rep SHL x y {-False-}+      MO_U_Shr rep -> shift_code rep SHR x y {-False-}+      MO_S_Shr rep -> shift_code rep SAR x y {-False-}++      MO_V_Insert {}   -> needLlvm+      MO_V_Extract {}  -> needLlvm+      MO_V_Add {}      -> needLlvm+      MO_V_Sub {}      -> needLlvm+      MO_V_Mul {}      -> needLlvm+      MO_VS_Quot {}    -> needLlvm+      MO_VS_Rem {}     -> needLlvm+      MO_VS_Neg {}     -> needLlvm+      MO_VF_Insert {}  -> needLlvm+      MO_VF_Extract {} -> needLlvm+      MO_VF_Add {}     -> needLlvm+      MO_VF_Sub {}     -> needLlvm+      MO_VF_Mul {}     -> needLlvm+      MO_VF_Quot {}    -> needLlvm+      MO_VF_Neg {}     -> needLlvm++      _other -> pprPanic "getRegister(x86) - binary CmmMachOp (1)" (pprMachOp mop)+  where+    --------------------+    triv_op width instr = trivialCode width op (Just op) x y+                        where op   = instr (intFormat width)++    -- Special case for IMUL for bytes, since the result of IMULB will be in+    -- %ax, the split to %dx/%edx/%rdx and %ax/%eax/%rax happens only for wider+    -- values.+    imulW8 :: CmmExpr -> CmmExpr -> NatM Register+    imulW8 arg_a arg_b = do+        (a_reg, a_code) <- getNonClobberedReg arg_a+        b_code <- getAnyReg arg_b++        let code = a_code `appOL` b_code eax `appOL`+                   toOL [ IMUL2 format (OpReg a_reg) ]+            format = intFormat W8++        return (Fixed format eax code)+++    imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register+    imulMayOflo rep a b = do+         (a_reg, a_code) <- getNonClobberedReg a+         b_code <- getAnyReg b+         let+             shift_amt  = case rep of+                           W32 -> 31+                           W64 -> 63+                           _ -> panic "shift_amt"++             format = intFormat rep+             code = a_code `appOL` b_code eax `appOL`+                        toOL [+                           IMUL2 format (OpReg a_reg),   -- result in %edx:%eax+                           SAR format (OpImm (ImmInt shift_amt)) (OpReg eax),+                                -- sign extend lower part+                           SUB format (OpReg edx) (OpReg eax)+                                -- compare against upper+                           -- eax==0 if high part == sign extended low part+                        ]+         return (Fixed format eax code)++    --------------------+    shift_code :: Width+               -> (Format -> Operand -> Operand -> Instr)+               -> CmmExpr+               -> CmmExpr+               -> NatM Register++    {- Case1: shift length as immediate -}+    shift_code width instr x (CmmLit lit)+      -- Handle the case of a shift larger than the width of the shifted value.+      -- This is necessary since x86 applies a mask of 0x1f to the shift+      -- amount, meaning that, e.g., `shr 47, $eax` will actually shift by+      -- `47 & 0x1f == 15`. See #20626.+      | CmmInt n _ <- lit+      , n >= fromIntegral (widthInBits width)+      = getRegister $ CmmLit $ CmmInt 0 width++      | otherwise = do+          x_code <- getAnyReg x+          let+               format = intFormat width+               code dst+                  = x_code dst `snocOL`+                    instr format (OpImm (litToImm lit)) (OpReg dst)+          return (Any format code)++    {- Case2: shift length is complex (non-immediate)+      * y must go in %ecx.+      * we cannot do y first *and* put its result in %ecx, because+        %ecx might be clobbered by x.+      * if we do y second, then x cannot be+        in a clobbered reg.  Also, we cannot clobber x's reg+        with the instruction itself.+      * so we can either:+        - do y first, put its result in a fresh tmp, then copy it to %ecx later+        - do y second and put its result into %ecx.  x gets placed in a fresh+          tmp.  This is likely to be better, because the reg alloc can+          eliminate this reg->reg move here (it won't eliminate the other one,+          because the move is into the fixed %ecx).+      * in the case of C calls the use of ecx here can interfere with arguments.+        We avoid this with the hack described in Note [Evaluate C-call+        arguments before placing in destination registers]+    -}+    shift_code width instr x y{-amount-} = do+        x_code <- getAnyReg x+        let format = intFormat width+        tmp <- getNewRegNat format+        y_code <- getAnyReg y+        let+           code = x_code tmp `appOL`+                  y_code ecx `snocOL`+                  instr format (OpReg ecx) (OpReg tmp)+        return (Fixed format tmp code)++    --------------------+    add_code :: Width -> CmmExpr -> CmmExpr -> NatM Register+    add_code rep x (CmmLit (CmmInt y _))+        | is32BitInteger y+        , rep /= W8 -- LEA doesn't support byte size (#18614)+        = add_int rep x y+    add_code rep x y = trivialCode rep (ADD format) (Just (ADD format)) x y+      where format = intFormat rep+    -- TODO: There are other interesting patterns we want to replace+    --     with a LEA, e.g. `(x + offset) + (y << shift)`.++    --------------------+    sub_code :: Width -> CmmExpr -> CmmExpr -> NatM Register+    sub_code rep x (CmmLit (CmmInt y _))+        | is32BitInteger (-y)+        , rep /= W8 -- LEA doesn't support byte size (#18614)+        = add_int rep x (-y)+    sub_code rep x y = trivialCode rep (SUB (intFormat rep)) Nothing x y++    -- our three-operand add instruction:+    add_int width x y = do+        (x_reg, x_code) <- getSomeReg x+        let+            format = intFormat width+            imm = ImmInt (fromInteger y)+            code dst+               = x_code `snocOL`+                 LEA format+                        (OpAddr (AddrBaseIndex (EABaseReg x_reg) EAIndexNone imm))+                        (OpReg dst)+        --+        return (Any format code)++    ----------------------++    -- See Note [DIV/IDIV for bytes]+    div_code W8 signed quotient x y = do+        let widen | signed    = MO_SS_Conv W8 W16+                  | otherwise = MO_UU_Conv W8 W16+        div_code+            W16+            signed+            quotient+            (CmmMachOp widen [x])+            (CmmMachOp widen [y])++    div_code width signed quotient x y = do+           (y_op, y_code) <- getRegOrMem y -- cannot be clobbered+           x_code <- getAnyReg x+           let+             format = intFormat width+             widen | signed    = CLTD format+                   | otherwise = XOR format (OpReg edx) (OpReg edx)++             instr | signed    = IDIV+                   | otherwise = DIV++             code = y_code `appOL`+                    x_code eax `appOL`+                    toOL [widen, instr format y_op]++             result | quotient  = eax+                    | otherwise = edx++           return (Fixed format result code)+++getRegister' _ _ (CmmLoad mem pk _)+  | isFloatType pk+  = do+    Amode addr mem_code <- getAmode mem+    loadFloatAmode  (typeWidth pk) addr mem_code++getRegister' _ is32Bit (CmmLoad mem pk _)+  | is32Bit && not (isWord64 pk)+  = do+    code <- intLoadCode instr mem+    return (Any format code)+  where+    width = typeWidth pk+    format = intFormat width+    instr = case width of+                W8     -> MOVZxL II8+                _other -> MOV format+        -- We always zero-extend 8-bit loads, if we+        -- can't think of anything better.  This is because+        -- we can't guarantee access to an 8-bit variant of every register+        -- (esi and edi don't have 8-bit variants), so to make things+        -- simpler we do our 8-bit arithmetic with full 32-bit registers.++-- Simpler memory load code on x86_64+getRegister' _ is32Bit (CmmLoad mem pk _)+ | not is32Bit+  = do+    code <- intLoadCode (MOV format) mem+    return (Any format code)+  where format = intFormat $ typeWidth pk++getRegister' _ is32Bit (CmmLit (CmmInt 0 width))+  = let+        format = intFormat width++        -- x86_64: 32-bit xor is one byte shorter, and zero-extends to 64 bits+        format1 = if is32Bit then format+                           else case format of+                                II64 -> II32+                                _ -> format+        code dst+           = unitOL (XOR format1 (OpReg dst) (OpReg dst))+    in+        return (Any format code)++-- Handle symbol references with LEA and %rip-relative addressing.+-- See Note [%rip-relative addressing on x86-64].+getRegister' platform is32Bit (CmmLit lit)+  | is_label lit+  , not is32Bit+  = do let format = cmmTypeFormat (cmmLitType platform lit)+           imm = litToImm lit+           op = OpAddr (AddrBaseIndex EABaseRip EAIndexNone imm)+           code dst = unitOL (LEA format op (OpReg dst))+       return (Any format code)+  where+    is_label (CmmLabel {})        = True+    is_label (CmmLabelOff {})     = True+    is_label (CmmLabelDiffOff {}) = True+    is_label _                    = False++  -- optimisation for loading small literals on x86_64: take advantage+  -- of the automatic zero-extension from 32 to 64 bits, because the 32-bit+  -- instruction forms are shorter.+getRegister' platform is32Bit (CmmLit lit)+  | not is32Bit, isWord64 (cmmLitType platform lit), not (isBigLit lit)+  = let+        imm = litToImm lit+        code dst = unitOL (MOV II32 (OpImm imm) (OpReg dst))+    in+        return (Any II64 code)+  where+   isBigLit (CmmInt i _) = i < 0 || i > 0xffffffff+   isBigLit _ = False+        -- note1: not the same as (not.is32BitLit), because that checks for+        -- signed literals that fit in 32 bits, but we want unsigned+        -- literals here.+        -- note2: all labels are small, because we're assuming the+        -- small memory model. See Note [%rip-relative addressing on x86-64].++getRegister' platform _ (CmmLit lit)+  = do let format = cmmTypeFormat (cmmLitType platform lit)+           imm = litToImm lit+           code dst = unitOL (MOV format (OpImm imm) (OpReg dst))+       return (Any format code)++getRegister' platform _ other+    | isVecExpr other  = needLlvm+    | otherwise        = pprPanic "getRegister(x86)" (pdoc platform other)+++intLoadCode :: (Operand -> Operand -> Instr) -> CmmExpr+   -> NatM (Reg -> InstrBlock)+intLoadCode instr mem = do+  Amode src mem_code <- getAmode mem+  return (\dst -> mem_code `snocOL` instr (OpAddr src) (OpReg dst))++-- Compute an expression into *any* register, adding the appropriate+-- move instruction if necessary.+getAnyReg :: CmmExpr -> NatM (Reg -> InstrBlock)+getAnyReg expr = do+  r <- getRegister expr+  anyReg r++anyReg :: Register -> NatM (Reg -> InstrBlock)+anyReg (Any _ code)          = return code+anyReg (Fixed rep reg fcode) = return (\dst -> fcode `snocOL` reg2reg rep reg dst)++-- A bit like getSomeReg, but we want a reg that can be byte-addressed.+-- Fixed registers might not be byte-addressable, so we make sure we've+-- got a temporary, inserting an extra reg copy if necessary.+getByteReg :: CmmExpr -> NatM (Reg, InstrBlock)+getByteReg expr = do+  is32Bit <- is32BitPlatform+  if is32Bit+      then do r <- getRegister expr+              case r of+                Any rep code -> do+                    tmp <- getNewRegNat rep+                    return (tmp, code tmp)+                Fixed rep reg code+                    | isVirtualReg reg -> return (reg,code)+                    | otherwise -> do+                        tmp <- getNewRegNat rep+                        return (tmp, code `snocOL` reg2reg rep reg tmp)+                    -- ToDo: could optimise slightly by checking for+                    -- byte-addressable real registers, but that will+                    -- happen very rarely if at all.+      else getSomeReg expr -- all regs are byte-addressable on x86_64++-- Another variant: this time we want the result in a register that cannot+-- be modified by code to evaluate an arbitrary expression.+getNonClobberedReg :: CmmExpr -> NatM (Reg, InstrBlock)+getNonClobberedReg expr = do+  r <- getRegister expr+  platform <- ncgPlatform <$> getConfig+  case r of+    Any rep code -> do+        tmp <- getNewRegNat rep+        return (tmp, code tmp)+    Fixed rep reg code+        -- only certain regs can be clobbered+        | reg `elem` instrClobberedRegs platform+        -> do+                tmp <- getNewRegNat rep+                return (tmp, code `snocOL` reg2reg rep reg tmp)+        | otherwise ->+                return (reg, code)++reg2reg :: Format -> Reg -> Reg -> Instr+reg2reg format src dst = MOV format (OpReg src) (OpReg dst)+++--------------------------------------------------------------------------------++-- | Convert a 'CmmExpr' representing a memory address into an 'Amode'.+--+-- An 'Amode' is a datatype representing a valid address form for the target+-- (e.g. "Base + Index + disp" or immediate) and the code to compute it.+getAmode :: CmmExpr -> NatM Amode+getAmode e = do+   platform <- getPlatform+   let is32Bit = target32Bit platform++   case e of+      CmmRegOff r n+         -> getAmode $ mangleIndexTree platform r n++      CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg), CmmLit displacement]+         | not is32Bit+         -> return $ Amode (ripRel (litToImm displacement)) nilOL++      -- This is all just ridiculous, since it carefully undoes+      -- what mangleIndexTree has just done.+      CmmMachOp (MO_Sub _rep) [x, CmmLit lit@(CmmInt i _)]+         | is32BitLit platform lit+         -- assert (rep == II32)???+         -> do+            (x_reg, x_code) <- getSomeReg x+            let off = ImmInt (-(fromInteger i))+            return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code)++      CmmMachOp (MO_Add _rep) [x, CmmLit lit]+         | is32BitLit platform lit+         -- assert (rep == II32)???+         -> do+            (x_reg, x_code) <- getSomeReg x+            let off = litToImm lit+            return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code)++      -- Turn (lit1 << n  + lit2) into  (lit2 + lit1 << n) so it will be+      -- recognised by the next rule.+      CmmMachOp (MO_Add rep) [a@(CmmMachOp (MO_Shl _) _), b@(CmmLit _)]+         -> getAmode (CmmMachOp (MO_Add rep) [b,a])++      -- Matches: (x + offset) + (y << shift)+      CmmMachOp (MO_Add _) [CmmRegOff x offset, CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)]]+         | shift == 0 || shift == 1 || shift == 2 || shift == 3+         -> x86_complex_amode (CmmReg x) y shift (fromIntegral offset)++      CmmMachOp (MO_Add _) [x, CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)]]+         | shift == 0 || shift == 1 || shift == 2 || shift == 3+         -> x86_complex_amode x y shift 0++      CmmMachOp (MO_Add _) [x, CmmMachOp (MO_Add _) [CmmMachOp (MO_Shl _)+                                                    [y, CmmLit (CmmInt shift _)], CmmLit (CmmInt offset _)]]+         | shift == 0 || shift == 1 || shift == 2 || shift == 3+         && is32BitInteger offset+         -> x86_complex_amode x y shift offset++      CmmMachOp (MO_Add _) [x,y]+         | not (isLit y) -- we already handle valid literals above.+         -> x86_complex_amode x y 0 0++      -- Handle labels with %rip-relative addressing since in general the image+      -- may be loaded anywhere in the 64-bit address space (e.g. on Windows+      -- with high-entropy ASLR). See Note [%rip-relative addressing on x86-64].+      CmmLit lit+         | not is32Bit+         , is_label lit+         -> return (Amode (AddrBaseIndex EABaseRip EAIndexNone (litToImm lit)) nilOL)++      CmmLit lit+         | is32BitLit platform lit+         -> return (Amode (ImmAddr (litToImm lit) 0) nilOL)++      -- Literal with offsets too big (> 32 bits) fails during the linking phase+      -- (#15570). We already handled valid literals above so we don't have to+      -- test anything here.+      CmmLit (CmmLabelOff l off)+         -> getAmode (CmmMachOp (MO_Add W64) [ CmmLit (CmmLabel l)+                                             , CmmLit (CmmInt (fromIntegral off) W64)+                                             ])+      CmmLit (CmmLabelDiffOff l1 l2 off w)+         -> getAmode (CmmMachOp (MO_Add W64) [ CmmLit (CmmLabelDiffOff l1 l2 0 w)+                                             , CmmLit (CmmInt (fromIntegral off) W64)+                                             ])++      -- in case we can't do something better, we just compute the expression+      -- and put the result in a register+      _ -> do+        (reg,code) <- getSomeReg e+        return (Amode (AddrBaseIndex (EABaseReg reg) EAIndexNone (ImmInt 0)) code)+  where+    is_label (CmmLabel{}) = True+    is_label (CmmLabelOff{}) = True+    is_label (CmmLabelDiffOff{}) = True+    is_label _ = False+++-- | Like 'getAmode', but on 32-bit use simple register addressing+-- (i.e. no index register). This stops us from running out of+-- registers on x86 when using instructions such as cmpxchg, which can+-- use up to three virtual registers and one fixed register.+getSimpleAmode :: CmmExpr -> NatM Amode+getSimpleAmode addr = is32BitPlatform >>= \case+  False -> getAmode addr+  True  -> do+    addr_code <- getAnyReg addr+    config <- getConfig+    addr_r <- getNewRegNat (intFormat (ncgWordWidth config))+    let amode = AddrBaseIndex (EABaseReg addr_r) EAIndexNone (ImmInt 0)+    return $! Amode amode (addr_code addr_r)++x86_complex_amode :: CmmExpr -> CmmExpr -> Integer -> Integer -> NatM Amode+x86_complex_amode base index shift offset+  = do (x_reg, x_code) <- getNonClobberedReg base+        -- x must be in a temp, because it has to stay live over y_code+        -- we could compare x_reg and y_reg and do something better here...+       (y_reg, y_code) <- getSomeReg index+       let+           code = x_code `appOL` y_code+           base = case shift of 0 -> 1; 1 -> 2; 2 -> 4; 3 -> 8;+                                n -> panic $ "x86_complex_amode: unhandled shift! (" ++ show n ++ ")"+       return (Amode (AddrBaseIndex (EABaseReg x_reg) (EAIndex y_reg base) (ImmInt (fromIntegral offset)))+               code)+++++-- -----------------------------------------------------------------------------+-- getOperand: sometimes any operand will do.++-- getNonClobberedOperand: the value of the operand will remain valid across+-- the computation of an arbitrary expression, unless the expression+-- is computed directly into a register which the operand refers to+-- (see trivialCode where this function is used for an example).++getNonClobberedOperand :: CmmExpr -> NatM (Operand, InstrBlock)+getNonClobberedOperand (CmmLit lit) =+  if isSuitableFloatingPointLit lit+  then do+    let CmmFloat _ w = lit+    Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit+    return (OpAddr addr, code)+  else do+    platform <- getPlatform+    if is32BitLit platform lit && not (isFloatType (cmmLitType platform lit))+    then return (OpImm (litToImm lit), nilOL)+    else getNonClobberedOperand_generic (CmmLit lit)++getNonClobberedOperand (CmmLoad mem pk _) = do+  is32Bit <- is32BitPlatform+  -- this logic could be simplified+  -- TODO FIXME+  if   (if is32Bit then not (isWord64 pk) else True)+      -- if 32bit and pk is at float/double/simd value+      -- or if 64bit+      --  this could use some eyeballs or i'll need to stare at it more later+    then do+      platform <- ncgPlatform <$> getConfig+      Amode src mem_code <- getAmode mem+      (src',save_code) <-+        if (amodeCouldBeClobbered platform src)+                then do+                   tmp <- getNewRegNat (archWordFormat is32Bit)+                   return (AddrBaseIndex (EABaseReg tmp) EAIndexNone (ImmInt 0),+                           unitOL (LEA (archWordFormat is32Bit)+                                       (OpAddr src)+                                       (OpReg tmp)))+                else+                   return (src, nilOL)+      return (OpAddr src', mem_code `appOL` save_code)+    else+      -- if its a word or gcptr on 32bit?+      getNonClobberedOperand_generic (CmmLoad mem pk NaturallyAligned)++getNonClobberedOperand e = getNonClobberedOperand_generic e++getNonClobberedOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock)+getNonClobberedOperand_generic e = do+  (reg, code) <- getNonClobberedReg e+  return (OpReg reg, code)++amodeCouldBeClobbered :: Platform -> AddrMode -> Bool+amodeCouldBeClobbered platform amode = any (regClobbered platform) (addrModeRegs amode)++regClobbered :: Platform -> Reg -> Bool+regClobbered platform (RegReal (RealRegSingle rr)) = freeReg platform rr+regClobbered _ _ = False++-- getOperand: the operand is not required to remain valid across the+-- computation of an arbitrary expression.+getOperand :: CmmExpr -> NatM (Operand, InstrBlock)++getOperand (CmmLit lit) = do+  use_sse2 <- sse2Enabled+  if (use_sse2 && isSuitableFloatingPointLit lit)+    then do+      let CmmFloat _ w = lit+      Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit+      return (OpAddr addr, code)+    else do++  platform <- getPlatform+  if is32BitLit platform lit && not (isFloatType (cmmLitType platform lit))+    then return (OpImm (litToImm lit), nilOL)+    else getOperand_generic (CmmLit lit)++getOperand (CmmLoad mem pk _) = do+  is32Bit <- is32BitPlatform+  use_sse2 <- sse2Enabled+  if (not (isFloatType pk) || use_sse2) && (if is32Bit then not (isWord64 pk) else True)+     then do+       Amode src mem_code <- getAmode mem+       return (OpAddr src, mem_code)+     else+       getOperand_generic (CmmLoad mem pk NaturallyAligned)++getOperand e = getOperand_generic e++getOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock)+getOperand_generic e = do+    (reg, code) <- getSomeReg e+    return (OpReg reg, code)++isOperand :: Platform -> CmmExpr -> Bool+isOperand _ (CmmLoad _ _ _) = True+isOperand platform (CmmLit lit)+                          = is32BitLit platform lit+                          || isSuitableFloatingPointLit lit+isOperand _ _            = False++-- | Given a 'Register', produce a new 'Register' with an instruction block+-- which will check the value for alignment. Used for @-falignment-sanitisation@.+addAlignmentCheck :: Int -> Register -> Register+addAlignmentCheck align reg =+    case reg of+      Fixed fmt reg code -> Fixed fmt reg (code `appOL` check fmt reg)+      Any fmt f          -> Any fmt (\reg -> f reg `appOL` check fmt reg)+  where+    check :: Format -> Reg -> InstrBlock+    check fmt reg =+        assert (not $ isFloatFormat fmt) $+        toOL [ TEST fmt (OpImm $ ImmInt $ align-1) (OpReg reg)+             , JXX_GBL NE $ ImmCLbl mkBadAlignmentLabel+             ]++memConstant :: Alignment -> CmmLit -> NatM Amode+memConstant align lit = do+  lbl <- getNewLabelNat+  let rosection = Section ReadOnlyData lbl+  config <- getConfig+  platform <- getPlatform+  (addr, addr_code) <- if target32Bit platform+                       then do dynRef <- cmmMakeDynamicReference+                                             config+                                             DataReference+                                             lbl+                               Amode addr addr_code <- getAmode dynRef+                               return (addr, addr_code)+                       else return (ripRel (ImmCLbl lbl), nilOL)+  let code =+        LDATA rosection (align, CmmStaticsRaw lbl [CmmStaticLit lit])+        `consOL` addr_code+  return (Amode addr code)+++loadFloatAmode :: Width -> AddrMode -> InstrBlock -> NatM Register+loadFloatAmode w addr addr_code = do+  let format = floatFormat w+      code dst = addr_code `snocOL`+                    MOV format (OpAddr addr) (OpReg dst)++  return (Any format code)+++-- if we want a floating-point literal as an operand, we can+-- use it directly from memory.  However, if the literal is+-- zero, we're better off generating it into a register using+-- xor.+isSuitableFloatingPointLit :: CmmLit -> Bool+isSuitableFloatingPointLit (CmmFloat f _) = f /= 0.0+isSuitableFloatingPointLit _ = False++getRegOrMem :: CmmExpr -> NatM (Operand, InstrBlock)+getRegOrMem e@(CmmLoad mem pk _) = do+  is32Bit <- is32BitPlatform+  use_sse2 <- sse2Enabled+  if (not (isFloatType pk) || use_sse2) && (if is32Bit then not (isWord64 pk) else True)+     then do+       Amode src mem_code <- getAmode mem+       return (OpAddr src, mem_code)+     else do+       (reg, code) <- getNonClobberedReg e+       return (OpReg reg, code)+getRegOrMem e = do+    (reg, code) <- getNonClobberedReg e+    return (OpReg reg, code)++is32BitLit :: Platform -> CmmLit -> Bool+is32BitLit platform _lit+   | target32Bit platform = True+is32BitLit platform lit =+   case lit of+      CmmInt i W64              -> is32BitInteger i+      -- Except on Windows, assume that labels are in the range 0-2^31-1: this+      -- assumes the small memory model. Note [%rip-relative addressing on+      -- x86-64].+      CmmLabel _                -> low_image+      -- however we can't assume that label offsets are in this range+      -- (see #15570)+      CmmLabelOff _ off         -> low_image && is32BitInteger (fromIntegral off)+      CmmLabelDiffOff _ _ off _ -> low_image && is32BitInteger (fromIntegral off)+      _                         -> True+  where+    -- Is the executable image certain to be located below 4GB? As noted in+    -- Note [%rip-relative addressing on x86-64], this is not true on Windows.+    low_image =+      case platformOS platform of+        OSMinGW32 -> False   -- See Note [%rip-relative addressing on x86-64]+        _         -> True+++-- Set up a condition code for a conditional branch.++getCondCode :: CmmExpr -> NatM CondCode++-- yes, they really do seem to want exactly the same!++getCondCode (CmmMachOp mop [x, y])+  =+    case mop of+      MO_F_Eq W32 -> condFltCode EQQ x y+      MO_F_Ne W32 -> condFltCode NE  x y+      MO_F_Gt W32 -> condFltCode GTT x y+      MO_F_Ge W32 -> condFltCode GE  x y+      -- Invert comparison condition and swap operands+      -- See Note [SSE Parity Checks]+      MO_F_Lt W32 -> condFltCode GTT  y x+      MO_F_Le W32 -> condFltCode GE   y x++      MO_F_Eq W64 -> condFltCode EQQ x y+      MO_F_Ne W64 -> condFltCode NE  x y+      MO_F_Gt W64 -> condFltCode GTT x y+      MO_F_Ge W64 -> condFltCode GE  x y+      MO_F_Lt W64 -> condFltCode GTT y x+      MO_F_Le W64 -> condFltCode GE  y x++      _ -> condIntCode (machOpToCond mop) x y++getCondCode other = do+   platform <- getPlatform+   pprPanic "getCondCode(2)(x86,x86_64)" (pdoc platform other)++machOpToCond :: MachOp -> Cond+machOpToCond mo = case mo of+  MO_Eq _   -> EQQ+  MO_Ne _   -> NE+  MO_S_Gt _ -> GTT+  MO_S_Ge _ -> GE+  MO_S_Lt _ -> LTT+  MO_S_Le _ -> LE+  MO_U_Gt _ -> GU+  MO_U_Ge _ -> GEU+  MO_U_Lt _ -> LU+  MO_U_Le _ -> LEU+  _other -> pprPanic "machOpToCond" (pprMachOp mo)+++-- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be+-- passed back up the tree.++condIntCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode+condIntCode cond x y = do platform <- getPlatform+                          condIntCode' platform cond x y++condIntCode' :: Platform -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode++-- memory vs immediate+condIntCode' platform cond (CmmLoad x pk _) (CmmLit lit)+ | is32BitLit platform lit = do+    Amode x_addr x_code <- getAmode x+    let+        imm  = litToImm lit+        code = x_code `snocOL`+                  CMP (cmmTypeFormat pk) (OpImm imm) (OpAddr x_addr)+    --+    return (CondCode False cond code)++-- anything vs zero, using a mask+-- TODO: Add some sanity checking!!!!+condIntCode' platform cond (CmmMachOp (MO_And _) [x,o2]) (CmmLit (CmmInt 0 pk))+    | (CmmLit lit@(CmmInt mask _)) <- o2, is32BitLit platform lit+    = do+      (x_reg, x_code) <- getSomeReg x+      let+         code = x_code `snocOL`+                TEST (intFormat pk) (OpImm (ImmInteger mask)) (OpReg x_reg)+      --+      return (CondCode False cond code)++-- anything vs zero+condIntCode' _ cond x (CmmLit (CmmInt 0 pk)) = do+    (x_reg, x_code) <- getSomeReg x+    let+        code = x_code `snocOL`+                  TEST (intFormat pk) (OpReg x_reg) (OpReg x_reg)+    --+    return (CondCode False cond code)++-- anything vs operand+condIntCode' platform cond x y+ | isOperand platform y = do+    (x_reg, x_code) <- getNonClobberedReg x+    (y_op,  y_code) <- getOperand y+    let+        code = x_code `appOL` y_code `snocOL`+                  CMP (cmmTypeFormat (cmmExprType platform x)) y_op (OpReg x_reg)+    return (CondCode False cond code)+-- operand vs. anything: invert the comparison so that we can use a+-- single comparison instruction.+ | isOperand platform x+ , Just revcond <- maybeFlipCond cond = do+    (y_reg, y_code) <- getNonClobberedReg y+    (x_op,  x_code) <- getOperand x+    let+        code = y_code `appOL` x_code `snocOL`+                  CMP (cmmTypeFormat (cmmExprType platform x)) x_op (OpReg y_reg)+    return (CondCode False revcond code)++-- anything vs anything+condIntCode' platform cond x y = do+  (y_reg, y_code) <- getNonClobberedReg y+  (x_op, x_code) <- getRegOrMem x+  let+        code = y_code `appOL`+               x_code `snocOL`+                  CMP (cmmTypeFormat (cmmExprType platform x)) (OpReg y_reg) x_op+  return (CondCode False cond code)++++--------------------------------------------------------------------------------+condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode++condFltCode cond x y+  =  condFltCode_sse2+  where+++  -- in the SSE2 comparison ops (ucomiss, ucomisd) the left arg may be+  -- an operand, but the right must be a reg.  We can probably do better+  -- than this general case...+  condFltCode_sse2 = do+    platform <- getPlatform+    (x_reg, x_code) <- getNonClobberedReg x+    (y_op, y_code) <- getOperand y+    let+        code = x_code `appOL`+               y_code `snocOL`+                  CMP (floatFormat $ cmmExprWidth platform x) y_op (OpReg x_reg)+        -- NB(1): we need to use the unsigned comparison operators on the+        -- result of this comparison.+    return (CondCode True (condToUnsigned cond) code)++-- -----------------------------------------------------------------------------+-- Generating assignments++-- Assignments are really at the heart of the whole code generation+-- business.  Almost all top-level nodes of any real importance are+-- assignments, which correspond to loads, stores, or register+-- transfers.  If we're really lucky, some of the register transfers+-- will go away, because we can use the destination register to+-- complete the code generation for the right hand side.  This only+-- fails when the right hand side is forced into a fixed register+-- (e.g. the result of a call).++assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock+assignReg_IntCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock++assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock+assignReg_FltCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock+++-- integer assignment to memory++-- specific case of adding/subtracting an integer to a particular address.+-- ToDo: catch other cases where we can use an operation directly on a memory+-- address.+assignMem_IntCode pk addr (CmmMachOp op [CmmLoad addr2 _ _,+                                                 CmmLit (CmmInt i _)])+   | addr == addr2, pk /= II64 || is32BitInteger i,+     Just instr <- check op+   = do Amode amode code_addr <- getAmode addr+        let code = code_addr `snocOL`+                   instr pk (OpImm (ImmInt (fromIntegral i))) (OpAddr amode)+        return code+   where+        check (MO_Add _) = Just ADD+        check (MO_Sub _) = Just SUB+        check _ = Nothing+        -- ToDo: more?++-- general case+assignMem_IntCode pk addr src = do+    platform <- getPlatform+    Amode addr code_addr <- getAmode addr+    (code_src, op_src)   <- get_op_RI platform src+    let+        code = code_src `appOL`+               code_addr `snocOL`+                  MOV pk op_src (OpAddr addr)+        -- NOTE: op_src is stable, so it will still be valid+        -- after code_addr.  This may involve the introduction+        -- of an extra MOV to a temporary register, but we hope+        -- the register allocator will get rid of it.+    --+    return code+  where+    get_op_RI :: Platform -> CmmExpr -> NatM (InstrBlock,Operand)   -- code, operator+    get_op_RI platform (CmmLit lit) | is32BitLit platform lit+      = return (nilOL, OpImm (litToImm lit))+    get_op_RI _ op+      = do (reg,code) <- getNonClobberedReg op+           return (code, OpReg reg)+++-- Assign; dst is a reg, rhs is mem+assignReg_IntCode pk reg (CmmLoad src _ _) = do+  load_code <- intLoadCode (MOV pk) src+  platform <- ncgPlatform <$> getConfig+  return (load_code (getRegisterReg platform reg))++-- dst is a reg, but src could be anything+assignReg_IntCode _ reg src = do+  platform <- ncgPlatform <$> getConfig+  code <- getAnyReg src+  return (code (getRegisterReg platform reg))+++-- Floating point assignment to memory+assignMem_FltCode pk addr src = do+  (src_reg, src_code) <- getNonClobberedReg src+  Amode addr addr_code <- getAmode addr+  let+        code = src_code `appOL`+               addr_code `snocOL`+               MOV pk (OpReg src_reg) (OpAddr addr)++  return code++-- Floating point assignment to a register/temporary+assignReg_FltCode _ reg src = do+  src_code <- getAnyReg src+  platform <- ncgPlatform <$> getConfig+  return (src_code (getRegisterReg platform reg))+++genJump :: CmmExpr{-the branch target-} -> [Reg] -> NatM InstrBlock++genJump (CmmLoad mem _ _) regs = do+  Amode target code <- getAmode mem+  return (code `snocOL` JMP (OpAddr target) regs)++genJump (CmmLit lit) regs =+  return (unitOL (JMP (OpImm (litToImm lit)) regs))++genJump expr regs = do+  (reg,code) <- getSomeReg expr+  return (code `snocOL` JMP (OpReg reg) regs)+++-- -----------------------------------------------------------------------------+--  Unconditional branches++genBranch :: BlockId -> InstrBlock+genBranch = toOL . mkJumpInstr++++-- -----------------------------------------------------------------------------+--  Conditional jumps/branches++{-+Conditional jumps are always to local labels, so we can use branch+instructions.  We peek at the arguments to decide what kind of+comparison to do.++I386: First, we have to ensure that the condition+codes are set according to the supplied comparison operation.+-}++{-  Note [64-bit integer comparisons on 32-bit]+    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++    When doing these comparisons there are 2 kinds of+    comparisons.++    * Comparison for equality (or lack thereof)++    We use xor to check if high/low bits are+    equal. Then combine the results using or and+    perform a single conditional jump based on the+    result.++    * Other comparisons:++    We map all other comparisons to the >= operation.+    Why? Because it's easy to encode it with a single+    conditional jump.++    We do this by first computing [r1_lo - r2_lo]+    and use the carry flag to compute+    [r1_high - r2_high - CF].++    At which point if r1 >= r2 then the result will be+    positive. Otherwise negative so we can branch on this+    condition.++-}+++genCondBranch+    :: BlockId      -- the source of the jump+    -> BlockId      -- the true branch target+    -> BlockId      -- the false branch target+    -> CmmExpr      -- the condition on which to branch+    -> NatM InstrBlock -- Instructions++genCondBranch bid id false expr = do+  is32Bit <- is32BitPlatform+  genCondBranch' is32Bit bid id false expr++-- | We return the instructions generated.+genCondBranch' :: Bool -> BlockId -> BlockId -> BlockId -> CmmExpr+               -> NatM InstrBlock++-- 64-bit integer comparisons on 32-bit+-- See Note [64-bit integer comparisons on 32-bit]+genCondBranch' is32Bit _bid true false (CmmMachOp mop [e1,e2])+  | is32Bit, Just W64 <- maybeIntComparison mop = do++  RegCode64 code1 r1hi r1lo <- iselExpr64 e1+  RegCode64 code2 r2hi r2lo <- iselExpr64 e2+  let cond = machOpToCond mop :: Cond++  -- we mustn't clobber r1/r2 so we use temporaries+  tmp1 <- getNewRegNat II32+  tmp2 <- getNewRegNat II32++  let cmpCode = intComparison cond true false r1hi r1lo r2hi r2lo tmp1 tmp2+  return $ code1 `appOL` code2 `appOL` cmpCode++  where+    intComparison cond true false r1_hi r1_lo r2_hi r2_lo tmp1 tmp2 =+      case cond of+        -- Impossible results of machOpToCond+        ALWAYS  -> panic "impossible"+        NEG     -> panic "impossible"+        POS     -> panic "impossible"+        CARRY   -> panic "impossible"+        OFLO    -> panic "impossible"+        PARITY  -> panic "impossible"+        NOTPARITY -> panic "impossible"+        -- Special case #1 x == y and x != y+        EQQ -> cmpExact+        NE  -> cmpExact+        -- [x >= y]+        GE  -> cmpGE+        GEU -> cmpGE+        -- [x >  y] <==> ![y >= x]+        GTT -> intComparison GE  false true r2_hi r2_lo r1_hi r1_lo tmp1 tmp2+        GU  -> intComparison GEU false true r2_hi r2_lo r1_hi r1_lo tmp1 tmp2+        -- [x <= y] <==> [y >= x]+        LE  -> intComparison GE  true false r2_hi r2_lo r1_hi r1_lo tmp1 tmp2+        LEU -> intComparison GEU true false r2_hi r2_lo r1_hi r1_lo tmp1 tmp2+        -- [x <  y] <==> ![x >= x]+        LTT -> intComparison GE  false true r1_hi r1_lo r2_hi r2_lo tmp1 tmp2+        LU  -> intComparison GEU false true r1_hi r1_lo r2_hi r2_lo tmp1 tmp2+      where+        cmpExact :: OrdList Instr+        cmpExact =+          toOL+            [ MOV II32 (OpReg r1_hi) (OpReg tmp1)+            , MOV II32 (OpReg r1_lo) (OpReg tmp2)+            , XOR II32 (OpReg r2_hi) (OpReg tmp1)+            , XOR II32 (OpReg r2_lo) (OpReg tmp2)+            , OR  II32 (OpReg tmp1)  (OpReg tmp2)+            , JXX cond true+            , JXX ALWAYS false+            ]+        cmpGE = toOL+            [ MOV II32 (OpReg r1_hi) (OpReg tmp1)+            , CMP II32 (OpReg r2_lo) (OpReg r1_lo)+            , SBB II32 (OpReg r2_hi) (OpReg tmp1)+            , JXX cond true+            , JXX ALWAYS false ]++genCondBranch' _ bid id false bool = do+  CondCode is_float cond cond_code <- getCondCode bool+  use_sse2 <- sse2Enabled+  if not is_float || not use_sse2+    then+        return (cond_code `snocOL` JXX cond id `appOL` genBranch false)+    else do+        -- See Note [SSE Parity Checks]+        let jmpFalse = genBranch false+            code+                = case cond of+                  NE  -> or_unordered+                  GU  -> plain_test+                  GEU -> plain_test+                  -- Use ASSERT so we don't break releases if+                  -- LTT/LE creep in somehow.+                  LTT ->+                    assertPpr False (ppr "Should have been turned into >")+                    and_ordered+                  LE  ->+                    assertPpr False (ppr "Should have been turned into >=")+                    and_ordered+                  _   -> and_ordered++            plain_test = unitOL (+                  JXX cond id+                ) `appOL` jmpFalse+            or_unordered = toOL [+                  JXX cond id,+                  JXX PARITY id+                ] `appOL` jmpFalse+            and_ordered = toOL [+                  JXX PARITY false,+                  JXX cond id,+                  JXX ALWAYS false+                ]+        updateCfgNat (\cfg -> adjustEdgeWeight cfg (+3) bid false)+        return (cond_code `appOL` code)++{-  Note [Introducing cfg edges inside basic blocks]+    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++    During instruction selection a statement `s`+    in a block B with control of the sort: B -> C+    will sometimes result in control+    flow of the sort:++            ┌ < ┐+            v   ^+      B ->  B1  ┴ -> C++    as is the case for some atomic operations.++    Now to keep the CFG in sync when introducing B1 we clearly+    want to insert it between B and C. However there is+    a catch when we have to deal with self loops.++    We might start with code and a CFG of these forms:++    loop:+        stmt1               ┌ < ┐+        ....                v   ^+        stmtX              loop ┘+        stmtY+        ....+        goto loop:++    Now we introduce B1:+                            ┌ ─ ─ ─ ─ ─┐+        loop:               │   ┌ <  ┐ │+        instrs              v   │    │ ^+        ....               loop ┴ B1 ┴ ┘+        instrsFromX+        stmtY+        goto loop:++    This is simple, all outgoing edges from loop now simply+    start from B1 instead and the code generator knows which+    new edges it introduced for the self loop of B1.++    Disaster strikes if the statement Y follows the same pattern.+    If we apply the same rule that all outgoing edges change then+    we end up with:++        loop ─> B1 ─> B2 ┬─┐+          │      │    └─<┤ │+          │      └───<───┘ │+          └───────<────────┘++    This is problematic. The edge B1->B1 is modified as expected.+    However the modification is wrong!++    The assembly in this case looked like this:++    _loop:+        <instrs>+    _B1:+        ...+        cmpxchgq ...+        jne _B1+        <instrs>+        <end _B1>+    _B2:+        ...+        cmpxchgq ...+        jne _B2+        <instrs>+        jmp loop++    There is no edge _B2 -> _B1 here. It's still a self loop onto _B1.++    The problem here is that really B1 should be two basic blocks.+    Otherwise we have control flow in the *middle* of a basic block.+    A contradiction!++    So to account for this we add yet another basic block marker:++    _B:+        <instrs>+    _B1:+        ...+        cmpxchgq ...+        jne _B1+        jmp _B1'+    _B1':+        <instrs>+        <end _B1>+    _B2:+        ...++    Now when inserting B2 we will only look at the outgoing edges of B1' and+    everything will work out nicely.++    You might also wonder why we don't insert jumps at the end of _B1'. There is+    no way another block ends up jumping to the labels _B1 or _B2 since they are+    essentially invisible to other blocks. View them as control flow labels local+    to the basic block if you'd like.++    Not doing this ultimately caused (part 2 of) #17334.+-}+++-- -----------------------------------------------------------------------------+--  Generating C calls++-- Now the biggest nightmare---calls.  Most of the nastiness is buried in+-- @get_arg@, which moves the arguments to the correct registers/stack+-- locations.  Apart from that, the code is easy.+--+-- (If applicable) Do not fill the delay slots here; you will confuse the+-- register allocator.+--+-- See Note [Keeping track of the current block] for information why we need+-- to take/return a block id.++genForeignCall+    :: ForeignTarget -- ^ function to call+    -> [CmmFormal]   -- ^ where to put the result+    -> [CmmActual]   -- ^ arguments (of mixed type)+    -> BlockId       -- ^ The block we are in+    -> NatM (InstrBlock, Maybe BlockId)++genForeignCall target dst args bid = do+  case target of+    PrimTarget prim         -> genPrim bid prim dst args+    ForeignTarget addr conv -> (,Nothing) <$> genCCall bid addr conv dst args++genPrim+    :: BlockId       -- ^ The block we are in+    -> CallishMachOp -- ^ MachOp+    -> [CmmFormal]   -- ^ where to put the result+    -> [CmmActual]   -- ^ arguments (of mixed type)+    -> NatM (InstrBlock, Maybe BlockId)++-- First we deal with cases which might introduce new blocks in the stream.+genPrim bid (MO_AtomicRMW width amop) [dst] [addr, n]+  = genAtomicRMW bid width amop dst addr n+genPrim bid (MO_Ctz width) [dst] [src]+  = genCtz bid width dst src++-- Then we deal with cases which not introducing new blocks in the stream.+genPrim bid prim dst args+  = (,Nothing) <$> genSimplePrim bid prim dst args++genSimplePrim+    :: BlockId       -- ^ the block we are in+    -> CallishMachOp -- ^ MachOp+    -> [CmmFormal]   -- ^ where to put the result+    -> [CmmActual]   -- ^ arguments (of mixed type)+    -> NatM InstrBlock+genSimplePrim bid (MO_Memcpy align)    []      [dst,src,n]    = genMemCpy  bid align dst src n+genSimplePrim bid (MO_Memmove align)   []      [dst,src,n]    = genMemMove bid align dst src n+genSimplePrim bid (MO_Memcmp align)    [res]   [dst,src,n]    = genMemCmp  bid align res dst src n+genSimplePrim bid (MO_Memset align)    []      [dst,c,n]      = genMemSet  bid align dst c n+genSimplePrim _   MO_ReadBarrier       []      []             = return nilOL -- barriers compile to no code on x86/x86-64;+genSimplePrim _   MO_WriteBarrier      []      []             = return nilOL -- we keep it this long in order to prevent earlier optimisations.+genSimplePrim _   MO_Touch             []      [_]            = return nilOL+genSimplePrim _   (MO_Prefetch_Data n) []      [src]          = genPrefetchData n src+genSimplePrim _   (MO_BSwap width)     [dst]   [src]          = genByteSwap width dst src+genSimplePrim bid (MO_BRev width)      [dst]   [src]          = genBitRev bid width dst src+genSimplePrim bid (MO_PopCnt width)    [dst]   [src]          = genPopCnt bid width dst src+genSimplePrim bid (MO_Pdep width)      [dst]   [src,mask]     = genPdep bid width dst src mask+genSimplePrim bid (MO_Pext width)      [dst]   [src,mask]     = genPext bid width dst src mask+genSimplePrim bid (MO_Clz width)       [dst]   [src]          = genClz bid width dst src+genSimplePrim bid (MO_UF_Conv width)   [dst]   [src]          = genWordToFloat bid width dst src+genSimplePrim _   (MO_AtomicRead w)    [dst]   [addr]         = genAtomicRead w dst addr+genSimplePrim _   (MO_AtomicWrite w)   []      [addr,val]     = genAtomicWrite w addr val+genSimplePrim bid (MO_Cmpxchg width)   [dst]   [addr,old,new] = genCmpXchg bid width dst addr old new+genSimplePrim _   (MO_Xchg width)      [dst]   [addr, value]  = genXchg width dst addr value+genSimplePrim _   (MO_AddWordC w)      [r,c]   [x,y]          = genAddSubRetCarry w ADD_CC (const Nothing) CARRY r c x y+genSimplePrim _   (MO_SubWordC w)      [r,c]   [x,y]          = genAddSubRetCarry w SUB_CC (const Nothing) CARRY r c x y+genSimplePrim _   (MO_AddIntC w)       [r,c]   [x,y]          = genAddSubRetCarry w ADD_CC (Just . ADD_CC) OFLO  r c x y+genSimplePrim _   (MO_SubIntC w)       [r,c]   [x,y]          = genAddSubRetCarry w SUB_CC (const Nothing) OFLO  r c x y+genSimplePrim _   (MO_Add2 w)          [h,l]   [x,y]          = genAddWithCarry w h l x y+genSimplePrim _   (MO_U_Mul2 w)        [h,l]   [x,y]          = genUnsignedLargeMul w h l x y+genSimplePrim _   (MO_S_Mul2 w)        [c,h,l] [x,y]          = genSignedLargeMul w c h l x y+genSimplePrim _   (MO_S_QuotRem w)     [q,r]   [x,y]          = genQuotRem w True  q r Nothing   x  y+genSimplePrim _   (MO_U_QuotRem w)     [q,r]   [x,y]          = genQuotRem w False q r Nothing   x  y+genSimplePrim _   (MO_U_QuotRem2 w)    [q,r]   [hx,lx,y]      = genQuotRem w False q r (Just hx) lx y+genSimplePrim _   MO_F32_Fabs          [dst]   [src]          = genFloatAbs W32 dst src+genSimplePrim _   MO_F64_Fabs          [dst]   [src]          = genFloatAbs W64 dst src+genSimplePrim _   MO_F32_Sqrt          [dst]   [src]          = genFloatSqrt FF32 dst src+genSimplePrim _   MO_F64_Sqrt          [dst]   [src]          = genFloatSqrt FF64 dst src+genSimplePrim bid MO_F32_Sin           [dst]   [src]          = genLibCCall bid (fsLit "sinf") [dst] [src]+genSimplePrim bid MO_F32_Cos           [dst]   [src]          = genLibCCall bid (fsLit "cosf") [dst] [src]+genSimplePrim bid MO_F32_Tan           [dst]   [src]          = genLibCCall bid (fsLit "tanf") [dst] [src]+genSimplePrim bid MO_F32_Exp           [dst]   [src]          = genLibCCall bid (fsLit "expf") [dst] [src]+genSimplePrim bid MO_F32_ExpM1         [dst]   [src]          = genLibCCall bid (fsLit "expm1f") [dst] [src]+genSimplePrim bid MO_F32_Log           [dst]   [src]          = genLibCCall bid (fsLit "logf") [dst] [src]+genSimplePrim bid MO_F32_Log1P         [dst]   [src]          = genLibCCall bid (fsLit "log1pf") [dst] [src]+genSimplePrim bid MO_F32_Asin          [dst]   [src]          = genLibCCall bid (fsLit "asinf") [dst] [src]+genSimplePrim bid MO_F32_Acos          [dst]   [src]          = genLibCCall bid (fsLit "acosf") [dst] [src]+genSimplePrim bid MO_F32_Atan          [dst]   [src]          = genLibCCall bid (fsLit "atanf") [dst] [src]+genSimplePrim bid MO_F32_Sinh          [dst]   [src]          = genLibCCall bid (fsLit "sinhf") [dst] [src]+genSimplePrim bid MO_F32_Cosh          [dst]   [src]          = genLibCCall bid (fsLit "coshf") [dst] [src]+genSimplePrim bid MO_F32_Tanh          [dst]   [src]          = genLibCCall bid (fsLit "tanhf") [dst] [src]+genSimplePrim bid MO_F32_Pwr           [dst]   [x,y]          = genLibCCall bid (fsLit "powf")  [dst] [x,y]+genSimplePrim bid MO_F32_Asinh         [dst]   [src]          = genLibCCall bid (fsLit "asinhf") [dst] [src]+genSimplePrim bid MO_F32_Acosh         [dst]   [src]          = genLibCCall bid (fsLit "acoshf") [dst] [src]+genSimplePrim bid MO_F32_Atanh         [dst]   [src]          = genLibCCall bid (fsLit "atanhf") [dst] [src]+genSimplePrim bid MO_F64_Sin           [dst]   [src]          = genLibCCall bid (fsLit "sin") [dst] [src]+genSimplePrim bid MO_F64_Cos           [dst]   [src]          = genLibCCall bid (fsLit "cos") [dst] [src]+genSimplePrim bid MO_F64_Tan           [dst]   [src]          = genLibCCall bid (fsLit "tan") [dst] [src]+genSimplePrim bid MO_F64_Exp           [dst]   [src]          = genLibCCall bid (fsLit "exp") [dst] [src]+genSimplePrim bid MO_F64_ExpM1         [dst]   [src]          = genLibCCall bid (fsLit "expm1") [dst] [src]+genSimplePrim bid MO_F64_Log           [dst]   [src]          = genLibCCall bid (fsLit "log") [dst] [src]+genSimplePrim bid MO_F64_Log1P         [dst]   [src]          = genLibCCall bid (fsLit "log1p") [dst] [src]+genSimplePrim bid MO_F64_Asin          [dst]   [src]          = genLibCCall bid (fsLit "asin") [dst] [src]+genSimplePrim bid MO_F64_Acos          [dst]   [src]          = genLibCCall bid (fsLit "acos") [dst] [src]+genSimplePrim bid MO_F64_Atan          [dst]   [src]          = genLibCCall bid (fsLit "atan") [dst] [src]+genSimplePrim bid MO_F64_Sinh          [dst]   [src]          = genLibCCall bid (fsLit "sinh") [dst] [src]+genSimplePrim bid MO_F64_Cosh          [dst]   [src]          = genLibCCall bid (fsLit "cosh") [dst] [src]+genSimplePrim bid MO_F64_Tanh          [dst]   [src]          = genLibCCall bid (fsLit "tanh") [dst] [src]+genSimplePrim bid MO_F64_Pwr           [dst]   [x,y]          = genLibCCall bid (fsLit "pow")  [dst] [x,y]+genSimplePrim bid MO_F64_Asinh         [dst]   [src]          = genLibCCall bid (fsLit "asinh") [dst] [src]+genSimplePrim bid MO_F64_Acosh         [dst]   [src]          = genLibCCall bid (fsLit "acosh") [dst] [src]+genSimplePrim bid MO_F64_Atanh         [dst]   [src]          = genLibCCall bid (fsLit "atanh") [dst] [src]+genSimplePrim bid MO_SuspendThread     [tok]   [rs,i]         = genRTSCCall bid (fsLit "suspendThread") [tok] [rs,i]+genSimplePrim bid MO_ResumeThread      [rs]    [tok]          = genRTSCCall bid (fsLit "resumeThread") [rs] [tok]+genSimplePrim _   MO_I64_ToI           [dst]   [src]          = genInt64ToInt dst src+genSimplePrim _   MO_I64_FromI         [dst]   [src]          = genIntToInt64 dst src+genSimplePrim _   MO_W64_ToW           [dst]   [src]          = genWord64ToWord dst src+genSimplePrim _   MO_W64_FromW         [dst]   [src]          = genWordToWord64 dst src+genSimplePrim _   MO_x64_Neg           [dst]   [src]          = genNeg64 dst src+genSimplePrim _   MO_x64_Add           [dst]   [x,y]          = genAdd64 dst x y+genSimplePrim _   MO_x64_Sub           [dst]   [x,y]          = genSub64 dst x y+genSimplePrim bid MO_x64_Mul           [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_mul64") [dst] [x,y]+genSimplePrim bid MO_I64_Quot          [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotInt64") [dst] [x,y]+genSimplePrim bid MO_I64_Rem           [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remInt64") [dst] [x,y]+genSimplePrim bid MO_W64_Quot          [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotWord64") [dst] [x,y]+genSimplePrim bid MO_W64_Rem           [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remWord64") [dst] [x,y]+genSimplePrim _   MO_x64_And           [dst]   [x,y]          = genAnd64 dst x y+genSimplePrim _   MO_x64_Or            [dst]   [x,y]          = genOr64  dst x y+genSimplePrim _   MO_x64_Xor           [dst]   [x,y]          = genXor64 dst x y+genSimplePrim _   MO_x64_Not           [dst]   [src]          = genNot64 dst src+genSimplePrim bid MO_x64_Shl           [dst]   [x,n]          = genPrimCCall bid (fsLit "hs_uncheckedShiftL64") [dst] [x,n]+genSimplePrim bid MO_I64_Shr           [dst]   [x,n]          = genPrimCCall bid (fsLit "hs_uncheckedIShiftRA64") [dst] [x,n]+genSimplePrim bid MO_W64_Shr           [dst]   [x,n]          = genPrimCCall bid (fsLit "hs_uncheckedShiftRL64") [dst] [x,n]+genSimplePrim _   MO_x64_Eq            [dst]   [x,y]          = genEq64 dst x y+genSimplePrim _   MO_x64_Ne            [dst]   [x,y]          = genNe64 dst x y+genSimplePrim _   MO_I64_Ge            [dst]   [x,y]          = genGeInt64 dst x y+genSimplePrim _   MO_I64_Gt            [dst]   [x,y]          = genGtInt64 dst x y+genSimplePrim _   MO_I64_Le            [dst]   [x,y]          = genLeInt64 dst x y+genSimplePrim _   MO_I64_Lt            [dst]   [x,y]          = genLtInt64 dst x y+genSimplePrim _   MO_W64_Ge            [dst]   [x,y]          = genGeWord64 dst x y+genSimplePrim _   MO_W64_Gt            [dst]   [x,y]          = genGtWord64 dst x y+genSimplePrim _   MO_W64_Le            [dst]   [x,y]          = genLeWord64 dst x y+genSimplePrim _   MO_W64_Lt            [dst]   [x,y]          = genLtWord64 dst x y+genSimplePrim _   op                   dst     args           = do+  platform <- ncgPlatform <$> getConfig+  pprPanic "genSimplePrim: unhandled primop" (ppr (pprCallishMachOp op, dst, fmap (pdoc platform) args))++{-+Note [Evaluate C-call arguments before placing in destination registers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++When producing code for C calls we must take care when placing arguments+in their final registers. Specifically, we must ensure that temporary register+usage due to evaluation of one argument does not clobber a register in which we+already placed a previous argument (e.g. as the code generation logic for+MO_Shl can clobber %rcx due to x86 instruction limitations).++This is precisely what happened in #18527. Consider this C--:++    (result::I64) = call "ccall" doSomething(_s2hp::I64, 2244, _s2hq::I64, _s2hw::I64 | (1 << _s2hz::I64));++Here we are calling the C function `doSomething` with three arguments, the last+involving a non-trivial expression involving MO_Shl. In this case the NCG could+naively generate the following assembly (where $tmp denotes some temporary+register and $argN denotes the register for argument N, as dictated by the+platform's calling convention):++    mov _s2hp, $arg1   # place first argument+    mov _s2hq, $arg2   # place second argument++    # Compute 1 << _s2hz+    mov _s2hz, %rcx+    shl %cl, $tmp++    # Compute (_s2hw | (1 << _s2hz))+    mov _s2hw, $arg3+    or $tmp, $arg3++    # Perform the call+    call func++This code is outright broken on Windows which assigns $arg1 to %rcx. This means+that the evaluation of the last argument clobbers the first argument.++To avoid this we use a rather awful hack: when producing code for a C call with+at least one non-trivial argument, we first evaluate all of the arguments into+local registers before moving them into their final calling-convention-defined+homes.  This is performed by 'evalArgs'. Here we define "non-trivial" to be an+expression which might contain a MachOp since these are the only cases which+might clobber registers. Furthermore, we use a conservative approximation of+this condition (only looking at the top-level of CmmExprs) to avoid spending+too much effort trying to decide whether we want to take the fast path.++Note that this hack *also* applies to calls to out-of-line PrimTargets (which+are lowered via a C call), which will ultimately end up in+genForeignCall{32,64}.+-}++-- | See Note [Evaluate C-call arguments before placing in destination registers]+evalArgs :: BlockId -> [CmmActual] -> NatM (InstrBlock, [CmmActual])+evalArgs bid actuals+  | any mightContainMachOp actuals = do+      regs_blks <- mapM evalArg actuals+      return (concatOL $ map fst regs_blks, map snd regs_blks)+  | otherwise = return (nilOL, actuals)+  where+    mightContainMachOp (CmmReg _)      = False+    mightContainMachOp (CmmRegOff _ _) = False+    mightContainMachOp (CmmLit _)      = False+    mightContainMachOp _               = True++    evalArg :: CmmActual -> NatM (InstrBlock, CmmExpr)+    evalArg actual = do+        platform <- getPlatform+        lreg <- newLocalReg $ cmmExprType platform actual+        (instrs, bid1) <- stmtToInstrs bid $ CmmAssign (CmmLocal lreg) actual+        -- The above assignment shouldn't change the current block+        massert (isNothing bid1)+        return (instrs, CmmReg $ CmmLocal lreg)++    newLocalReg :: CmmType -> NatM LocalReg+    newLocalReg ty = LocalReg <$> getUniqueM <*> pure ty++-- Note [DIV/IDIV for bytes]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~+-- IDIV reminder:+--   Size    Dividend   Divisor   Quotient    Remainder+--   byte    %ax         r/m8      %al          %ah+--   word    %dx:%ax     r/m16     %ax          %dx+--   dword   %edx:%eax   r/m32     %eax         %edx+--   qword   %rdx:%rax   r/m64     %rax         %rdx+--+-- We do a special case for the byte division because the current+-- codegen doesn't deal well with accessing %ah register (also,+-- accessing %ah in 64-bit mode is complicated because it cannot be an+-- operand of many instructions). So we just widen operands to 16 bits+-- and get the results from %al, %dl. This is not optimal, but a few+-- register moves are probably not a huge deal when doing division.+++-- | Generate C call to the given function in ghc-prim+genPrimCCall+  :: BlockId+  -> FastString+  -> [CmmFormal]+  -> [CmmActual]+  -> NatM InstrBlock+genPrimCCall bid lbl_txt dsts args = do+  config <- getConfig+  -- FIXME: we should use mkForeignLabel instead of mkCmmCodeLabel+  let lbl = mkCmmCodeLabel primUnitId lbl_txt+  addr <- cmmMakeDynamicReference config CallReference lbl+  let conv = ForeignConvention CCallConv [] [] CmmMayReturn+  genCCall bid addr conv dsts args++-- | Generate C call to the given function in libc+genLibCCall+  :: BlockId+  -> FastString+  -> [CmmFormal]+  -> [CmmActual]+  -> NatM InstrBlock+genLibCCall bid lbl_txt dsts args = do+  config <- getConfig+  -- Assume we can call these functions directly, and that they're not in a dynamic library.+  -- TODO: Why is this ok? Under linux this code will be in libm.so+  --       Is it because they're really implemented as a primitive instruction by the assembler??  -- BL 2009/12/31+  let lbl = mkForeignLabel lbl_txt Nothing ForeignLabelInThisPackage IsFunction+  addr <- cmmMakeDynamicReference config CallReference lbl+  let conv = ForeignConvention CCallConv [] [] CmmMayReturn+  genCCall bid addr conv dsts args++-- | Generate C call to the given function in the RTS+genRTSCCall+  :: BlockId+  -> FastString+  -> [CmmFormal]+  -> [CmmActual]+  -> NatM InstrBlock+genRTSCCall bid lbl_txt dsts args = do+  config <- getConfig+  -- Assume we can call these functions directly, and that they're not in a dynamic library.+  let lbl = mkForeignLabel lbl_txt Nothing ForeignLabelInThisPackage IsFunction+  addr <- cmmMakeDynamicReference config CallReference lbl+  let conv = ForeignConvention CCallConv [] [] CmmMayReturn+  genCCall bid addr conv dsts args++-- | Generate a real C call to the given address with the given convention+genCCall+  :: BlockId+  -> CmmExpr+  -> ForeignConvention+  -> [CmmFormal]+  -> [CmmActual]+  -> NatM InstrBlock+genCCall bid addr conv dest_regs args = do+  is32Bit <- is32BitPlatform+  (instrs0, args') <- evalArgs bid args+  instrs1 <- if is32Bit+    then genCCall32 addr conv dest_regs args'+    else genCCall64 addr conv dest_regs args'+  return (instrs0 `appOL` instrs1)++genCCall32 :: CmmExpr           -- ^ address of the function to call+           -> ForeignConvention -- ^ calling convention+           -> [CmmFormal]       -- ^ where to put the result+           -> [CmmActual]       -- ^ arguments (of mixed type)+           -> NatM InstrBlock+genCCall32 addr conv dest_regs args = do+        config <- getConfig+        let platform = ncgPlatform config+            prom_args = map (maybePromoteCArg platform W32) args++            -- If the size is smaller than the word, we widen things (see maybePromoteCArg)+            arg_size_bytes :: CmmType -> Int+            arg_size_bytes ty = max (widthInBytes (typeWidth ty)) (widthInBytes (wordWidth platform))++            roundTo a x | x `mod` a == 0 = x+                        | otherwise = x + a - (x `mod` a)++            push_arg :: CmmActual {-current argument-}+                            -> NatM InstrBlock  -- code++            push_arg  arg -- we don't need the hints on x86+              | isWord64 arg_ty = do+                RegCode64 code r_hi r_lo <- iselExpr64 arg+                delta <- getDeltaNat+                setDeltaNat (delta - 8)+                return (       code `appOL`+                               toOL [PUSH II32 (OpReg r_hi), DELTA (delta - 4),+                                     PUSH II32 (OpReg r_lo), DELTA (delta - 8),+                                     DELTA (delta-8)]+                    )++              | isFloatType arg_ty = do+                (reg, code) <- getSomeReg arg+                delta <- getDeltaNat+                setDeltaNat (delta-size)+                return (code `appOL`+                                toOL [SUB II32 (OpImm (ImmInt size)) (OpReg esp),+                                      DELTA (delta-size),+                                      let addr = AddrBaseIndex (EABaseReg esp)+                                                                EAIndexNone+                                                                (ImmInt 0)+                                          format = floatFormat (typeWidth arg_ty)+                                      in++                                      -- assume SSE2+                                       MOV format (OpReg reg) (OpAddr addr)++                                     ]+                               )++              | otherwise = do+                -- Arguments can be smaller than 32-bit, but we still use @PUSH+                -- II32@ - the usual calling conventions expect integers to be+                -- 4-byte aligned.+                massert ((typeWidth arg_ty) <= W32)+                (operand, code) <- getOperand arg+                delta <- getDeltaNat+                setDeltaNat (delta-size)+                return (code `snocOL`+                        PUSH II32 operand `snocOL`+                        DELTA (delta-size))++              where+                 arg_ty = cmmExprType platform arg+                 size = arg_size_bytes arg_ty -- Byte size++        let+            -- Align stack to 16n for calls, assuming a starting stack+            -- alignment of 16n - word_size on procedure entry. Which we+            -- maintiain. See Note [Stack Alignment on X86] in rts/StgCRun.c.+            sizes               = map (arg_size_bytes . cmmExprType platform) (reverse args)+            raw_arg_size        = sum sizes + platformWordSizeInBytes platform+            arg_pad_size        = (roundTo 16 $ raw_arg_size) - raw_arg_size+            tot_arg_size        = raw_arg_size + arg_pad_size - platformWordSizeInBytes platform+++        delta0 <- getDeltaNat+        setDeltaNat (delta0 - arg_pad_size)++        push_codes <- mapM push_arg (reverse prom_args)+        delta <- getDeltaNat+        massert (delta == delta0 - tot_arg_size)++        -- deal with static vs dynamic call targets+        (callinsns,cconv) <-+          case addr of+            CmmLit (CmmLabel lbl)+               -> -- ToDo: stdcall arg sizes+                  return (unitOL (CALL (Left fn_imm) []), conv)+               where fn_imm = ImmCLbl lbl+            _+               -> do { (dyn_r, dyn_c) <- getSomeReg addr+                     ; massert (isWord32 (cmmExprType platform addr))+                     ; return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) }+        let push_code+                | arg_pad_size /= 0+                = toOL [SUB II32 (OpImm (ImmInt arg_pad_size)) (OpReg esp),+                        DELTA (delta0 - arg_pad_size)]+                  `appOL` concatOL push_codes+                | otherwise+                = concatOL push_codes++              -- Deallocate parameters after call for ccall;+              -- but not for stdcall (callee does it)+              --+              -- We have to pop any stack padding we added+              -- even if we are doing stdcall, though (#5052)+            pop_size+               | ForeignConvention StdCallConv _ _ _ <- cconv = arg_pad_size+               | otherwise = tot_arg_size++            call = callinsns `appOL`+                   toOL (+                      (if pop_size==0 then [] else+                       [ADD II32 (OpImm (ImmInt pop_size)) (OpReg esp)])+                      +++                      [DELTA delta0]+                   )+        setDeltaNat delta0++        let+            -- assign the results, if necessary+            assign_code []     = nilOL+            assign_code [dest]+              | isFloatType ty =+                  -- we assume SSE2+                  let tmp_amode = AddrBaseIndex (EABaseReg esp)+                                                       EAIndexNone+                                                       (ImmInt 0)+                      fmt = floatFormat w+                         in toOL [ SUB II32 (OpImm (ImmInt b)) (OpReg esp),+                                   DELTA (delta0 - b),+                                   X87Store fmt  tmp_amode,+                                   -- X87Store only supported for the CDECL ABI+                                   -- NB: This code will need to be+                                   -- revisited once GHC does more work around+                                   -- SIGFPE f+                                   MOV fmt (OpAddr tmp_amode) (OpReg r_dest),+                                   ADD II32 (OpImm (ImmInt b)) (OpReg esp),+                                   DELTA delta0]+              | isWord64 ty    = toOL [MOV II32 (OpReg eax) (OpReg r_dest),+                                        MOV II32 (OpReg edx) (OpReg r_dest_hi)]+              | otherwise      = unitOL (MOV (intFormat w)+                                             (OpReg eax)+                                             (OpReg r_dest))+              where+                    ty = localRegType dest+                    w  = typeWidth ty+                    b  = widthInBytes w+                    r_dest_hi = getHiVRegFromLo r_dest+                    r_dest    = getLocalRegReg dest+            assign_code many = pprPanic "genForeignCall.assign_code - too many return values:" (ppr many)++        return (push_code `appOL`+                call `appOL`+                assign_code dest_regs)++genCCall64 :: CmmExpr           -- ^ address of function to call+           -> ForeignConvention -- ^ calling convention+           -> [CmmFormal]       -- ^ where to put the result+           -> [CmmActual]       -- ^ arguments (of mixed type)+           -> NatM InstrBlock+genCCall64 addr conv dest_regs args = do+    platform <- getPlatform+    -- load up the register arguments+    let prom_args = map (maybePromoteCArg platform W32) args++    let load_args :: [CmmExpr]+                  -> [Reg]         -- int regs avail for args+                  -> [Reg]         -- FP regs avail for args+                  -> InstrBlock    -- code computing args+                  -> InstrBlock    -- code assigning args to ABI regs+                  -> NatM ([CmmExpr],[Reg],[Reg],InstrBlock,InstrBlock)+        -- no more regs to use+        load_args args [] [] code acode     =+            return (args, [], [], code, acode)++        -- no more args to push+        load_args [] aregs fregs code acode =+            return ([], aregs, fregs, code, acode)++        load_args (arg : rest) aregs fregs code acode+            | isFloatType arg_rep = case fregs of+                 []     -> push_this_arg+                 (r:rs) -> do+                    (code',acode') <- reg_this_arg r+                    load_args rest aregs rs code' acode'+            | otherwise           = case aregs of+                 []     -> push_this_arg+                 (r:rs) -> do+                    (code',acode') <- reg_this_arg r+                    load_args rest rs fregs code' acode'+            where++              -- put arg into the list of stack pushed args+              push_this_arg = do+                 (args',ars,frs,code',acode')+                     <- load_args rest aregs fregs code acode+                 return (arg:args', ars, frs, code', acode')++              -- pass the arg into the given register+              reg_this_arg r+                -- "operand" args can be directly assigned into r+                | isOperand platform arg = do+                    arg_code <- getAnyReg arg+                    return (code, (acode `appOL` arg_code r))+                -- The last non-operand arg can be directly assigned after its+                -- computation without going into a temporary register+                | all (isOperand platform) rest = do+                    arg_code   <- getAnyReg arg+                    return (code `appOL` arg_code r,acode)++                -- other args need to be computed beforehand to avoid clobbering+                -- previously assigned registers used to pass parameters (see+                -- #11792, #12614). They are assigned into temporary registers+                -- and get assigned to proper call ABI registers after they all+                -- have been computed.+                | otherwise     = do+                    arg_code <- getAnyReg arg+                    tmp      <- getNewRegNat arg_fmt+                    let+                      code'  = code `appOL` arg_code tmp+                      acode' = acode `snocOL` reg2reg arg_fmt tmp r+                    return (code',acode')++              arg_rep = cmmExprType platform arg+              arg_fmt = cmmTypeFormat arg_rep++        load_args_win :: [CmmExpr]+                      -> [Reg]        -- used int regs+                      -> [Reg]        -- used FP regs+                      -> [(Reg, Reg)] -- (int, FP) regs avail for args+                      -> InstrBlock+                      -> NatM ([CmmExpr],[Reg],[Reg],InstrBlock,InstrBlock)+        load_args_win args usedInt usedFP [] code+            = return (args, usedInt, usedFP, code, nilOL)+            -- no more regs to use+        load_args_win [] usedInt usedFP _ code+            = return ([], usedInt, usedFP, code, nilOL)+            -- no more args to push+        load_args_win (arg : rest) usedInt usedFP+                      ((ireg, freg) : regs) code+            | isFloatType arg_rep = do+                 arg_code <- getAnyReg arg+                 load_args_win rest (ireg : usedInt) (freg : usedFP) regs+                               (code `appOL`+                                arg_code freg `snocOL`+                                -- If we are calling a varargs function+                                -- then we need to define ireg as well+                                -- as freg+                                MOV II64 (OpReg freg) (OpReg ireg))+            | otherwise = do+                 arg_code <- getAnyReg arg+                 load_args_win rest (ireg : usedInt) usedFP regs+                               (code `appOL` arg_code ireg)+            where+              arg_rep = cmmExprType platform arg++        arg_size = 8 -- always, at the mo++        push_args [] code = return code+        push_args (arg:rest) code+           | isFloatType arg_rep = do+             (arg_reg, arg_code) <- getSomeReg arg+             delta <- getDeltaNat+             setDeltaNat (delta-arg_size)+             let code' = code `appOL` arg_code `appOL` toOL [+                            SUB (intFormat (wordWidth platform)) (OpImm (ImmInt arg_size)) (OpReg rsp),+                            DELTA (delta-arg_size),+                            MOV (floatFormat width) (OpReg arg_reg) (OpAddr (spRel platform 0))]+             push_args rest code'++           | otherwise = do+             -- Arguments can be smaller than 64-bit, but we still use @PUSH+             -- II64@ - the usual calling conventions expect integers to be+             -- 8-byte aligned.+             massert (width <= W64)+             (arg_op, arg_code) <- getOperand arg+             delta <- getDeltaNat+             setDeltaNat (delta-arg_size)+             let code' = code `appOL` arg_code `appOL` toOL [+                                    PUSH II64 arg_op,+                                    DELTA (delta-arg_size)]+             push_args rest code'+            where+              arg_rep = cmmExprType platform arg+              width = typeWidth arg_rep++        leaveStackSpace n = do+             delta <- getDeltaNat+             setDeltaNat (delta - n * arg_size)+             return $ toOL [+                         SUB II64 (OpImm (ImmInt (n * platformWordSizeInBytes platform))) (OpReg rsp),+                         DELTA (delta - n * arg_size)]++    (stack_args, int_regs_used, fp_regs_used, load_args_code, assign_args_code)+         <-+        if platformOS platform == OSMinGW32+        then load_args_win prom_args [] [] (allArgRegs platform) nilOL+        else do+           (stack_args, aregs, fregs, load_args_code, assign_args_code)+               <- load_args prom_args (allIntArgRegs platform)+                                      (allFPArgRegs platform)+                                      nilOL nilOL+           let used_regs rs as = reverse (drop (length rs) (reverse as))+               fregs_used      = used_regs fregs (allFPArgRegs platform)+               aregs_used      = used_regs aregs (allIntArgRegs platform)+           return (stack_args, aregs_used, fregs_used, load_args_code+                                                      , assign_args_code)++    let+        arg_regs_used = int_regs_used ++ fp_regs_used+        arg_regs = [eax] ++ arg_regs_used+                -- for annotating the call instruction with+        sse_regs = length fp_regs_used+        arg_stack_slots = if platformOS platform == OSMinGW32+                          then length stack_args + length (allArgRegs platform)+                          else length stack_args+        tot_arg_size = arg_size * arg_stack_slots+++    -- Align stack to 16n for calls, assuming a starting stack+    -- alignment of 16n - word_size on procedure entry. Which we+    -- maintain. See Note [Stack Alignment on X86] in rts/StgCRun.c+    let word_size = platformWordSizeInBytes platform+    (real_size, adjust_rsp) <-+        if (tot_arg_size + word_size) `rem` 16 == 0+            then return (tot_arg_size, nilOL)+            else do -- we need to adjust...+                delta <- getDeltaNat+                setDeltaNat (delta - word_size)+                return (tot_arg_size + word_size, toOL [+                                SUB II64 (OpImm (ImmInt word_size)) (OpReg rsp),+                                DELTA (delta - word_size) ])++    -- push the stack args, right to left+    push_code <- push_args (reverse stack_args) nilOL+    -- On Win64, we also have to leave stack space for the arguments+    -- that we are passing in registers+    lss_code <- if platformOS platform == OSMinGW32+                then leaveStackSpace (length (allArgRegs platform))+                else return nilOL+    delta <- getDeltaNat++    -- deal with static vs dynamic call targets+    (callinsns,_cconv) <- case addr of+      CmmLit (CmmLabel lbl) ->+        -- ToDo: stdcall arg sizes+        return (unitOL (CALL (Left (ImmCLbl lbl)) arg_regs), conv)+      _ -> do+        (dyn_r, dyn_c) <- getSomeReg addr+        return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv)++    let+        -- The x86_64 ABI requires us to set %al to the number of SSE2+        -- registers that contain arguments, if the called routine+        -- is a varargs function.  We don't know whether it's a+        -- varargs function or not, so we have to assume it is.+        --+        -- It's not safe to omit this assignment, even if the number+        -- of SSE2 regs in use is zero.  If %al is larger than 8+        -- on entry to a varargs function, seg faults ensue.+        assign_eax n = unitOL (MOV II32 (OpImm (ImmInt n)) (OpReg eax))++    let call = callinsns `appOL`+               toOL (+                    -- Deallocate parameters after call for ccall;+                    -- stdcall has callee do it, but is not supported on+                    -- x86_64 target (see #3336)+                  (if real_size==0 then [] else+                   [ADD (intFormat (platformWordWidth platform)) (OpImm (ImmInt real_size)) (OpReg esp)])+                  +++                  [DELTA (delta + real_size)]+               )+    setDeltaNat (delta + real_size)++    let+        -- assign the results, if necessary+        assign_code []     = nilOL+        assign_code [dest] =+          case typeWidth rep of+                W32 | isFloatType rep -> unitOL (MOV (floatFormat W32)+                                                     (OpReg xmm0)+                                                     (OpReg r_dest))+                W64 | isFloatType rep -> unitOL (MOV (floatFormat W64)+                                                     (OpReg xmm0)+                                                     (OpReg r_dest))+                _ -> unitOL (MOV (cmmTypeFormat rep) (OpReg rax) (OpReg r_dest))+          where+                rep = localRegType dest+                r_dest = getRegisterReg platform  (CmmLocal dest)+        assign_code _many = panic "genForeignCall.assign_code many"++    return (adjust_rsp          `appOL`+            push_code           `appOL`+            load_args_code      `appOL`+            assign_args_code    `appOL`+            lss_code            `appOL`+            assign_eax sse_regs `appOL`+            call                `appOL`+            assign_code dest_regs)+++maybePromoteCArg :: Platform -> Width -> CmmExpr -> CmmExpr+maybePromoteCArg platform wto arg+ | wfrom < wto = CmmMachOp (MO_UU_Conv wfrom wto) [arg]+ | otherwise   = arg+ where+   wfrom = cmmExprWidth platform arg++-- -----------------------------------------------------------------------------+-- Generating a table-branch++{-+Note [Sub-word subtlety during jump-table indexing]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Offset the index by the start index of the jump table.+It's important that we do this *before* the widening below. To see+why, consider a switch with a sub-word, signed discriminant such as:++    switch [-5...+2] x::I16 {+        case -5: ...+        ...+        case +2: ...+    }++Consider what happens if we offset *after* widening in the case that+x=-4:++                                         // x == -4 == 0xfffc::I16+    indexWidened = UU_Conv(x);           // == 0xfffc::I64+    indexExpr    = indexWidened - (-5);  // == 0x10000::I64++This index is clearly nonsense given that the jump table only has+eight entries.++By contrast, if we widen *after* we offset then we get the correct+index (1),++                                         // x == -4 == 0xfffc::I16+    indexOffset  = x - (-5);             // == 1::I16+    indexExpr    = UU_Conv(indexOffset); // == 1::I64++See #21186.+-}++genSwitch :: CmmExpr -> SwitchTargets -> NatM InstrBlock++genSwitch expr targets = do+  config <- getConfig+  let platform = ncgPlatform config+      expr_w = cmmExprWidth platform expr+      indexExpr0 = cmmOffset platform expr offset+      -- We widen to a native-width register because we cannot use arbitrary sizes+      -- in x86 addressing modes.+      -- See Note [Sub-word subtlety during jump-table indexing].+      indexExpr = CmmMachOp+        (MO_UU_Conv expr_w (platformWordWidth platform))+        [indexExpr0]+  if ncgPIC config+  then do+        (reg,e_code) <- getNonClobberedReg indexExpr+           -- getNonClobberedReg because it needs to survive across t_code+        lbl <- getNewLabelNat+        let is32bit = target32Bit platform+            os = platformOS platform+            -- Might want to use .rodata.<function we're in> instead, but as+            -- long as it's something unique it'll work out since the+            -- references to the jump table are in the appropriate section.+            rosection = case os of+              -- on Mac OS X/x86_64, put the jump table in the text section to+              -- work around a limitation of the linker.+              -- ld64 is unable to handle the relocations for+              --     .quad L1 - L0+              -- if L0 is not preceded by a non-anonymous label in its section.+              OSDarwin | not is32bit -> Section Text lbl+              _ -> Section ReadOnlyData lbl+        dynRef <- cmmMakeDynamicReference config DataReference lbl+        (tableReg,t_code) <- getSomeReg $ dynRef+        let op = OpAddr (AddrBaseIndex (EABaseReg tableReg)+                                       (EAIndex reg (platformWordSizeInBytes platform)) (ImmInt 0))++        offsetReg <- getNewRegNat (intFormat (platformWordWidth platform))+        return $ if is32bit || os == OSDarwin+                 then e_code `appOL` t_code `appOL` toOL [+                                ADD (intFormat (platformWordWidth platform)) op (OpReg tableReg),+                                JMP_TBL (OpReg tableReg) ids rosection lbl+                       ]+                 else -- HACK: On x86_64 binutils<2.17 is only able to generate+                      -- PC32 relocations, hence we only get 32-bit offsets in+                      -- the jump table. As these offsets are always negative+                      -- we need to properly sign extend them to 64-bit. This+                      -- hack should be removed in conjunction with the hack in+                      -- PprMach.hs/pprDataItem once binutils 2.17 is standard.+                      e_code `appOL` t_code `appOL` toOL [+                               MOVSxL II32 op (OpReg offsetReg),+                               ADD (intFormat (platformWordWidth platform))+                                   (OpReg offsetReg)+                                   (OpReg tableReg),+                               JMP_TBL (OpReg tableReg) ids rosection lbl+                       ]+  else do+        (reg,e_code) <- getSomeReg indexExpr+        lbl <- getNewLabelNat+        let is32bit = target32Bit platform+        if is32bit+          then let op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg (platformWordSizeInBytes platform)) (ImmCLbl lbl))+                   jmp_code = JMP_TBL op ids (Section ReadOnlyData lbl) lbl+               in return $ e_code `appOL` unitOL jmp_code+          else do+            -- See Note [%rip-relative addressing on x86-64].+            tableReg <- getNewRegNat (intFormat (platformWordWidth platform))+            targetReg <- getNewRegNat (intFormat (platformWordWidth platform))+            let op = OpAddr (AddrBaseIndex (EABaseReg tableReg) (EAIndex reg (platformWordSizeInBytes platform)) (ImmInt 0))+                code = e_code `appOL` toOL+                    [ LEA (archWordFormat is32bit) (OpAddr (AddrBaseIndex EABaseRip EAIndexNone (ImmCLbl lbl))) (OpReg tableReg)+                    , MOV (archWordFormat is32bit) op (OpReg targetReg)+                    , JMP_TBL (OpReg targetReg) ids (Section ReadOnlyData lbl) lbl+                    ]+            return code+  where+    (offset, blockIds) = switchTargetsToTable targets+    ids = map (fmap DestBlockId) blockIds++generateJumpTableForInstr :: NCGConfig -> Instr -> Maybe (NatCmmDecl (Alignment, RawCmmStatics) Instr)+generateJumpTableForInstr config (JMP_TBL _ ids section lbl)+    = let getBlockId (DestBlockId id) = id+          getBlockId _ = panic "Non-Label target in Jump Table"+          blockIds = map (fmap getBlockId) ids+      in Just (createJumpTable config blockIds section lbl)+generateJumpTableForInstr _ _ = Nothing++createJumpTable :: NCGConfig -> [Maybe BlockId] -> Section -> CLabel+                -> GenCmmDecl (Alignment, RawCmmStatics) h g+createJumpTable config ids section lbl+    = let jumpTable+            | ncgPIC config =+                  let ww = ncgWordWidth config+                      jumpTableEntryRel Nothing+                          = CmmStaticLit (CmmInt 0 ww)+                      jumpTableEntryRel (Just blockid)+                          = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0 ww)+                          where blockLabel = blockLbl blockid+                  in map jumpTableEntryRel ids+            | otherwise = map (jumpTableEntry config) ids+      in CmmData section (mkAlignment 1, CmmStaticsRaw lbl jumpTable)++extractUnwindPoints :: [Instr] -> [UnwindPoint]+extractUnwindPoints instrs =+    [ UnwindPoint lbl unwinds | UNWIND lbl unwinds <- instrs]++-- -----------------------------------------------------------------------------+-- 'condIntReg' and 'condFltReg': condition codes into registers++-- Turn those condition codes into integers now (when they appear on+-- the right hand side of an assignment).+--+-- (If applicable) Do not fill the delay slots here; you will confuse the+-- register allocator.++condIntReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register++condIntReg cond x y = do+  CondCode _ cond cond_code <- condIntCode cond x y+  tmp <- getNewRegNat II8+  let+        code dst = cond_code `appOL` toOL [+                    SETCC cond (OpReg tmp),+                    MOVZxL II8 (OpReg tmp) (OpReg dst)+                  ]+  return (Any II32 code)+++-- Note [SSE Parity Checks]+-- ~~~~~~~~~~~~~~~~~~~~~~~~+-- We have to worry about unordered operands (eg. comparisons+-- against NaN).  If the operands are unordered, the comparison+-- sets the parity flag, carry flag and zero flag.+-- All comparisons are supposed to return false for unordered+-- operands except for !=, which returns true.+--+-- Optimisation: we don't have to test the parity flag if we+-- know the test has already excluded the unordered case: eg >+-- and >= test for a zero carry flag, which can only occur for+-- ordered operands.+--+-- By reversing comparisons we can avoid testing the parity+-- for < and <= as well. If any of the arguments is an NaN we+-- return false either way. If both arguments are valid then+-- x <= y  <->  y >= x  holds. So it's safe to swap these.+--+-- We invert the condition inside getRegister'and  getCondCode+-- which should cover all invertable cases.+-- All other functions translating FP comparisons to assembly+-- use these to two generate the comparison code.+--+-- As an example consider a simple check:+--+-- func :: Float -> Float -> Int+-- func x y = if x < y then 1 else 0+--+-- Which in Cmm gives the floating point comparison.+--+--  if (%MO_F_Lt_W32(F1, F2)) goto c2gg; else goto c2gf;+--+-- We used to compile this to an assembly code block like this:+-- _c2gh:+--  ucomiss %xmm2,%xmm1+--  jp _c2gf+--  jb _c2gg+--  jmp _c2gf+--+-- Where we have to introduce an explicit+-- check for unordered results (using jmp parity):+--+-- We can avoid this by exchanging the arguments and inverting the direction+-- of the comparison. This results in the sequence of:+--+--  ucomiss %xmm1,%xmm2+--  ja _c2g2+--  jmp _c2g1+--+-- Removing the jump reduces the pressure on the branch predidiction system+-- and plays better with the uOP cache.++condFltReg :: Bool -> Cond -> CmmExpr -> CmmExpr -> NatM Register+condFltReg is32Bit cond x y = condFltReg_sse2+ where+++  condFltReg_sse2 = do+    CondCode _ cond cond_code <- condFltCode cond x y+    tmp1 <- getNewRegNat (archWordFormat is32Bit)+    tmp2 <- getNewRegNat (archWordFormat is32Bit)+    let -- See Note [SSE Parity Checks]+        code dst =+           cond_code `appOL`+             (case cond of+                NE  -> or_unordered dst+                GU  -> plain_test   dst+                GEU -> plain_test   dst+                -- Use ASSERT so we don't break releases if these creep in.+                LTT -> assertPpr False (ppr "Should have been turned into >") $+                       and_ordered  dst+                LE  -> assertPpr False (ppr "Should have been turned into >=") $+                       and_ordered  dst+                _   -> and_ordered  dst)++        plain_test dst = toOL [+                    SETCC cond (OpReg tmp1),+                    MOVZxL II8 (OpReg tmp1) (OpReg dst)+                 ]+        or_unordered dst = toOL [+                    SETCC cond (OpReg tmp1),+                    SETCC PARITY (OpReg tmp2),+                    OR II8 (OpReg tmp1) (OpReg tmp2),+                    MOVZxL II8 (OpReg tmp2) (OpReg dst)+                  ]+        and_ordered dst = toOL [+                    SETCC cond (OpReg tmp1),+                    SETCC NOTPARITY (OpReg tmp2),+                    AND II8 (OpReg tmp1) (OpReg tmp2),+                    MOVZxL II8 (OpReg tmp2) (OpReg dst)+                  ]+    return (Any II32 code)+++-- -----------------------------------------------------------------------------+-- 'trivial*Code': deal with trivial instructions++-- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode',+-- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions.+-- Only look for constants on the right hand side, because that's+-- where the generic optimizer will have put them.++-- Similarly, for unary instructions, we don't have to worry about+-- matching an StInt as the argument, because genericOpt will already+-- have handled the constant-folding.+++{-+The Rules of the Game are:++* You cannot assume anything about the destination register dst;+  it may be anything, including a fixed reg.++* You may compute an operand into a fixed reg, but you may not+  subsequently change the contents of that fixed reg.  If you+  want to do so, first copy the value either to a temporary+  or into dst.  You are free to modify dst even if it happens+  to be a fixed reg -- that's not your problem.++* You cannot assume that a fixed reg will stay live over an+  arbitrary computation.  The same applies to the dst reg.++* Temporary regs obtained from getNewRegNat are distinct from+  each other and from all other regs, and stay live over+  arbitrary computations.++--------------------++SDM's version of The Rules:++* If getRegister returns Any, that means it can generate correct+  code which places the result in any register, period.  Even if that+  register happens to be read during the computation.++  Corollary #1: this means that if you are generating code for an+  operation with two arbitrary operands, you cannot assign the result+  of the first operand into the destination register before computing+  the second operand.  The second operand might require the old value+  of the destination register.++  Corollary #2: A function might be able to generate more efficient+  code if it knows the destination register is a new temporary (and+  therefore not read by any of the sub-computations).++* If getRegister returns Any, then the code it generates may modify only:+        (a) fresh temporaries+        (b) the destination register+        (c) known registers (eg. %ecx is used by shifts)+  In particular, it may *not* modify global registers, unless the global+  register happens to be the destination register.+-}++trivialCode :: Width -> (Operand -> Operand -> Instr)+            -> Maybe (Operand -> Operand -> Instr)+            -> CmmExpr -> CmmExpr -> NatM Register+trivialCode width instr m a b+    = do platform <- getPlatform+         trivialCode' platform width instr m a b++trivialCode' :: Platform -> Width -> (Operand -> Operand -> Instr)+             -> Maybe (Operand -> Operand -> Instr)+             -> CmmExpr -> CmmExpr -> NatM Register+trivialCode' platform width _ (Just revinstr) (CmmLit lit_a) b+  | is32BitLit platform lit_a = do+  b_code <- getAnyReg b+  let+       code dst+         = b_code dst `snocOL`+           revinstr (OpImm (litToImm lit_a)) (OpReg dst)+  return (Any (intFormat width) code)++trivialCode' _ width instr _ a b+  = genTrivialCode (intFormat width) instr a b++-- This is re-used for floating pt instructions too.+genTrivialCode :: Format -> (Operand -> Operand -> Instr)+               -> CmmExpr -> CmmExpr -> NatM Register+genTrivialCode rep instr a b = do+  (b_op, b_code) <- getNonClobberedOperand b+  a_code <- getAnyReg a+  tmp <- getNewRegNat rep+  let+     -- We want the value of b to stay alive across the computation of a.+     -- But, we want to calculate a straight into the destination register,+     -- because the instruction only has two operands (dst := dst `op` src).+     -- The troublesome case is when the result of b is in the same register+     -- as the destination reg.  In this case, we have to save b in a+     -- new temporary across the computation of a.+     code dst+        | dst `regClashesWithOp` b_op =+                b_code `appOL`+                unitOL (MOV rep b_op (OpReg tmp)) `appOL`+                a_code dst `snocOL`+                instr (OpReg tmp) (OpReg dst)+        | otherwise =+                b_code `appOL`+                a_code dst `snocOL`+                instr b_op (OpReg dst)+  return (Any rep code)++regClashesWithOp :: Reg -> Operand -> Bool+reg `regClashesWithOp` OpReg reg2   = reg == reg2+reg `regClashesWithOp` OpAddr amode = any (==reg) (addrModeRegs amode)+_   `regClashesWithOp` _            = False++-----------++trivialUCode :: Format -> (Operand -> Instr)+             -> CmmExpr -> NatM Register+trivialUCode rep instr x = do+  x_code <- getAnyReg x+  let+     code dst =+        x_code dst `snocOL`+        instr (OpReg dst)+  return (Any rep code)++-----------+++trivialFCode_sse2 :: Width -> (Format -> Operand -> Operand -> Instr)+                  -> CmmExpr -> CmmExpr -> NatM Register+trivialFCode_sse2 pk instr x y+    = genTrivialCode format (instr format) x y+    where format = floatFormat pk+++--------------------------------------------------------------------------------+coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register+coerceInt2FP from to x =  coerce_sse2+ where++   coerce_sse2 = do+     (x_op, x_code) <- getOperand x  -- ToDo: could be a safe operand+     let+           opc  = case to of W32 -> CVTSI2SS; W64 -> CVTSI2SD+                             n -> panic $ "coerceInt2FP.sse: unhandled width ("+                                         ++ show n ++ ")"+           code dst = x_code `snocOL` opc (intFormat from) x_op dst+     return (Any (floatFormat to) code)+        -- works even if the destination rep is <II32++--------------------------------------------------------------------------------+coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register+coerceFP2Int from to x =  coerceFP2Int_sse2+ where+   coerceFP2Int_sse2 = do+     (x_op, x_code) <- getOperand x  -- ToDo: could be a safe operand+     let+           opc  = case from of W32 -> CVTTSS2SIQ; W64 -> CVTTSD2SIQ;+                               n -> panic $ "coerceFP2Init.sse: unhandled width ("+                                           ++ show n ++ ")"+           code dst = x_code `snocOL` opc (intFormat to) x_op dst+     return (Any (intFormat to) code)+         -- works even if the destination rep is <II32+++--------------------------------------------------------------------------------+coerceFP2FP :: Width -> CmmExpr -> NatM Register+coerceFP2FP to x = do+  (x_reg, x_code) <- getSomeReg x+  let+        opc  = case to of W32 -> CVTSD2SS; W64 -> CVTSS2SD;+                                     n -> panic $ "coerceFP2FP: unhandled width ("+                                                 ++ show n ++ ")"+        code dst = x_code `snocOL` opc x_reg dst+  return (Any ( floatFormat to) code)++--------------------------------------------------------------------------------++sse2NegCode :: Width -> CmmExpr -> NatM Register+sse2NegCode w x = do+  let fmt = floatFormat w+  x_code <- getAnyReg x+  -- This is how gcc does it, so it can't be that bad:+  let+    const = case fmt of+      FF32 -> CmmInt 0x80000000 W32+      FF64 -> CmmInt 0x8000000000000000 W64+      x@II8  -> wrongFmt x+      x@II16 -> wrongFmt x+      x@II32 -> wrongFmt x+      x@II64 -> wrongFmt x++      where+        wrongFmt x = panic $ "sse2NegCode: " ++ show x+  Amode amode amode_code <- memConstant (mkAlignment $ widthInBytes w) const+  tmp <- getNewRegNat fmt+  let+    code dst = x_code dst `appOL` amode_code `appOL` toOL [+        MOV fmt (OpAddr amode) (OpReg tmp),+        XOR fmt (OpReg tmp) (OpReg dst)+        ]+  --+  return (Any fmt code)++isVecExpr :: CmmExpr -> Bool+isVecExpr (CmmMachOp (MO_V_Insert {}) _)   = True+isVecExpr (CmmMachOp (MO_V_Extract {}) _)  = True+isVecExpr (CmmMachOp (MO_V_Add {}) _)      = True+isVecExpr (CmmMachOp (MO_V_Sub {}) _)      = True+isVecExpr (CmmMachOp (MO_V_Mul {}) _)      = True+isVecExpr (CmmMachOp (MO_VS_Quot {}) _)    = True+isVecExpr (CmmMachOp (MO_VS_Rem {}) _)     = True+isVecExpr (CmmMachOp (MO_VS_Neg {}) _)     = True+isVecExpr (CmmMachOp (MO_VF_Insert {}) _)  = True+isVecExpr (CmmMachOp (MO_VF_Extract {}) _) = True+isVecExpr (CmmMachOp (MO_VF_Add {}) _)     = True+isVecExpr (CmmMachOp (MO_VF_Sub {}) _)     = True+isVecExpr (CmmMachOp (MO_VF_Mul {}) _)     = True+isVecExpr (CmmMachOp (MO_VF_Quot {}) _)    = True+isVecExpr (CmmMachOp (MO_VF_Neg {}) _)     = True+isVecExpr (CmmMachOp _ [e])                = isVecExpr e+isVecExpr _                                = False++needLlvm :: NatM a+needLlvm =+    sorry $ unlines ["The native code generator does not support vector"+                    ,"instructions. Please use -fllvm."]++-- | This works on the invariant that all jumps in the given blocks are required.+--   Starting from there we try to make a few more jumps redundant by reordering+--   them.+--   We depend on the information in the CFG to do so so without a given CFG+--   we do nothing.+invertCondBranches :: Maybe CFG  -- ^ CFG if present+                   -> LabelMap a -- ^ Blocks with info tables+                   -> [NatBasicBlock Instr] -- ^ List of basic blocks+                   -> [NatBasicBlock Instr]+invertCondBranches Nothing _       bs = bs+invertCondBranches (Just cfg) keep bs =+    invert bs+  where+    invert :: [NatBasicBlock Instr] -> [NatBasicBlock Instr]+    invert ((BasicBlock lbl1 ins@(_:_:_xs)):b2@(BasicBlock lbl2 _):bs)+      | --pprTrace "Block" (ppr lbl1) True,+        (jmp1,jmp2) <- last2 ins+      , JXX cond1 target1 <- jmp1+      , target1 == lbl2+      --, pprTrace "CutChance" (ppr b1) True+      , JXX ALWAYS target2 <- jmp2+      -- We have enough information to check if we can perform the inversion+      -- TODO: We could also check for the last asm instruction which sets+      -- status flags instead. Which I suspect is worse in terms of compiler+      -- performance, but might be applicable to more cases+      , Just edgeInfo1 <- getEdgeInfo lbl1 target1 cfg+      , Just edgeInfo2 <- getEdgeInfo lbl1 target2 cfg+      -- Both jumps come from the same cmm statement+      , transitionSource edgeInfo1 == transitionSource edgeInfo2+      , CmmSource {trans_cmmNode = cmmCondBranch} <- transitionSource edgeInfo1++      --Int comparisons are invertable+      , CmmCondBranch (CmmMachOp op _args) _ _ _ <- cmmCondBranch+      , Just _ <- maybeIntComparison op+      , Just invCond <- maybeInvertCond cond1++      --Swap the last two jumps, invert the conditional jumps condition.+      = let jumps =+              case () of+                -- We are free the eliminate the jmp. So we do so.+                _ | not (mapMember target1 keep)+                    -> [JXX invCond target2]+                -- If the conditional target is unlikely we put the other+                -- target at the front.+                  | edgeWeight edgeInfo2 > edgeWeight edgeInfo1+                    -> [JXX invCond target2, JXX ALWAYS target1]+                -- Keep things as-is otherwise+                  | otherwise+                    -> [jmp1, jmp2]+        in --pprTrace "Cutable" (ppr [jmp1,jmp2] <+> text "=>" <+> ppr jumps) $+           (BasicBlock lbl1+            (dropTail 2 ins ++ jumps))+            : invert (b2:bs)+    invert (b:bs) = b : invert bs+    invert [] = []++genAtomicRMW+  :: BlockId+  -> Width+  -> AtomicMachOp+  -> LocalReg+  -> CmmExpr+  -> CmmExpr+  -> NatM (InstrBlock, Maybe BlockId)+genAtomicRMW bid width amop dst addr n = do+    Amode amode addr_code <-+        if amop `elem` [AMO_Add, AMO_Sub]+        then getAmode addr+        else getSimpleAmode addr  -- See genForeignCall for MO_Cmpxchg+    arg <- getNewRegNat format+    arg_code <- getAnyReg n+    platform <- ncgPlatform <$> getConfig++    let dst_r    = getRegisterReg platform  (CmmLocal dst)+    (code, lbl) <- op_code dst_r arg amode+    return (addr_code `appOL` arg_code arg `appOL` code, Just lbl)+  where+    -- Code for the operation+    op_code :: Reg       -- Destination reg+            -> Reg       -- Register containing argument+            -> AddrMode  -- Address of location to mutate+            -> NatM (OrdList Instr,BlockId) -- TODO: Return Maybe BlockId+    op_code dst_r arg amode = case amop of+        -- In the common case where dst_r is a virtual register the+        -- final move should go away, because it's the last use of arg+        -- and the first use of dst_r.+        AMO_Add  -> return $ (toOL [ LOCK (XADD format (OpReg arg) (OpAddr amode))+                                   , MOV format (OpReg arg) (OpReg dst_r)+                                   ], bid)+        AMO_Sub  -> return $ (toOL [ NEGI format (OpReg arg)+                                   , LOCK (XADD format (OpReg arg) (OpAddr amode))+                                   , MOV format (OpReg arg) (OpReg dst_r)+                                   ], bid)+        -- In these cases we need a new block id, and have to return it so+        -- that later instruction selection can reference it.+        AMO_And  -> cmpxchg_code (\ src dst -> unitOL $ AND format src dst)+        AMO_Nand -> cmpxchg_code (\ src dst -> toOL [ AND format src dst+                                                    , NOT format dst+                                                    ])+        AMO_Or   -> cmpxchg_code (\ src dst -> unitOL $ OR format src dst)+        AMO_Xor  -> cmpxchg_code (\ src dst -> unitOL $ XOR format src dst)+      where+        -- Simulate operation that lacks a dedicated instruction using+        -- cmpxchg.+        cmpxchg_code :: (Operand -> Operand -> OrdList Instr)+                     -> NatM (OrdList Instr, BlockId)+        cmpxchg_code instrs = do+            lbl1 <- getBlockIdNat+            lbl2 <- getBlockIdNat+            tmp <- getNewRegNat format++            --Record inserted blocks+            --  We turn A -> B into A -> A' -> A'' -> B+            --  with a self loop on A'.+            addImmediateSuccessorNat bid lbl1+            addImmediateSuccessorNat lbl1 lbl2+            updateCfgNat (addWeightEdge lbl1 lbl1 0)++            return $ (toOL+                [ MOV format (OpAddr amode) (OpReg eax)+                , JXX ALWAYS lbl1+                , NEWBLOCK lbl1+                  -- Keep old value so we can return it:+                , MOV format (OpReg eax) (OpReg dst_r)+                , MOV format (OpReg eax) (OpReg tmp)+                ]+                `appOL` instrs (OpReg arg) (OpReg tmp) `appOL` toOL+                [ LOCK (CMPXCHG format (OpReg tmp) (OpAddr amode))+                , JXX NE lbl1+                -- See Note [Introducing cfg edges inside basic blocks]+                -- why this basic block is required.+                , JXX ALWAYS lbl2+                , NEWBLOCK lbl2+                ],+                lbl2)+    format = intFormat width++-- | Count trailing zeroes+genCtz :: BlockId -> Width -> LocalReg -> CmmExpr -> NatM (InstrBlock, Maybe BlockId)+genCtz bid width dst src = do+  is32Bit <- is32BitPlatform+  if is32Bit && width == W64+    then genCtz64_32 bid dst src+    else (,Nothing) <$> genCtzGeneric width dst src++-- | Count trailing zeroes+--+-- 64-bit width on 32-bit architecture+genCtz64_32+  :: BlockId+  -> LocalReg+  -> CmmExpr+  -> NatM (InstrBlock, Maybe BlockId)+genCtz64_32 bid dst src = do+  RegCode64 vcode rhi rlo <- iselExpr64 src+  let dst_r = getLocalRegReg dst+  lbl1 <- getBlockIdNat+  lbl2 <- getBlockIdNat+  tmp_r <- getNewRegNat II64++  -- New CFG Edges:+  --  bid -> lbl2+  --  bid -> lbl1 -> lbl2+  --  We also changes edges originating at bid to start at lbl2 instead.+  weights <- getCfgWeights+  updateCfgNat (addWeightEdge bid lbl1 110 .+                addWeightEdge lbl1 lbl2 110 .+                addImmediateSuccessor weights bid lbl2)++  -- The following instruction sequence corresponds to the pseudo-code+  --+  --  if (src) {+  --    dst = src.lo32 ? BSF(src.lo32) : (BSF(src.hi32) + 32);+  --  } else {+  --    dst = 64;+  --  }+  let instrs = vcode `appOL` toOL+           ([ MOV      II32 (OpReg rhi)         (OpReg tmp_r)+            , OR       II32 (OpReg rlo)         (OpReg tmp_r)+            , MOV      II32 (OpImm (ImmInt 64)) (OpReg dst_r)+            , JXX EQQ    lbl2+            , JXX ALWAYS lbl1++            , NEWBLOCK   lbl1+            , BSF     II32 (OpReg rhi)         dst_r+            , ADD     II32 (OpImm (ImmInt 32)) (OpReg dst_r)+            , BSF     II32 (OpReg rlo)         tmp_r+            , CMOV NE II32 (OpReg tmp_r)       dst_r+            , JXX ALWAYS lbl2++            , NEWBLOCK   lbl2+            ])+  return (instrs, Just lbl2)++-- | Count trailing zeroes+--+-- Generic case (width <= word size)+genCtzGeneric :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock+genCtzGeneric width dst src = do+  code_src <- getAnyReg src+  config <- getConfig+  let bw = widthInBits width+  let dst_r = getLocalRegReg dst+  if ncgBmiVersion config >= Just BMI2+  then do+      src_r <- getNewRegNat (intFormat width)+      let instrs = appOL (code_src src_r) $ case width of+              W8 -> toOL+                  [ OR    II32 (OpImm (ImmInteger 0xFFFFFF00)) (OpReg src_r)+                  , TZCNT II32 (OpReg src_r) dst_r+                  ]+              W16 -> toOL+                  [ TZCNT  II16 (OpReg src_r) dst_r+                  , MOVZxL II16 (OpReg dst_r) (OpReg dst_r)+                  ]+              _ -> unitOL $ TZCNT (intFormat width) (OpReg src_r) dst_r+      return instrs+  else do+      -- The following insn sequence makes sure 'ctz 0' has a defined value.+      -- starting with Haswell, one could use the TZCNT insn instead.+      let format = if width == W8 then II16 else intFormat width+      src_r <- getNewRegNat format+      tmp_r <- getNewRegNat format+      let instrs = code_src src_r `appOL` toOL+               ([ MOVZxL  II8    (OpReg src_r) (OpReg src_r) | width == W8 ] +++                [ BSF     format (OpReg src_r) tmp_r+                , MOV     II32   (OpImm (ImmInt bw)) (OpReg dst_r)+                , CMOV NE format (OpReg tmp_r) dst_r+                ]) -- NB: We don't need to zero-extend the result for the+                   -- W8/W16 cases because the 'MOV' insn already+                   -- took care of implicitly clearing the upper bits+      return instrs++++-- | Copy memory+--+-- Unroll memcpy calls if the number of bytes to copy isn't too large (cf+-- ncgInlineThresholdMemcpy).  Otherwise, call C's memcpy.+genMemCpy+  :: BlockId+  -> Int+  -> CmmExpr+  -> CmmExpr+  -> CmmExpr+  -> NatM InstrBlock+genMemCpy bid align dst src arg_n = do++  let libc_memcpy = genLibCCall bid (fsLit "memcpy") [] [dst,src,arg_n]++  case arg_n of+    CmmLit (CmmInt n _) -> do+      -- try to inline it+      mcode <- genMemCpyInlineMaybe align dst src n+      -- if it didn't inline, call the C function+      case mcode of+        Nothing -> libc_memcpy+        Just c  -> pure c++    -- not a literal size argument: call the C function+    _ -> libc_memcpy++++genMemCpyInlineMaybe+  :: Int+  -> CmmExpr+  -> CmmExpr+  -> Integer+  -> NatM (Maybe InstrBlock)+genMemCpyInlineMaybe align dst src n = do+  config <- getConfig+  let+    platform     = ncgPlatform config+    maxAlignment = wordAlignment platform+                   -- only machine word wide MOVs are supported+    effectiveAlignment = min (alignmentOf align) maxAlignment+    format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment+++  -- The size of each move, in bytes.+  let sizeBytes :: Integer+      sizeBytes = fromIntegral (formatInBytes format)++  -- The number of instructions we will generate (approx). We need 2+  -- instructions per move.+  let insns = 2 * ((n + sizeBytes - 1) `div` sizeBytes)++      go :: Reg -> Reg -> Reg -> Integer -> OrdList Instr+      go dst src tmp i+          | i >= sizeBytes =+              unitOL (MOV format (OpAddr src_addr) (OpReg tmp)) `appOL`+              unitOL (MOV format (OpReg tmp) (OpAddr dst_addr)) `appOL`+              go dst src tmp (i - sizeBytes)+          -- Deal with remaining bytes.+          | i >= 4 =  -- Will never happen on 32-bit+              unitOL (MOV II32 (OpAddr src_addr) (OpReg tmp)) `appOL`+              unitOL (MOV II32 (OpReg tmp) (OpAddr dst_addr)) `appOL`+              go dst src tmp (i - 4)+          | i >= 2 =+              unitOL (MOVZxL II16 (OpAddr src_addr) (OpReg tmp)) `appOL`+              unitOL (MOV II16 (OpReg tmp) (OpAddr dst_addr)) `appOL`+              go dst src tmp (i - 2)+          | i >= 1 =+              unitOL (MOVZxL II8 (OpAddr src_addr) (OpReg tmp)) `appOL`+              unitOL (MOV II8 (OpReg tmp) (OpAddr dst_addr)) `appOL`+              go dst src tmp (i - 1)+          | otherwise = nilOL+        where+          src_addr = AddrBaseIndex (EABaseReg src) EAIndexNone+                       (ImmInteger (n - i))++          dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone+                       (ImmInteger (n - i))++  if insns > fromIntegral (ncgInlineThresholdMemcpy config)+    then pure Nothing+    else do+      code_dst <- getAnyReg dst+      dst_r <- getNewRegNat format+      code_src <- getAnyReg src+      src_r <- getNewRegNat format+      tmp_r <- getNewRegNat format+      pure $ Just $ code_dst dst_r `appOL` code_src src_r `appOL`+                      go dst_r src_r tmp_r (fromInteger n)++-- | Set memory to the given byte+--+-- Unroll memset calls if the number of bytes to copy isn't too large (cf+-- ncgInlineThresholdMemset).  Otherwise, call C's memset.+genMemSet+  :: BlockId+  -> Int+  -> CmmExpr+  -> CmmExpr+  -> CmmExpr+  -> NatM InstrBlock+genMemSet bid align dst arg_c arg_n = do++  let libc_memset = genLibCCall bid (fsLit "memset") [] [dst,arg_c,arg_n]++  case (arg_c,arg_n) of+    (CmmLit (CmmInt c _), CmmLit (CmmInt n _)) -> do+      -- try to inline it+      mcode <- genMemSetInlineMaybe align dst c n+      -- if it didn't inline, call the C function+      case mcode of+        Nothing -> libc_memset+        Just c  -> pure c++    -- not literal size arguments: call the C function+    _ -> libc_memset++genMemSetInlineMaybe+  :: Int+  -> CmmExpr+  -> Integer+  -> Integer+  -> NatM (Maybe InstrBlock)+genMemSetInlineMaybe align dst c n = do+  config <- getConfig+  let+    platform = ncgPlatform config+    maxAlignment = wordAlignment platform -- only machine word wide MOVs are supported+    effectiveAlignment = min (alignmentOf align) maxAlignment+    format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment+    c2 = c `shiftL` 8 .|. c+    c4 = c2 `shiftL` 16 .|. c2+    c8 = c4 `shiftL` 32 .|. c4++    -- The number of instructions we will generate (approx). We need 1+    -- instructions per move.+    insns = (n + sizeBytes - 1) `div` sizeBytes++    -- The size of each move, in bytes.+    sizeBytes :: Integer+    sizeBytes = fromIntegral (formatInBytes format)++    -- Depending on size returns the widest MOV instruction and its+    -- width.+    gen4 :: AddrMode -> Integer -> (InstrBlock, Integer)+    gen4 addr size+        | size >= 4 =+            (unitOL (MOV II32 (OpImm (ImmInteger c4)) (OpAddr addr)), 4)+        | size >= 2 =+            (unitOL (MOV II16 (OpImm (ImmInteger c2)) (OpAddr addr)), 2)+        | size >= 1 =+            (unitOL (MOV II8 (OpImm (ImmInteger c)) (OpAddr addr)), 1)+        | otherwise = (nilOL, 0)++    -- Generates a 64-bit wide MOV instruction from REG to MEM.+    gen8 :: AddrMode -> Reg -> InstrBlock+    gen8 addr reg8byte =+      unitOL (MOV format (OpReg reg8byte) (OpAddr addr))++    -- Unrolls memset when the widest MOV is <= 4 bytes.+    go4 :: Reg -> Integer -> InstrBlock+    go4 dst left =+      if left <= 0 then nilOL+      else curMov `appOL` go4 dst (left - curWidth)+      where+        possibleWidth = minimum [left, sizeBytes]+        dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - left))+        (curMov, curWidth) = gen4 dst_addr possibleWidth++    -- Unrolls memset when the widest MOV is 8 bytes (thus another Reg+    -- argument). Falls back to go4 when all 8 byte moves are+    -- exhausted.+    go8 :: Reg -> Reg -> Integer -> InstrBlock+    go8 dst reg8byte left =+      if possibleWidth >= 8 then+        let curMov = gen8 dst_addr reg8byte+        in  curMov `appOL` go8 dst reg8byte (left - 8)+      else go4 dst left+      where+        possibleWidth = minimum [left, sizeBytes]+        dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - left))++  if fromInteger insns > ncgInlineThresholdMemset config+    then pure Nothing+    else do+        code_dst <- getAnyReg dst+        dst_r <- getNewRegNat format+        if format == II64 && n >= 8+          then do+            code_imm8byte <- getAnyReg (CmmLit (CmmInt c8 W64))+            imm8byte_r <- getNewRegNat II64+            return $ Just $ code_dst dst_r `appOL`+                              code_imm8byte imm8byte_r `appOL`+                              go8 dst_r imm8byte_r (fromInteger n)+          else+            return $ Just $ code_dst dst_r `appOL`+                              go4 dst_r (fromInteger n)+++genMemMove :: BlockId -> p -> CmmActual -> CmmActual -> CmmActual -> NatM InstrBlock+genMemMove bid _align dst src n = do+  -- TODO: generate inline assembly when under a given treshold (similarly to+  -- memcpy and memset)+  genLibCCall bid (fsLit "memmove") [] [dst,src,n]++genMemCmp :: BlockId -> p -> CmmFormal -> CmmActual -> CmmActual -> CmmActual -> NatM InstrBlock+genMemCmp bid _align res dst src n = do+  -- TODO: generate inline assembly when under a given treshold (similarly to+  -- memcpy and memset)+  genLibCCall bid (fsLit "memcmp") [res] [dst,src,n]++genPrefetchData :: Int -> CmmExpr -> NatM (OrdList Instr)+genPrefetchData n src = do+  is32Bit <- is32BitPlatform+  let+    format = archWordFormat is32Bit+    -- need to know what register width for pointers!+    genPrefetch inRegSrc prefetchCTor = do+      code_src <- getAnyReg inRegSrc+      src_r <- getNewRegNat format+      return $ code_src src_r `appOL`+        (unitOL (prefetchCTor  (OpAddr+                    ((AddrBaseIndex (EABaseReg src_r )   EAIndexNone (ImmInt 0))))  ))+        -- prefetch always takes an address++  -- the c / llvm prefetch convention is 0, 1, 2, and 3+  -- the x86 corresponding names are : NTA, 2 , 1, and 0+  case n of+      0 -> genPrefetch src $ PREFETCH NTA  format+      1 -> genPrefetch src $ PREFETCH Lvl2 format+      2 -> genPrefetch src $ PREFETCH Lvl1 format+      3 -> genPrefetch src $ PREFETCH Lvl0 format+      l -> pprPanic "genPrefetchData: unexpected prefetch level" (ppr l)++genByteSwap :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock+genByteSwap width dst src = do+  is32Bit <- is32BitPlatform+  let format = intFormat width+  case width of+      W64 | is32Bit -> do+        let Reg64 dst_hi dst_lo = localReg64 dst+        RegCode64 vcode rhi rlo <- iselExpr64 src+        return $ vcode `appOL`+                 toOL [ MOV II32 (OpReg rlo) (OpReg dst_hi),+                        MOV II32 (OpReg rhi) (OpReg dst_lo),+                        BSWAP II32 dst_hi,+                        BSWAP II32 dst_lo ]+      W16 -> do+        let dst_r = getLocalRegReg dst+        code_src <- getAnyReg src+        return $ code_src dst_r `appOL`+                 unitOL (BSWAP II32 dst_r) `appOL`+                 unitOL (SHR II32 (OpImm $ ImmInt 16) (OpReg dst_r))+      _   -> do+        let dst_r = getLocalRegReg dst+        code_src <- getAnyReg src+        return $ code_src dst_r `appOL` unitOL (BSWAP format dst_r)++genBitRev :: BlockId -> Width -> CmmFormal -> CmmActual -> NatM InstrBlock+genBitRev bid width dst src = do+  -- Here the C implementation (hs_bitrevN) is used as there is no x86+  -- instruction to reverse a word's bit order.+  genPrimCCall bid (bRevLabel width) [dst] [src]++genPopCnt :: BlockId -> Width -> LocalReg -> CmmExpr -> NatM InstrBlock+genPopCnt bid width dst src = do+  config <- getConfig+  let+    platform = ncgPlatform config+    format = intFormat width++  sse4_2Enabled >>= \case++    True -> do+      code_src <- getAnyReg src+      src_r <- getNewRegNat format+      let dst_r = getRegisterReg platform  (CmmLocal dst)+      return $ code_src src_r `appOL`+          (if width == W8 then+               -- The POPCNT instruction doesn't take a r/m8+               unitOL (MOVZxL II8 (OpReg src_r) (OpReg src_r)) `appOL`+               unitOL (POPCNT II16 (OpReg src_r) dst_r)+           else+               unitOL (POPCNT format (OpReg src_r) dst_r)) `appOL`+          (if width == W8 || width == W16 then+               -- We used a 16-bit destination register above,+               -- so zero-extend+               unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r))+           else nilOL)++    False ->+      -- generate C call to hs_popcntN in ghc-prim+      -- TODO: we could directly generate the assembly to index popcount_tab+      -- here instead of doing it by calling a C function+      genPrimCCall bid (popCntLabel width) [dst] [src]+++genPdep :: BlockId -> Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genPdep bid width dst src mask = do+  config <- getConfig+  let+    platform = ncgPlatform config+    format = intFormat width++  if ncgBmiVersion config >= Just BMI2+    then do+      code_src  <- getAnyReg src+      code_mask <- getAnyReg mask+      src_r     <- getNewRegNat format+      mask_r    <- getNewRegNat format+      let dst_r = getRegisterReg platform  (CmmLocal dst)+      return $ code_src src_r `appOL` code_mask mask_r `appOL`+          -- PDEP only supports > 32 bit args+          ( if width == W8 || width == W16 then+              toOL+                [ MOVZxL format (OpReg src_r ) (OpReg src_r )+                , MOVZxL format (OpReg mask_r) (OpReg mask_r)+                , PDEP   II32 (OpReg mask_r) (OpReg src_r ) dst_r+                , MOVZxL format (OpReg dst_r) (OpReg dst_r) -- Truncate to op width+                ]+            else+              unitOL (PDEP format (OpReg mask_r) (OpReg src_r) dst_r)+          )+    else+      -- generate C call to hs_pdepN in ghc-prim+      genPrimCCall bid (pdepLabel width) [dst] [src,mask]+++genPext :: BlockId -> Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genPext bid width dst src mask = do+  config <- getConfig+  if ncgBmiVersion config >= Just BMI2+    then do+      let format   = intFormat width+      let dst_r    = getLocalRegReg dst+      code_src  <- getAnyReg src+      code_mask <- getAnyReg mask+      src_r     <- getNewRegNat format+      mask_r    <- getNewRegNat format+      return $ code_src src_r `appOL` code_mask mask_r `appOL`+          (if width == W8 || width == W16 then+               -- The PEXT instruction doesn't take a r/m8 or 16+              toOL+                [ MOVZxL format (OpReg src_r ) (OpReg src_r )+                , MOVZxL format (OpReg mask_r) (OpReg mask_r)+                , PEXT   II32 (OpReg mask_r) (OpReg src_r ) dst_r+                , MOVZxL format (OpReg dst_r) (OpReg dst_r) -- Truncate to op width+                ]+            else+              unitOL (PEXT format (OpReg mask_r) (OpReg src_r) dst_r)+          )+    else+      -- generate C call to hs_pextN in ghc-prim+      genPrimCCall bid (pextLabel width) [dst] [src,mask]++genClz :: BlockId -> Width -> CmmFormal -> CmmActual -> NatM InstrBlock+genClz bid width dst src = do+  is32Bit <- is32BitPlatform+  config <- getConfig+  if is32Bit && width == W64++    then+      -- Fallback to `hs_clz64` on i386+      genPrimCCall bid (clzLabel width) [dst] [src]++    else do+      code_src <- getAnyReg src+      let dst_r = getLocalRegReg dst+      if ncgBmiVersion config >= Just BMI2+        then do+          src_r <- getNewRegNat (intFormat width)+          return $ appOL (code_src src_r) $ case width of+            W8 -> toOL+                [ MOVZxL II8  (OpReg src_r)       (OpReg src_r) -- zero-extend to 32 bit+                , LZCNT  II32 (OpReg src_r)       dst_r         -- lzcnt with extra 24 zeros+                , SUB    II32 (OpImm (ImmInt 24)) (OpReg dst_r) -- compensate for extra zeros+                ]+            W16 -> toOL+                [ LZCNT  II16 (OpReg src_r) dst_r+                , MOVZxL II16 (OpReg dst_r) (OpReg dst_r) -- zero-extend from 16 bit+                ]+            _ -> unitOL (LZCNT (intFormat width) (OpReg src_r) dst_r)+        else do+          let format = if width == W8 then II16 else intFormat width+          let bw = widthInBits width+          src_r <- getNewRegNat format+          tmp_r <- getNewRegNat format+          return $ code_src src_r `appOL` toOL+                   ([ MOVZxL  II8    (OpReg src_r) (OpReg src_r) | width == W8 ] +++                    [ BSR     format (OpReg src_r) tmp_r+                    , MOV     II32   (OpImm (ImmInt (2*bw-1))) (OpReg dst_r)+                    , CMOV NE format (OpReg tmp_r) dst_r+                    , XOR     format (OpImm (ImmInt (bw-1))) (OpReg dst_r)+                    ]) -- NB: We don't need to zero-extend the result for the+                       -- W8/W16 cases because the 'MOV' insn already+                       -- took care of implicitly clearing the upper bits++genWordToFloat :: BlockId -> Width -> CmmFormal -> CmmActual -> NatM InstrBlock+genWordToFloat bid width dst src =+  -- TODO: generate assembly instead+  genPrimCCall bid (word2FloatLabel width) [dst] [src]++genAtomicRead :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock+genAtomicRead width dst addr = do+  load_code <- intLoadCode (MOV (intFormat width)) addr+  return (load_code (getLocalRegReg dst))++genAtomicWrite :: Width -> CmmExpr -> CmmExpr -> NatM InstrBlock+genAtomicWrite width addr val = do+  code <- assignMem_IntCode (intFormat width) addr val+  return $ code `snocOL` MFENCE++genCmpXchg+  :: BlockId+  -> Width+  -> LocalReg+  -> CmmExpr+  -> CmmExpr+  -> CmmExpr+  -> NatM InstrBlock+genCmpXchg bid width dst addr old new = do+  is32Bit <- is32BitPlatform+  -- On x86 we don't have enough registers to use cmpxchg with a+  -- complicated addressing mode, so on that architecture we+  -- pre-compute the address first.+  if not (is32Bit && width == W64)+    then do+      let format = intFormat width+      Amode amode addr_code <- getSimpleAmode addr+      newval <- getNewRegNat format+      newval_code <- getAnyReg new+      oldval <- getNewRegNat format+      oldval_code <- getAnyReg old+      platform <- getPlatform+      let dst_r    = getRegisterReg platform  (CmmLocal dst)+          code     = toOL+                     [ MOV format (OpReg oldval) (OpReg eax)+                     , LOCK (CMPXCHG format (OpReg newval) (OpAddr amode))+                     , MOV format (OpReg eax) (OpReg dst_r)+                     ]+      return $ addr_code `appOL` newval_code newval `appOL` oldval_code oldval+          `appOL` code+    else+      -- generate C call to hs_cmpxchgN in ghc-prim+      genPrimCCall bid (cmpxchgLabel width) [dst] [addr,old,new]+      -- TODO: implement cmpxchg8b instruction++genXchg :: Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genXchg width dst addr value = do+  is32Bit <- is32BitPlatform++  when (is32Bit && width == W64) $+    panic "genXchg: 64bit atomic exchange not supported on 32bit platforms"++  Amode amode addr_code <- getSimpleAmode addr+  (newval, newval_code) <- getSomeReg value+  let format   = intFormat width+  let dst_r    = getLocalRegReg dst+  -- Copy the value into the target register, perform the exchange.+  let code     = toOL+                 [ MOV format (OpReg newval) (OpReg dst_r)+                  -- On X86 xchg implies a lock prefix if we use a memory argument.+                  -- so this is atomic.+                 , XCHG format (OpAddr amode) dst_r+                 ]+  return $ addr_code `appOL` newval_code `appOL` code+++genFloatAbs :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock+genFloatAbs width dst src = do+  let+    format = floatFormat width+    const = case width of+      W32 -> CmmInt 0x7fffffff W32+      W64 -> CmmInt 0x7fffffffffffffff W64+      _   -> pprPanic "genFloatAbs: invalid width" (ppr width)+  src_code <- getAnyReg src+  Amode amode amode_code <- memConstant (mkAlignment $ widthInBytes width) const+  tmp <- getNewRegNat format+  let dst_r = getLocalRegReg dst+  pure $ src_code dst_r `appOL` amode_code `appOL` toOL+           [ MOV format (OpAddr amode) (OpReg tmp)+           , AND format (OpReg tmp) (OpReg dst_r)+           ]+++genFloatSqrt :: Format -> LocalReg -> CmmExpr -> NatM InstrBlock+genFloatSqrt format dst src = do+  let dst_r = getLocalRegReg dst+  src_code <- getAnyReg src+  pure $ src_code dst_r `snocOL` SQRT format (OpReg dst_r) dst_r+++genAddSubRetCarry+  :: Width+  -> (Format -> Operand -> Operand -> Instr)+  -> (Format -> Maybe (Operand -> Operand -> Instr))+  -> Cond+  -> LocalReg+  -> LocalReg+  -> CmmExpr+  -> CmmExpr+  -> NatM InstrBlock+genAddSubRetCarry width instr mrevinstr cond res_r res_c arg_x arg_y = do+  platform <- ncgPlatform <$> getConfig+  let format = intFormat width+  rCode <- anyReg =<< trivialCode width (instr format)+                        (mrevinstr format) arg_x arg_y+  reg_tmp <- getNewRegNat II8+  let reg_c = getRegisterReg platform  (CmmLocal res_c)+      reg_r = getRegisterReg platform  (CmmLocal res_r)+      code = rCode reg_r `snocOL`+             SETCC cond (OpReg reg_tmp) `snocOL`+             MOVZxL II8 (OpReg reg_tmp) (OpReg reg_c)+  return code+++genAddWithCarry+  :: Width+  -> LocalReg+  -> LocalReg+  -> CmmExpr+  -> CmmExpr+  -> NatM InstrBlock+genAddWithCarry width res_h res_l arg_x arg_y = do+  hCode <- getAnyReg (CmmLit (CmmInt 0 width))+  let format = intFormat width+  lCode <- anyReg =<< trivialCode width (ADD_CC format)+                        (Just (ADD_CC format)) arg_x arg_y+  let reg_l = getLocalRegReg res_l+      reg_h = getLocalRegReg res_h+      code = hCode reg_h `appOL`+             lCode reg_l `snocOL`+             ADC format (OpImm (ImmInteger 0)) (OpReg reg_h)+  return code+++genSignedLargeMul+  :: Width+  -> LocalReg+  -> LocalReg+  -> LocalReg+  -> CmmExpr+  -> CmmExpr+  -> NatM (OrdList Instr)+genSignedLargeMul width res_c res_h res_l arg_x arg_y = do+  (y_reg, y_code) <- getRegOrMem arg_y+  x_code <- getAnyReg arg_x+  reg_tmp <- getNewRegNat II8+  let format = intFormat width+      reg_h = getLocalRegReg res_h+      reg_l = getLocalRegReg res_l+      reg_c = getLocalRegReg res_c+      code = y_code `appOL`+             x_code rax `appOL`+             toOL [ IMUL2 format y_reg+                  , MOV format (OpReg rdx) (OpReg reg_h)+                  , MOV format (OpReg rax) (OpReg reg_l)+                  , SETCC CARRY (OpReg reg_tmp)+                  , MOVZxL II8 (OpReg reg_tmp) (OpReg reg_c)+                  ]+  return code++genUnsignedLargeMul+  :: Width+  -> LocalReg+  -> LocalReg+  -> CmmExpr+  -> CmmExpr+  -> NatM (OrdList Instr)+genUnsignedLargeMul width res_h res_l arg_x arg_y = do+  (y_reg, y_code) <- getRegOrMem arg_y+  x_code <- getAnyReg arg_x+  let format = intFormat width+      reg_h = getLocalRegReg res_h+      reg_l = getLocalRegReg res_l+      code = y_code `appOL`+             x_code rax `appOL`+             toOL [MUL2 format y_reg,+                   MOV format (OpReg rdx) (OpReg reg_h),+                   MOV format (OpReg rax) (OpReg reg_l)]+  return code+++genQuotRem+  :: Width+  -> Bool+  -> LocalReg+  -> LocalReg+  -> Maybe CmmExpr+  -> CmmExpr+  -> CmmExpr+  -> NatM InstrBlock+genQuotRem width signed res_q res_r m_arg_x_high arg_x_low arg_y = do+  case width of+    W8 -> do+      -- See Note [DIV/IDIV for bytes]+      let widen | signed = MO_SS_Conv W8 W16+                | otherwise = MO_UU_Conv W8 W16+          arg_x_low_16 = CmmMachOp widen [arg_x_low]+          arg_y_16 = CmmMachOp widen [arg_y]+          m_arg_x_high_16 = (\p -> CmmMachOp widen [p]) <$> m_arg_x_high+      genQuotRem W16 signed res_q res_r m_arg_x_high_16 arg_x_low_16 arg_y_16++    _ -> do+      let format = intFormat width+          reg_q = getLocalRegReg res_q+          reg_r = getLocalRegReg res_r+          widen | signed    = CLTD format+                | otherwise = XOR format (OpReg rdx) (OpReg rdx)+          instr | signed    = IDIV+                | otherwise = DIV+      (y_reg, y_code) <- getRegOrMem arg_y+      x_low_code <- getAnyReg arg_x_low+      x_high_code <- case m_arg_x_high of+                     Just arg_x_high ->+                         getAnyReg arg_x_high+                     Nothing ->+                         return $ const $ unitOL widen+      return $ y_code `appOL`+               x_low_code rax `appOL`+               x_high_code rdx `appOL`+               toOL [instr format y_reg,+                     MOV format (OpReg rax) (OpReg reg_q),+                     MOV format (OpReg rdx) (OpReg reg_r)]+++----------------------------------------------------------------------------+-- The following functions implement certain 64-bit MachOps inline for 32-bit+-- architectures. On 64-bit architectures, those MachOps aren't supported and+-- calling these functions for a 64-bit target platform is considered an error+-- (hence the use of `expect32BitPlatform`).+--+-- On 64-bit platforms, generic MachOps should be used instead of these 64-bit+-- specific ones (e.g. use MO_Add instead of MO_x64_Add). This MachOp selection+-- is done by StgToCmm.++genInt64ToInt :: LocalReg -> CmmExpr -> NatM InstrBlock+genInt64ToInt dst src = do+  expect32BitPlatform (text "genInt64ToInt")+  RegCode64 code _src_hi src_lo <- iselExpr64 src+  let dst_r = getLocalRegReg dst+  pure $ code `snocOL` MOV II32 (OpReg src_lo) (OpReg dst_r)++genWord64ToWord :: LocalReg -> CmmExpr -> NatM InstrBlock+genWord64ToWord dst src = do+  expect32BitPlatform (text "genWord64ToWord")+  RegCode64 code _src_hi src_lo <- iselExpr64 src+  let dst_r = getLocalRegReg dst+  pure $ code `snocOL` MOV II32 (OpReg src_lo) (OpReg dst_r)++genIntToInt64 :: LocalReg -> CmmExpr -> NatM InstrBlock+genIntToInt64 dst src = do+  expect32BitPlatform (text "genIntToInt64")+  let Reg64 dst_hi dst_lo = localReg64 dst+  src_code <- getAnyReg src+  pure $ src_code rax `appOL` toOL+          [ CLTD II32 -- sign extend EAX in EDX:EAX+          , MOV II32 (OpReg rax) (OpReg dst_lo)+          , MOV II32 (OpReg rdx) (OpReg dst_hi)+          ]++genWordToWord64 :: LocalReg -> CmmExpr -> NatM InstrBlock+genWordToWord64 dst src = do+  expect32BitPlatform (text "genWordToWord64")+  let Reg64 dst_hi dst_lo = localReg64 dst+  src_code <- getAnyReg src+  pure $ src_code dst_lo+          `snocOL` XOR II32 (OpReg dst_hi) (OpReg dst_hi)++genNeg64 :: LocalReg -> CmmExpr -> NatM InstrBlock+genNeg64 dst src = do+  expect32BitPlatform (text "genNeg64")+  let Reg64 dst_hi dst_lo = localReg64 dst+  RegCode64 code src_hi src_lo <- iselExpr64 src+  pure $ code `appOL` toOL+          [ MOV  II32 (OpReg src_lo) (OpReg dst_lo)+          , MOV  II32 (OpReg src_hi) (OpReg dst_hi)+          , NEGI II32 (OpReg dst_lo)+          , ADC  II32 (OpImm (ImmInt 0)) (OpReg dst_hi)+          , NEGI II32 (OpReg dst_hi)+          ]++genAdd64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genAdd64 dst x y = do+  expect32BitPlatform (text "genAdd64")+  let Reg64 dst_hi dst_lo = localReg64 dst+  RegCode64 x_code x_hi x_lo <- iselExpr64 x+  RegCode64 y_code y_hi y_lo <- iselExpr64 y+  pure $ x_code `appOL` y_code `appOL` toOL+          [ MOV  II32 (OpReg x_lo) (OpReg dst_lo)+          , MOV  II32 (OpReg x_hi) (OpReg dst_hi)+          , ADD  II32 (OpReg y_lo) (OpReg dst_lo)+          , ADC  II32 (OpReg y_hi) (OpReg dst_hi)+          ]++genSub64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genSub64 dst x y = do+  expect32BitPlatform (text "genSub64")+  let Reg64 dst_hi dst_lo = localReg64 dst+  RegCode64 x_code x_hi x_lo <- iselExpr64 x+  RegCode64 y_code y_hi y_lo <- iselExpr64 y+  pure $ x_code `appOL` y_code `appOL` toOL+          [ MOV  II32 (OpReg x_lo) (OpReg dst_lo)+          , MOV  II32 (OpReg x_hi) (OpReg dst_hi)+          , SUB  II32 (OpReg y_lo) (OpReg dst_lo)+          , SBB  II32 (OpReg y_hi) (OpReg dst_hi)+          ]++genAnd64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genAnd64 dst x y = do+  expect32BitPlatform (text "genAnd64")+  let Reg64 dst_hi dst_lo = localReg64 dst+  RegCode64 x_code x_hi x_lo <- iselExpr64 x+  RegCode64 y_code y_hi y_lo <- iselExpr64 y+  pure $ x_code `appOL` y_code `appOL` toOL+          [ MOV II32 (OpReg x_lo) (OpReg dst_lo)+          , MOV II32 (OpReg x_hi) (OpReg dst_hi)+          , AND II32 (OpReg y_lo) (OpReg dst_lo)+          , AND II32 (OpReg y_hi) (OpReg dst_hi)+          ]++genOr64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genOr64 dst x y = do+  expect32BitPlatform (text "genOr64")+  let Reg64 dst_hi dst_lo = localReg64 dst+  RegCode64 x_code x_hi x_lo <- iselExpr64 x+  RegCode64 y_code y_hi y_lo <- iselExpr64 y+  pure $ x_code `appOL` y_code `appOL` toOL+          [ MOV II32 (OpReg x_lo) (OpReg dst_lo)+          , MOV II32 (OpReg x_hi) (OpReg dst_hi)+          , OR  II32 (OpReg y_lo) (OpReg dst_lo)+          , OR  II32 (OpReg y_hi) (OpReg dst_hi)+          ]++genXor64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genXor64 dst x y = do+  expect32BitPlatform (text "genXor64")+  let Reg64 dst_hi dst_lo = localReg64 dst+  RegCode64 x_code x_hi x_lo <- iselExpr64 x+  RegCode64 y_code y_hi y_lo <- iselExpr64 y+  pure $ x_code `appOL` y_code `appOL` toOL+          [ MOV II32 (OpReg x_lo) (OpReg dst_lo)+          , MOV II32 (OpReg x_hi) (OpReg dst_hi)+          , XOR II32 (OpReg y_lo) (OpReg dst_lo)+          , XOR II32 (OpReg y_hi) (OpReg dst_hi)+          ]++genNot64 :: LocalReg -> CmmExpr -> NatM InstrBlock+genNot64 dst src = do+  expect32BitPlatform (text "genNot64")+  let Reg64 dst_hi dst_lo = localReg64 dst+  RegCode64 src_code src_hi src_lo <- iselExpr64 src+  pure $ src_code `appOL` toOL+          [ MOV II32 (OpReg src_lo) (OpReg dst_lo)+          , MOV II32 (OpReg src_hi) (OpReg dst_hi)+          , NOT II32 (OpReg dst_lo)+          , NOT II32 (OpReg dst_hi)+          ]++genEq64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genEq64 dst x y = do+  expect32BitPlatform (text "genEq64")+  let dst_r = getLocalRegReg dst+  RegCode64 x_code x_hi x_lo <- iselExpr64 x+  RegCode64 y_code y_hi y_lo <- iselExpr64 y+  Reg64 tmp_hi tmp_lo <- getNewReg64+  pure $ x_code `appOL` y_code `appOL` toOL+          [ MOV II32 (OpReg x_lo)   (OpReg tmp_lo)+          , MOV II32 (OpReg x_hi)   (OpReg tmp_hi)+          , XOR II32 (OpReg y_lo)   (OpReg tmp_lo)+          , XOR II32 (OpReg y_hi)   (OpReg tmp_hi)+          , OR  II32 (OpReg tmp_lo) (OpReg tmp_hi)+          , SETCC EQQ (OpReg dst_r)+          , MOVZxL II8 (OpReg dst_r) (OpReg dst_r)+          ]++genNe64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genNe64 dst x y = do+  expect32BitPlatform (text "genNe64")+  let dst_r = getLocalRegReg dst+  RegCode64 x_code x_hi x_lo <- iselExpr64 x+  RegCode64 y_code y_hi y_lo <- iselExpr64 y+  Reg64 tmp_hi tmp_lo <- getNewReg64+  pure $ x_code `appOL` y_code `appOL` toOL+          [ MOV II32 (OpReg x_lo)   (OpReg tmp_lo)+          , MOV II32 (OpReg x_hi)   (OpReg tmp_hi)+          , XOR II32 (OpReg y_lo)   (OpReg tmp_lo)+          , XOR II32 (OpReg y_hi)   (OpReg tmp_hi)+          , OR  II32 (OpReg tmp_lo) (OpReg tmp_hi)+          , SETCC NE (OpReg dst_r)+          , MOVZxL II8 (OpReg dst_r) (OpReg dst_r)+          ]++genGtWord64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genGtWord64 dst x y = do+  expect32BitPlatform (text "genGtWord64")+  genPred64 LU dst y x++genLtWord64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genLtWord64 dst x y = do+  expect32BitPlatform (text "genLtWord64")+  genPred64 LU dst x y++genGeWord64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genGeWord64 dst x y = do+  expect32BitPlatform (text "genGeWord64")+  genPred64 GEU dst x y++genLeWord64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genLeWord64 dst x y = do+  expect32BitPlatform (text "genLeWord64")+  genPred64 GEU dst y x++genGtInt64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genGtInt64 dst x y = do+  expect32BitPlatform (text "genGtInt64")+  genPred64 LTT dst y x++genLtInt64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genLtInt64 dst x y = do+  expect32BitPlatform (text "genLtInt64")+  genPred64 LTT dst x y++genGeInt64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genGeInt64 dst x y = do+  expect32BitPlatform (text "genGeInt64")+  genPred64 GE dst x y++genLeInt64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genLeInt64 dst x y = do+  expect32BitPlatform (text "genLeInt64")+  genPred64 GE dst y x++genPred64 :: Cond -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genPred64 cond dst x y = do+  -- we can only rely on CF/SF/OF flags!+  -- Not on ZF, which doesn't take into account the lower parts.+  massert (cond `elem` [LU,GEU,LTT,GE])++  let dst_r = getLocalRegReg dst+  RegCode64 x_code x_hi x_lo <- iselExpr64 x+  RegCode64 y_code y_hi y_lo <- iselExpr64 y+  -- Basically we perform a subtraction with borrow.+  -- As we don't need to result, we can use CMP instead of SUB for the low part+  -- (it sets the borrow flag just like SUB does)+  pure $ x_code `appOL` y_code `appOL` toOL+          [ MOV II32 (OpReg x_hi) (OpReg dst_r)+          , CMP II32 (OpReg y_lo) (OpReg x_lo)+          , SBB II32 (OpReg y_hi) (OpReg dst_r)+          , SETCC cond (OpReg dst_r)+          , MOVZxL II8 (OpReg dst_r) (OpReg dst_r)+          ]+
compiler/GHC/CmmToAsm/X86/Cond.hs view
@@ -11,22 +11,22 @@  data Cond         = ALWAYS        -- What's really used? ToDo-        | EQQ           -- je/jz -> zf = 1-        | GE            -- jge-        | GEU           -- ae-        | GTT           -- jg-        | GU            -- ja-        | LE            -- jle-        | LEU           -- jbe-        | LTT           -- jl-        | LU            -- jb-        | NE            -- jne-        | NEG           -- js-        | POS           -- jns-        | CARRY         -- jc-        | OFLO          -- jo-        | PARITY        -- jp-        | NOTPARITY     -- jnp+        | EQQ           -- je/jz -> zf=1+        | GE            -- jge   -> sf=of+        | GEU           -- ae    -> cf=0+        | GTT           -- jg    -> zf=0 && sf=of+        | GU            -- ja    -> cf=0 && zf=0+        | LE            -- jle   -> zf=1 || sf/=of+        | LEU           -- jbe   -> cf=1 || zf=1+        | LTT           -- jl    -> sf/=of+        | LU            -- jb    -> cf=1+        | NE            -- jne   -> zf=0+        | NEG           -- js    -> sf=1+        | POS           -- jns   -> sf=0+        | CARRY         -- jc    -> cf=1+        | OFLO          -- jo    -> of=1+        | PARITY        -- jp    -> pf=1+        | NOTPARITY     -- jnp   -> pf=0         deriving Eq  condToUnsigned :: Cond -> Cond
compiler/GHC/CmmToAsm/X86/Instr.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, TypeFamilies #-}+{-# LANGUAGE TypeFamilies #-}  ----------------------------------------------------------------------------- --@@ -37,8 +37,6 @@    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.CmmToAsm.X86.Cond@@ -57,7 +55,6 @@ import GHC.Cmm.Dataflow.Label import GHC.Platform.Regs import GHC.Cmm-import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Platform@@ -69,7 +66,6 @@ import GHC.Types.Basic (Alignment) import GHC.Cmm.DebugBlock (UnwindTable) -import Control.Monad import Data.Maybe       (fromMaybe)  -- Format of an x86/x86_64 memory address, in bytes.@@ -124,7 +120,7 @@  {- Note [x86 Floating point precision]-+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Intel's internal floating point registers are by default 80 bit extended precision.  This means that all operations done on values in registers are done at 80 bits, and unless the intermediate values are@@ -174,7 +170,7 @@  data Instr         -- comment pseudo-op-        = COMMENT FastString+        = COMMENT SDoc          -- location pseudo-op (file, line, col, name)         | LOCATION Int Int Int String@@ -200,8 +196,16 @@          -- Moves.         | MOV         Format Operand Operand+             -- ^ N.B. when used with the 'II64' 'Format', the source+             -- operand is interpreted to be a 32-bit sign-extended value.+             -- True 64-bit operands need to be moved with @MOVABS@, which we+             -- currently don't use.         | CMOV   Cond Format Operand Reg-        | MOVZxL      Format Operand Operand -- format is the size of operand 1+        | MOVZxL      Format Operand Operand+              -- ^ The format argument is the size of operand 1 (the number of bits we keep)+              -- We always zero *all* high bits, even though this isn't how the actual instruction+              -- works. The code generator also seems to rely on this behaviour and it's faster+              -- to execute on many cpus as well so for now I'm just documenting the fact.         | MOVSxL      Format Operand Operand -- format is the size of operand 1         -- x86_64 note: plain mov into a 32-bit register always zero-extends         -- into the 64-bit reg, in contrast to the 8 and 16-bit movs which@@ -513,7 +517,6 @@ interesting :: Platform -> Reg -> Bool interesting _        (RegVirtual _)              = True interesting platform (RegReal (RealRegSingle i)) = freeReg platform i-interesting _        (RegReal (RealRegPair{}))   = panic "X86.interesting: no reg pairs on this arch"   @@ -754,14 +757,7 @@         DELTA{}         -> True         _               -> False ------  TODO: why is there -- | Make a reg-reg move instruction.---      On SPARC v8 there are no instructions to move directly between---      floating point and integer regs. If we need to do that then we---      have to go via memory.--- mkRegRegMoveInstr     :: Platform     -> Reg@@ -803,6 +799,8 @@         = [JXX ALWAYS id]  -- Note [Windows stack layout]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~+ -- | On most OSes the kernel will place a guard page after the current stack --   page.  If you allocate larger than a page worth you may jump over this --   guard page.  Not only is this a security issue, but on certain OSes such@@ -859,7 +857,7 @@         --    there are no expectations for volatile registers.         --         -- 3. When the target is a local branch point it is re-targeted-        --    after the dealloc, preserving #2.  See note [extra spill slots].+        --    after the dealloc, preserving #2.  See Note [extra spill slots].         --         -- We emit a call because the stack probes are quite involved and         -- would bloat code size a lot.  GHC doesn't really have an -Os.@@ -904,9 +902,8 @@       _ -> panic "X86.mkStackDeallocInstr"  --- -- Note [extra spill slots]---+-- ~~~~~~~~~~~~~~~~~~~~~~~~ -- If the register allocator used more spill slots than we have -- pre-allocated (rESERVED_C_STACK_BYTES), then we must allocate more -- C stack space on entry and exit from this proc.  Therefore we@@ -956,7 +953,7 @@ allocMoreStack platform slots proc@(CmmProc info lbl live (ListGraph code)) = do     let entries = entryBlocks proc -    uniqs <- replicateM (length entries) getUniqueM+    uniqs <- getUniquesM      let       delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up
compiler/GHC/CmmToAsm/X86/Ppr.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE LambdaCase #-}  -----------------------------------------------------------------------------@@ -20,8 +20,6 @@  where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Platform@@ -45,18 +43,13 @@ import GHC.Types.Basic (Alignment, mkAlignment, alignmentBytes) import GHC.Types.Unique ( pprUniqueAlways ) -import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic  import Data.Word --- -------------------------------------------------------------------------------- Printing this stuff out------ -- Note [Subsections Via Symbols]---+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- If we are using the .subsections_via_symbols directive -- (available on recent versions of Darwin), -- we have to make sure that there is some kind of reference@@ -100,7 +93,7 @@       pprProcAlignment config $$       pprProcLabel config lbl $$       (if platformHasSubsectionsViaSymbols platform-          then pdoc platform (mkDeadStripPreventer info_lbl) <> char ':'+          then pdoc platform (mkDeadStripPreventer info_lbl) <> colon           else empty) $$       vcat (map (pprBasicBlock config top_info) blocks) $$       ppWhen (ncgDwarfEnabled config) (pprProcEndLabel platform info_lbl) $$@@ -120,25 +113,25 @@ pprProcLabel config lbl   | ncgExposeInternalSymbols config   , Just lbl' <- ppInternalProcLabel (ncgThisModule config) lbl-  = lbl' <> char ':'+  = lbl' <> colon   | otherwise   = empty  pprProcEndLabel :: Platform -> CLabel -- ^ Procedure name                 -> SDoc pprProcEndLabel platform lbl =-    pdoc platform (mkAsmTempProcEndLabel lbl) <> char ':'+    pdoc platform (mkAsmTempProcEndLabel lbl) <> colon  pprBlockEndLabel :: Platform -> CLabel -- ^ Block name                  -> SDoc pprBlockEndLabel platform lbl =-    pdoc platform (mkAsmTempEndLabel lbl) <> char ':'+    pdoc platform (mkAsmTempEndLabel lbl) <> colon  -- | Output the ELF .size directive. pprSizeDecl :: Platform -> CLabel -> SDoc pprSizeDecl platform lbl  = if osElfTarget (platformOS platform)-   then text "\t.size" <+> pdoc platform lbl <> ptext (sLit ", .-") <> pdoc platform lbl+   then text "\t.size" <+> pdoc platform lbl <> text ", .-" <> pdoc platform lbl    else empty  pprBasicBlock :: NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr -> SDoc@@ -163,17 +156,17 @@            vcat (map (pprData config) info) $$            pprLabel platform infoLbl $$            c $$-           ppWhen (ncgDwarfEnabled config) (pdoc platform (mkAsmTempEndLabel infoLbl) <> char ':')+           ppWhen (ncgDwarfEnabled config) (pdoc platform (mkAsmTempEndLabel infoLbl) <> colon)      -- Make sure the info table has the right .loc for the block-    -- coming right after it. See [Note: Info Offset]+    -- coming right after it. See Note [Info Offset]     infoTableLoc = case instrs of       (l@LOCATION{} : _) -> pprInstr platform l       _other             -> empty   pprDatas :: NCGConfig -> (Alignment, RawCmmStatics) -> SDoc--- See note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel".+-- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". pprDatas config (_, CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])   | lbl == mkIndStaticInfoLabel   , let labelInd (CmmLabelOff l _) = Just l@@ -267,14 +260,14 @@ pprTypeDecl :: Platform -> CLabel -> SDoc pprTypeDecl platform lbl     = if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl-      then text ".type " <> pdoc platform lbl <> ptext (sLit  ", ") <> pprLabelType' platform lbl+      then text ".type " <> pdoc platform lbl <> text ", " <> pprLabelType' platform lbl       else empty  pprLabel :: Platform -> CLabel -> SDoc pprLabel platform lbl =    pprGloblDecl platform lbl    $$ pprTypeDecl platform lbl-   $$ (pdoc platform lbl <> char ':')+   $$ (pdoc platform lbl <> colon)  pprAlign :: Platform -> Alignment -> SDoc pprAlign platform alignment@@ -298,7 +291,6 @@       RegReal    (RealRegSingle i) ->           if target32Bit platform then ppr32_reg_no f i                                   else ppr64_reg_no f i-      RegReal    (RealRegPair _ _) -> panic "X86.Ppr: no reg pairs on this arch"       RegVirtual (VirtualRegI  u)  -> text "%vI_"   <> pprUniqueAlways u       RegVirtual (VirtualRegHi u)  -> text "%vHi_"  <> pprUniqueAlways u       RegVirtual (VirtualRegF  u)  -> text "%vF_"   <> pprUniqueAlways u@@ -310,30 +302,30 @@     ppr32_reg_no II16  = ppr32_reg_word     ppr32_reg_no _     = ppr32_reg_long -    ppr32_reg_byte i = ptext-      (case i of {-         0 -> sLit "%al";     1 -> sLit "%bl";-         2 -> sLit "%cl";     3 -> sLit "%dl";-        _  -> sLit $ "very naughty I386 byte register: " ++ show i-      })+    ppr32_reg_byte i =+      case i of {+         0 -> text "%al";     1 -> text "%bl";+         2 -> text "%cl";     3 -> text "%dl";+        _  -> text "very naughty I386 byte register: " <> int i+      } -    ppr32_reg_word i = ptext-      (case i of {-         0 -> sLit "%ax";     1 -> sLit "%bx";-         2 -> sLit "%cx";     3 -> sLit "%dx";-         4 -> sLit "%si";     5 -> sLit "%di";-         6 -> sLit "%bp";     7 -> sLit "%sp";-        _  -> sLit "very naughty I386 word register"-      })+    ppr32_reg_word i =+      case i of {+         0 -> text "%ax";     1 -> text "%bx";+         2 -> text "%cx";     3 -> text "%dx";+         4 -> text "%si";     5 -> text "%di";+         6 -> text "%bp";     7 -> text "%sp";+        _  -> text "very naughty I386 word register"+      } -    ppr32_reg_long i = ptext-      (case i of {-         0 -> sLit "%eax";    1 -> sLit "%ebx";-         2 -> sLit "%ecx";    3 -> sLit "%edx";-         4 -> sLit "%esi";    5 -> sLit "%edi";-         6 -> sLit "%ebp";    7 -> sLit "%esp";+    ppr32_reg_long i =+      case i of {+         0 -> text "%eax";    1 -> text "%ebx";+         2 -> text "%ecx";    3 -> text "%edx";+         4 -> text "%esi";    5 -> text "%edi";+         6 -> text "%ebp";    7 -> text "%esp";          _  -> ppr_reg_float i-      })+      }      ppr64_reg_no :: Format -> Int -> SDoc     ppr64_reg_no II8   = ppr64_reg_byte@@ -341,101 +333,97 @@     ppr64_reg_no II32  = ppr64_reg_long     ppr64_reg_no _     = ppr64_reg_quad -    ppr64_reg_byte i = ptext-      (case i of {-         0 -> sLit "%al";     1 -> sLit "%bl";-         2 -> sLit "%cl";     3 -> sLit "%dl";-         4 -> sLit "%sil";    5 -> sLit "%dil"; -- new 8-bit regs!-         6 -> sLit "%bpl";    7 -> sLit "%spl";-         8 -> sLit "%r8b";    9  -> sLit "%r9b";-        10 -> sLit "%r10b";   11 -> sLit "%r11b";-        12 -> sLit "%r12b";   13 -> sLit "%r13b";-        14 -> sLit "%r14b";   15 -> sLit "%r15b";-        _  -> sLit $ "very naughty x86_64 byte register: " ++ show i-      })+    ppr64_reg_byte i =+      case i of {+         0 -> text "%al";      1 -> text "%bl";+         2 -> text "%cl";      3 -> text "%dl";+         4 -> text "%sil";     5 -> text "%dil"; -- new 8-bit regs!+         6 -> text "%bpl";     7 -> text "%spl";+         8 -> text "%r8b";     9 -> text "%r9b";+        10 -> text "%r10b";   11 -> text "%r11b";+        12 -> text "%r12b";   13 -> text "%r13b";+        14 -> text "%r14b";   15 -> text "%r15b";+        _  -> text "very naughty x86_64 byte register: " <> int i+      } -    ppr64_reg_word i = ptext-      (case i of {-         0 -> sLit "%ax";     1 -> sLit "%bx";-         2 -> sLit "%cx";     3 -> sLit "%dx";-         4 -> sLit "%si";     5 -> sLit "%di";-         6 -> sLit "%bp";     7 -> sLit "%sp";-         8 -> sLit "%r8w";    9  -> sLit "%r9w";-        10 -> sLit "%r10w";   11 -> sLit "%r11w";-        12 -> sLit "%r12w";   13 -> sLit "%r13w";-        14 -> sLit "%r14w";   15 -> sLit "%r15w";-        _  -> sLit "very naughty x86_64 word register"-      })+    ppr64_reg_word i =+      case i of {+         0 -> text "%ax";      1 -> text "%bx";+         2 -> text "%cx";      3 -> text "%dx";+         4 -> text "%si";      5 -> text "%di";+         6 -> text "%bp";      7 -> text "%sp";+         8 -> text "%r8w";     9 -> text "%r9w";+        10 -> text "%r10w";   11 -> text "%r11w";+        12 -> text "%r12w";   13 -> text "%r13w";+        14 -> text "%r14w";   15 -> text "%r15w";+        _  -> text "very naughty x86_64 word register"+      } -    ppr64_reg_long i = ptext-      (case i of {-         0 -> sLit "%eax";    1  -> sLit "%ebx";-         2 -> sLit "%ecx";    3  -> sLit "%edx";-         4 -> sLit "%esi";    5  -> sLit "%edi";-         6 -> sLit "%ebp";    7  -> sLit "%esp";-         8 -> sLit "%r8d";    9  -> sLit "%r9d";-        10 -> sLit "%r10d";   11 -> sLit "%r11d";-        12 -> sLit "%r12d";   13 -> sLit "%r13d";-        14 -> sLit "%r14d";   15 -> sLit "%r15d";-        _  -> sLit "very naughty x86_64 register"-      })+    ppr64_reg_long i =+      case i of {+         0 -> text "%eax";    1  -> text "%ebx";+         2 -> text "%ecx";    3  -> text "%edx";+         4 -> text "%esi";    5  -> text "%edi";+         6 -> text "%ebp";    7  -> text "%esp";+         8 -> text "%r8d";    9  -> text "%r9d";+        10 -> text "%r10d";   11 -> text "%r11d";+        12 -> text "%r12d";   13 -> text "%r13d";+        14 -> text "%r14d";   15 -> text "%r15d";+        _  -> text "very naughty x86_64 register"+      } -    ppr64_reg_quad i = ptext-      (case i of {-         0 -> sLit "%rax";      1 -> sLit "%rbx";-         2 -> sLit "%rcx";      3 -> sLit "%rdx";-         4 -> sLit "%rsi";      5 -> sLit "%rdi";-         6 -> sLit "%rbp";      7 -> sLit "%rsp";-         8 -> sLit "%r8";       9 -> sLit "%r9";-        10 -> sLit "%r10";    11 -> sLit "%r11";-        12 -> sLit "%r12";    13 -> sLit "%r13";-        14 -> sLit "%r14";    15 -> sLit "%r15";+    ppr64_reg_quad i =+      case i of {+         0 -> text "%rax";     1 -> text "%rbx";+         2 -> text "%rcx";     3 -> text "%rdx";+         4 -> text "%rsi";     5 -> text "%rdi";+         6 -> text "%rbp";     7 -> text "%rsp";+         8 -> text "%r8";      9 -> text "%r9";+        10 -> text "%r10";    11 -> text "%r11";+        12 -> text "%r12";    13 -> text "%r13";+        14 -> text "%r14";    15 -> text "%r15";         _  -> ppr_reg_float i-      })+      } -ppr_reg_float :: Int -> PtrString+ppr_reg_float :: Int -> SDoc ppr_reg_float i = case i of-        16 -> sLit "%xmm0" ;   17 -> sLit "%xmm1"-        18 -> sLit "%xmm2" ;   19 -> sLit "%xmm3"-        20 -> sLit "%xmm4" ;   21 -> sLit "%xmm5"-        22 -> sLit "%xmm6" ;   23 -> sLit "%xmm7"-        24 -> sLit "%xmm8" ;   25 -> sLit "%xmm9"-        26 -> sLit "%xmm10";   27 -> sLit "%xmm11"-        28 -> sLit "%xmm12";   29 -> sLit "%xmm13"-        30 -> sLit "%xmm14";   31 -> sLit "%xmm15"-        _  -> sLit "very naughty x86 register"+        16 -> text "%xmm0" ;   17 -> text "%xmm1"+        18 -> text "%xmm2" ;   19 -> text "%xmm3"+        20 -> text "%xmm4" ;   21 -> text "%xmm5"+        22 -> text "%xmm6" ;   23 -> text "%xmm7"+        24 -> text "%xmm8" ;   25 -> text "%xmm9"+        26 -> text "%xmm10";   27 -> text "%xmm11"+        28 -> text "%xmm12";   29 -> text "%xmm13"+        30 -> text "%xmm14";   31 -> text "%xmm15"+        _  -> text "very naughty x86 register"  pprFormat :: Format -> SDoc-pprFormat x- = ptext (case x of-                II8   -> sLit "b"-                II16  -> sLit "w"-                II32  -> sLit "l"-                II64  -> sLit "q"-                FF32  -> sLit "ss"      -- "scalar single-precision float" (SSE2)-                FF64  -> sLit "sd"      -- "scalar double-precision float" (SSE2)-                )+pprFormat x = case x of+  II8   -> text "b"+  II16  -> text "w"+  II32  -> text "l"+  II64  -> text "q"+  FF32  -> text "ss"      -- "scalar single-precision float" (SSE2)+  FF64  -> text "sd"      -- "scalar double-precision float" (SSE2)  pprFormat_x87 :: Format -> SDoc-pprFormat_x87 x-  = ptext $ case x of-                FF32  -> sLit "s"-                FF64  -> sLit "l"-                _     -> panic "X86.Ppr.pprFormat_x87"+pprFormat_x87 x = case x of+  FF32  -> text "s"+  FF64  -> text "l"+  _     -> panic "X86.Ppr.pprFormat_x87"   pprCond :: Cond -> SDoc-pprCond c- = ptext (case c of {-                GEU     -> sLit "ae";   LU    -> sLit "b";-                EQQ     -> sLit "e";    GTT   -> sLit "g";-                GE      -> sLit "ge";   GU    -> sLit "a";-                LTT     -> sLit "l";    LE    -> sLit "le";-                LEU     -> sLit "be";   NE    -> sLit "ne";-                NEG     -> sLit "s";    POS   -> sLit "ns";-                CARRY   -> sLit "c";   OFLO  -> sLit "o";-                PARITY  -> sLit "p";   NOTPARITY -> sLit "np";-                ALWAYS  -> sLit "mp"})+pprCond c = case c of {+  GEU     -> text "ae";   LU   -> text "b";+  EQQ     -> text "e";    GTT  -> text "g";+  GE      -> text "ge";   GU   -> text "a";+  LTT     -> text "l";    LE   -> text "le";+  LEU     -> text "be";   NE   -> text "ne";+  NEG     -> text "s";    POS  -> text "ns";+  CARRY   -> text "c";   OFLO  -> text "o";+  PARITY  -> text "p";   NOTPARITY -> text "np";+  ALWAYS  -> text "mp"}   pprImm :: Platform -> Imm -> SDoc@@ -562,7 +550,7 @@                   -- to 32-bit offset fields and modify the RTS                   -- appropriately                   ---                  -- See Note [x86-64-relative] in includes/rts/storage/InfoTables.h+                  -- See Note [x86-64-relative] in rts/include/rts/storage/InfoTables.h                   --                   case lit of                   -- A relative relocation:@@ -579,7 +567,7 @@ pprInstr :: Platform -> Instr -> SDoc pprInstr platform i = case i of    COMMENT s-      -> asmComment (ftext s)+      -> asmComment s     LOCATION file line col _name       -> text "\t.loc " <> ppr file <+> ppr line <+> ppr col@@ -624,70 +612,70 @@                 _    -> format     MOV format src dst-     -> pprFormatOpOp (sLit "mov") format src dst+     -> pprFormatOpOp (text "mov") format src dst     CMOV cc format src dst-     -> pprCondOpReg (sLit "cmov") format cc src dst+     -> pprCondOpReg (text "cmov") format cc src dst     MOVZxL II32 src dst-      -> pprFormatOpOp (sLit "mov") II32 src dst+      -> pprFormatOpOp (text "mov") II32 src dst         -- 32-to-64 bit zero extension on x86_64 is accomplished by a simple         -- movl.  But we represent it as a MOVZxL instruction, because         -- the reg alloc would tend to throw away a plain reg-to-reg         -- move, and we still want it to do that.     MOVZxL formats src dst-      -> pprFormatOpOpCoerce (sLit "movz") formats II32 src dst+      -> pprFormatOpOpCoerce (text "movz") formats II32 src dst         -- zero-extension only needs to extend to 32 bits: on x86_64,         -- the remaining zero-extension to 64 bits is automatic, and the 32-bit         -- instruction is shorter.     MOVSxL formats src dst-      -> pprFormatOpOpCoerce (sLit "movs") formats (archWordFormat (target32Bit platform)) src dst+      -> pprFormatOpOpCoerce (text "movs") formats (archWordFormat (target32Bit platform)) src dst     -- here we do some patching, since the physical registers are only set late    -- in the code generation.    LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3)       | reg1 == reg3-      -> pprFormatOpOp (sLit "add") format (OpReg reg2) dst+      -> pprFormatOpOp (text "add") format (OpReg reg2) dst     LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3)       | reg2 == reg3-      -> pprFormatOpOp (sLit "add") format (OpReg reg1) dst+      -> pprFormatOpOp (text "add") format (OpReg reg1) dst     LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) EAIndexNone displ)) dst@(OpReg reg3)       | reg1 == reg3       -> pprInstr platform (ADD format (OpImm displ) dst)     LEA format src dst-      -> pprFormatOpOp (sLit "lea") format src dst+      -> pprFormatOpOp (text "lea") format src dst     ADD format (OpImm (ImmInt (-1))) dst-      -> pprFormatOp (sLit "dec") format dst+      -> pprFormatOp (text "dec") format dst     ADD format (OpImm (ImmInt 1)) dst-      -> pprFormatOp (sLit "inc") format dst+      -> pprFormatOp (text "inc") format dst     ADD format src dst-      -> pprFormatOpOp (sLit "add") format src dst+      -> pprFormatOpOp (text "add") format src dst     ADC format src dst-      -> pprFormatOpOp (sLit "adc") format src dst+      -> pprFormatOpOp (text "adc") format src dst     SUB format src dst-      -> pprFormatOpOp (sLit "sub") format src dst+      -> pprFormatOpOp (text "sub") format src dst     SBB format src dst-      -> pprFormatOpOp (sLit "sbb") format src dst+      -> pprFormatOpOp (text "sbb") format src dst     IMUL format op1 op2-      -> pprFormatOpOp (sLit "imul") format op1 op2+      -> pprFormatOpOp (text "imul") format op1 op2     ADD_CC format src dst-      -> pprFormatOpOp (sLit "add") format src dst+      -> pprFormatOpOp (text "add") format src dst     SUB_CC format src dst-      -> pprFormatOpOp (sLit "sub") format src dst+      -> pprFormatOpOp (text "sub") format src dst     -- Use a 32-bit instruction when possible as it saves a byte.    -- Notably, extracting the tag bits of a pointer has this form.@@ -698,86 +686,86 @@       -> pprInstr platform (AND II32 src dst)     AND FF32 src dst-      -> pprOpOp (sLit "andps") FF32 src dst+      -> pprOpOp (text "andps") FF32 src dst     AND FF64 src dst-      -> pprOpOp (sLit "andpd") FF64 src dst+      -> pprOpOp (text "andpd") FF64 src dst     AND format src dst-      -> pprFormatOpOp (sLit "and") format src dst+      -> pprFormatOpOp (text "and") format src dst     OR  format src dst-      -> pprFormatOpOp (sLit "or")  format src dst+      -> pprFormatOpOp (text "or")  format src dst     XOR FF32 src dst-      -> pprOpOp (sLit "xorps") FF32 src dst+      -> pprOpOp (text "xorps") FF32 src dst     XOR FF64 src dst-      ->  pprOpOp (sLit "xorpd") FF64 src dst+      ->  pprOpOp (text "xorpd") FF64 src dst     XOR format src dst-      -> pprFormatOpOp (sLit "xor") format src dst+      -> pprFormatOpOp (text "xor") format src dst     POPCNT format src dst-      -> pprOpOp (sLit "popcnt") format src (OpReg dst)+      -> pprOpOp (text "popcnt") format src (OpReg dst)     LZCNT format src dst-      ->  pprOpOp (sLit "lzcnt") format src (OpReg dst)+      ->  pprOpOp (text "lzcnt") format src (OpReg dst)     TZCNT format src dst-      -> pprOpOp (sLit "tzcnt") format src (OpReg dst)+      -> pprOpOp (text "tzcnt") format src (OpReg dst)     BSF format src dst-      -> pprOpOp (sLit "bsf") format src (OpReg dst)+      -> pprOpOp (text "bsf") format src (OpReg dst)     BSR format src dst-      -> pprOpOp (sLit "bsr") format src (OpReg dst)+      -> pprOpOp (text "bsr") format src (OpReg dst)     PDEP format src mask dst-      -> pprFormatOpOpReg (sLit "pdep") format src mask dst+      -> pprFormatOpOpReg (text "pdep") format src mask dst     PEXT format src mask dst-      -> pprFormatOpOpReg (sLit "pext") format src mask dst+      -> pprFormatOpOpReg (text "pext") format src mask dst     PREFETCH NTA format src-      -> pprFormatOp_ (sLit "prefetchnta") format src+      -> pprFormatOp_ (text "prefetchnta") format src     PREFETCH Lvl0 format src-      -> pprFormatOp_ (sLit "prefetcht0") format src+      -> pprFormatOp_ (text "prefetcht0") format src     PREFETCH Lvl1 format src-      -> pprFormatOp_ (sLit "prefetcht1") format src+      -> pprFormatOp_ (text "prefetcht1") format src     PREFETCH Lvl2 format src-      -> pprFormatOp_ (sLit "prefetcht2") format src+      -> pprFormatOp_ (text "prefetcht2") format src     NOT format op-      -> pprFormatOp (sLit "not") format op+      -> pprFormatOp (text "not") format op     BSWAP format op-      -> pprFormatOp (sLit "bswap") format (OpReg op)+      -> pprFormatOp (text "bswap") format (OpReg op)     NEGI format op-      -> pprFormatOp (sLit "neg") format op+      -> pprFormatOp (text "neg") format op     SHL format src dst-      -> pprShift (sLit "shl") format src dst+      -> pprShift (text "shl") format src dst     SAR format src dst-      -> pprShift (sLit "sar") format src dst+      -> pprShift (text "sar") format src dst     SHR format src dst-      -> pprShift (sLit "shr") format src dst+      -> pprShift (text "shr") format src dst     BT format imm src-      -> pprFormatImmOp (sLit "bt") format imm src+      -> pprFormatImmOp (text "bt") format imm src     CMP format src dst-     | isFloatFormat format -> pprFormatOpOp (sLit "ucomi") format src dst -- SSE2-     | otherwise            -> pprFormatOpOp (sLit "cmp")   format src dst+     | isFloatFormat format -> pprFormatOpOp (text "ucomi") format src dst -- SSE2+     | otherwise            -> pprFormatOpOp (text "cmp")   format src dst     TEST format src dst-      -> pprFormatOpOp (sLit "test") format' src dst+      -> pprFormatOpOp (text "test") format' src dst          where         -- Match instructions like 'test $0x3,%esi' or 'test $0x7,%rbx'.         -- We can replace them by equivalent, but smaller instructions@@ -800,10 +788,10 @@           minSizeOfReg _ _ = format                 -- other     PUSH format op-      -> pprFormatOp (sLit "push") format op+      -> pprFormatOp (text "push") format op     POP format op-      -> pprFormatOp (sLit "pop") format op+      -> pprFormatOp (text "pop") format op  -- both unused (SDM): -- PUSHA -> text "\tpushal"@@ -828,17 +816,17 @@       -> panic $ "pprInstr: CLTD " ++ show x     SETCC cond op-      -> pprCondInstr (sLit "set") cond (pprOperand platform II8 op)+      -> pprCondInstr (text "set") cond (pprOperand platform II8 op)     XCHG format src val-      -> pprFormatOpReg (sLit "xchg") format src val+      -> pprFormatOpReg (text "xchg") format src val     JXX cond blockid-      -> pprCondInstr (sLit "j") cond (pdoc platform lab)+      -> pprCondInstr (text "j") cond (pdoc platform lab)          where lab = blockLbl blockid     JXX_GBL cond imm-      -> pprCondInstr (sLit "j") cond (pprImm platform imm)+      -> pprCondInstr (text "j") cond (pprImm platform imm)     JMP (OpImm imm) _       -> text "\tjmp " <> pprImm platform imm@@ -856,44 +844,44 @@       -> text "\tcall *" <> pprReg platform (archWordFormat (target32Bit platform)) reg     IDIV fmt op-      -> pprFormatOp (sLit "idiv") fmt op+      -> pprFormatOp (text "idiv") fmt op     DIV fmt op-      -> pprFormatOp (sLit "div")  fmt op+      -> pprFormatOp (text "div")  fmt op     IMUL2 fmt op-      -> pprFormatOp (sLit "imul") fmt op+      -> pprFormatOp (text "imul") fmt op     -- x86_64 only    MUL format op1 op2-      -> pprFormatOpOp (sLit "mul") format op1 op2+      -> pprFormatOpOp (text "mul") format op1 op2     MUL2 format op-      -> pprFormatOp (sLit "mul") format op+      -> pprFormatOp (text "mul") format op     FDIV format op1 op2-      -> pprFormatOpOp (sLit "div") format op1 op2+      -> pprFormatOpOp (text "div") format op1 op2     SQRT format op1 op2-      -> pprFormatOpReg (sLit "sqrt") format op1 op2+      -> pprFormatOpReg (text "sqrt") format op1 op2     CVTSS2SD from to-      -> pprRegReg (sLit "cvtss2sd") from to+      -> pprRegReg (text "cvtss2sd") from to     CVTSD2SS from to-      -> pprRegReg (sLit "cvtsd2ss") from to+      -> pprRegReg (text "cvtsd2ss") from to     CVTTSS2SIQ fmt from to-      -> pprFormatFormatOpReg (sLit "cvttss2si") FF32 fmt from to+      -> pprFormatFormatOpReg (text "cvttss2si") FF32 fmt from to     CVTTSD2SIQ fmt from to-      -> pprFormatFormatOpReg (sLit "cvttsd2si") FF64 fmt from to+      -> pprFormatFormatOpReg (text "cvttsd2si") FF64 fmt from to     CVTSI2SS fmt from to-      -> pprFormatOpReg (sLit "cvtsi2ss") fmt from to+      -> pprFormatOpReg (text "cvtsi2ss") fmt from to     CVTSI2SD fmt from to-      -> pprFormatOpReg (sLit "cvtsi2sd") fmt from to+      -> pprFormatOpReg (text "cvtsi2sd") fmt from to         -- FETCHGOT for PIC on ELF platforms    FETCHGOT reg@@ -925,10 +913,10 @@       -> text "\tmfence"     XADD format src dst-      -> pprFormatOpOp (sLit "xadd") format src dst+      -> pprFormatOpOp (text "xadd") format src dst     CMPXCHG format src dst-      -> pprFormatOpOp (sLit "cmpxchg") format src dst+      -> pprFormatOpOp (text "cmpxchg") format src dst     where@@ -945,7 +933,7 @@       = (char '#' <> pprX87Instr fake) $$ actual     pprX87Instr :: Instr -> SDoc-   pprX87Instr (X87Store fmt dst) = pprFormatAddr (sLit "gst") fmt dst+   pprX87Instr (X87Store fmt dst) = pprFormatAddr (text "gst") fmt dst    pprX87Instr _ = panic "X86.Ppr.pprX87Instr: no match"     pprDollImm :: Imm -> SDoc@@ -959,17 +947,17 @@       OpAddr ea -> pprAddr platform ea  -   pprMnemonic_  :: PtrString -> SDoc+   pprMnemonic_  :: SDoc -> SDoc    pprMnemonic_ name =-      char '\t' <> ptext name <> space+      char '\t' <> name <> space  -   pprMnemonic  :: PtrString -> Format -> SDoc+   pprMnemonic  :: SDoc -> Format -> SDoc    pprMnemonic name format =-      char '\t' <> ptext name <> pprFormat format <> space+      char '\t' <> name <> pprFormat format <> space  -   pprFormatImmOp :: PtrString -> Format -> Imm -> Operand -> SDoc+   pprFormatImmOp :: SDoc -> Format -> Imm -> Operand -> SDoc    pprFormatImmOp name format imm op1      = hcat [            pprMnemonic name format,@@ -980,14 +968,14 @@        ]  -   pprFormatOp_ :: PtrString -> Format -> Operand -> SDoc+   pprFormatOp_ :: SDoc -> Format -> Operand -> SDoc    pprFormatOp_ name format op1      = hcat [            pprMnemonic_ name ,            pprOperand platform format op1        ] -   pprFormatOp :: PtrString -> Format -> Operand -> SDoc+   pprFormatOp :: SDoc -> Format -> Operand -> SDoc    pprFormatOp name format op1      = hcat [            pprMnemonic name format,@@ -995,7 +983,7 @@        ]  -   pprFormatOpOp :: PtrString -> Format -> Operand -> Operand -> SDoc+   pprFormatOpOp :: SDoc -> Format -> Operand -> Operand -> SDoc    pprFormatOpOp name format op1 op2      = hcat [            pprMnemonic name format,@@ -1005,7 +993,7 @@        ]  -   pprOpOp :: PtrString -> Format -> Operand -> Operand -> SDoc+   pprOpOp :: SDoc -> Format -> Operand -> Operand -> SDoc    pprOpOp name format op1 op2      = hcat [            pprMnemonic_ name,@@ -1014,7 +1002,7 @@            pprOperand platform format op2        ] -   pprRegReg :: PtrString -> Reg -> Reg -> SDoc+   pprRegReg :: SDoc -> Reg -> Reg -> SDoc    pprRegReg name reg1 reg2      = hcat [            pprMnemonic_ name,@@ -1024,7 +1012,7 @@        ]  -   pprFormatOpReg :: PtrString -> Format -> Operand -> Reg -> SDoc+   pprFormatOpReg :: SDoc -> Format -> Operand -> Reg -> SDoc    pprFormatOpReg name format op1 reg2      = hcat [            pprMnemonic name format,@@ -1033,11 +1021,11 @@            pprReg platform (archWordFormat (target32Bit platform)) reg2        ] -   pprCondOpReg :: PtrString -> Format -> Cond -> Operand -> Reg -> SDoc+   pprCondOpReg :: SDoc -> Format -> Cond -> Operand -> Reg -> SDoc    pprCondOpReg name format cond op1 reg2      = hcat [            char '\t',-           ptext name,+           name,            pprCond cond,            space,            pprOperand platform format op1,@@ -1045,7 +1033,7 @@            pprReg platform format reg2        ] -   pprFormatFormatOpReg :: PtrString -> Format -> Format -> Operand -> Reg -> SDoc+   pprFormatFormatOpReg :: SDoc -> Format -> Format -> Operand -> Reg -> SDoc    pprFormatFormatOpReg name format1 format2 op1 reg2      = hcat [            pprMnemonic name format2,@@ -1054,7 +1042,7 @@            pprReg platform format2 reg2        ] -   pprFormatOpOpReg :: PtrString -> Format -> Operand -> Operand -> Reg -> SDoc+   pprFormatOpOpReg :: SDoc -> Format -> Operand -> Operand -> Reg -> SDoc    pprFormatOpOpReg name format op1 op2 reg3      = hcat [            pprMnemonic name format,@@ -1067,7 +1055,7 @@   -   pprFormatAddr :: PtrString -> Format -> AddrMode -> SDoc+   pprFormatAddr :: SDoc -> Format -> AddrMode -> SDoc    pprFormatAddr name format  op      = hcat [            pprMnemonic name format,@@ -1075,7 +1063,7 @@            pprAddr platform op        ] -   pprShift :: PtrString -> Format -> Operand -> Operand -> SDoc+   pprShift :: SDoc -> Format -> Operand -> Operand -> SDoc    pprShift name format src dest      = hcat [            pprMnemonic name format,@@ -1085,15 +1073,15 @@        ]  -   pprFormatOpOpCoerce :: PtrString -> Format -> Format -> Operand -> Operand -> SDoc+   pprFormatOpOpCoerce :: SDoc -> Format -> Format -> Operand -> Operand -> SDoc    pprFormatOpOpCoerce name format1 format2 op1 op2-     = hcat [ char '\t', ptext name, pprFormat format1, pprFormat format2, space,+     = hcat [ char '\t', name, pprFormat format1, pprFormat format2, space,            pprOperand platform format1 op1,            comma,            pprOperand platform format2 op2        ]  -   pprCondInstr :: PtrString -> Cond -> SDoc -> SDoc+   pprCondInstr :: SDoc -> Cond -> SDoc -> SDoc    pprCondInstr name cond arg-     = hcat [ char '\t', ptext name, pprCond cond, space, arg]+     = hcat [ char '\t', name, pprCond cond, space, arg]
compiler/GHC/CmmToAsm/X86/RegInfo.hs view
@@ -1,12 +1,10 @@-{-# LANGUAGE CPP #-}+ module GHC.CmmToAsm.X86.RegInfo (         mkVirtualReg,         regDotColor )  where--#include "GhclibHsVersions.h"  import GHC.Prelude
compiler/GHC/CmmToAsm/X86/Regs.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + module GHC.CmmToAsm.X86.Regs (         -- squeese functions for the graph allocator         virtualRegSqueeze,@@ -47,8 +47,6 @@  where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Platform.Regs@@ -98,17 +96,12 @@                         | regNo < firstxmm -> 1                         | otherwise     -> 0 -                RealRegPair{}           -> 0-         RcDouble          -> case rr of                 RealRegSingle regNo                         | regNo >= firstxmm  -> 1                         | otherwise     -> 0 -                RealRegPair{}           -> 0--         _other -> 0  -- -----------------------------------------------------------------------------@@ -251,7 +244,6 @@             | i <= lastint platform -> RcInteger             | i <= lastxmm platform -> RcDouble             | otherwise             -> panic "X86.Reg.classOfRealReg registerSingle too high"-        _   -> panic "X86.Regs.classOfRealReg: RegPairs on this arch"  -- | Get the name of the register with this number. -- NOTE: fixme, we dont track which "way" the XMM registers are used
compiler/GHC/CmmToC.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP           #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GADTs         #-} {-# LANGUAGE LambdaCase    #-}@@ -26,14 +25,14 @@    ) where -#include "GhclibHsVersions.h"---- Cmm stuff import GHC.Prelude +import GHC.Platform++import GHC.CmmToAsm.CPrim+ import GHC.Cmm.BlockId import GHC.Cmm.CLabel-import GHC.Types.ForeignCall import GHC.Cmm hiding (pprBBlock) import GHC.Cmm.Ppr () -- For Outputable instances import GHC.Cmm.Dataflow.Block@@ -41,32 +40,26 @@ import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Utils import GHC.Cmm.Switch+import GHC.Cmm.InitFini --- Utils-import GHC.CmmToAsm.CPrim-import GHC.Driver.Session-import GHC.Driver.Ppr-import GHC.Data.FastString-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Platform+import GHC.Types.ForeignCall import GHC.Types.Unique.Set import GHC.Types.Unique.FM import GHC.Types.Unique++import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Utils.Misc+import GHC.Utils.Trace --- The rest import Data.ByteString (ByteString) import qualified Data.ByteString as BS-import Control.Monad.ST import Data.Char import Data.List (intersperse) import Data.Map (Map)-import Data.Word import qualified Data.Map as Map import Control.Monad (ap)-import qualified Data.Array.Unsafe as U ( castSTUArray )-import Data.Array.ST+import GHC.Float  -- -------------------------------------------------------------------------- -- Now do some real work@@ -108,6 +101,9 @@    -- We only handle (a) arrays of word-sized things and (b) strings. +  cmm_data | Just (initOrFini, clbls) <- isInitOrFiniArray cmm_data ->+    pprCtorArray platform initOrFini clbls+   (CmmData section (CmmStaticsRaw lbl [CmmString str])) ->     pprExternDecl platform lbl $$     hcat [@@ -172,6 +168,7 @@      text "__attribute__((aligned(" <> int (widthInBytes words) <> text ")))"  -- Note [StgWord alignment]+-- ~~~~~~~~~~~~~~~~~~~~~~~~ -- C codegen builds static closures as StgWord C arrays (pprWordArray). -- Their real C type is 'StgClosure'. Macros like UNTAG_CLOSURE assume -- pointers to 'StgClosure' are aligned at pointer size boundary:@@ -207,7 +204,7 @@ pprStmt platform stmt =     case stmt of     CmmEntry{}   -> empty-    CmmComment _ -> empty -- (hang (text "/*") 3 (ftext s)) $$ ptext (sLit "*/")+    CmmComment _ -> empty -- (hang (text "/*") 3 (ftext s)) $$ text "*/"                           -- XXX if the string contains "*/", we need to fix it                           -- XXX we probably want to emit these comments when                           -- some debugging option is on.  They can get quite@@ -221,7 +218,7 @@     CmmStore  dest src align         | typeWidth rep == W64 && wordWidth platform /= W64         -> (if isFloatType rep then text "ASSIGN_DBL"-                               else ptext (sLit ("ASSIGN_Word64"))) <>+                               else text "ASSIGN_Word64") <>            parens (mkP_ <> pprExpr1 platform dest <> comma <> pprExpr platform src) <> semi          | otherwise@@ -272,12 +269,17 @@         hresults = zip results res_hints         hargs    = zip args arg_hints +        need_cdecl+          | MO_ResumeThread  <- op                 = True+          | MO_SuspendThread <- op                 = True+          | otherwise                              = False+         fn_call           -- The mem primops carry an extra alignment arg.           -- We could maybe emit an alignment directive using this info.           -- We also need to cast mem primops to prevent conflicts with GCC           -- builtins (see bug #5967).-          | Just _align <- machOpMemcpyishAlign op+          | need_cdecl           = (text ";EFF_(" <> fn <> char ')' <> semi) $$             pprForeignCall platform fn cconv hresults hargs           | otherwise@@ -340,21 +342,23 @@   where     (pairs, mbdef) = switchTargetsFallThrough ids +    rep = typeWidth (cmmExprType platform e)+     -- fall through case     caseify (ix:ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix         where         do_fallthrough ix =-                 hsep [ text "case" , pprHexVal platform ix (wordWidth platform) <> colon ,+                 hsep [ text "case" , pprHexVal platform ix rep <> colon ,                         text "/* fall through */" ]          final_branch ix =-                hsep [ text "case" , pprHexVal platform ix (wordWidth platform) <> colon ,+                hsep [ text "case" , pprHexVal platform ix rep <> colon ,                        text "goto" , (pprBlockId ident) <> semi ]      caseify (_     , _    ) = panic "pprSwitch: switch with no cases!"      def | Just l <- mbdef = text "default: goto" <+> pprBlockId l <> semi-        | otherwise       = empty+        | otherwise       = text "default: __builtin_unreachable();"  -- --------------------------------------------------------------------- -- Expressions.@@ -493,7 +497,7 @@     -- resultRepOfMachOp says).   | isComparisonMachOp mop = Just mkW_ -    -- See Note [Zero-extended sub-word signed results]+    -- See Note [Zero-extending sub-word signed results]   | signedOp mop   , res_ty <- machOpResultType platform mop args   , not $ isFloatType res_ty -- only integer operations, not MO_SF_Conv@@ -634,14 +638,15 @@     -- single-word (or smaller) literals.     decomposeMultiWord :: CmmLit -> [CmmLit]     decomposeMultiWord (CmmFloat n W64)-      -- This will produce a W64 integer, which will then be broken up further-      -- on the next iteration on 32-bit platforms.-      = [doubleToWord64 n]+      | W32 <- wordWidth platform = decomposeMultiWord (doubleToWord64 n)+      | otherwise = [doubleToWord64 n]     decomposeMultiWord (CmmFloat n W32)       = [floatToWord32 n]     decomposeMultiWord (CmmInt n W64)       | W32 <- wordWidth platform-      = [CmmInt hi W32, CmmInt lo W32]+      = case platformByteOrder platform of+          BigEndian -> [CmmInt hi W32, CmmInt lo W32]+          LittleEndian -> [CmmInt lo W32, CmmInt hi W32]       where         hi = n `shiftR` 32         lo = n .&. 0xffffffff@@ -926,24 +931,28 @@         MO_F32_Fabs     -> text "fabsf"         MO_ReadBarrier  -> text "load_load_barrier"         MO_WriteBarrier -> text "write_barrier"-        MO_Memcpy _     -> text "memcpy"-        MO_Memset _     -> text "memset"-        MO_Memmove _    -> text "memmove"-        MO_Memcmp _     -> text "memcmp"-        (MO_BSwap w)    -> ptext (sLit $ bSwapLabel w)-        (MO_BRev w)     -> ptext (sLit $ bRevLabel w)-        (MO_PopCnt w)   -> ptext (sLit $ popCntLabel w)-        (MO_Pext w)     -> ptext (sLit $ pextLabel w)-        (MO_Pdep w)     -> ptext (sLit $ pdepLabel w)-        (MO_Clz w)      -> ptext (sLit $ clzLabel w)-        (MO_Ctz w)      -> ptext (sLit $ ctzLabel w)-        (MO_AtomicRMW w amop) -> ptext (sLit $ atomicRMWLabel w amop)-        (MO_Cmpxchg w)  -> ptext (sLit $ cmpxchgLabel w)-        (MO_Xchg w)     -> ptext (sLit $ xchgLabel w)-        (MO_AtomicRead w)  -> ptext (sLit $ atomicReadLabel w)-        (MO_AtomicWrite w) -> ptext (sLit $ atomicWriteLabel w)-        (MO_UF_Conv w)  -> ptext (sLit $ word2FloatLabel w)+        MO_Memcpy _     -> text "__builtin_memcpy"+        MO_Memset _     -> text "__builtin_memset"+        MO_Memmove _    -> text "__builtin_memmove"+        MO_Memcmp _     -> text "__builtin_memcmp" +        MO_SuspendThread -> text "suspendThread"+        MO_ResumeThread  -> text "resumeThread"++        MO_BSwap w          -> ftext (bSwapLabel w)+        MO_BRev w           -> ftext (bRevLabel w)+        MO_PopCnt w         -> ftext (popCntLabel w)+        MO_Pext w           -> ftext (pextLabel w)+        MO_Pdep w           -> ftext (pdepLabel w)+        MO_Clz w            -> ftext (clzLabel w)+        MO_Ctz w            -> ftext (ctzLabel w)+        MO_AtomicRMW w amop -> ftext (atomicRMWLabel w amop)+        MO_Cmpxchg w        -> ftext (cmpxchgLabel w)+        MO_Xchg w           -> ftext (xchgLabel w)+        MO_AtomicRead w     -> ftext (atomicReadLabel w)+        MO_AtomicWrite w    -> ftext (atomicWriteLabel w)+        MO_UF_Conv w        -> ftext (word2FloatLabel w)+         MO_S_Mul2     {} -> unsupported         MO_S_QuotRem  {} -> unsupported         MO_U_QuotRem  {} -> unsupported@@ -1003,7 +1012,7 @@ mkFN_  i = text "FN_"  <> parens i -- externally visible function mkIF_  i = text "IF_"  <> parens i -- locally visible --- from includes/Stg.h+-- from rts/include/Stg.h -- mkC_,mkW_,mkP_ :: SDoc @@ -1107,7 +1116,7 @@  pprAsPtrReg :: CmmReg -> SDoc pprAsPtrReg (CmmGlobal (VanillaReg n gcp))-  = WARN( gcp /= VGcPtr, ppr n ) char 'R' <> int n <> text ".p"+  = warnPprTrace (gcp /= VGcPtr) "pprAsPtrReg" (ppr n) $ char 'R' <> int n <> text ".p" pprAsPtrReg other_reg = pprReg other_reg  pprGlobalReg :: GlobalReg -> SDoc@@ -1310,8 +1319,6 @@           bewareLoadStoreAlignment ArchMipsel   = True           bewareLoadStoreAlignment (ArchARM {}) = True           bewareLoadStoreAlignment ArchAArch64  = True-          bewareLoadStoreAlignment ArchSPARC    = True-          bewareLoadStoreAlignment ArchSPARC64  = True           -- Pessimistically assume that they will also cause problems           -- on unknown arches           bewareLoadStoreAlignment ArchUnknown  = True@@ -1404,28 +1411,10 @@ -- can safely initialise to static locations.  floatToWord32 :: Rational -> CmmLit-floatToWord32 r-  = runST $ do-        arr <- newArray_ ((0::Int),0)-        writeArray arr 0 (fromRational r)-        arr' <- castFloatToWord32Array arr-        w32 <- readArray arr' 0-        return (CmmInt (toInteger w32) W32)-  where-    castFloatToWord32Array :: STUArray s Int Float -> ST s (STUArray s Int Word32)-    castFloatToWord32Array = U.castSTUArray+floatToWord32 r = CmmInt (toInteger (castFloatToWord32 (fromRational r))) W32  doubleToWord64 :: Rational -> CmmLit-doubleToWord64 r-  = runST $ do-        arr <- newArray_ ((0::Int),1)-        writeArray arr 0 (fromRational r)-        arr' <- castDoubleToWord64Array arr-        w64 <- readArray arr' 0-        return $ CmmInt (toInteger w64) W64-  where-    castDoubleToWord64Array :: STUArray s Int Double -> ST s (STUArray s Int Word64)-    castDoubleToWord64Array = U.castSTUArray+doubleToWord64 r = CmmInt (toInteger (castDoubleToWord64 (fromRational r))) W64   -- ---------------------------------------------------------------------------@@ -1502,3 +1491,19 @@              (q,r) = w' `quotRem` 16              dig | r < 10    = char (chr (fromInteger r + ord '0'))                  | otherwise = char (chr (fromInteger r - 10 + ord 'a'))++-- | Construct a constructor/finalizer function. Instead of emitting a+-- initializer/finalizer array we rather just emit a single function, annotated+-- with the appropriate C attribute, which then calls each of the initializers.+pprCtorArray :: Platform -> InitOrFini -> [CLabel] -> SDoc+pprCtorArray platform initOrFini lbls =+       decls+    <> text "static __attribute__((" <> attribute <> text "))"+    <> text "void _hs_" <> attribute <> text "()"+    <> braces body+  where+    body = vcat [ pprCLabel platform CStyle lbl <> text " ();" | lbl <- lbls ]+    decls = vcat [ text "void" <+> pprCLabel platform CStyle lbl <> text " (void);" | lbl <- lbls ]+    attribute = case initOrFini of+                  IsInitArray -> text "constructor"+                  IsFiniArray -> text "destructor"
compiler/GHC/CmmToLlvm.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, TypeFamilies, ViewPatterns, OverloadedStrings #-}+{-# LANGUAGE TypeFamilies, ViewPatterns, OverloadedStrings #-}  -- ----------------------------------------------------------------------------- -- | This is the top-level module in the LLVM code generator.@@ -11,13 +11,12 @@    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Llvm import GHC.CmmToLlvm.Base import GHC.CmmToLlvm.CodeGen+import GHC.CmmToLlvm.Config import GHC.CmmToLlvm.Data import GHC.CmmToLlvm.Ppr import GHC.CmmToLlvm.Regs@@ -36,7 +35,6 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Logger-import GHC.SysTools ( figureLlvmVersion ) import qualified GHC.Data.Stream as Stream  import Control.Monad ( when, forM_ )@@ -46,33 +44,33 @@ -- ----------------------------------------------------------------------------- -- | Top-level of the LLVM Code generator ---llvmCodeGen :: Logger -> DynFlags -> Handle+llvmCodeGen :: Logger -> LlvmCgConfig -> Handle                -> Stream.Stream IO RawCmmGroup a                -> IO a-llvmCodeGen logger dflags h cmm_stream-  = withTiming logger dflags (text "LLVM CodeGen") (const ()) $ do+llvmCodeGen logger cfg h cmm_stream+  = withTiming logger (text "LLVM CodeGen") (const ()) $ do        bufh <- newBufHandle h         -- Pass header-       showPass logger dflags "LLVM CodeGen"+       showPass logger "LLVM CodeGen"         -- get llvm version, cache for later use-       mb_ver <- figureLlvmVersion logger dflags+       let mb_ver = llvmCgLlvmVersion cfg         -- warn if unsupported        forM_ mb_ver $ \ver -> do-         debugTraceMsg logger dflags 2+         debugTraceMsg logger 2               (text "Using LLVM version:" <+> text (llvmVersionStr ver))-         let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags-         when (not (llvmVersionSupported ver) && doWarn) $ putMsg logger dflags $+         let doWarn = llvmCgDoWarn cfg+         when (not (llvmVersionSupported ver) && doWarn) $ putMsg logger $            "You are using an unsupported version of LLVM!" $$            "Currently only" <+> text (llvmVersionStr supportedLlvmVersionLowerBound) <+>-           "to" <+> text (llvmVersionStr supportedLlvmVersionUpperBound) <+> "is supported." <+>+           "up to" <+> text (llvmVersionStr supportedLlvmVersionUpperBound) <+> "(non inclusive) is supported." <+>            "System LLVM version: " <> text (llvmVersionStr ver) $$            "We will try though..."-         let isS390X = platformArch (targetPlatform dflags) == ArchS390X+         let isS390X = platformArch (llvmCgPlatform cfg)  == ArchS390X          let major_ver = head . llvmVersionList $ ver-         when (isS390X && major_ver < 10 && doWarn) $ putMsg logger dflags $+         when (isS390X && major_ver < 10 && doWarn) $ putMsg logger $            "Warning: For s390x the GHC calling convention is only supported since LLVM version 10." <+>            "You are using LLVM version: " <> text (llvmVersionStr ver) @@ -83,15 +81,15 @@            llvm_ver = fromMaybe supportedLlvmVersionLowerBound mb_ver         -- run code generation-       a <- runLlvm logger dflags llvm_ver bufh $-         llvmCodeGen' dflags cmm_stream+       a <- runLlvm logger cfg llvm_ver bufh $+         llvmCodeGen' cfg cmm_stream         bFlush bufh         return a -llvmCodeGen' :: DynFlags -> Stream.Stream IO RawCmmGroup a -> LlvmM a-llvmCodeGen' dflags cmm_stream+llvmCodeGen' :: LlvmCgConfig -> Stream.Stream IO RawCmmGroup a -> LlvmM a+llvmCodeGen' cfg cmm_stream   = do  -- Preamble         renderLlvm header         ghcInternalFunctions@@ -101,8 +99,7 @@         a <- Stream.consume cmm_stream liftIO llvmGroupLlvmGens          -- Declare aliases for forward references-        opts <- getLlvmOpts-        renderLlvm . pprLlvmData opts =<< generateExternDecls+        renderLlvm . pprLlvmData cfg =<< generateExternDecls          -- Postamble         cmmUsedLlvmGens@@ -111,8 +108,9 @@   where     header :: SDoc     header =-      let target = platformMisc_llvmTarget $ platformMisc dflags-      in     text ("target datalayout = \"" ++ getDataLayout (llvmConfig dflags) target ++ "\"")+      let target  = llvmCgLlvmTarget cfg+          llvmCfg = llvmCgLlvmConfig cfg+      in     text ("target datalayout = \"" ++ getDataLayout llvmCfg target ++ "\"")          $+$ text ("target triple = \"" ++ target ++ "\"")      getDataLayout :: LlvmConfig -> String -> String@@ -160,8 +158,8 @@        mapM_ regGlobal gs        gss' <- mapM aliasify $ gs -       opts <- getLlvmOpts-       renderLlvm $ pprLlvmData opts (concat gss', concat tss)+       cfg <- getConfig+       renderLlvm $ pprLlvmData cfg (concat gss', concat tss)  -- | Complete LLVM code generation phase for a single top-level chunk of Cmm. cmmLlvmGen ::RawCmmDecl -> LlvmM ()@@ -205,8 +203,8 @@               -- just a name on its own. Previously `null` was accepted as the               -- name.               Nothing -> [ MetaStr name ]-  opts <- getLlvmOpts-  renderLlvm $ ppLlvmMetas opts metas+  cfg <- getConfig+  renderLlvm $ ppLlvmMetas cfg metas  -- ----------------------------------------------------------------------------- -- | Marks variables as used where necessary@@ -224,12 +222,11 @@   -- Which is the LLVM way of protecting them against getting removed.   ivars <- getUsedVars   let cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr-      ty     = (LMArray (length ivars) i8Ptr)+      ty     = LMArray (length ivars) i8Ptr       usedArray = LMStaticArray (map cast ivars) ty       sectName  = Just $ fsLit "llvm.metadata"       lmUsedVar = LMGlobalVar (fsLit "llvm.used") ty Appending sectName Nothing Constant       lmUsed    = LMGlobal lmUsedVar (Just usedArray)-  opts <- getLlvmOpts   if null ivars      then return ()-     else renderLlvm $ pprLlvmData opts ([lmUsed], [])+     else getConfig >>= renderLlvm . flip pprLlvmData ([lmUsed], [])
compiler/GHC/CmmToLlvm/Base.hs view
@@ -22,9 +22,9 @@         LlvmM,         runLlvm, withClearVars, varLookup, varInsert,         markStackReg, checkStackReg,-        funLookup, funInsert, getLlvmVer, getDynFlags,+        funLookup, funInsert, getLlvmVer,         dumpIfSetLlvm, renderLlvm, markUsedVar, getUsedVars,-        ghcInternalFunctions, getPlatform, getLlvmOpts,+        ghcInternalFunctions, getPlatform, getConfig,          getMetaUniqueId,         setUniqMeta, getUniqMeta, liftIO,@@ -39,14 +39,14 @@         aliasify, llvmDefLabel     ) where -#include "GhclibHsVersions.h"-#include "ghcautoconf.h"+#include "ghc-llvm-version.h"  import GHC.Prelude import GHC.Utils.Panic  import GHC.Llvm import GHC.CmmToLlvm.Regs+import GHC.CmmToLlvm.Config  import GHC.Cmm.CLabel import GHC.Cmm.Ppr.Expr ()@@ -150,10 +150,10 @@ llvmInfAlign platform = Just (platformWordSizeInBytes platform)  -- | Section to use for a function-llvmFunSection :: LlvmOpts -> LMString -> LMSection+llvmFunSection :: LlvmCgConfig -> LMString -> LMSection llvmFunSection opts lbl-    | llvmOptsSplitSections opts = Just (concatFS [fsLit ".text.", lbl])-    | otherwise                  = Nothing+    | llvmCgSplitSection opts = Just (concatFS [fsLit ".text.", lbl])+    | otherwise               = Nothing  -- | A Function's arguments llvmFunArgs :: Platform -> LiveGlobalRegs -> [LlvmVar]@@ -264,9 +264,6 @@ -- * Llvm Version -- -newtype LlvmVersion = LlvmVersion { llvmVersionNE :: NE.NonEmpty Int }-  deriving (Eq, Ord)- parseLlvmVersion :: String -> Maybe LlvmVersion parseLlvmVersion =     fmap LlvmVersion . NE.nonEmpty . go [] . dropWhile (not . isDigit)@@ -304,21 +301,20 @@ --  data LlvmEnv = LlvmEnv-  { envVersion :: LlvmVersion      -- ^ LLVM version-  , envOpts    :: LlvmOpts         -- ^ LLVM backend options-  , envDynFlags :: DynFlags        -- ^ Dynamic flags-  , envLogger :: !Logger           -- ^ Logger-  , envOutput :: BufHandle         -- ^ Output buffer-  , envMask :: !Char               -- ^ Mask for creating unique values-  , envFreshMeta :: MetaId         -- ^ Supply of fresh metadata IDs-  , envUniqMeta :: UniqFM Unique MetaId   -- ^ Global metadata nodes-  , envFunMap :: LlvmEnvMap        -- ^ Global functions so far, with type-  , envAliases :: UniqSet LMString -- ^ Globals that we had to alias, see [Llvm Forward References]-  , envUsedVars :: [LlvmVar]       -- ^ Pointers to be added to llvm.used (see @cmmUsedLlvmGens@)+  { envVersion   :: LlvmVersion      -- ^ LLVM version+  , envConfig    :: !LlvmCgConfig    -- ^ Configuration for LLVM code gen+  , envLogger    :: !Logger          -- ^ Logger+  , envOutput    :: BufHandle        -- ^ Output buffer+  , envMask      :: !Char            -- ^ Mask for creating unique values+  , envFreshMeta :: MetaId           -- ^ Supply of fresh metadata IDs+  , envUniqMeta  :: UniqFM Unique MetaId   -- ^ Global metadata nodes+  , envFunMap    :: LlvmEnvMap       -- ^ Global functions so far, with type+  , envAliases   :: UniqSet LMString -- ^ Globals that we had to alias, see [Llvm Forward References]+  , envUsedVars  :: [LlvmVar]        -- ^ Pointers to be added to llvm.used (see @cmmUsedLlvmGens@)      -- the following get cleared for every function (see @withClearVars@)-  , envVarMap :: LlvmEnvMap        -- ^ Local variables so far, with type-  , envStackRegs :: [GlobalReg]    -- ^ Non-constant registers (alloca'd in the function prelude)+  , envVarMap    :: LlvmEnvMap       -- ^ Local variables so far, with type+  , envStackRegs :: [GlobalReg]      -- ^ Non-constant registers (alloca'd in the function prelude)   }  type LlvmEnvMap = UniqFM Unique LlvmType@@ -335,20 +331,16 @@     m >>= f  = LlvmM $ \env -> do (x, env') <- runLlvmM m env                                   runLlvmM (f x) env' -instance HasDynFlags LlvmM where-    getDynFlags = LlvmM $ \env -> return (envDynFlags env, env)- instance HasLogger LlvmM where     getLogger = LlvmM $ \env -> return (envLogger env, env)   -- | Get target platform getPlatform :: LlvmM Platform-getPlatform = llvmOptsPlatform <$> getLlvmOpts+getPlatform = llvmCgPlatform <$> getConfig --- | Get LLVM options-getLlvmOpts :: LlvmM LlvmOpts-getLlvmOpts = LlvmM $ \env -> return (envOpts env, env)+getConfig :: LlvmM LlvmCgConfig+getConfig = LlvmM $ \env -> return (envConfig env, env)  instance MonadUnique LlvmM where     getUniqueSupplyM = do@@ -365,23 +357,22 @@                               return (x, env)  -- | Get initial Llvm environment.-runLlvm :: Logger -> DynFlags -> LlvmVersion -> BufHandle -> LlvmM a -> IO a-runLlvm logger dflags ver out m = do+runLlvm :: Logger -> LlvmCgConfig -> LlvmVersion -> BufHandle -> LlvmM a -> IO a+runLlvm logger cfg ver out m = do     (a, _) <- runLlvmM m env     return a-  where env = LlvmEnv { envFunMap = emptyUFM-                      , envVarMap = emptyUFM+  where env = LlvmEnv { envFunMap    = emptyUFM+                      , envVarMap    = emptyUFM                       , envStackRegs = []-                      , envUsedVars = []-                      , envAliases = emptyUniqSet-                      , envVersion = ver-                      , envOpts = initLlvmOpts dflags-                      , envDynFlags = dflags-                      , envLogger = logger-                      , envOutput = out-                      , envMask = 'n'+                      , envUsedVars  = []+                      , envAliases   = emptyUniqSet+                      , envVersion   = ver+                      , envConfig    = cfg+                      , envLogger    = logger+                      , envOutput    = out+                      , envMask      = 'n'                       , envFreshMeta = MetaId 0-                      , envUniqMeta = emptyUFM+                      , envUniqMeta  = emptyUFM                       }  -- | Get environment (internal)@@ -428,18 +419,16 @@ -- | Dumps the document if the corresponding flag has been set by the user dumpIfSetLlvm :: DumpFlag -> String -> DumpFormat -> Outp.SDoc -> LlvmM () dumpIfSetLlvm flag hdr fmt doc = do-  dflags <- getDynFlags   logger <- getLogger-  liftIO $ dumpIfSet_dyn logger dflags flag hdr fmt doc+  liftIO $ putDumpFileMaybe logger flag hdr fmt doc  -- | Prints the given contents to the output handle renderLlvm :: Outp.SDoc -> LlvmM () renderLlvm sdoc = do      -- Write to output-    dflags <- getDynFlags+    ctx <- llvmCgContext <$> getConfig     out <- getEnv envOutput-    let ctx = initSDocContext dflags (Outp.PprCode Outp.CStyle)     liftIO $ Outp.bufLeftRenderSDoc ctx out sdoc      -- Dump, if requested@@ -501,12 +490,10 @@ -- | Pretty print a 'CLabel'. strCLabel_llvm :: CLabel -> LlvmM LMString strCLabel_llvm lbl = do-    dflags <- getDynFlags+    ctx <- llvmCgContext <$> getConfig     platform <- getPlatform     let sdoc = pprCLabel platform CStyle lbl-        str = Outp.renderWithContext-                  (initSDocContext dflags (Outp.PprCode Outp.CStyle))-                  sdoc+        str = Outp.renderWithContext ctx sdoc     return (fsLit str)  -- ----------------------------------------------------------------------------@@ -566,7 +553,7 @@ -- | Here we take a global variable definition, rename it with a -- @$def@ suffix, and generate the appropriate alias. aliasify :: LMGlobal -> LlvmM [LMGlobal]--- See note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel".+-- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". -- Here we obtain the indirectee's precise type and introduce -- fresh aliases to both the precise typed label (lbl$def) and the i8* -- typed (regular) label of it with the matching new names.@@ -604,7 +591,7 @@            ]  -- Note [Llvm Forward References]---+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- The issue here is that LLVM insists on being strongly typed at -- every corner, so the first time we mention something, we have to -- settle what type we assign to it. That makes things awkward, as Cmm
compiler/GHC/CmmToLlvm/CodeGen.hs view
@@ -1,24 +1,22 @@-{-# LANGUAGE CPP, GADTs, MultiWayIf #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs, MultiWayIf #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}--- ----------------------------------------------------------------------------+ -- | Handle conversion of CmmProc to LLVM code.--- module GHC.CmmToLlvm.CodeGen ( genLlvmProc ) where -#include "GhclibHsVersions.h"- import GHC.Prelude -import GHC.Driver.Session-import GHC.Driver.Ppr+import GHC.Platform+import GHC.Platform.Regs ( activeStgRegs )  import GHC.Llvm import GHC.CmmToLlvm.Base+import GHC.CmmToLlvm.Config import GHC.CmmToLlvm.Regs  import GHC.Cmm.BlockId-import GHC.Platform.Regs ( activeStgRegs ) import GHC.Cmm.CLabel import GHC.Cmm import GHC.Cmm.Ppr as PprCmm@@ -29,14 +27,15 @@ import GHC.Cmm.Dataflow.Collections  import GHC.Data.FastString-import GHC.Types.ForeignCall-import GHC.Utils.Outputable-import GHC.Utils.Panic (assertPanic)-import qualified GHC.Utils.Panic as Panic-import GHC.Platform import GHC.Data.OrdList++import GHC.Types.ForeignCall import GHC.Types.Unique.Supply import GHC.Types.Unique++import GHC.Utils.Outputable+import GHC.Utils.Panic.Plain (massert)+import qualified GHC.Utils.Panic as Panic import GHC.Utils.Misc  import Control.Monad.Trans.Class@@ -194,10 +193,10 @@ -- Barriers need to be handled specially as they are implemented as LLVM -- intrinsic functions. genCall (PrimTarget MO_ReadBarrier) _ _ =-    barrierUnless [ArchX86, ArchX86_64, ArchSPARC]+    barrierUnless [ArchX86, ArchX86_64]  genCall (PrimTarget MO_WriteBarrier) _ _ =-    barrierUnless [ArchX86, ArchX86_64, ArchSPARC]+    barrierUnless [ArchX86, ArchX86_64]  genCall (PrimTarget MO_Touch) _ _ =     return (nilOL, [])@@ -560,7 +559,7 @@                             , MO_AddWordC w                             , MO_SubWordC w                             ]-    MASSERT(valid)+    massert valid     let width = widthToLlvmInt w     -- This will do most of the work of generating the call to the intrinsic and     -- extracting the values from the struct.@@ -692,14 +691,13 @@      ForeignTarget expr _ -> do         (v1, stmts, top) <- exprToVar expr-        dflags <- getDynFlags         let fty = funTy $ fsLit "dynamic"             cast = case getVarType v1 of                 ty | isPointer ty -> LM_Bitcast                 ty | isInt ty     -> LM_Inttoptr -                ty -> panic $ "genCall: Expr is of bad type for function"-                              ++ " call! (" ++ showSDoc dflags (ppr ty) ++ ")"+                ty -> pprPanic "genCall: Expr is of bad type for function" $+                  text " call! " <> lparen <> ppr ty <> rparen          (v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty)         return (v2, stmts `snocOL` s1, top)@@ -728,13 +726,12 @@  arg_vars ((e, AddrHint):rest) (vars, stmts, tops)   = do (v1, stmts', top') <- exprToVar e-       dflags <- getDynFlags        let op = case getVarType v1 of                ty | isPointer ty -> LM_Bitcast                ty | isInt ty     -> LM_Inttoptr -               a  -> panic $ "genCall: Can't cast llvmType to i8*! ("-                           ++ showSDoc dflags (ppr a) ++ ")"+               a  -> pprPanic "genCall: Can't cast llvmType to i8*! " $+                lparen <>  ppr a <> rparen         (v2, s1) <- doExpr i8Ptr $ Cast op v1 i8Ptr        arg_vars rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1,@@ -768,8 +765,7 @@             = return (v, Nop)              | otherwise-            = do dflags <- getDynFlags-                 platform <- getPlatform+            = do platform <- getPlatform                  let op = case (getVarType v, t) of                       (LMInt n, LMInt m)                           -> if n < m then extend else LM_Trunc@@ -783,8 +779,11 @@                       (vt, _) | isPointer vt && isPointer t -> LM_Bitcast                       (vt, _) | isVector vt && isVector t   -> LM_Bitcast -                      (vt, _) -> panic $ "castVars: Can't cast this type ("-                                  ++ showSDoc dflags (ppr vt) ++ ") to (" ++ showSDoc dflags (ppr t) ++ ")"+                      (vt, _) -> pprPanic "castVars: Can't cast this type " $+                                lparen <> ppr vt <> rparen+                                <> text " to " <>+                                lparen <> ppr t <> rparen+                  doExpr t $ Cast op v t     where extend = case signage of             Signed      -> LM_Sext@@ -800,11 +799,10 @@ -- | Decide what C function to use to implement a CallishMachOp cmmPrimOpFunctions :: CallishMachOp -> LlvmM LMString cmmPrimOpFunctions mop = do--  dflags <- getDynFlags+  cfg      <- getConfig   platform <- getPlatform-  let intrinTy1 = "p0i8.p0i8." ++ showSDoc dflags (ppr $ llvmWord platform)-      intrinTy2 = "p0i8." ++ showSDoc dflags (ppr $ llvmWord platform)+  let !isBmi2Enabled = llvmCgBmiVersion cfg >= Just BMI2+      !is32bit       = platformWordSize platform == PW4       unsupported = panic ("cmmPrimOpFunctions: " ++ show mop                         ++ " not supported here")       dontReach64 = panic ("cmmPrimOpFunctions: " ++ show mop@@ -859,39 +857,150 @@     MO_F64_Acosh  -> fsLit "acosh"     MO_F64_Atanh  -> fsLit "atanh" -    MO_Memcpy _   -> fsLit $ "llvm.memcpy."  ++ intrinTy1-    MO_Memmove _  -> fsLit $ "llvm.memmove." ++ intrinTy1-    MO_Memset _   -> fsLit $ "llvm.memset."  ++ intrinTy2-    MO_Memcmp _   -> fsLit $ "memcmp"+    -- In the following ops, it looks like we could factorize the concatenation+    -- of the bit size, and indeed it was like this before, e.g.+    --+    --     MO_PopCnt w -> fsLit $ "llvm.ctpop.i" ++ wbits w+    -- or+    --     MO_Memcpy _ -> fsLit $ "llvm.memcpy."  ++ intrinTy1+    --+    -- however it meant that FastStrings were not built from constant string+    -- literals, hence they weren't matching the "fslit" rewrite rule in+    -- GHC.Data.FastString that computes the string size at compilation time. -    (MO_PopCnt w) -> fsLit $ "llvm.ctpop."      ++ showSDoc dflags (ppr $ widthToLlvmInt w)-    (MO_BSwap w)  -> fsLit $ "llvm.bswap."      ++ showSDoc dflags (ppr $ widthToLlvmInt w)-    (MO_BRev w)   -> fsLit $ "llvm.bitreverse." ++ showSDoc dflags (ppr $ widthToLlvmInt w)-    (MO_Clz w)    -> fsLit $ "llvm.ctlz."       ++ showSDoc dflags (ppr $ widthToLlvmInt w)-    (MO_Ctz w)    -> fsLit $ "llvm.cttz."       ++ showSDoc dflags (ppr $ widthToLlvmInt w)+    MO_Memcpy _+      | is32bit   -> fsLit "llvm.memcpy.p0i8.p0i8.i32"+      | otherwise -> fsLit "llvm.memcpy.p0i8.p0i8.i64"+    MO_Memmove _+      | is32bit   -> fsLit "llvm.memmove.p0i8.p0i8.i32"+      | otherwise -> fsLit "llvm.memmove.p0i8.p0i8.i64"+    MO_Memset _+       | is32bit   -> fsLit "llvm.memset.p0i8.i32"+       | otherwise -> fsLit "llvm.memset.p0i8.i64"+    MO_Memcmp _   -> fsLit "memcmp" -    (MO_Pdep w)   ->  let w' = showSDoc dflags (ppr $ widthInBits w)-                      in  if isBmi2Enabled dflags-                            then fsLit $ "llvm.x86.bmi.pdep."   ++ w'-                            else fsLit $ "hs_pdep"              ++ w'-    (MO_Pext w)   ->  let w' = showSDoc dflags (ppr $ widthInBits w)-                      in  if isBmi2Enabled dflags-                            then fsLit $ "llvm.x86.bmi.pext."   ++ w'-                            else fsLit $ "hs_pext"              ++ w'+    MO_SuspendThread -> fsLit "suspendThread"+    MO_ResumeThread  -> fsLit "resumeThread" -    (MO_Prefetch_Data _ )-> fsLit "llvm.prefetch"+    MO_PopCnt w -> case w of+      W8   -> fsLit "llvm.ctpop.i8"+      W16  -> fsLit "llvm.ctpop.i16"+      W32  -> fsLit "llvm.ctpop.i32"+      W64  -> fsLit "llvm.ctpop.i64"+      W128 -> fsLit "llvm.ctpop.i128"+      W256 -> fsLit "llvm.ctpop.i256"+      W512 -> fsLit "llvm.ctpop.i512"+    MO_BSwap w  -> case w of+      W8   -> fsLit "llvm.bswap.i8"+      W16  -> fsLit "llvm.bswap.i16"+      W32  -> fsLit "llvm.bswap.i32"+      W64  -> fsLit "llvm.bswap.i64"+      W128 -> fsLit "llvm.bswap.i128"+      W256 -> fsLit "llvm.bswap.i256"+      W512 -> fsLit "llvm.bswap.i512"+    MO_BRev w   -> case w of+      W8   -> fsLit "llvm.bitreverse.i8"+      W16  -> fsLit "llvm.bitreverse.i16"+      W32  -> fsLit "llvm.bitreverse.i32"+      W64  -> fsLit "llvm.bitreverse.i64"+      W128 -> fsLit "llvm.bitreverse.i128"+      W256 -> fsLit "llvm.bitreverse.i256"+      W512 -> fsLit "llvm.bitreverse.i512"+    MO_Clz w    -> case w of+      W8   -> fsLit "llvm.ctlz.i8"+      W16  -> fsLit "llvm.ctlz.i16"+      W32  -> fsLit "llvm.ctlz.i32"+      W64  -> fsLit "llvm.ctlz.i64"+      W128 -> fsLit "llvm.ctlz.i128"+      W256 -> fsLit "llvm.ctlz.i256"+      W512 -> fsLit "llvm.ctlz.i512"+    MO_Ctz w    -> case w of+      W8   -> fsLit "llvm.cttz.i8"+      W16  -> fsLit "llvm.cttz.i16"+      W32  -> fsLit "llvm.cttz.i32"+      W64  -> fsLit "llvm.cttz.i64"+      W128 -> fsLit "llvm.cttz.i128"+      W256 -> fsLit "llvm.cttz.i256"+      W512 -> fsLit "llvm.cttz.i512"+    MO_Pdep w+      | isBmi2Enabled -> case w of+          W8   -> fsLit "llvm.x86.bmi.pdep.8"+          W16  -> fsLit "llvm.x86.bmi.pdep.16"+          W32  -> fsLit "llvm.x86.bmi.pdep.32"+          W64  -> fsLit "llvm.x86.bmi.pdep.64"+          W128 -> fsLit "llvm.x86.bmi.pdep.128"+          W256 -> fsLit "llvm.x86.bmi.pdep.256"+          W512 -> fsLit "llvm.x86.bmi.pdep.512"+      | otherwise -> case w of+          W8   -> fsLit "hs_pdep8"+          W16  -> fsLit "hs_pdep16"+          W32  -> fsLit "hs_pdep32"+          W64  -> fsLit "hs_pdep64"+          W128 -> fsLit "hs_pdep128"+          W256 -> fsLit "hs_pdep256"+          W512 -> fsLit "hs_pdep512"+    MO_Pext w+      | isBmi2Enabled -> case w of+          W8   -> fsLit "llvm.x86.bmi.pext.8"+          W16  -> fsLit "llvm.x86.bmi.pext.16"+          W32  -> fsLit "llvm.x86.bmi.pext.32"+          W64  -> fsLit "llvm.x86.bmi.pext.64"+          W128 -> fsLit "llvm.x86.bmi.pext.128"+          W256 -> fsLit "llvm.x86.bmi.pext.256"+          W512 -> fsLit "llvm.x86.bmi.pext.512"+      | otherwise -> case w of+          W8   -> fsLit "hs_pext8"+          W16  -> fsLit "hs_pext16"+          W32  -> fsLit "hs_pext32"+          W64  -> fsLit "hs_pext64"+          W128 -> fsLit "hs_pext128"+          W256 -> fsLit "hs_pext256"+          W512 -> fsLit "hs_pext512" -    MO_AddIntC w    -> fsLit $ "llvm.sadd.with.overflow."-                             ++ showSDoc dflags (ppr $ widthToLlvmInt w)-    MO_SubIntC w    -> fsLit $ "llvm.ssub.with.overflow."-                             ++ showSDoc dflags (ppr $ widthToLlvmInt w)-    MO_Add2 w       -> fsLit $ "llvm.uadd.with.overflow."-                             ++ showSDoc dflags (ppr $ widthToLlvmInt w)-    MO_AddWordC w   -> fsLit $ "llvm.uadd.with.overflow."-                             ++ showSDoc dflags (ppr $ widthToLlvmInt w)-    MO_SubWordC w   -> fsLit $ "llvm.usub.with.overflow."-                             ++ showSDoc dflags (ppr $ widthToLlvmInt w)+    MO_AddIntC w    -> case w of+      W8   -> fsLit "llvm.sadd.with.overflow.i8"+      W16  -> fsLit "llvm.sadd.with.overflow.i16"+      W32  -> fsLit "llvm.sadd.with.overflow.i32"+      W64  -> fsLit "llvm.sadd.with.overflow.i64"+      W128 -> fsLit "llvm.sadd.with.overflow.i128"+      W256 -> fsLit "llvm.sadd.with.overflow.i256"+      W512 -> fsLit "llvm.sadd.with.overflow.i512"+    MO_SubIntC w    -> case w of+      W8   -> fsLit "llvm.ssub.with.overflow.i8"+      W16  -> fsLit "llvm.ssub.with.overflow.i16"+      W32  -> fsLit "llvm.ssub.with.overflow.i32"+      W64  -> fsLit "llvm.ssub.with.overflow.i64"+      W128 -> fsLit "llvm.ssub.with.overflow.i128"+      W256 -> fsLit "llvm.ssub.with.overflow.i256"+      W512 -> fsLit "llvm.ssub.with.overflow.i512"+    MO_Add2 w       -> case w of+      W8   -> fsLit "llvm.uadd.with.overflow.i8"+      W16  -> fsLit "llvm.uadd.with.overflow.i16"+      W32  -> fsLit "llvm.uadd.with.overflow.i32"+      W64  -> fsLit "llvm.uadd.with.overflow.i64"+      W128 -> fsLit "llvm.uadd.with.overflow.i128"+      W256 -> fsLit "llvm.uadd.with.overflow.i256"+      W512 -> fsLit "llvm.uadd.with.overflow.i512"+    MO_AddWordC w   -> case w of+      W8   -> fsLit "llvm.uadd.with.overflow.i8"+      W16  -> fsLit "llvm.uadd.with.overflow.i16"+      W32  -> fsLit "llvm.uadd.with.overflow.i32"+      W64  -> fsLit "llvm.uadd.with.overflow.i64"+      W128 -> fsLit "llvm.uadd.with.overflow.i128"+      W256 -> fsLit "llvm.uadd.with.overflow.i256"+      W512 -> fsLit "llvm.uadd.with.overflow.i512"+    MO_SubWordC w   -> case w of+      W8   -> fsLit "llvm.usub.with.overflow.i8"+      W16  -> fsLit "llvm.usub.with.overflow.i16"+      W32  -> fsLit "llvm.usub.with.overflow.i32"+      W64  -> fsLit "llvm.usub.with.overflow.i64"+      W128 -> fsLit "llvm.usub.with.overflow.i128"+      W256 -> fsLit "llvm.usub.with.overflow.i256"+      W512 -> fsLit "llvm.usub.with.overflow.i512" ++    MO_Prefetch_Data _ -> fsLit "llvm.prefetch"+     MO_S_Mul2    {}  -> unsupported     MO_S_QuotRem {}  -> unsupported     MO_U_QuotRem {}  -> unsupported@@ -957,14 +1066,13 @@ genJump expr live = do     fty <- llvmFunTy live     (vf, stmts, top) <- exprToVar expr-    dflags <- getDynFlags      let cast = case getVarType vf of          ty | isPointer ty -> LM_Bitcast          ty | isInt ty     -> LM_Inttoptr -         ty -> panic $ "genJump: Expr is of bad type for function call! ("-                     ++ showSDoc dflags (ppr ty) ++ ")"+         ty -> pprPanic "genJump: Expr is of bad type for function call! "+                $ lparen <> ppr ty <> rparen      (v1, s1) <- doExpr (pLift fty) $ Cast cast vf (pLift fty)     (stgRegs, stgStmts) <- funEpilogue live@@ -1075,9 +1183,8 @@     (vval,  stmts2, top2) <- exprToVar val      let stmts = stmts1 `appOL` stmts2-    dflags <- getDynFlags     platform <- getPlatform-    opts <- getLlvmOpts+    cfg      <- getConfig     case getVarType vaddr of         -- sometimes we need to cast an int to a pointer before storing         LMPointer ty@(LMPointer _) | getVarType vval == llvmWord platform -> do@@ -1098,9 +1205,9 @@         other ->             pprPanic "genStore: ptr not right type!"                     (PprCmm.pprExpr platform addr <+> text (-                        "Size of Ptr: " ++ show (llvmPtrBits platform) +++                        "Size of Ptr: "   ++ show (llvmPtrBits platform) ++                         ", Size of var: " ++ show (llvmWidthInBits platform other) ++-                        ", Var: " ++ showSDoc dflags (ppVar opts vaddr)))+                        ", Var: "         ++ renderWithContext (llvmCgContext cfg) (ppVar cfg vaddr)))  mkStore :: LlvmVar -> LlvmVar -> AlignmentSpec -> LlvmStatement mkStore vval vptr alignment =@@ -1135,22 +1242,22 @@             let s1 = BranchIf vc' labelT labelF             return (stmts1 `appOL` stmts2 `snocOL` s1, top1 ++ top2)         else do-            dflags <- getDynFlags-            opts <- getLlvmOpts-            panic $ "genCondBranch: Cond expr not bool! (" ++ showSDoc dflags (ppVar opts vc) ++ ")"+            cfg <- getConfig+            pprPanic "genCondBranch: Cond expr not bool! " $+              lparen <> ppVar cfg vc <> rparen   -- | Generate call to llvm.expect.x intrinsic. Assigning result to a new var. genExpectLit :: Integer -> LlvmType -> LlvmVar -> LlvmM (LlvmVar, StmtData) genExpectLit expLit expTy var = do-  dflags <- getDynFlags+  cfg <- getConfig    let     lit = LMLitVar $ LMIntLit expLit expTy      llvmExpectName-      | isInt expTy = fsLit $ "llvm.expect." ++ showSDoc dflags (ppr expTy)-      | otherwise   = panic $ "genExpectedLit: Type not an int!"+      | isInt expTy = fsLit $ "llvm.expect." ++ renderWithContext (llvmCgContext cfg) (ppr expTy)+      | otherwise   = panic "genExpectedLit: Type not an int!"    (llvmExpect, stmts, top) <-     getInstrinct llvmExpectName expTy [expTy, expTy]@@ -1159,7 +1266,6 @@  {- Note [Literals and branch conditions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- It is important that whenever we generate branch conditions for literals like '1', they are properly narrowed to an LLVM expression of type 'i1' (for bools.) Otherwise, nobody is happy. So when we convert@@ -1600,6 +1706,7 @@      where         binLlvmOp ty binOp allow_y_cast = do+          cfg      <- getConfig           platform <- getPlatform           runExprData $ do             vx <- exprToVarW x@@ -1617,10 +1724,8 @@                | otherwise                -> do                     -- Error. Continue anyway so we can debug the generated ll file.-                    dflags <- getDynFlags-                    let style = PprCode CStyle-                        toString doc = renderWithContext (initSDocContext dflags style) doc-                        cmmToStr = (lines . toString . PprCmm.pprExpr platform)+                    let render   = renderWithContext (llvmCgContext cfg)+                        cmmToStr = (lines . render . PprCmm.pprExpr platform)                     statement $ Comment $ map fsLit $ cmmToStr x                     statement $ Comment $ map fsLit $ cmmToStr y                     doExprW (ty vx) $ binOp vx vy@@ -1633,12 +1738,11 @@               [vx',vy'] -> doExprW ty $ binOp vx' vy'               _         -> panic "genMachOp_slow: binCastLlvmOp" -        -- | Need to use EOption here as Cmm expects word size results from+        -- Need to use EOption here as Cmm expects word size results from         -- comparisons while LLVM return i1. Need to extend to llvmWord type         -- if expected. See Note [Literals and branch conditions].         genBinComp opt cmp = do-            ed@(v1, stmts, top) <- binLlvmOp (\_ -> i1) (Compare cmp) False-            dflags <- getDynFlags+            ed@(v1, stmts, top) <- binLlvmOp (const i1) (Compare cmp) False             platform <- getPlatform             if getVarType v1 == i1                 then case i1Expected opt of@@ -1648,8 +1752,8 @@                         (v2, s1) <- doExpr w_ $ Cast LM_Zext v1 w_                         return (v2, stmts `snocOL` s1, top)                 else-                    panic $ "genBinComp: Compare returned type other then i1! "-                        ++ (showSDoc dflags $ ppr $ getVarType v1)+                    pprPanic "genBinComp: Compare returned type other then i1! "+                               (ppr $ getVarType v1)          genBinMach op = binLlvmOp getVarType (LlvmOp op) False @@ -1657,20 +1761,19 @@          genCastBinMach ty op = binCastLlvmOp ty (LlvmOp op) -        -- | Detect if overflow will occur in signed multiply of the two+        -- Detect if overflow will occur in signed multiply of the two         -- CmmExpr's. This is the LLVM assembly equivalent of the NCG         -- implementation. Its much longer due to type information/safety.         -- This should actually compile to only about 3 asm instructions.         isSMulOK :: Width -> CmmExpr -> CmmExpr -> LlvmM ExprData         isSMulOK _ x y = do           platform <- getPlatform-          dflags <- getDynFlags           runExprData $ do             vx <- exprToVarW x             vy <- exprToVarW y              let word  = getVarType vx-            let word2 = LMInt $ 2 * (llvmWidthInBits platform $ getVarType vx)+            let word2 = LMInt $ 2 * llvmWidthInBits platform (getVarType vx)             let shift = llvmWidthInBits platform word             let shift1 = toIWord platform (shift - 1)             let shift2 = toIWord platform shift@@ -1687,7 +1790,8 @@                     doExprW word $ LlvmOp LM_MO_Sub rlow2 rhigh2                  else-                    panic $ "isSMulOK: Not bit type! (" ++ showSDoc dflags (ppr word) ++ ")"+                    pprPanic "isSMulOK: Not bit type! " $+                        lparen <> ppr word <> rparen          panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: unary op encountered"                        ++ "with two arguments! (" ++ show op ++ ")"@@ -1765,8 +1869,7 @@              -> LlvmM ExprData genLoad_slow atomic e ty align meta = do   platform <- getPlatform-  dflags <- getDynFlags-  opts <- getLlvmOpts+  cfg      <- getConfig   runExprData $ do     iptr <- exprToVarW e     case getVarType iptr of@@ -1780,9 +1883,9 @@          other -> pprPanic "exprToVar: CmmLoad expression is not right type!"                      (PprCmm.pprExpr platform e <+> text (-                         "Size of Ptr: " ++ show (llvmPtrBits platform) +++                         "Size of Ptr: "   ++ show (llvmPtrBits platform) ++                          ", Size of var: " ++ show (llvmWidthInBits platform other) ++-                         ", Var: " ++ showSDoc dflags (ppVar opts iptr)))+                         ", Var: " ++ renderWithContext (llvmCgContext cfg) (ppVar cfg iptr)))  {- Note [Alignment of vector-typed values]@@ -1814,21 +1917,21 @@ getCmmReg :: CmmReg -> LlvmM LlvmVar getCmmReg (CmmLocal (LocalReg un _))   = do exists <- varLookup un-       dflags <- getDynFlags        case exists of          Just ety -> return (LMLocalVar un $ pLift ety)-         Nothing  -> panic $ "getCmmReg: Cmm register " ++ showSDoc dflags (ppr un) ++ " was not allocated!"+         Nothing  -> pprPanic "getCmmReg: Cmm register " $+                        ppr un <> text " was not allocated!"            -- This should never happen, as every local variable should            -- have been assigned a value at some point, triggering            -- "funPrologue" to allocate it on the stack.  getCmmReg (CmmGlobal g)-  = do onStack <- checkStackReg g-       dflags <- getDynFlags+  = do onStack  <- checkStackReg g        platform <- getPlatform        if onStack          then return (lmGlobalRegVar platform g)-         else panic $ "getCmmReg: Cmm register " ++ showSDoc dflags (ppr g) ++ " not stack-allocated!"+         else pprPanic "getCmmReg: Cmm register " $+                ppr g <> text " not stack-allocated!"  -- | Return the value of a given register, as well as its type. Might -- need to be load from stack.
+ compiler/GHC/CmmToLlvm/Config.hs view
@@ -0,0 +1,31 @@+-- | Llvm code generator configuration+module GHC.CmmToLlvm.Config+  ( LlvmCgConfig(..)+  , LlvmVersion(..)+  )+where++import GHC.Prelude+import GHC.Platform++import GHC.Utils.Outputable+import GHC.Driver.Session++import qualified Data.List.NonEmpty as NE++newtype LlvmVersion = LlvmVersion { llvmVersionNE :: NE.NonEmpty Int }+  deriving (Eq, Ord)++data LlvmCgConfig = LlvmCgConfig+  { llvmCgPlatform          :: !Platform     -- ^ Target platform+  , llvmCgContext           :: !SDocContext  -- ^ Context for LLVM code generation+  , llvmCgFillUndefWithGarbage :: !Bool      -- ^ Fill undefined literals with garbage values+  , llvmCgSplitSection      :: !Bool         -- ^ Split sections+  , llvmCgBmiVersion        :: Maybe BmiVersion  -- ^ (x86) BMI instructions+  , llvmCgLlvmVersion       :: Maybe LlvmVersion -- ^ version of Llvm we're using+  , llvmCgDoWarn            :: !Bool         -- ^ True ==> warn unsupported Llvm version+  , llvmCgLlvmTarget        :: !String       -- ^ target triple passed to LLVM+  , llvmCgLlvmConfig        :: !LlvmConfig   -- ^ mirror DynFlags LlvmConfig.+    -- see Note [LLVM configuration] in "GHC.SysTools". This can be strict since+    -- GHC.Driver.Config.CmmToLlvm.initLlvmCgConfig verifies the files are present.+  }
compiler/GHC/CmmToLlvm/Data.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ -- ---------------------------------------------------------------------------- -- | Handle conversion of CmmData to LLVM code. --@@ -7,15 +7,15 @@         genLlvmData, genData     ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Llvm import GHC.CmmToLlvm.Base+import GHC.CmmToLlvm.Config  import GHC.Cmm.BlockId import GHC.Cmm.CLabel+import GHC.Cmm.InitFini import GHC.Cmm import GHC.Platform @@ -42,7 +42,7 @@  -- | Pass a CmmStatic section to an equivalent Llvm code. genLlvmData :: (Section, RawCmmStatics) -> LlvmM LlvmData--- See note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel".+-- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". genLlvmData (_, CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])   | lbl == mkIndStaticInfoLabel   , let labelInd (CmmLabelOff l _) = Just l@@ -66,6 +66,14 @@      pure ([LMGlobal aliasDef $ Just orig], [tyAlias]) +-- See Note [Initializers and finalizers in Cmm] in GHC.Cmm.InitFini.+genLlvmData (sect, statics)+  | Just (initOrFini, clbls) <- isInitOrFiniArray (CmmData sect statics)+  = let var = case initOrFini of+                IsInitArray -> fsLit "llvm.global_ctors"+                IsFiniArray -> fsLit "llvm.global_dtors"+    in genGlobalLabelArray var clbls+ genLlvmData (sec, CmmStaticsRaw lbl xs) = do     label <- strCLabel_llvm lbl     static <- mapM genData xs@@ -89,6 +97,37 @@      return ([globDef], [tyAlias]) +-- | Produce an initializer or finalizer array declaration.+-- See Note [Initializers and finalizers in Cmm] in GHC.Cmm.InitFini for+-- details.+genGlobalLabelArray :: FastString -> [CLabel] -> LlvmM LlvmData+genGlobalLabelArray var_nm clbls = do+    lbls <- mapM strCLabel_llvm clbls+    decls <- mapM mkFunDecl lbls+    let entries = map toArrayEntry lbls+        static = LMStaticArray entries arr_ty+        arr = LMGlobal arr_var (Just static)+    return ([arr], decls)+  where+    mkFunDecl :: LMString -> LlvmM LlvmType+    mkFunDecl fn_lbl = do+        let fn_ty = mkFunTy fn_lbl+        funInsert fn_lbl fn_ty+        return (fn_ty)++    toArrayEntry :: LMString -> LlvmStatic+    toArrayEntry fn_lbl =+        let fn_var = LMGlobalVar fn_lbl (LMPointer $ mkFunTy fn_lbl) Internal Nothing Nothing Global+            fn = LMStaticPointer fn_var+            null = LMStaticLit (LMNullLit i8Ptr)+            prio = LMStaticLit $ LMIntLit 0xffff i32+        in LMStaticStrucU [prio, fn, null] entry_ty++    arr_var = LMGlobalVar var_nm arr_ty Internal Nothing Nothing Global+    mkFunTy lbl = LMFunction $ LlvmFunctionDecl lbl ExternallyVisible CC_Ccc LMVoid FixedArgs [] Nothing+    entry_ty = LMStructU [i32, LMPointer $ mkFunTy $ fsLit "placeholder", LMPointer i8]+    arr_ty = LMArray (length clbls) entry_ty+ -- | Format the section type part of a Cmm Section llvmSectionType :: Platform -> SectionType -> FastString llvmSectionType p t = case t of@@ -107,14 +146,17 @@     CString                 -> case platformOS p of                                  OSMinGW32 -> fsLit ".rdata$str"                                  _         -> fsLit ".rodata.str"-    (OtherSection _)        -> panic "llvmSectionType: unknown section type" +    InitArray               -> panic "llvmSectionType: InitArray"+    FiniArray               -> panic "llvmSectionType: FiniArray"+    OtherSection _          -> panic "llvmSectionType: unknown section type"+ -- | Format a Cmm Section into a LLVM section name llvmSection :: Section -> LlvmM LMSection llvmSection (Section t suffix) = do-  opts <- getLlvmOpts-  let splitSect = llvmOptsSplitSections opts-      platform  = llvmOptsPlatform opts+  opts <- getConfig+  let splitSect = llvmCgSplitSection opts+      platform  = llvmCgPlatform     opts   if not splitSect   then return Nothing   else do
compiler/GHC/CmmToLlvm/Mangler.hs view
@@ -13,44 +13,39 @@  import GHC.Prelude -import GHC.Driver.Session ( DynFlags, targetPlatform )-import GHC.Platform ( platformArch, Arch(..) )-import GHC.Utils.Error ( withTiming )-import GHC.Utils.Outputable ( text )-import GHC.Utils.Logger+import GHC.Platform ( Platform, platformArch, Arch(..) )+import GHC.Utils.Exception (try) -import Control.Exception import qualified Data.ByteString.Char8 as B import System.IO  -- | Read in assembly file and process-llvmFixupAsm :: Logger -> DynFlags -> FilePath -> FilePath -> IO ()-llvmFixupAsm logger dflags f1 f2 = {-# SCC "llvm_mangler" #-}-    withTiming logger dflags (text "LLVM Mangler") id $-    withBinaryFile f1 ReadMode $ \r -> withBinaryFile f2 WriteMode $ \w -> do-        go r w-        hClose r-        hClose w-        return ()+llvmFixupAsm :: Platform -> FilePath -> FilePath -> IO ()+llvmFixupAsm platform f1 f2 = {-# SCC "llvm_mangler" #-}+  withBinaryFile f1 ReadMode $ \r -> withBinaryFile f2 WriteMode $ \w -> do+      go r w+      hClose r+      hClose w+      return ()   where     go :: Handle -> Handle -> IO ()     go r w = do       e_l <- try $ B.hGetLine r ::IO (Either IOError B.ByteString)-      let writeline a = B.hPutStrLn w (rewriteLine dflags rewrites a) >> go r w+      let writeline a = B.hPutStrLn w (rewriteLine platform rewrites a) >> go r w       case e_l of         Right l -> writeline l         Left _  -> return ()  -- | These are the rewrites that the mangler will perform rewrites :: [Rewrite]-rewrites = [rewriteSymType, rewriteAVX]+rewrites = [rewriteSymType, rewriteAVX, rewriteCall] -type Rewrite = DynFlags -> B.ByteString -> Maybe B.ByteString+type Rewrite = Platform -> B.ByteString -> Maybe B.ByteString  -- | Rewrite a line of assembly source with the given rewrites, -- taking the first rewrite that applies.-rewriteLine :: DynFlags -> [Rewrite] -> B.ByteString -> B.ByteString-rewriteLine dflags rewrites l+rewriteLine :: Platform -> [Rewrite] -> B.ByteString -> B.ByteString+rewriteLine platform rewrites l   -- We disable .subsections_via_symbols on darwin and ios, as the llvm code   -- gen uses prefix data for the info table.  This however does not prevent   -- llvm from generating .subsections_via_symbols, which in turn with@@ -58,7 +53,7 @@   | isSubsectionsViaSymbols l =     (B.pack "## no .subsection_via_symbols for ghc. We need our info tables!")   | otherwise =-    case firstJust $ map (\rewrite -> rewrite dflags rest) rewrites of+    case firstJust $ map (\rewrite -> rewrite platform rest) rewrites of       Nothing        -> l       Just rewritten -> B.concat $ [symbol, B.pack "\t", rewritten]   where@@ -97,15 +92,36 @@ -- tells LLVM that the stack is 32-byte aligned (even though it isn't) and then -- rewrites the instructions in the mangler. rewriteAVX :: Rewrite-rewriteAVX dflags s+rewriteAVX platform s   | not isX86_64 = Nothing   | isVmovdqa s  = Just $ replaceOnce (B.pack "vmovdqa") (B.pack "vmovdqu") s   | isVmovap s   = Just $ replaceOnce (B.pack "vmovap") (B.pack "vmovup") s   | otherwise    = Nothing   where-    isX86_64 = platformArch (targetPlatform dflags) == ArchX86_64+    isX86_64 = platformArch platform == ArchX86_64     isVmovdqa = B.isPrefixOf (B.pack "vmovdqa")     isVmovap = B.isPrefixOf (B.pack "vmovap")++-- | This rewrites (tail) calls to avoid creating PLT entries for+-- functions on riscv64. The replacement will load the address from the+-- GOT, which is resolved to point to the real address of the function.+rewriteCall :: Rewrite+rewriteCall platform l+  | not isRISCV64 = Nothing+  | isCall l      = Just $ replaceCall "call" "jalr" "ra" l+  | isTail l      = Just $ replaceCall "tail" "jr" "t1" l+  | otherwise     = Nothing+  where+    isRISCV64 = platformArch platform == ArchRISCV64+    isCall = B.isPrefixOf (B.pack "call\t")+    isTail = B.isPrefixOf (B.pack "tail\t")++    replaceCall call jump reg l =+        appendInsn (jump ++ "\t" ++ reg) $ removePlt $+        replaceOnce (B.pack call) (B.pack ("la\t" ++ reg ++ ",")) l+      where+        removePlt = replaceOnce (B.pack "@plt") (B.pack "")+        appendInsn i = (`B.append` B.pack ("\n\t" ++ i))  -- | @replaceOnce match replace bs@ replaces the first occurrence of the -- substring @match@ in @bs@ with @replace@.
compiler/GHC/CmmToLlvm/Ppr.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + -- ---------------------------------------------------------------------------- -- | Pretty print helpers for the LLVM Code generator. --@@ -7,15 +7,12 @@         pprLlvmCmmDecl, pprLlvmData, infoSection     ) where -#include "GhclibHsVersions.h"- import GHC.Prelude -import GHC.Driver.Ppr- import GHC.Llvm import GHC.CmmToLlvm.Base import GHC.CmmToLlvm.Data+import GHC.CmmToLlvm.Config  import GHC.Cmm.CLabel import GHC.Cmm@@ -29,21 +26,21 @@ --  -- | Pretty print LLVM data code-pprLlvmData :: LlvmOpts -> LlvmData -> SDoc-pprLlvmData opts (globals, types) =+pprLlvmData :: LlvmCgConfig -> LlvmData -> SDoc+pprLlvmData cfg (globals, types) =     let ppLlvmTys (LMAlias    a) = ppLlvmAlias a         ppLlvmTys (LMFunction f) = ppLlvmFunctionDecl f         ppLlvmTys _other         = empty          types'   = vcat $ map ppLlvmTys types-        globals' = ppLlvmGlobals opts globals+        globals' = ppLlvmGlobals cfg globals     in types' $+$ globals'   -- | Pretty print LLVM code pprLlvmCmmDecl :: LlvmCmmDecl -> LlvmM (SDoc, [LlvmVar]) pprLlvmCmmDecl (CmmData _ lmdata) = do-  opts <- getLlvmOpts+  opts <- getConfig   return (vcat $ map (pprLlvmData opts) lmdata, [])  pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks))@@ -56,13 +53,12 @@            lmblocks = map (\(BasicBlock id stmts) ->                                 LlvmBlock (getUnique id) stmts) blks -       funDec <- llvmFunSig live lbl link-       dflags <- getDynFlags-       opts <- getLlvmOpts+       funDec   <- llvmFunSig live lbl link+       cfg      <- getConfig        platform <- getPlatform-       let buildArg = fsLit . showSDoc dflags . ppPlainName opts+       let buildArg = fsLit . renderWithContext (llvmCgContext cfg). ppPlainName cfg            funArgs = map buildArg (llvmFunArgs platform live)-           funSect = llvmFunSection opts (decName funDec)+           funSect = llvmFunSection cfg (decName funDec)         -- generate the info table        prefix <- case mb_info of@@ -96,7 +92,7 @@                             (Just $ LMBitc (LMStaticPointer defVar)                                            i8Ptr) -       return (ppLlvmGlobal opts alias $+$ ppLlvmFunction opts fun', [])+       return (ppLlvmGlobal cfg alias $+$ ppLlvmFunction cfg fun', [])   -- | The section we are putting info tables and their entry code into, should
compiler/GHC/CmmToLlvm/Regs.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + -------------------------------------------------------------------------------- -- | Deal with Cmm registers --@@ -8,8 +8,6 @@         lmGlobalRegArg, lmGlobalRegVar, alwaysLive,         stgTBAA, baseN, stackN, heapN, rxN, topN, tbaa, getTBAA     ) where--#include "GhclibHsVersions.h"  import GHC.Prelude
+ compiler/GHC/Core/LateCC.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE TupleSections #-}++-- | Adds cost-centers after the core piple has run.+module GHC.Core.LateCC+    ( addLateCostCentresMG+    , addLateCostCentresPgm+    , addLateCostCentres -- Might be useful for API users+    , Env(..)+    ) where++import Control.Applicative+import GHC.Utils.Monad.State.Strict+import Control.Monad++import GHC.Prelude+import GHC.Driver.Session+import GHC.Types.CostCentre+import GHC.Types.CostCentre.State+import GHC.Types.Name hiding (varName)+import GHC.Types.Tickish+import GHC.Unit.Module.ModGuts+import GHC.Types.Var+import GHC.Unit.Types+import GHC.Data.FastString+import GHC.Core+import GHC.Core.Opt.Monad+import GHC.Types.Id+import GHC.Core.Utils (mkTick)++import qualified Data.Set as S+import GHC.Utils.Logger+import GHC.Utils.Outputable+import GHC.Utils.Misc+import GHC.Utils.Error (withTiming)+++{- Note [Collecting late cost centres]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Usually cost centres defined by a module are collected+during tidy by collectCostCentres. However with `-fprof-late`+we insert cost centres after inlining. So we keep a list of+all the cost centres we inserted and combine that with the list+of cost centres found during tidy.++To avoid overhead when using -fprof-inline there is a flag to stop+us from collecting them here when we run this pass before tidy.++Note [Adding late cost centres]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The basic idea is very simple. For every top level binder+`f = rhs` we compile it as if the user had written+`f = {-# SCC f #-} rhs`.++If we do this after unfoldings for `f` have been created this+doesn't impact core-level optimizations at all. If we do it+before the cost centre will be included in the unfolding and+might inhibit optimizations at the call site. For this reason+we provide flags for both approaches as they have different+tradeoffs.++We also don't add a cost centre for any binder that is a constructor+worker or wrapper. These will never meaningfully enrich the resulting+profile so we improve efficiency by omitting those.++-}++addLateCostCentresMG :: ModGuts -> CoreM ModGuts+addLateCostCentresMG guts = do+  dflags <- getDynFlags+  let env :: Env+      env = Env+        { thisModule = mg_module guts+        , ccState = newCostCentreState+        , countEntries = gopt Opt_ProfCountEntries dflags+        , collectCCs = False -- See Note [Collecting late cost centres]+        }+  let guts' = guts { mg_binds = fst (addLateCostCentres env (mg_binds guts))+                   }+  return guts'++addLateCostCentresPgm :: DynFlags -> Logger -> Module -> CoreProgram -> IO (CoreProgram, S.Set CostCentre)+addLateCostCentresPgm dflags logger mod binds =+  withTiming logger+               (text "LateCC"<+>brackets (ppr mod))+               (\(a,b) -> a `seqList` (b `seq` ())) $ do+  let env = Env+        { thisModule = mod+        , ccState = newCostCentreState+        , countEntries = gopt Opt_ProfCountEntries dflags+        , collectCCs = True -- See Note [Collecting late cost centres]+        }+      (binds', ccs) = addLateCostCentres env binds+  when (dopt Opt_D_dump_late_cc dflags || dopt Opt_D_verbose_core2core dflags) $+    putDumpFileMaybe logger Opt_D_dump_late_cc "LateCC" FormatCore (vcat (map ppr binds'))+  return (binds', ccs)++addLateCostCentres :: Env -> CoreProgram -> (CoreProgram,S.Set CostCentre)+addLateCostCentres env binds =+  let (binds', state) = runState (mapM (doBind env) binds) initLateCCState+  in (binds',lcs_ccs state)+++doBind :: Env -> CoreBind -> M CoreBind+doBind env (NonRec b rhs) = NonRec b <$> doBndr env b rhs+doBind env (Rec bs) = Rec <$> mapM doPair bs+  where+    doPair :: ((Id, CoreExpr) -> M (Id, CoreExpr))+    doPair (b,rhs) = (b,) <$> doBndr env b rhs++doBndr :: Env -> Id -> CoreExpr -> M CoreExpr+doBndr env bndr rhs+  -- Cost centres on constructor workers are pretty much useless+  -- so we don't emit them if we are looking at the rhs of a constructor+  -- binding.+  | Just _ <- isDataConId_maybe bndr = pure rhs+  | otherwise = doBndr' env bndr rhs+++-- We want to put the cost centra below the lambda as we only care about executions of the RHS.+doBndr' :: Env -> Id -> CoreExpr -> State LateCCState CoreExpr+doBndr' env bndr (Lam b rhs) = Lam b <$> doBndr' env bndr rhs+doBndr' env bndr rhs = do+    let name = idName bndr+        name_loc = nameSrcSpan name+        cc_name = getOccFS name+        count = countEntries env+    cc_flavour <- getCCFlavour cc_name+    let cc_mod = thisModule env+        bndrCC = NormalCC cc_flavour cc_name cc_mod name_loc+        note = ProfNote bndrCC count True+    addCC env bndrCC+    return $ mkTick note rhs++data LateCCState = LateCCState+    { lcs_state :: !CostCentreState+    , lcs_ccs   :: S.Set CostCentre+    }+type M = State LateCCState++initLateCCState :: LateCCState+initLateCCState = LateCCState newCostCentreState mempty++getCCFlavour :: FastString -> M CCFlavour+getCCFlavour name = LateCC <$> getCCIndex' name++getCCIndex' :: FastString -> M CostCentreIndex+getCCIndex' name = do+  state <- get+  let (index,cc_state') = getCCIndex name (lcs_state state)+  put (state { lcs_state = cc_state'})+  return index++addCC :: Env -> CostCentre -> M ()+addCC !env cc = do+    state <- get+    when (collectCCs env) $ do+        let ccs' = S.insert cc (lcs_ccs state)+        put (state { lcs_ccs = ccs'})++data Env = Env+  { thisModule  :: !Module+  , countEntries:: !Bool+  , ccState     :: !CostCentreState+  , collectCCs  :: !Bool+  }+
− compiler/GHC/Core/Map/Expr.hs 
@@ -1,393 +0,0 @@-{-# LANGUAGE CPP #-}-{-# 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,-   -- * 'TrieMap' class reexports-   TrieMap(..), insertTM, deleteTM,-   lkDFreeVar, xtDFreeVar,-   lkDNamed, xtDNamed,-   (>.>), (|>), (|>>),- ) where--#include "GhclibHsVersions.h"--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-  D env1 e1 == D env2 e2 = go e1 e2 where-    go (Var v1) (Var v2)-      = case (lookupCME env1 v1, lookupCME env2 v2) of-                            (Just b1, Just b2) -> b1 == b2-                            (Nothing, Nothing) -> v1 == v2-                            _ -> False-    go (Lit lit1)    (Lit lit2)      = lit1 == lit2-    go (Type t1)    (Type t2)        = D env1 t1 == D env2 t2-    go (Coercion co1) (Coercion co2) = D env1 co1 == D env2 co2-    go (Cast e1 co1) (Cast e2 co2) = D env1 co1 == D env2 co2 && go e1 e2-    go (App f1 a1)   (App f2 a2)   = go f1 f2 && go a1 a2-    -- This seems a bit dodgy, see 'eqTickish'-    go (Tick n1 e1)  (Tick n2 e2)  = n1 == n2 && go e1 e2--    go (Lam b1 e1)  (Lam b2 e2)-      =  D env1 (varType b1) == D env2 (varType b2)-      && D env1 (varMultMaybe b1) == D env2 (varMultMaybe b2)-      && D (extendCME env1 b1) e1 == D (extendCME env2 b2) e2--    go (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2)-      =  go r1 r2-      && D (extendCME env1 v1) e1 == D (extendCME env2 v2) e2--    go (Let (Rec ps1) e1) (Let (Rec ps2) e2)-      = equalLength ps1 ps2-      && D env1' rs1 == D env2' rs2-      && 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--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/Opt/CSE.hs view
@@ -4,15 +4,13 @@ \section{Common subexpression} -} -{-# LANGUAGE CPP #-} + {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}  module GHC.Core.Opt.CSE (cseProgram, cseOneExpr) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Core.Subst@@ -22,7 +20,7 @@                         , idInlineActivation, setInlineActivation                         , zapIdOccInfo, zapIdUsageInfo, idInlinePragma                         , isJoinId, isJoinId_maybe )-import GHC.Core.Utils   ( mkAltExpr, eqExpr+import GHC.Core.Utils   ( mkAltExpr                         , exprIsTickedString                         , stripTicksE, stripTicksT, mkTicks ) import GHC.Core.FVs     ( exprFreeVars )@@ -32,7 +30,7 @@ import GHC.Types.Basic import GHC.Types.Tickish import GHC.Core.Map.Expr-import GHC.Utils.Misc   ( filterOut, equalLength, debugIsOn )+import GHC.Utils.Misc   ( filterOut, equalLength ) import GHC.Utils.Panic import Data.List        ( mapAccumL ) @@ -714,7 +712,7 @@ cseCase :: CSEnv -> InExpr -> InId -> InType -> [InAlt] -> OutExpr cseCase env scrut bndr ty alts   = Case scrut1 bndr3 ty' $-    combineAlts alt_env (map cse_alt alts)+    combineAlts (map cse_alt alts)   where     ty' = substTy (csEnvSubst env) ty     (cse_done, scrut1) = try_for_cse env scrut@@ -746,20 +744,19 @@         where           (env', args') = addBinders alt_env args -combineAlts :: CSEnv -> [OutAlt] -> [OutAlt]+combineAlts :: [OutAlt] -> [OutAlt] -- See Note [Combine case alternatives]-combineAlts env alts+combineAlts alts   | (Just alt1, rest_alts) <- find_bndr_free_alt alts   , Alt _ bndrs1 rhs1 <- alt1   , let filtered_alts = filterOut (identical_alt rhs1) rest_alts   , not (equalLength rest_alts filtered_alts)-  = ASSERT2( null bndrs1, ppr alts )+  = assertPpr (null bndrs1) (ppr alts) $     Alt DEFAULT [] rhs1 : filtered_alts    | otherwise   = alts   where-    in_scope = substInScope (csEnvSubst env)      find_bndr_free_alt :: [CoreAlt] -> (Maybe CoreAlt, [CoreAlt])        -- The (Just alt) is a binder-free alt@@ -771,7 +768,7 @@       | otherwise  = case find_bndr_free_alt alts of                        (mb_bf, alts) -> (mb_bf, alt:alts) -    identical_alt rhs1 (Alt _ _ rhs) = eqExpr in_scope rhs1 rhs+    identical_alt rhs1 (Alt _ _ rhs) = eqCoreExpr rhs1 rhs        -- Even if this alt has binders, they will have been cloned        -- If any of these binders are mentioned in 'rhs', then        -- 'rhs' won't compare equal to 'rhs1' (which is from an
compiler/GHC/Core/Opt/CallArity.hs view
@@ -13,7 +13,6 @@  import GHC.Types.Var.Set import GHC.Types.Var.Env-import GHC.Driver.Session ( DynFlags )  import GHC.Types.Basic import GHC.Core@@ -100,7 +99,7 @@ the information about what variables are being called once or multiple times.  Note [Analysis I: The arity analysis]-------------------------------------+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  The arity analysis is quite straightforward: The information about an expression is an@@ -116,7 +115,7 @@   Note [Analysis II: The Co-Called analysis]-------------------------------------------+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  The second part is more sophisticated. For reasons explained below, it is not sufficient to simply know how often an expression evaluates a variable. Instead@@ -171,7 +170,7 @@    Tricky.    We assume that it is really mutually recursive, i.e. that every variable    calls one of the others, and that this is strongly connected (otherwise we-   return an over-approximation, so that's ok), see note [Recursion and fixpointing].+   return an over-approximation, so that's ok), see Note [Recursion and fixpointing].     Let V = {v₁,...vₙ}.    Assume that the vs have been analysed with an incoming demand and@@ -434,12 +433,12 @@  -- Main entry point -callArityAnalProgram :: DynFlags -> CoreProgram -> CoreProgram-callArityAnalProgram _dflags binds = binds'+callArityAnalProgram :: CoreProgram -> CoreProgram+callArityAnalProgram binds = binds'   where     (_, binds') = callArityTopLvl [] emptyVarSet binds --- See Note [Analysing top-level-binds]+-- See Note [Analysing top-level binds] callArityTopLvl :: [Var] -> VarSet -> [CoreBind] -> (CallArityRes, [CoreBind]) callArityTopLvl exported _ []     = ( calledMultipleTimes $ (emptyUnVarGraph, mkVarEnv $ [(v, 0) | v <- exported])@@ -526,7 +525,7 @@       (final_ae, Case scrut' bndr ty alts')   where     (alt_aes, alts') = unzip $ map go alts-    go (Alt dc bndrs e) = let (ae, e') = callArityAnal arity int e+    go (Alt dc bndrs e) = let (ae, e') = callArityAnal arity (int `delVarSetList` (bndr:bndrs)) e                           in  (ae, Alt dc bndrs e')     alt_ae = lubRess alt_aes     (scrut_ae, scrut') = callArityAnal 0 int scrut@@ -568,7 +567,7 @@     --          (vcat [ppr v, ppr ae_body, ppr int, ppr ae_rhs, ppr safe_arity])     (final_ae, NonRec v' rhs')   where-    is_thunk = not (exprIsCheap rhs) -- see note [What is a thunk]+    is_thunk = not (exprIsCheap rhs) -- see Note [What is a thunk]     -- If v is boring, we will not find it in ae_body, but always assume (0, False)     boring = v `elemVarSet` boring_vars @@ -638,7 +637,7 @@              | otherwise             -- We previously analyzed this with a different arity (or not at all)-            = let is_thunk = not (exprIsCheap rhs) -- see note [What is a thunk]+            = let is_thunk = not (exprIsCheap rhs) -- see Note [What is a thunk]                    safe_arity | is_thunk    = 0  -- See Note [Thunks in recursive groups]                              | otherwise   = new_arity@@ -706,7 +705,7 @@         | isDeadEndDiv result_info = length demands         | otherwise = a -    (demands, result_info) = splitStrictSig (idStrictness v)+    (demands, result_info) = splitDmdSig (idDmdSig v)  --------------------------------------- -- Functions related to CallArityRes --
compiler/GHC/Core/Opt/CprAnal.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-}  -- | Constructed Product Result analysis. Identifies functions that surely -- return heap-allocated records on every code path, so that we can eliminate@@ -9,81 +8,148 @@ -- See Note [Phase ordering]. module GHC.Core.Opt.CprAnal ( cprAnalProgram ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Driver.Session-import GHC.Types.Demand-import GHC.Types.Cpr-import GHC.Core-import GHC.Core.Seq-import GHC.Utils.Outputable+ import GHC.Builtin.Names ( runRWKey )+ import GHC.Types.Var.Env import GHC.Types.Basic import GHC.Types.Id import GHC.Types.Id.Info+import GHC.Types.Demand+import GHC.Types.Cpr+import GHC.Types.Unique.MemoFun++import GHC.Core.FamInstEnv import GHC.Core.DataCon-import GHC.Core.Multiplicity-import GHC.Core.Utils   ( exprIsHNF, dumpIdInfoOfProgram ) import GHC.Core.Type-import GHC.Core.FamInstEnv+import GHC.Core.Utils+import GHC.Core+import GHC.Core.Seq import GHC.Core.Opt.WorkWrap.Utils++import GHC.Data.Graph.UnVar -- for UnVarSet++import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic-import GHC.Utils.Logger  ( Logger, dumpIfSet_dyn, DumpFormat (..) )-import GHC.Data.Graph.UnVar -- for UnVarSet-import GHC.Data.Maybe   ( isNothing )+import GHC.Utils.Panic.Plain+import GHC.Utils.Logger  ( Logger, putDumpFileMaybe, DumpFormat (..) ) -import Control.Monad ( guard ) import Data.List ( mapAccumL ) -import GHC.Driver.Ppr-_ = pprTrace -- Tired of commenting out the import all the time- {- Note [Constructed Product Result] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The goal of Constructed Product Result analysis is to identify functions that surely return heap-allocated records on every code path, so that we can-eliminate said heap allocation by performing a worker/wrapper split.--@swap@ below is such a function:+eliminate said heap allocation by performing a worker/wrapper split+(via 'GHC.Core.Opt.WorkWrap.Utils.mkWWcpr_entry'). +`swap` below is such a function:+```   swap (a, b) = (b, a)--A @case@ on an application of @swap@, like-@case swap (10, 42) of (a, b) -> a + b@ could cancel away-(by case-of-known-constructor) if we "inlined" @swap@ and simplified. We then-say that @swap@ has the CPR property.+```+A `case` on an application of `swap`, like+`case swap (10, 42) of (a, b) -> a + b` could cancel away+(by case-of-known-constructor) if we \"inlined\" `swap` and simplified. We then+say that `swap` has the CPR property.  We can't inline recursive functions, but similar reasoning applies there:-+```   f x n = case n of     0 -> (x, 0)     _ -> f (x+1) (n-1)--Inductively, @case f 1 2 of (a, b) -> a + b@ could cancel away the constructed-product with the case. So @f@, too, has the CPR property. But we can't really-"inline" @f@, because it's recursive. Also, non-recursive functions like @swap@+```+Inductively, `case f 1 2 of (a, b) -> a + b` could cancel away the constructed+product with the case. So `f`, too, has the CPR property. But we can't really+"inline" `f`, because it's recursive. Also, non-recursive functions like `swap` might be too big to inline (or even marked NOINLINE). We still want to exploit the CPR property, and that is exactly what the worker/wrapper transformation can do for us:-+```   $wf x n = case n of     0 -> case (x, 0) of -> (a, b) -> (# a, b #)     _ -> case f (x+1) (n-1) of (a, b) -> (# a, b #)   f x n = case $wf x n of (# a, b #) -> (a, b)--where $wf readily simplifies (by case-of-known-constructor and inlining @f@) to:-+```+where $wf readily simplifies (by case-of-known-constructor and inlining `f`) to:+```   $wf x n = case n of     0 -> (# x, 0 #)     _ -> $wf (x+1) (n-1)--Now, a call site like @case f 1 2 of (a, b) -> a + b@ can inline @f@ and+```+Now, a call site like `case f 1 2 of (a, b) -> a + b` can inline `f` and eliminate the heap-allocated pair constructor. +Note [Nested CPR]+~~~~~~~~~~~~~~~~~+We can apply Note [Constructed Product Result] deeper than just the top-level+result constructor of a function, e.g.,+```+  g x+    | even x = (x+1,x+2) :: (Int, Int)+    | odd  x = (x+2,x+3)+```+Not only does `g` return a constructed pair, the pair components /also/ have the+CPR property. We can split `g` for its /nested/ CPR property, as follows:+```+  $wg (x :: Int#)+    | .. x .. = (# x +# 1#, x +# 2# #) :: (# Int#, Int# #)+    | .. x .. = (# x +# 2#, x +# 3# #)+  g (I# x) = case $wf x of (# y, z #) -> (I# y, I# z)+```+Note however that in the following we will only unbox the second component,+even if `foo` has the CPR property:+```+  h x+    | even x = (foo x, x+2) :: (Int, Int)+    | odd  x = (x+2,   x+3)+    -- where `foo` has the CPR property+```+Why can't we also unbox `foo x`? Because in order to do so, we have to evaluate+it and that might diverge, so we cannot give `h` the nested CPR property in the+first component of the result.++The Right Thing is to do a termination analysis, to see if we can guarantee that+`foo` terminates quickly, in which case we can speculatively evaluate `foo x` and+hence give `h` a nested CPR property.  That is done in !1866.  But for now we+have an incredibly simple termination analysis; an expression terminates fast+iff it is in HNF: see `exprTerminates`. We call `exprTerminates` in+`cprTransformDataConWork`, which is the main function figuring out whether it's+OK to propagate nested CPR info (in `extract_nested_cpr`).++In addition to `exprTerminates`, `extract_nested_cpr` also looks at the+`StrictnessMark` of the corresponding constructor field. Example:+```+  data T a = MkT !a+  h2 x+    | even x = MkT (foo x) :: T Int+    | odd  x = MkT (x+2)+    -- where `foo` has the CPR property+```+Regardless of whether or not `foo` terminates, we may unbox the strict field,+because it has to be evaluated (the Core for `MkT (foo x)` will look more like+`case foo x of y { __DEFAULT -> MkT y }`).++Surprisingly, there are local binders with a strict demand that *do not*+terminate quickly in a sense that is useful to us! The following function+demonstrates that:+```+  j x = (let t = x+1 in t+t, 42)+```+Here, `t` is used strictly, *but only within its scope in the first pair+component*. `t` satisfies Note [CPR for binders that will be unboxed], so it has+the CPR property, nevertheless we may not unbox `j` deeply lest evaluation of+`x` diverges. The termination analysis must say "Might diverge" for `t` and we+won't unbox the first pair component.+There are a couple of tests in T18174 that show case Nested CPR. Some of them+only work with the termination analysis from !1866.++Giving the (Nested) CPR property to deep data structures can lead to loss of+sharing; see Note [CPR for data structures can destroy sharing].+ Note [Phase ordering] ~~~~~~~~~~~~~~~~~~~~~ We need to perform strictness analysis before CPR analysis, because that might@@ -96,8 +162,7 @@ 4. worker/wrapper (for CPR)  Currently, we omit 2. and anticipate the results of worker/wrapper.-See Note [CPR for binders that will be unboxed]-and Note [Optimistic field binder CPR].+See Note [CPR for binders that will be unboxed]. An additional w/w pass would simplify things, but probably add slight overhead. So currently we have @@ -110,12 +175,12 @@ -- * Analysing programs -- -cprAnalProgram :: Logger -> DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram-cprAnalProgram logger dflags fam_envs binds = do+cprAnalProgram :: Logger -> FamInstEnvs -> CoreProgram -> IO CoreProgram+cprAnalProgram logger fam_envs binds = do   let env            = emptyAnalEnv fam_envs   let binds_plus_cpr = snd $ mapAccumL cprAnalTopBind env binds-  dumpIfSet_dyn logger dflags Opt_D_dump_cpr_signatures "Cpr signatures" FormatText $-    dumpIdInfoOfProgram (ppr . cprInfo) binds_plus_cpr+  putDumpFileMaybe logger Opt_D_dump_cpr_signatures "Cpr signatures" FormatText $+    dumpIdInfoOfProgram False (ppr . cprSigInfo) binds_plus_cpr   -- See Note [Stamp out space leaks in demand analysis] in GHC.Core.Opt.DmdAnal   seqBinds binds_plus_cpr `seq` return binds_plus_cpr @@ -126,12 +191,12 @@ cprAnalTopBind env (NonRec id rhs)   = (env', NonRec id' rhs')   where-    (id', rhs', env') = cprAnalBind TopLevel env id rhs+    (id', rhs', env') = cprAnalBind env id rhs  cprAnalTopBind env (Rec pairs)   = (env', Rec pairs')   where-    (env', pairs') = cprFix TopLevel env pairs+    (env', pairs') = cprFix env pairs  -- -- * Analysing expressions@@ -162,9 +227,9 @@     (cpr_ty, e') = cprAnal env e  cprAnal' env e@(Var{})-  = cprAnalApp env e [] []+  = cprAnalApp env e [] cprAnal' env e@(App{})-  = cprAnalApp env e [] []+  = cprAnalApp env e []  cprAnal' env (Lam var body)   | isTyVar var@@ -189,13 +254,13 @@ cprAnal' env (Let (NonRec id rhs) body)   = (body_ty, Let (NonRec id' rhs') body')   where-    (id', rhs', env') = cprAnalBind NotTopLevel env id rhs+    (id', rhs', env') = cprAnalBind env id rhs     (body_ty, body')  = cprAnal env' body  cprAnal' env (Let (Rec pairs) body)   = body_ty `seq` (body_ty, Let (Rec pairs') body')   where-    (env', pairs')   = cprFix NotTopLevel env pairs+    (env', pairs')   = cprFix env pairs     (body_ty, body') = cprAnal env' body  cprAnalAlt@@ -210,7 +275,7 @@       | DataAlt dc <- con       , let ids = filter isId bndrs       , CprType arity cpr <- scrut_ty-      , ASSERT( arity == 0 ) True+      , assert (arity == 0 ) True       = case unpackConFieldsCpr dc cpr of           AllFieldsSame field_cpr             | let sig = mkCprSig 0 field_cpr@@ -226,79 +291,122 @@ -- * CPR transformer -- -cprAnalApp :: AnalEnv -> CoreExpr -> [CoreArg] -> [CprType] -> (CprType, CoreExpr)-cprAnalApp env e args' arg_tys-  -- Collect CprTypes for (value) args (inlined collectArgs):-  | App fn arg <- e, isTypeArg arg -- Don't analyse Type args-  = cprAnalApp env fn (arg:args') arg_tys-  | App fn arg <- e-  , (arg_ty, arg') <- cprAnal env arg-  = cprAnalApp env fn (arg':args') (arg_ty:arg_tys)+data TermFlag -- Better than using a Bool+  = Terminates+  | MightDiverge -  | Var fn <- e-  = (cprTransform env fn arg_tys, mkApps e args')+-- See Note [Nested CPR]+exprTerminates :: CoreExpr -> TermFlag+exprTerminates e+  | exprIsHNF e = Terminates -- A /very/ simple termination analysis.+  | otherwise   = MightDiverge -  | otherwise -- e is not an App and not a Var-  , (e_ty, e') <- cprAnal env e-  = (applyCprTy e_ty (length arg_tys), mkApps e' args')+cprAnalApp :: AnalEnv -> CoreExpr -> [(CprType, CoreArg)] -> (CprType, CoreExpr)+-- Main function that takes care of /nested/ CPR. See Note [Nested CPR]+cprAnalApp env e arg_infos = go e arg_infos []+  where+    go e arg_infos args'+      -- Collect CprTypes for (value) args (inlined collectArgs):+      | App fn arg <- e, isTypeArg arg -- Don't analyse Type args+      = go fn arg_infos (arg:args')+      | App fn arg <- e+      , arg_info@(_arg_ty, arg') <- cprAnal env arg+      -- See Note [Nested CPR] on the need for termination analysis+      = go fn (arg_info:arg_infos) (arg':args') -cprTransform :: AnalEnv   -- ^ The analysis environment-             -> Id        -- ^ The function-             -> [CprType] -- ^ info about incoming /value/ arguments-             -> CprType   -- ^ The demand type of the application+      | Var fn <- e+      = (cprTransform env fn arg_infos, mkApps e args')++      | (e_ty, e') <- cprAnal env e -- e is not an App and not a Var+      = (applyCprTy e_ty (length arg_infos), mkApps e' args')++cprTransform :: AnalEnv               -- ^ The analysis environment+             -> Id                    -- ^ The function+             -> [(CprType, CoreArg)]  -- ^ info about incoming /value/ arguments+             -> CprType               -- ^ The demand type of the application cprTransform env id args-  = -- pprTrace "cprTransform" (vcat [ppr id, ppr args, ppr sig])-    sig-  where-    sig-      -- Top-level binding, local let-binding, lambda arg or case binder-      | Just sig <- lookupSigEnv env id-      = applyCprTy (getCprSig sig) (length args)-      -- CPR transformers for special Ids-      | Just cpr_ty <- cprTransformSpecial id args-      = cpr_ty-      -- See Note [CPR for data structures]-      | Just rhs <- cprDataStructureUnfolding_maybe id-      = fst $ cprAnal env rhs-      -- Imported function or data con worker-      | isGlobalId id-      = applyCprTy (getCprSig (idCprInfo id)) (length args)-      | otherwise-      = topCprType+  -- Any local binding, except for data structure bindings+  -- See Note [Efficient Top sigs in SigEnv]+  | Just sig <- lookupSigEnv env id+  = applyCprTy (getCprSig sig) (length args)+  -- See Note [CPR for data structures]+  | Just rhs <- cprDataStructureUnfolding_maybe id+  = fst $ cprAnal env rhs+  -- Some (mostly global, known-key) Ids have bespoke CPR transformers+  | Just cpr_ty <- cprTransformBespoke id args+  = cpr_ty+  -- Other local Ids that respond True to 'isDataStructure' but don't have an+  -- expandable unfolding, such as NOINLINE bindings. They all get a top sig+  | isLocalId id+  = assertPpr (isDataStructure id) (ppr id) topCprType+  -- See Note [CPR for DataCon wrappers]+  | isDataConWrapId id, let rhs = uf_tmpl (realIdUnfolding id)+  = fst $ cprAnalApp env rhs args+  -- DataCon worker+  | Just con <- isDataConWorkId_maybe id+  = cprTransformDataConWork env con args+  -- Imported function+  | otherwise+  = applyCprTy (getCprSig (idCprSig id)) (length args) --- | CPR transformers for special Ids-cprTransformSpecial :: Id -> [CprType] -> Maybe CprType-cprTransformSpecial id args+-- | Precise, hand-written CPR transformers for select Ids+cprTransformBespoke :: Id -> [(CprType, CoreArg)] -> Maybe CprType+cprTransformBespoke id args   -- See Note [Simplification of runRW#] in GHC.CoreToStg.Prep-  | idUnique id == runRWKey -- `runRW (\s -> e)`-  , [arg] <- args           -- `\s -> e` has CPR type `arg` (e.g. `. -> 2`)-  = Just $ applyCprTy arg 1 -- `e` has CPR type `2`+  | idUnique id == runRWKey    -- `runRW (\s -> e)`+  , [(arg_ty, _arg)] <- args   -- `\s -> e` has CPR type `arg` (e.g. `. -> 2`)+  = Just $ applyCprTy arg_ty 1 -- `e` has CPR type `2`   | otherwise   = Nothing +-- | Get a (possibly nested) 'CprType' for an application of a 'DataCon' worker,+-- given a saturated number of 'CprType's for its field expressions.+-- Implements the Nested part of Note [Nested CPR].+cprTransformDataConWork :: AnalEnv -> DataCon -> [(CprType, CoreArg)] -> CprType+cprTransformDataConWork env con args+  | null (dataConExTyCoVars con)  -- No existentials+  , wkr_arity <= mAX_CPR_SIZE -- See Note [Trimming to mAX_CPR_SIZE]+  , args `lengthIs` wkr_arity+  , ae_rec_dc env con /= DefinitelyRecursive -- See Note [CPR for recursive data constructors]+  -- , pprTrace "cprTransformDataConWork" (ppr con <+> ppr wkr_arity <+> ppr args) True+  = CprType 0 (ConCpr (dataConTag con) (strictZipWith extract_nested_cpr args wkr_str_marks))+  | otherwise+  = topCprType+  where+    wkr_arity = dataConRepArity con+    wkr_str_marks = dataConRepStrictness con+    -- See Note [Nested CPR]+    extract_nested_cpr (CprType 0 cpr, arg) str+      | MarkedStrict <- str              = cpr+      | Terminates <- exprTerminates arg = cpr+    extract_nested_cpr _ _               = topCpr -- intervening lambda or doesn't terminate++-- | See Note [Trimming to mAX_CPR_SIZE].+mAX_CPR_SIZE :: Arity+mAX_CPR_SIZE = 10+ -- -- * Bindings --  -- Recursive bindings-cprFix :: TopLevelFlag-       -> AnalEnv                    -- Does not include bindings for this binding+cprFix :: AnalEnv                    -- Does not include bindings for this binding        -> [(Id,CoreExpr)]        -> (AnalEnv, [(Id,CoreExpr)]) -- Binders annotated with CPR info-cprFix top_lvl orig_env orig_pairs+cprFix orig_env orig_pairs   = loop 1 init_env init_pairs   where-    init_sig id rhs+    init_sig id       -- See Note [CPR for data structures]-      | isDataStructure id rhs = topCprSig-      | otherwise              = mkCprSig 0 botCpr+      | isDataStructure id = topCprSig+      | otherwise          = mkCprSig 0 botCpr     -- See Note [Initialising strictness] in GHC.Core.Opt.DmdAnal     orig_virgin = ae_virgin orig_env-    init_pairs | orig_virgin  = [(setIdCprInfo id (init_sig id rhs), rhs) | (id, rhs) <- orig_pairs ]+    init_pairs | orig_virgin  = [(setIdCprSig id (init_sig id), rhs) | (id, rhs) <- orig_pairs ]                | otherwise    = orig_pairs     init_env = extendSigEnvFromIds orig_env (map fst init_pairs) -    -- The fixed-point varies the idCprInfo field of the binders and and their+    -- The fixed-point varies the idCprSig field of the binders and and their     -- entries in the AnalEnv, and terminates if that annotation does not change     -- any more.     loop :: Int -> AnalEnv -> [(Id,CoreExpr)] -> (AnalEnv, [(Id,CoreExpr)])@@ -311,27 +419,53 @@         (env', pairs') = step (applyWhen (n/=1) nonVirgin env) pairs         -- Make sure we reset the virgin flag to what it was when we are stable         reset_env'     = env'{ ae_virgin = orig_virgin }-        found_fixpoint = map (idCprInfo . fst) pairs' == map (idCprInfo . fst) pairs+        found_fixpoint = map (idCprSig . fst) pairs' == map (idCprSig . fst) pairs      step :: AnalEnv -> [(Id, CoreExpr)] -> (AnalEnv, [(Id, CoreExpr)])     step env pairs = mapAccumL go env pairs       where         go env (id, rhs) = (env', (id', rhs'))           where-            (id', rhs', env') = cprAnalBind top_lvl env id rhs+            (id', rhs', env') = cprAnalBind env id rhs +{-+Note [The OPAQUE pragma and avoiding the reboxing of results]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider:++  {-# OPAQUE f #-}+  f x = (x,y)++  g True  = f 2 x+  g False = (0,0)++Where if we didn't strip the CPR info from 'f' we would end up with the+following W/W pair for 'g':++  $wg True  = case f 2 of (x, y) -> (# x, y #)+  $wg False = (# 0, 0 #)++  g b = case wg$ b of (# x, y #) -> (x, y)++Where the worker unboxes the result of 'f', only for wrapper to box it again.+That's because the non-stripped CPR signature of 'f' is saying to W/W-transform+'f'. However, OPAQUE-annotated binders aren't W/W transformed (see+Note [OPAQUE pragma]), so we should strip 'f's CPR signature.+-}+ -- | Process the RHS of the binding for a sensible arity, add the CPR signature -- to the Id, and augment the environment with the signature as well. cprAnalBind-  :: TopLevelFlag-  -> AnalEnv+  :: AnalEnv   -> Id   -> CoreExpr   -> (Id, CoreExpr, AnalEnv)-cprAnalBind top_lvl env id rhs+cprAnalBind env id rhs+  | isDFunId id -- Never give DFuns the CPR property; we'll never save allocs.+  = (id,  rhs,  extendSigEnv env id topCprSig)   -- See Note [CPR for data structures]-  | isDataStructure id rhs-  = (id,  rhs,  env) -- Data structure => no code => need to analyse rhs+  | isDataStructure id+  = (id,  rhs,  env) -- Data structure => no code => no need to analyse rhs   | otherwise   = (id', rhs', env')   where@@ -340,38 +474,37 @@     rhs_ty'       -- See Note [CPR for thunks]       | stays_thunk = trimCprTy rhs_ty-      -- See Note [CPR for sum types]-      | returns_sum = trimCprTy rhs_ty       | otherwise   = rhs_ty     -- See Note [Arity trimming for CPR signatures]     sig  = mkCprSigForArity (idArity id) rhs_ty'-    id'  = setIdCprInfo id sig-    env' = extendSigEnv env id sig+    -- See Note [OPAQUE pragma]+    -- See Note [The OPAQUE pragma and avoiding the reboxing of results]+    sig' | isOpaquePragma (idInlinePragma id) = topCprSig+         | otherwise                          = sig+    id'  = setIdCprSig id sig'+    env' = extendSigEnv env id sig'      -- See Note [CPR for thunks]     stays_thunk = is_thunk && not_strict     is_thunk    = not (exprIsHNF rhs) && not (isJoinId id)     not_strict  = not (isStrUsedDmd (idDemandInfo id))-    -- See Note [CPR for sum types]-    (_, ret_ty) = splitPiTys (idType id)-    not_a_prod  = isNothing (splitArgType_maybe (ae_fam_envs env) ret_ty)-    returns_sum = not (isTopLevel top_lvl) && not_a_prod -isDataStructure :: Id -> CoreExpr -> Bool+isDataStructure :: Id -> Bool -- See Note [CPR for data structures]-isDataStructure id rhs =-  idArity id == 0 && exprIsHNF rhs+isDataStructure id =+  not (isJoinId id) && idArity id == 0 && isEvaldUnfolding (idUnfolding id)  -- | Returns an expandable unfolding -- (See Note [exprIsExpandable] in "GHC.Core.Utils") that has -- So effectively is a constructor application. cprDataStructureUnfolding_maybe :: Id -> Maybe CoreExpr-cprDataStructureUnfolding_maybe id = do+cprDataStructureUnfolding_maybe id   -- There are only FinalPhase Simplifier runs after CPR analysis-  guard (activeInFinalPhase (idInlineActivation id))-  unf <- expandUnfolding_maybe (idUnfolding id)-  guard (isDataStructure id unf)-  return unf+  | activeInFinalPhase (idInlineActivation id)+  , isDataStructure id+  = expandUnfolding_maybe (idUnfolding id)+  | otherwise+  = Nothing  {- Note [Arity trimming for CPR signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -403,6 +536,49 @@  And the case in @g@ can never cancel away, thus we introduced extra reboxing. Hence we always trim the CPR signature of a binding to idArity.++Note [CPR for DataCon wrappers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We used to give DataCon wrappers a (necessarily flat) CPR signature in+'GHC.Types.Id.Make.mkDataConRep'. Now we transform DataCon wrappers simply by+analysing their unfolding. A few reasons for the change:++  1. DataCon wrappers are generally inlined in the Final phase (so before CPR),+     all leftover occurrences are in a boring context like `f x y = $WMkT y x`.+     It's simpler to analyse the unfolding anew at every such call site, and the+     unfolding will be pretty cheap to analyse. Also they occur seldom enough+     that performance-wise it doesn't matter.+  2. 'GHC.Types.Id.Make' no longer precomputes CPR signatures for DataCon+     *workers*, because their transformers need to adapt to CPR for their+     arguments in 'cprTransformDataConWork' to enable Note [Nested CPR].+     Better keep it all in this module! The alternative would be that+     'GHC.Types.Id.Make' depends on DmdAnal.+  3. In the future, Nested CPR could take a better account of incoming args+     in cprAnalApp and do some beta-reduction on the fly, like !1866 did. If+     any of those args had the CPR property, then we'd even get Nested CPR for+     DataCon wrapper calls, for free. Not so if we simply give the wrapper a+     single CPR sig in 'GHC.Types.Id.Make.mkDataConRep'!++Note [Trimming to mAX_CPR_SIZE]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We do not treat very big tuples as CPR-ish:++  a) For a start, we get into trouble because there aren't+     "enough" unboxed tuple types (a tiresome restriction,+     but hard to fix),+  b) More importantly, big unboxed tuples get returned mainly+     on the stack, and are often then allocated in the heap+     by the caller. So doing CPR for them may in fact make+     things worse, especially if the wrapper doesn't cancel away+     and we move to the stack in the worker and then to the heap+     in the wrapper.++So we (nested) CPR for functions that would otherwise pass more than than+'mAX_CPR_SIZE' fields.+That effect is exacerbated for the unregisterised backend, where we+don't have any hardware registers to return the fields in. Returning+everything on the stack results in much churn and increases compiler+allocation by 15% for T15164 in a validate build. -}  data AnalEnv@@ -414,6 +590,8 @@   -- iteration. See Note [Initialising strictness] in "GHC.Core.Opt.DmdAnal"   , ae_fam_envs :: FamInstEnvs   -- ^ Needed when expanding type families and synonyms of product types.+  , ae_rec_dc :: DataCon -> IsRecDataConResult+  -- ^ Memoised result of 'GHC.Core.Opt.WorkWrap.Utils.isRecDataCon'   }  instance Outputable AnalEnv where@@ -445,7 +623,11 @@   { ae_sigs = SE emptyUnVarSet emptyVarEnv   , ae_virgin = True   , ae_fam_envs = fam_envs-  }+  , ae_rec_dc = memoiseUniqueFun (isRecDataCon fam_envs fuel)+  } where+    fuel = 3 -- If we can unbox more than 3 constructors to find a+             -- recursive occurrence, then we can just as well unbox it+             -- See Note [CPR for recursive data constructors], point (4)  modifySigEnv :: (SigEnv -> SigEnv) -> AnalEnv -> AnalEnv modifySigEnv f env = env { ae_sigs = f (ae_sigs env) }@@ -472,7 +654,7 @@ -- | Extend an environment with the CPR sigs attached to the ids extendSigEnvFromIds :: AnalEnv -> [Id] -> AnalEnv extendSigEnvFromIds env ids-  = foldl' (\env id -> extendSigEnv env id (idCprInfo id)) env ids+  = foldl' (\env id -> extendSigEnv env id (idCprSig id)) env ids  -- | Extend an environment with the same CPR sig for all ids extendSigEnvAllSame :: AnalEnv -> [Id] -> CprSig -> AnalEnv@@ -489,35 +671,23 @@ -- See Note [CPR for binders that will be unboxed]. extendSigEnvForArg :: AnalEnv -> Id -> AnalEnv extendSigEnvForArg env id-  = extendSigEnv env id (CprSig (argCprType env (idType id) (idDemandInfo id)))+  = extendSigEnv env id (CprSig (argCprType (idDemandInfo id)))  -- | Produces a 'CprType' according to how a strict argument will be unboxed. -- Examples: -----   * A head-strict demand @1L@ on @Int@ would translate to @1@---   * A product demand @1P(1L,L)@ on @(Int, Bool)@ would translate to @1(1,)@---   * A product demand @1P(1L,L)@ on @(a , Bool)@ would translate to @1(,)@,---     because the unboxing strategy would not unbox the @a@.-argCprType :: AnalEnv -> Type -> Demand -> CprType-argCprType env arg_ty dmd = CprType 0 (go arg_ty dmd)+--   * A head-strict demand @1!L@ would translate to @1@+--   * A product demand @1!P(1!L,L)@ would translate to @1(1,)@+--   * A product demand @1!P(1L,L)@ would translate to @1(,)@,+--     because the first field will not be unboxed.+argCprType :: Demand -> CprType+argCprType dmd = CprType 0 (go dmd)   where-    go ty dmd-      | Unbox (DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args }) ds-          <- wantToUnbox (ae_fam_envs env) no_inlineable_prag ty dmd-      -- No existentials; see Note [Which types are unboxed?])-      -- Otherwise we'd need to call dataConRepInstPat here and thread a-      -- UniqSupply. So argCprType is a bit less aggressive than it could-      -- be, for the sake of coding convenience.-      , null (dataConExTyCoVars dc)-      , let arg_tys = map scaledThing (dataConInstArgTys dc tc_args)-      = ConCpr (dataConTag dc) (zipWith go arg_tys ds)-      | otherwise-      = topCpr-    -- Rather than maintaining in AnalEnv whether we are in an INLINEABLE-    -- function, we just assume that we aren't. That flag is only relevant-    -- to Note [Do not unpack class dictionaries], the few unboxing-    -- opportunities on dicts it prohibits are probably irrelevant to CPR.-    no_inlineable_prag = False+    go (n :* sd)+      | isAbs n               = topCpr+      | Prod Unboxed ds <- sd = ConCpr fIRST_TAG (strictMap go ds)+      | Poly Unboxed _  <- sd = ConCpr fIRST_TAG []+      | otherwise             = topCpr  {- Note [Safe abortion in the fixed-point iteration] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -570,7 +740,7 @@  Note that -  * Whether or not something unboxes is decided by 'wantToUnbox', else we may+  * Whether or not something unboxes is decided by 'wantToUnboxArg', else we may     get over-optimistic CPR results (e.g., from \(x :: a) -> x!).    * If the demand unboxes deeply, we can give the binder a /nested/ CPR@@ -592,110 +762,6 @@    * See Note [CPR examples] -Historic Note [Optimistic field binder CPR]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-This Note describes how we used to guess whether fields have the CPR property-before we were able to express Nested CPR for arguments.--Consider--  data T a = MkT a-  f :: T Int -> Int-  f x = ... (case x of-    MkT y -> y) ...--And assume we know from strictness analysis that `f` is strict in `x` and its-field `y` and we unbox both. Then we give `x` the CPR property according-to Note [CPR for binders that will be unboxed]. But `x`'s sole field `y`-likewise will be unboxed and it should also get the CPR property. We'd-need a *nested* CPR property here for `x` to express that and unwrap one level-when we analyse the Case to give the CPR property to `y`.--Lacking Nested CPR, we have to guess a bit, by looking for--  (A) Flat CPR on the scrutinee-  (B) A variable scrutinee. Otherwise surely it can't be a parameter.-  (C) Strict demand on the field binder `y` (or it binds a strict field)--While (A) is a necessary condition to give a field the CPR property, there are-ways in which (B) and (C) are too lax, leading to unsound analysis results and-thus reboxing in the wrapper:--  (b) We could scrutinise some other variable than a parameter, like in--        g :: T Int -> Int-        g x = let z = foo x in -- assume `z` has CPR property-              case z of MkT y -> y--      Lacking Nested CPR and multiple levels of unboxing, only the outer box-      of `z` will be available and a case on `y` won't actually cancel away.-      But it's simple, and nothing terrible happens if we get it wrong. e.g.-      #10694.--  (c) A strictly used field binder doesn't mean the function is strict in it.--        h :: T Int -> Int -> Int-        h !x 0 = 0-        h  x 0 = case x of MkT y -> y--      Here, `y` is used strictly, but the field of `x` certainly is not and-      consequently will not be available unboxed.-      Why not look at the demand of `x` instead to determine whether `y` is-      unboxed? Because the 'idDemandInfo' on `x` will not have been propagated-      to its occurrence in the scrutinee when CprAnal runs directly after-      DmdAnal.--We used to give the case binder the CPR property unconditionally instead of-deriving it from the case scrutinee.-See Historical Note [Optimistic case binder CPR].--Historical Note [Optimistic case binder CPR]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We used to give the case binder the CPR property unconditionally, which is too-optimistic (#19232). Here are the details:--Inside the alternative, the case binder always has the CPR property, meaning-that a case on it will successfully cancel.-Example:-  f True  x = case x of y { I# x' -> if x' ==# 3-                                     then y-                                     else I# 8 }-  f False x = I# 3-By giving 'y' the CPR property, we ensure that 'f' does too, so we get-  f b x = case fw b x of { r -> I# r }-  fw True  x = case x of y { I# x' -> if x' ==# 3 then x' else 8 }-  fw False x = 3-Of course there is the usual risk of re-boxing: we have 'x' available boxed-and unboxed, but we return the unboxed version for the wrapper to box. If the-wrapper doesn't cancel with its caller, we'll end up re-boxing something that-we did have available in boxed form.--Note [CPR for sum types]-~~~~~~~~~~~~~~~~~~~~~~~~-At the moment we do not do CPR for let-bindings that-   * non-top level-   * bind a sum type-Reason: I found that in some benchmarks we were losing let-no-escapes,-which messed it all up.  Example-   let j = \x. ....-   in case y of-        True  -> j False-        False -> j True-If we w/w this we get-   let j' = \x. ....-   in case y of-        True  -> case j' False of { (# a #) -> Just a }-        False -> case j' True of { (# a #) -> Just a }-Notice that j' is not a let-no-escape any more.--However this means in turn that the *enclosing* function-may be CPR'd (via the returned Justs).  But in the case of-sums, there may be Nothing alternatives; and that messes-up the sum-type CPR.--Conclusion: only do this for products.  It's still not-guaranteed OK for products, but sums definitely lose sometimes.- Note [CPR for thunks] ~~~~~~~~~~~~~~~~~~~~~ If the rhs is a thunk, we usually forget the CPR info, because@@ -765,65 +831,282 @@   xs1 = x2 : xs2   xs2 = x3 : xs3 -should not get CPR signatures (#18154), because they+should not get (nested) CPR signatures (#18154), because they    * Never get WW'd, so their CPR signature should be irrelevant after analysis     (in fact the signature might even be harmful for that reason)   * Would need to be inlined/expanded to see their constructed product-  * Recording CPR on them blows up interface file sizes and is redundant with+  * BUT MOST IMPORTANTLY, Problem P1:+    Recording CPR on them blows up interface file sizes and is redundant with     their unfolding. In case of Nested CPR, this blow-up can be quadratic!     Reason: the CPR info for xs1 contains the CPR info for xs; the CPR info     for xs2 contains that for xs1. And so on.+    By contrast, the size of unfoldings and types stays linear. That's why+    quadratic blowup is problematic; it makes an asymptotic difference. -Hence we don't analyse or annotate data structures in 'cprAnalBind'. To-implement this, the isDataStructure guard is triggered for bindings that satisfy+Hence (Solution S1) we don't give data structure bindings a CPR *signature* and+hence don't to analyse them in 'cprAnalBind'.+What do we mean by "data structure binding"? Answer: -  (1) idArity id == 0 (otherwise it's a function)-  (2) exprIsHNF rhs   (otherwise it's a thunk, Note [CPR for thunks] applies)+  (1) idArity id == 0    (otherwise it's a function)+  (2) is eval'd          (otherwise it's a thunk, Note [CPR for thunks] applies)+  (3) not (isJoinId id)  (otherwise it's a function and its more efficient to+                          analyse it just once rather than at each call site) -But we can't just stop giving DataCon application bindings the CPR *property*,-for example+But (S1) leads to a new Problem P2: We can't just stop giving DataCon application+bindings the CPR *property*, for example the factorial function after FloatOut -  fac 0 = I# 1#+  lvl = I# 1#+  fac 0 = lvl   fac n = n * fac (n-1) -fac certainly has the CPR property and should be WW'd! But FloatOut will-transform the first clause to+lvl is a data structure, and hence (see above) will not have a CPR *signature*.+But if lvl doesn't have the CPR *property*, fac won't either and we allocate a+box for the result on every iteration of the loop. -  lvl = I# 1#-  fac 0 = lvl+So (Solution S2) when 'cprAnal' meets a variable lacking a CPR signature to+extrapolate into a CPR transformer, 'cprTransform' tries to get its unfolding+(via 'cprDataStructureUnfolding_maybe'), and analyses that instead. -If lvl doesn't have the CPR property, fac won't either. But lvl is a data-structure, and hence (see above) will not have a CPR signature. So instead, when-'cprAnal' meets a variable lacking a CPR signature to extrapolate into a CPR-transformer, 'cprTransform' instead tries to get its unfolding (via-'cprDataStructureUnfolding_maybe'), and analyses that instead.+The Result R1: Everything behaves as if there was a CPR signature, but without+the blowup in interface files. -In practice, GHC generates a lot of (nested) TyCon and KindRep bindings, one-for each data declaration. They should not have CPR signatures (blow up!).+There is one exception to (R1): -There is a perhaps surprising special case: KindRep bindings satisfy-'isDataStructure' (so no CPR signature), but are marked NOINLINE at the same-time (see the noinline wrinkle in Note [Grand plan for Typeable]). So there is-no unfolding for 'cprDataStructureUnfolding_maybe' to look through and we'll-return topCprType. And that is fine! We should refrain to look through NOINLINE-data structures in general, as a constructed product could never be exposed-after WW.+  x   = (y, z); {-# NOINLINE x #-}+  f p = (y, z); {-# NOINLINE f #-} -It's also worth pointing out how ad-hoc this is: If we instead had+While we still give the NOINLINE *function* 'f' the CPR property (and WW+accordingly, see Note [Worker/wrapper for NOINLINE functions]), we won't+give the NOINLINE *data structure* 'x' the CPR property, because it lacks an+unfolding. In particular, KindRep bindings are NOINLINE data structures (see+the noinline wrinkle in Note [Grand plan for Typeable]). We'll behave as if the+bindings had 'topCprSig', and that is fine, as a case on the binding would never+cancel away after WW! +It's also worth pointing out how ad-hoc (S1) is: If we instead had+     f1 x = x:[]     f2 x = x : f1 x     f3 x = x : f2 x     ... -we still give every function an every deepening CPR signature. But it's very+we still give every function an ever deepening CPR signature. But it's very uncommon to find code like this, whereas the long static data structures from the beginning of this Note are very common because of GHC's strategy of ANF'ing data structure RHSs. +Note [CPR for data structures can destroy sharing]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In Note [CPR for data structures], we argued that giving data structure bindings+the CPR property is useful to give functions like fac the CPR property:++  lvl = I# 1#+  fac 0 = lvl+  fac n = n * fac (n-1)++Worker/wrappering fac for its CPR property means we get a very fast worker+function with type Int# -> Int#, without any heap allocation at all.++But consider what happens if we call `map fac (replicate n 0)`, where the+wrapper doesn't cancel away: Then we rebox the result of $wfac *on each call*,+n times, instead of reusing the static thunk for 1, e.g. an asymptotic increase+in allocations. If you twist it just right, you can actually write programs that+that take O(n) space if you do CPR and O(1) if you don't:++  fac :: Int -> Int+  fac 0 = 1 -- this clause will trigger CPR and destroy sharing for O(n) space+  -- fac 0 = lazy 1 -- this clause will prevent CPR and run in O(1) space+  fac n = n * fac (n-1)++  const0 :: Int -> Int+  const0 n = signum n - 1 -- will return 0 for [1..n]+  {-# NOINLINE const0 #-}++  main = print $ foldl' (\acc n -> acc + lazy n) 0 $ map (fac . const0) [1..100000000]++Generally, this kind of asymptotic increase in allocation can happen whenever we+give a data structure the CPR property that is bound outside of a recursive+function. So far we don't have a convincing remedy; giving fac the CPR property+is just too attractive. #19309 documents a futile idea. #13331 tracks the+general issue of WW destroying sharing and also contains above reproducer.+#19326 is about CPR destroying sharing in particular.++With Nested CPR, sharing can also be lost within the same "lambda level", for+example:++  f (I# x) = let y = I# (x*#x) in (y, y)++Nestedly unboxing would destroy the box shared through 'y'. (Perhaps we can call+this "internal sharing", in contrast to "external sharing" beyond lambda or even+loop levels above.) But duplicate occurrences like that are pretty rare and may+never lead to an asymptotic difference in allocations of 'f'.++Note [CPR for recursive data constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [CPR for data structures can destroy sharing] gives good reasons not to+give shared data structure bindings the CPR property. But we shouldn't even+give *functions* that return *recursive* data constructor applications the CPR+property. Here's an example for why:++  c = C# 'a'+  replicateC :: Int -> [Int]+  replicateC 1 = [c]+  replicateC n = c : replicateC (n-1)++What happens if we give `replicateC` the (nested) CPR property? We get a WW+split for 'replicateC', the wrapper of which is certain to inline, like this:++  replicateC (I# n) = case $wreplicateC n of (# x, xs #) -> C# x : xs+  $wreplicateC 1# = (# 'a', [] #)+  $wreplicateC n  = (# 'a', replicateC (I# (n -# 1#)) #)++Eliminating the shared 'c' binding in the process. And then++  * We *might* save allocation of the topmost (of most likely several) (:)+    constructor if it cancels away at the call site. Similarly for the 'C#'+    constructor.+  * But we will now re-allocate the C# box on every iteration of the loop,+    because we separated the character literal from the C# application.+    That means n times as many C# allocations as before. Yikes!!+  * We make all other call sites where the wrapper inlines a bit larger, most of+    them for no gain. But this shouldn't matter much.+  * The inlined wrapper may inhibit eta-expansion in some cases. Here's how:+    If the wrapper is inlined in a strict arg position, the Simplifier will+    transform as follows++      f (replicateC n)+      ==> { inline }+      f (case $wreplicateC n of (# x, xs #) -> (C# x, xs))+      ==> { strict arg }+      case $wreplicateC n of (# x, xs #) -> f (C# x, xs)++    Now we can't float out the case anymore. In fact, we can't even float out+    `$wreplicateC n`, because it returns an unboxed tuple.+    This can inhibit eta-expansion if we later find out that `f` has arity > 1+    (such as when we define `foldl` in terms of `foldr`). #19970 shows how+    abstaining from worker/wrappering made a difference of -20% in reptile. So+    while WW'ing for CPR didn't make the program slower directly, the resulting+    program got much harder to optimise because of the returned unboxed tuple+    (which can't easily float because unlifted).++`replicateC` comes up in T5536, which regresses significantly if CPR'd nestedly.++What can we do about it?++ A. Don't CPR functions that return a *recursive data type* (the list in this+    case). This is the solution we adopt. Rationale: the benefit of CPR on+    recursive data structures is slight, because it only affects the outer layer+    of a potentially massive data structure.+ B. Don't CPR any *recursive function*. That would be quite conservative, as it+    would also affect e.g. the factorial function.+ C. Flat CPR only for recursive functions. This prevents the asymptotic+    worsening part arising through unsharing the C# box, but it's still quite+    conservative.+ D. No CPR at occurrences of shared data structure in hot paths (e.g. the use of+    `c` in the second eqn of `replicateC`). But we'd need to know which paths+    were hot. We want such static branch frequency estimates in #20378.++We adopt solution (A) It is ad-hoc, but appears to work reasonably well.+Deciding what a "recursive data constructor" is is quite tricky and ad-hoc, too:+See Note [Detecting recursive data constructors]. We don't have to be perfect+and can simply keep on unboxing if unsure.++Note [Detecting recursive data constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+What qualifies as a "recursive data constructor" as per+Note [CPR for recursive data constructors]? That is up to+'GHC.Core.Opt.WorkWrapW.Utils.isRecDataCon' to decide. It does a DFS search over+the field types of the DataCon and looks for term-level recursion into the data+constructor's type constructor. Assuming infinite fuel (point (4) below), it+looks inside the following class of types, represented by `ty` (and responds+`NonRecursiveOrUnsure` in all other cases):++ A. If `ty = forall v. ty'`, then look into `ty'`+ B. If `ty = Tc tc_args` and `Tc` is an `AlgTyCon`, look into the arg+    types of its data constructors and check `tc_args` for recursion.+ C. If `ty = F tc_args`, `F` is a `FamTyCon` and we can reduce `F tc_args` to+    `rhs`, look into the `rhs` type.++A few perhaps surprising points:++  1. It deems any function type as non-recursive, because it's unlikely that+     a recursion through a function type builds up a recursive data structure.+  2. It doesn't look into kinds or coercion types because there's nothing to unbox.+     Same for promoted data constructors.+  3. We don't care whether an AlgTyCon app `T tc_args` is fully saturated or not;+     we simply look at its definition/DataCons and its field tys and look for+     recursive occs in the `tc_args` we are given. This is so that we expand+     the `ST` in `StateT Int (ST s) a`.+  4. We don't recurse deeper than 3 (at the moment of this writing) TyCons and+     assume the DataCon is non-recursive after that. One reason for this "fuel"+     approach is guaranteed constant-time efficiency; the other is that it's+     fair to say that a recursion over 3 or more TyCons doesn't really count as+     a list-like data structure anymore and a bit of unboxing doesn't hurt much.+  5. It checks AlgTyCon apps like `T tc_args` by eagerly checking the `tc_args`+     *before* it looks into the expanded DataCons/NewTyCon, so that it+     terminates before doing a deep nest of expansions only to discover that the+     first level already contained a recursion.+  6. As a result of keeping the implementation simple, it says "recursive"+     for `data T = MkT [T]`, even though we could argue that the inner recursion+     (through the `[]` TyCon) by way of which `T` is recursive will already be+     "broken" and thus never unboxed. Consequently, it might be OK to CPR a+     function returning `T`. Lacking arguments for or against the current simple+     behavior, we stick to it.+  7. When the search hits an abstract TyCon (algebraic, but without visible+     DataCons, e.g., from an .hs-boot file), it returns 'NonRecursiveOrUnsure',+     the same as when we run out of fuel. If there is ever a recursion through+     an abstract TyCon, then it's not part of the same function we are looking+     at in CPR, so we can treat it as if it wasn't recursive.+     We handle stuck type and data families much the same.++Here are a few examples of data constructors or data types with a single data+con and the answers of our function:++  data T = T (Int, (Bool, Char))               NonRec+  (:)                                          Rec+  []                                           NonRec+  data U = U [Int]                             NonRec+  data U2 = U2 [U2]                            Rec     (see point (6))+  data T1 = T1 T2; data T2 = T2 T1             Rec+  newtype Fix f = Fix (f (Fix f))              Rec+  data N = N (Fix (Either Int))                NonRec+  data M = M (Fix (Either M))                  Rec+  data F = F (F -> Int)                        NonRec  (see point (1))+  data G = G (Int -> G)                        NonRec  (see point (1))+  newtype MyM s a = MyM (StateT Int (ST s) a   NonRec+  type S = (Int, Bool)                         NonRec++  { type family E a where+      E Int = Char+      E (a,b) = (E a, E b)+      E Char = Blub+    data Blah = Blah (E (Int, (Int, Int)))     NonRec+    data Blub = Blub (E (Char, Int))           Rec+    data Blub2 = Blub2 (E (Bool, Int))     }   Unsure, because stuck (see point (7))++  { data T1 = T1 T2; data T2 = T2 T3;+    ... data T5 = T5 T1                    }   Unsure (out of fuel)  (see point (4))++  { module A where -- A.hs-boot+      data T+    module B where+      import {-# SOURCE #-} A+      data U = MkU T+      f :: T -> U+      f t = MkU t                              Unsure (T is abstract)  (see point (7))+    module A where -- A.hs+      import B+      data T = MkT U }++These examples are tested by the testcase RecDataConCPR.++I've played with the idea to make points (1) through (3) of 'isRecDataCon'+configurable like (4) to enable more re-use throughout the compiler, but haven't+found a killer app for that yet, so ultimately didn't do that.+ Note [CPR examples]-~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~ Here are some examples (stranal/should_compile/T10482a) of the usefulness of Note [Optimistic field binder CPR].  The main point: all of these functions can have the CPR property.@@ -846,4 +1129,84 @@     f1 :: T3 -> Int     f1 (MkT3 x y) | h x y     = f3 (MkT3 x (y-1))                   | otherwise = x++Historic Note [Optimistic field binder CPR]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This Note describes how we used to guess whether fields have the CPR property+before we were able to express Nested CPR for arguments.++Consider++  data T a = MkT a+  f :: T Int -> Int+  f x = ... (case x of+    MkT y -> y) ...++And assume we know from strictness analysis that `f` is strict in `x` and its+field `y` and we unbox both. Then we give `x` the CPR property according+to Note [CPR for binders that will be unboxed]. But `x`'s sole field `y`+likewise will be unboxed and it should also get the CPR property. We'd+need a *nested* CPR property here for `x` to express that and unwrap one level+when we analyse the Case to give the CPR property to `y`.++Lacking Nested CPR (hence this Note is historic now that we have Nested CPR), we+have to guess a bit, by looking for++  (A) Flat CPR on the scrutinee+  (B) A variable scrutinee. Otherwise surely it can't be a parameter.+  (C) Strict demand on the field binder `y` (or it binds a strict field)++While (A) is a necessary condition to give a field the CPR property, there are+ways in which (B) and (C) are too lax, leading to unsound analysis results and+thus reboxing in the wrapper:++  (b) We could scrutinise some other variable than a parameter, like in++        g :: T Int -> Int+        g x = let z = foo x in -- assume `z` has CPR property+              case z of MkT y -> y++      Lacking Nested CPR and multiple levels of unboxing, only the outer box+      of `z` will be available and a case on `y` won't actually cancel away.+      But it's simple, and nothing terrible happens if we get it wrong. e.g.+      #10694.++  (c) A strictly used field binder doesn't mean the function is strict in it.++        h :: T Int -> Int -> Int+        h !x 0 = 0+        h  x 0 = case x of MkT y -> y++      Here, `y` is used strictly, but the field of `x` certainly is not and+      consequently will not be available unboxed.+      Why not look at the demand of `x` instead to determine whether `y` is+      unboxed? Because the 'idDemandInfo' on `x` will not have been propagated+      to its occurrence in the scrutinee when CprAnal runs directly after+      DmdAnal.++We used to give the case binder the CPR property unconditionally instead of+deriving it from the case scrutinee.+See Historic Note [Optimistic case binder CPR].++Historic Note [Optimistic case binder CPR]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We used to give the case binder the CPR property unconditionally, which is too+optimistic (#19232). Here are the details:++Inside the alternative, the case binder always has the CPR property, meaning+that a case on it will successfully cancel.+Example:+  f True  x = case x of y { I# x' -> if x' ==# 3+                                     then y+                                     else I# 8 }+  f False x = I# 3+By giving 'y' the CPR property, we ensure that 'f' does too, so we get+  f b x = case fw b x of { r -> I# r }+  fw True  x = case x of y { I# x' -> if x' ==# 3 then x' else 8 }+  fw False x = 3+Of course there is the usual risk of re-boxing: we have 'x' available boxed+and unboxed, but we return the unboxed version for the wrapper to box. If the+wrapper doesn't cancel with its caller, we'll end up re-boxing something that+we did have available in boxed form.+ -}
compiler/GHC/Core/Opt/DmdAnal.hs view
@@ -7,7 +7,6 @@                         ----------------- -} -{-# LANGUAGE CPP #-}  module GHC.Core.Opt.DmdAnal    ( DmdAnalOpts(..)@@ -15,8 +14,6 @@    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Core.Opt.WorkWrap.Utils@@ -34,18 +31,23 @@ import GHC.Core.Utils import GHC.Core.TyCon import GHC.Core.Type+import GHC.Core.Predicate ( isClassPred ) import GHC.Core.FVs      ( rulesRhsFreeIds, bndrRuleAndUnfoldingIds )-import GHC.Core.Coercion ( Coercion, coVarsOfCo )+import GHC.Core.Coercion ( Coercion )+import GHC.Core.TyCo.FVs ( coVarsOfCos ) import GHC.Core.FamInstEnv import GHC.Core.Opt.Arity ( typeArity ) import GHC.Utils.Misc import GHC.Utils.Panic-import GHC.Data.Maybe         ( isJust )+import GHC.Utils.Panic.Plain+import GHC.Data.Maybe import GHC.Builtin.PrimOps import GHC.Builtin.Types.Prim ( realWorldStatePrimTy ) import GHC.Types.Unique.Set+import GHC.Types.Unique.MemoFun --- import GHC.Driver.Ppr+import GHC.Utils.Trace+_ = pprTrace -- Tired of commenting out the import all the time  {- ************************************************************************@@ -56,8 +58,10 @@ -}  -- | Options for the demand analysis-newtype DmdAnalOpts = DmdAnalOpts-   { dmd_strict_dicts :: Bool -- ^ Use strict dictionaries+data DmdAnalOpts = DmdAnalOpts+   { dmd_strict_dicts    :: !Bool -- ^ Use strict dictionaries+   , dmd_unbox_width     :: !Int  -- ^ Use strict dictionaries+   , dmd_max_worker_args :: !Int    }  -- This is a strict alternative to (,)@@ -93,7 +97,7 @@     add_exported_uses :: AnalEnv -> DmdType -> [Id] -> DmdType     add_exported_uses env = foldl' (add_exported_use env) -    -- | If @e@ is denoted by @dmd_ty@, then @add_exported_use _ dmd_ty id@+    -- If @e@ is denoted by @dmd_ty@, then @add_exported_use _ dmd_ty id@     -- corresponds to the demand type of @(id, e)@, but is a lot more direct.     -- See Note [Analysing top-level bindings].     add_exported_use :: AnalEnv -> DmdType -> Id -> DmdType@@ -229,7 +233,7 @@ -- -- It calls a function that knows how to analyse this \"body\" given -- an 'AnalEnv' with updated demand signatures for the binding group--- (reflecting their 'idStrictnessInfo') and expects to receive a+-- (reflecting their 'idDmdSigInfo') and expects to receive a -- 'DmdType' in return, which it uses to annotate the binding group with their -- 'idDemandInfo'. dmdAnalBind@@ -275,11 +279,14 @@                  -> WithDmdType (DmdResult CoreBind a) dmdAnalBindLetUp top_lvl env id rhs anal_body = WithDmdType final_ty (R (NonRec id' rhs') (body'))   where-    WithDmdType body_ty body'   = anal_body (addInScopeAnalEnv env id)-    WithDmdType body_ty' id_dmd = findBndrDmd env notArgOfDfun body_ty id-    !id'                = setBindIdDemandInfo top_lvl id id_dmd-    (rhs_ty, rhs')     = dmdAnalStar env (dmdTransformThunkDmd rhs id_dmd) rhs+    WithDmdType body_ty body'   = anal_body env+    WithDmdType body_ty' id_dmd = findBndrDmd env body_ty id+    -- See Note [Finalising boxity for demand signatures] +    id_dmd'            = finaliseLetBoxity (ae_fam_envs env) (idType id) id_dmd+    !id'               = setBindIdDemandInfo top_lvl id id_dmd'+    (rhs_ty, rhs')     = dmdAnalStar env (dmdTransformThunkDmd rhs id_dmd') rhs+     -- See Note [Absence analysis for stable unfoldings and RULES]     rule_fvs           = bndrRuleAndUnfoldingIds id     final_ty           = body_ty' `plusDmdType` rhs_ty `keepAliveDmdType` rule_fvs@@ -342,11 +349,12 @@             -> Demand   -- This one takes a *Demand*             -> CoreExpr -- Should obey the let/app invariant             -> (PlusDmdArg, CoreExpr)-dmdAnalStar env (n :* cd) e-  | WithDmdType dmd_ty e'    <- dmdAnal env cd e-  = ASSERT2( not (isUnliftedType (exprType e)) || exprOkForSpeculation e, ppr e )+dmdAnalStar env (n :* sd) e+  -- NB: (:*) expands AbsDmd and BotDmd as needed+  -- See Note [Analysing with absent demand]+  | WithDmdType dmd_ty e' <- dmdAnal env sd e+  = assertPpr (mightBeLiftedType (exprType e) || exprOkForSpeculation e) (ppr e)     -- The argument 'e' should satisfy the let/app invariant-    -- See Note [Analysing with absent demand] in GHC.Types.Demand     (toPlusDmdArg $ multDmdType n dmd_ty, e')  -- Main Demand Analsysis machinery@@ -405,8 +413,7 @@ dmdAnal' env dmd (Lam var body)   | isTyVar var   = let-        WithDmdType body_ty body' = dmdAnal (addInScopeAnalEnv env var) dmd body-        -- See Note [Bringing a new variable into scope]+        WithDmdType body_ty body' = dmdAnal env dmd body     in     WithDmdType body_ty (Lam var body') @@ -414,52 +421,50 @@   = let (n, body_dmd)    = peelCallDmd dmd           -- body_dmd: a demand to analyze the body -        WithDmdType body_ty body' = dmdAnal (addInScopeAnalEnv env var) body_dmd body-        -- See Note [Bringing a new variable into scope]-        WithDmdType lam_ty var'   = annotateLamIdBndr env notArgOfDfun body_ty var+        WithDmdType body_ty body' = dmdAnal env body_dmd body+        WithDmdType lam_ty var'   = annotateLamIdBndr env body_ty var         new_dmd_type = multDmdType n lam_ty     in     WithDmdType new_dmd_type (Lam var' body')  dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt bndrs rhs])   -- Only one alternative.-  -- If it's a DataAlt, it should be the only constructor of the type.-  | is_single_data_alt alt+  -- If it's a DataAlt, it should be the only constructor of the type and we+  -- can consider its field demands when analysing the scrutinee.+  | want_precise_field_dmds alt   = let-        rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs)-        -- See Note [Bringing a new variable into scope]-        WithDmdType rhs_ty rhs'           = dmdAnal rhs_env dmd rhs-        WithDmdType alt_ty1 dmds          = findBndrsDmds env rhs_ty bndrs-        WithDmdType alt_ty2 case_bndr_dmd = findBndrDmd env False alt_ty1 case_bndr+        WithDmdType rhs_ty rhs'           = dmdAnal env dmd rhs+        WithDmdType alt_ty1 fld_dmds      = findBndrsDmds env rhs_ty bndrs+        WithDmdType alt_ty2 case_bndr_dmd = findBndrDmd env alt_ty1 case_bndr+        !case_bndr'                       = setIdDemandInfo case_bndr case_bndr_dmd         -- Evaluation cardinality on the case binder is irrelevant and a no-op.         -- What matters is its nested sub-demand!-        (_ :* case_bndr_sd)      = case_bndr_dmd+        -- NB: If case_bndr_dmd is absDmd, boxity will say Unboxed, which is+        -- what we want, because then `seq` will put a `seqDmd` on its scrut.+        (_ :* case_bndr_sd) = case_bndr_dmd         -- Compute demand on the scrutinee         -- FORCE the result, otherwise thunks will end up retaining the         -- whole DmdEnv         !(!bndrs', !scrut_sd)           | DataAlt _ <- alt           -- See Note [Demand on the scrutinee of a product case]-          , let !scrut_sd = scrutSubDmd case_bndr_sd dmds-          , let !fld_dmds' = fieldBndrDmds scrut_sd (length dmds)-          = let !new_info = setBndrsDemandInfo bndrs fld_dmds'-                !new_prod = mkProd fld_dmds'-            in (new_info, new_prod)+          -- See Note [Demand on case-alternative binders]+          , (!scrut_sd, fld_dmds') <- addCaseBndrDmd case_bndr_sd fld_dmds+          , let !bndrs' = setBndrsDemandInfo bndrs fld_dmds'+          = (bndrs', scrut_sd)           | otherwise           -- __DEFAULT and literal alts. Simply add demands and discard the           -- evaluation cardinality, as we evaluate the scrutinee exactly once.-          = ASSERT( null bndrs ) (bndrs, case_bndr_sd)-        fam_envs                 = ae_fam_envs env+          = assert (null bndrs) (bndrs, case_bndr_sd)         alt_ty3           -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand"-          | exprMayThrowPreciseException fam_envs scrut+          | exprMayThrowPreciseException (ae_fam_envs env) scrut           = deferAfterPreciseException alt_ty2           | otherwise           = alt_ty2          WithDmdType scrut_ty scrut' = dmdAnal env scrut_sd scrut         res_ty             = alt_ty3 `plusDmdType` toPlusDmdArg scrut_ty-        !case_bndr'        = setIdDemandInfo case_bndr case_bndr_dmd     in --    pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut --                                   , text "dmd" <+> ppr dmd@@ -470,8 +475,12 @@ --                                   , text "res_ty" <+> ppr res_ty ]) $     WithDmdType res_ty (Case scrut' case_bndr' ty [Alt alt bndrs' rhs'])     where-      is_single_data_alt (DataAlt dc) = isJust $ tyConSingleAlgDataCon_maybe $ dataConTyCon dc-      is_single_data_alt _            = True+      want_precise_field_dmds alt = case alt of+        (DataAlt dc)+          | Nothing <- tyConSingleAlgDataCon_maybe $ dataConTyCon dc -> False+          | DefinitelyRecursive <- ae_rec_dc env dc                  -> False+              -- See Note [Demand analysis for recursive data constructors]+        _                                                            -> True   @@ -487,8 +496,9 @@             WithDmdType rest_ty as' = combineAltDmds as           in WithDmdType (lubDmdType cur_ty rest_ty) (a':as') -        WithDmdType scrut_ty scrut'   = dmdAnal env topSubDmd scrut-        WithDmdType alt_ty1 case_bndr' = annotateBndr env alt_ty case_bndr+        WithDmdType alt_ty1 case_bndr_dmd = findBndrDmd env alt_ty case_bndr+        !case_bndr'                       = setIdDemandInfo case_bndr case_bndr_dmd+        WithDmdType scrut_ty scrut'       = dmdAnal env topSubDmd scrut                                -- NB: Base case is botDmdType, for empty case alternatives                                --     This is a unit for lubDmdType, and the right result                                --     when there really are no alternatives@@ -542,53 +552,47 @@ forcesRealWorld fam_envs ty   | ty `eqType` realWorldStatePrimTy   = True-  | Just DataConPatContext{ dcpc_dc = dc, dcpc_tc_args = tc_args }-      <- splitArgType_maybe fam_envs ty-  , isUnboxedTupleDataCon dc-  , let field_tys = dataConInstArgTys dc tc_args+  | Just (tc, tc_args, _co)  <- normSplitTyConApp_maybe fam_envs ty+  , isUnboxedTupleTyCon tc+  , let field_tys = dataConInstArgTys (tyConSingleDataCon tc) tc_args   = any (eqType realWorldStatePrimTy . scaledThing) field_tys   | otherwise   = False  dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> Alt Var -> WithDmdType (Alt Var) dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs)-  | let rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs)-    -- See Note [Bringing a new variable into scope]-  , WithDmdType rhs_ty rhs' <- dmdAnal rhs_env dmd rhs+  | WithDmdType rhs_ty rhs' <- dmdAnal env dmd rhs   , WithDmdType alt_ty dmds <- findBndrsDmds env rhs_ty bndrs   , let (_ :* case_bndr_sd) = findIdDemand alt_ty case_bndr         -- See Note [Demand on case-alternative binders]         -- we can't use the scrut_sd, because it says 'Prod' and we'll use         -- topSubDmd anyway for scrutinees of sum types.-        scrut_sd = scrutSubDmd case_bndr_sd dmds-        id_dmds = fieldBndrDmds scrut_sd (length dmds)+        (!_scrut_sd, dmds') = addCaseBndrDmd case_bndr_sd dmds         -- Do not put a thunk into the Alt-        !new_ids            = setBndrsDemandInfo bndrs id_dmds-  = -- pprTrace "dmdAnalSumAlt" (ppr con $$ ppr case_bndr $$ ppr dmd $$ ppr alt_ty) $-    WithDmdType alt_ty (Alt con new_ids rhs')+        !new_ids            = setBndrsDemandInfo bndrs dmds'+  = WithDmdType alt_ty (Alt con new_ids rhs') +-- Precondition: The SubDemand is not a Call -- See Note [Demand on the scrutinee of a product case]-scrutSubDmd :: SubDemand -> [Demand] -> SubDemand-scrutSubDmd case_sd fld_dmds =-  -- pprTraceWith "scrutSubDmd" (\scrut_sd -> ppr case_sd $$ ppr fld_dmds $$ ppr scrut_sd) $-  case_sd `plusSubDmd` mkProd fld_dmds---- See Note [Demand on case-alternative binders]-fieldBndrDmds :: SubDemand -- on the scrutinee-              -> Arity-              -> [Demand]  -- Final demands for the components of the DataCon-fieldBndrDmds scrut_sd n_flds =-  case viewProd n_flds scrut_sd of-    Just ds -> ds-    Nothing      -> replicate n_flds topDmd-                      -- Either an arity mismatch or scrut_sd was a call demand.-                      -- See Note [Untyped demand on case-alternative binders]+-- and Note [Demand on case-alternative binders]+addCaseBndrDmd :: SubDemand -- On the case binder+               -> [Demand]  -- On the fields of the constructor+               -> (SubDemand, [Demand])+                            -- SubDemand on the case binder incl. field demands+                            -- and final demands for the components of the constructor+addCaseBndrDmd case_sd fld_dmds+  | Just (_, ds) <- viewProd (length fld_dmds) scrut_sd+  = (scrut_sd, ds)+  | otherwise+  = pprPanic "was a call demand" (ppr case_sd $$ ppr fld_dmds) -- See the Precondition+  where+    scrut_sd = case_sd `plusSubDmd` mkProd Unboxed fld_dmds  {- Note [Analysing with absent demand] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we analyse an expression with demand A.  The "A" means-"absent", so this expression will never be needed.  What should happen?+"absent", so this expression will never be needed. What should happen? There are several wrinkles:  * We *do* want to analyse the expression regardless.@@ -597,6 +601,15 @@   But we can post-process the results to ignore all the usage   demands coming back. This is done by multDmdType. +* Nevertheless, which sub-demand should we pick for analysis?+  Since the demand was absent, any would do. Worker/wrapper will replace+  absent bindings with an absent filler anyway, so annotations in the RHS+  of an absent binding don't matter much.+  Picking 'botSubDmd' would be the most useful, but would also look a bit+  misleading in the Core output of DmdAnal, because all nested annotations would+  be bottoming. Better pick 'seqSubDmd', so that we annotate many of those+  nested bindings with A themselves.+ * In a previous incarnation of GHC we needed to be extra careful in the   case of an *unlifted type*, because unlifted values are evaluated   even if they are not used.  Example (see #9254):@@ -681,12 +694,29 @@ from 'topDiv' to 'conDiv', leading to bugs, performance regressions and complexity that didn't justify the single fixed testcase T13380c. +Note [Demand analysis for recursive data constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+T11545 features a single-product, recursive data type+  data A = A A A ... A+    deriving Eq+Naturally, `(==)` is deeply strict in `A` and in fact will never terminate. That+leads to very large (exponential in the depth) demand signatures and fruitless+churn in boxity analysis, demand analysis and worker/wrapper.+So we detect `A` as a recursive data constructor+(see Note [Detecting recursive data constructors]) analysing `case x of A ...`+and simply assume L for the demand on field binders, which is the same code+path as we take for sum types.+Combined with the B demand on the case binder, we get the very small demand+signature <1S><1S>b on `(==)`. This improves ghc/alloc performance on T11545+tenfold! See also Note [CPR for recursive data constructors] which describes the+sibling mechanism in CPR analysis.+ Note [Demand on the scrutinee of a product case] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When figuring out the demand on the scrutinee of a product case, we use the demands of the case alternative, i.e. id_dmds. But note that these include the demand on the case binder;-see Note [Demand on case-alternative binders] in GHC.Types.Demand.+see Note [Demand on case-alternative binders]. This is crucial. Example:    f x = case x of y { (a,b) -> k y a } If we just take scrut_demand = 1P(L,A), then we won't pass x to the@@ -739,44 +769,6 @@ This is needed even for non-product types, in case the case-binder is used but the components of the case alternative are not. -Note [Untyped demand on case-alternative binders]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-With unsafeCoerce, #8037 and #22039 taught us that the demand on the case binder-may be a call demand or have a different number of fields than the constructor-of the case alternative it is used in. From T22039:--  blarg :: (Int, Int) -> Int-  blarg (x,y) = x+y-  -- blarg :: <1!P(1L,1L)>--  f :: Either Int Int -> Int-  f Left{} = 0-  f e = blarg (unsafeCoerce e)-  ==> { desugars to }-  f = \ (ds_d1nV :: Either Int Int) ->-      case ds_d1nV of wild_X1 {-        Left ds_d1oV -> lvl_s1Q6;-        Right ipv_s1Pl ->-          blarg-            (case unsafeEqualityProof @(*) @(Either Int Int) @(Int, Int) of-             { UnsafeRefl co_a1oT ->-             wild_X1 `cast` (Sub (Sym co_a1oT) :: Either Int Int ~R# (Int, Int))-             })-      }--The case binder `e`/`wild_X1` has demand 1!P(1L,1L), with two fields, from the call-to `blarg`, but `Right` only has one field. Although the code will crash when-executed, we must be able to analyse it in 'fieldBndrDmds' and conservatively-approximate with Top instead of panicking because of the mismatch.-In #22039, this kind of code was guarded behind a safe `cast` and thus dead-code, but nevertheless led to a panic of the compiler.--You might wonder why the same problem doesn't come up when scrutinising a-product type instead of a sum type. It appears that for products, `wild_X1`-will be inlined before DmdAnal.--See also Note [mkWWstr and unsafeCoerce] for a related issue.- Note [Aggregated demand for cardinality] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ FIXME: This Note should be named [LetUp vs. LetDown] and probably predates@@ -828,43 +820,42 @@ ************************************************************************ -} -dmdTransform :: AnalEnv         -- ^ The strictness environment-             -> Id              -- ^ The function-             -> SubDemand       -- ^ The demand on the function-             -> DmdType         -- ^ The demand type of the function in this context-                                -- Returned DmdEnv includes the demand on-                                -- this function plus demand on its free variables-+dmdTransform :: AnalEnv   -- ^ The analysis environment+             -> Id        -- ^ The variable+             -> SubDemand -- ^ The evaluation context of the var+             -> DmdType   -- ^ The demand type unleashed by the variable in this+                          -- context. The returned DmdEnv includes the demand on+                          -- this function plus demand on its free variables -- See Note [What are demand signatures?] in "GHC.Types.Demand"-dmdTransform env var dmd+dmdTransform env var sd   -- Data constructors   | isDataConWorkId var-  = dmdTransformDataConSig (idArity var) dmd+  = dmdTransformDataConSig (idArity var) sd   -- Dictionary component selectors   -- Used to be controlled by a flag.   -- See #18429 for some perf measurements.   | Just _ <- isClassOpId_maybe var-  = -- pprTrace "dmdTransform:DictSel" (ppr var $$ ppr dmd) $-    dmdTransformDictSelSig (idStrictness var) dmd+  = -- pprTrace "dmdTransform:DictSel" (ppr var $$ ppr (idDmdSig var) $$ ppr sd) $+    dmdTransformDictSelSig (idDmdSig var) sd   -- Imported functions   | isGlobalId var-  , let res = dmdTransformSig (idStrictness var) dmd-  = -- pprTrace "dmdTransform:import" (vcat [ppr var, ppr (idStrictness var), ppr dmd, ppr res])+  , let res = dmdTransformSig (idDmdSig var) sd+  = -- pprTrace "dmdTransform:import" (vcat [ppr var, ppr (idDmdSig var), ppr sd, ppr res])     res   -- Top-level or local let-bound thing for which we use LetDown ('useLetUp').   -- In that case, we have a strictness signature to unleash in our AnalEnv.   | Just (sig, top_lvl) <- lookupSigEnv env var-  , let fn_ty = dmdTransformSig sig dmd-  = -- pprTrace "dmdTransform:LetDown" (vcat [ppr var, ppr sig, ppr dmd, ppr fn_ty]) $+  , let fn_ty = dmdTransformSig sig sd+  = -- pprTrace "dmdTransform:LetDown" (vcat [ppr var, ppr sig, ppr sd, ppr fn_ty]) $     case top_lvl of-      NotTopLevel -> addVarDmd fn_ty var (C_11 :* dmd)+      NotTopLevel -> addVarDmd fn_ty var (C_11 :* sd)       TopLevel         | isInterestingTopLevelFn var         -- Top-level things will be used multiple times or not at         -- all anyway, hence the multDmd below: It means we don't         -- have to track whether @var@ is used strictly or at most         -- once, because ultimately it never will.-        -> addVarDmd fn_ty var (C_0N `multDmd` (C_11 :* dmd)) -- discard strictness+        -> addVarDmd fn_ty var (C_0N `multDmd` (C_11 :* sd)) -- discard strictness         | otherwise         -> fn_ty -- don't bother tracking; just annotate with 'topDmd' later   -- Everything else:@@ -872,8 +863,8 @@   --   * Lambda binders   --   * Case and constructor field binders   | otherwise-  = -- pprTrace "dmdTransform:other" (vcat [ppr var, ppr sig, ppr dmd, ppr res]) $-    unitDmdType (unitVarEnv var (C_11 :* dmd))+  = -- pprTrace "dmdTransform:other" (vcat [ppr var, ppr boxity, ppr sd]) $+    unitDmdType (unitVarEnv var (C_11 :* sd))  {- ********************************************************************* *                                                                      *@@ -900,26 +891,36 @@ -- to the Id, and augment the environment with the signature as well. -- See Note [NOINLINE and strictness] dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs-  = -- pprTrace "dmdAnalRhsSig" (ppr id $$ ppr let_dmd $$ ppr sig $$ ppr lazy_fv) $-    (env', lazy_fv, id', rhs')+  = -- pprTrace "dmdAnalRhsSig" (ppr id $$ ppr let_dmd $$ ppr rhs_dmds $$ ppr sig $$ ppr lazy_fv) $+    (final_env, lazy_fv, final_id, final_rhs)   where     rhs_arity = idArity id     -- See Note [Demand signatures are computed for a threshold demand based on idArity]-    rhs_dmd -- See Note [Demand analysis for join points]-            -- See Note [Invariants on join points] invariant 2b, in GHC.Core-            --     rhs_arity matches the join arity of the join point-            | isJoinId id-            = mkCalledOnceDmds rhs_arity let_dmd-            | otherwise-            = mkCalledOnceDmds rhs_arity topSubDmd +    rhs_dmd = mkCalledOnceDmds rhs_arity body_dmd++    body_dmd+      | isJoinId id+      -- See Note [Demand analysis for join points]+      -- See Note [Invariants on join points] invariant 2b, in GHC.Core+      --     rhs_arity matches the join arity of the join point+      -- See Note [Unboxed demand on function bodies returning small products]+      = unboxedWhenSmall env rec_flag (resultType_maybe id) let_dmd+      | otherwise+      -- See Note [Unboxed demand on function bodies returning small products]+      = unboxedWhenSmall env rec_flag (resultType_maybe id) topSubDmd+     WithDmdType rhs_dmd_ty rhs' = dmdAnal env rhs_dmd rhs     DmdType rhs_fv rhs_dmds rhs_div = rhs_dmd_ty+    -- See Note [Do not unbox class dictionaries]+    -- See Note [Boxity for bottoming functions]+    (final_rhs_dmds, final_rhs) = finaliseArgBoxities env id rhs_arity rhs' rhs_div+                                  `orElse` (rhs_dmds, rhs') -    sig = mkStrictSigForArity rhs_arity (DmdType sig_fv rhs_dmds rhs_div)+    sig = mkDmdSigForArity rhs_arity (DmdType sig_fv final_rhs_dmds rhs_div) -    id' = id `setIdStrictness` sig-    !env' = extendAnalEnv top_lvl env id' sig+    final_id   = id `setIdDmdSig` sig+    !final_env = extendAnalEnv top_lvl env final_id sig      -- See Note [Aggregated demand for cardinality]     -- FIXME: That Note doesn't explain the following lines at all. The reason@@ -932,6 +933,7 @@     --        might turn into used-many even if the signature was stable and     --        we'd have to do an additional iteration. reuseEnv makes sure that     --        we never get used-once info for FVs of recursive functions.+    --        See #14816 where we try to get rid of reuseEnv.     rhs_fv1 = case rec_flag of                 Recursive    -> reuseEnv rhs_fv                 NonRecursive -> rhs_fv@@ -942,6 +944,45 @@     -- See Note [Lazy and unleashable free variables]     !(!lazy_fv, !sig_fv) = partitionVarEnv isWeakDmd rhs_fv2 +-- | The result type after applying 'idArity' many arguments. Returns 'Nothing'+-- when the type doesn't have exactly 'idArity' many arrows.+resultType_maybe :: Id -> Maybe Type+resultType_maybe id+  | (pis,ret_ty) <- splitPiTys (idType id)+  , count (not . isNamedBinder) pis == idArity id+  = Just $! ret_ty+  | otherwise+  = Nothing++unboxedWhenSmall :: AnalEnv -> RecFlag -> Maybe Type -> SubDemand -> SubDemand+-- See Note [Unboxed demand on function bodies returning small products]+unboxedWhenSmall _   _        Nothing       sd = sd+unboxedWhenSmall env rec_flag (Just ret_ty) sd = go 1 ret_ty sd+  where+    -- Magic constant, bounding the depth of optimistic 'Unboxed' flags. We+    -- might want to minmax in the future.+    max_depth | isRec rec_flag = 3 -- So we get at most something as deep as !P(L!P(L!L))+              | otherwise      = 1 -- Otherwise be unbox too deep in T18109, T18174 and others and get a bunch of stack overflows+    go :: Int -> Type -> SubDemand -> SubDemand+    go depth ty sd+      | depth <= max_depth+      , Just (tc, tc_args, _co) <- normSplitTyConApp_maybe (ae_fam_envs env) ty+      , Just dc <- tyConSingleAlgDataCon_maybe tc+      , null (dataConExTyCoVars dc) -- Can't unbox results with existentials+      , dataConRepArity dc <= dmd_unbox_width (ae_opts env)+      , Just (_, ds) <- viewProd (dataConRepArity dc) sd+      , arg_tys <- map scaledThing $ dataConInstArgTys dc tc_args+      , equalLength ds arg_tys+      = mkProd Unboxed $! strictZipWith (go_dmd (depth+1)) arg_tys ds+      | otherwise+      = sd++    go_dmd :: Int -> Type -> Demand -> Demand+    go_dmd depth ty dmd = case dmd of+      AbsDmd  -> AbsDmd+      BotDmd  -> BotDmd+      n :* sd -> n :* go depth ty sd+ -- | If given the (local, non-recursive) let-bound 'Id', 'useLetUp' determines -- whether we should process the binding up (body before rhs) or down (rhs -- before body).@@ -1045,7 +1086,7 @@ Because idArity of a function varies independently of its cardinality properties (cf. Note [idArity varies independently of dmdTypeDepth]), we implicitly encode the arity for when a demand signature is sound to unleash-in its 'dmdTypeDepth' (cf. Note [Understanding DmdType and StrictSig] in+in its 'dmdTypeDepth' (cf. Note [Understanding DmdType and DmdSig] in GHC.Types.Demand). It is unsound to unleash a demand signature when the incoming number of arguments is less than that. See Note [What are demand signatures?] in GHC.Types.Demand for more details@@ -1094,7 +1135,7 @@   * idArity is analysis information itself, thus volatile   * We already *have* dmdTypeDepth, wo why not just use it to encode the     threshold for when to unleash the signature-    (cf. Note [Understanding DmdType and StrictSig] in GHC.Types.Demand)+    (cf. Note [Understanding DmdType and DmdSig] in GHC.Types.Demand)  Consider the following expression, for example: @@ -1160,35 +1201,466 @@ disaster.  But regardless, #18638 was a more complicated version of this, that actually happened in practice. -Historical Note [Product demands for function body]+Note [Boxity for bottoming functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+```hs+indexError :: Show a => (a, a) -> a -> String -> b+-- Str=<..><1!P(S,S)><1S><S>b+indexError rng i s = error (show rng ++ show i ++ show s)++get :: (Int, Int) -> Int -> [a] -> a+get p@(l,u) i xs+  | l <= i, i < u = xs !! (i-u)+  | otherwise     = indexError p i "get"+```+The hot path of `get` certainly wants to unbox `p` as well as `l` and `u`, but+the unimportant, diverging error path needs `l` and `u` boxed (although the+wrapper for `indexError` *will* unbox `p`). This pattern often occurs in+performance sensitive code that does bounds-checking.++It would be a shame to let `Boxed` win for the fields! So here's what we do:+While to summarising `indexError`'s boxity signature in `finaliseArgBoxities`,+we `unboxDeeplyDmd` all its argument demands and are careful not to discard+excess boxity in the `StopUnboxing` case, to get the signature+`<1!P(!S,!S)><1!S><S!S>b`.++Then worker/wrapper will not only unbox the pair passed to `indexError` (as it+would do anyway), demand analysis will also pretend that `indexError` needs `l`+and `u` unboxed (and the two other args). Which is a lie, because `indexError`'s+type abstracts over their types and could never unbox them.++The important change is at the *call sites* of `$windexError`: Boxity analysis+will conclude to unbox `l` and `u`, which *will* incur reboxing of crud that+should better float to the call site of `$windexError`. There we don't care+much, because it's in the slow, diverging code path! And that floating often+happens, but not always. See Note [Reboxed crud for bottoming calls].++Note [Reboxed crud for bottoming calls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For functions like `get` in Note [Boxity for bottoming functions], it's clear+that the reboxed crud will be floated inside to the call site of `$windexError`.+But here's an example where that is not the case:+```hs+import GHC.Ix++theresCrud :: Int -> Int -> Int+theresCrud x y = go x+  where+    go 0 = index (0,y) 0+    go 1 = index (x,y) 1+    go n = go (n-1)+    {-# NOINLINE theresCrud #-}+```+If you look at the Core, you'll see that `y` will be reboxed and used in the+two exit join points for the `$windexError` calls, while `x` is only reboxed in the+exit join point for `index (x,y) 1` (happens in lvl below):+```+$wtheresCrud = \ ww ww1 ->+      let { y = I# ww1 } in+      join { lvl2 = ... case lvl1 ww y of wild { }; ... } in+      join { lvl3 = ... case lvl y of wild { }; ... } in+      ...+```+This is currently a bug that we willingly accept and it's documented in #21128.+-}++{- *********************************************************************+*                                                                      *+             Finalising boxity+*                                                                      *+********************************************************************* -}++{- Note [Finalising boxity for demand signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The worker/wrapper pass must strictly adhere to the boxity decisions+encoded in the demand signature, because that is the information that+demand analysis propagates throughout the program. Failing to+implement the strategy laid out in the signature can result in+reboxing in unexpected places. Hence, we must completely anticipate+unboxing decisions during demand analysis and reflect these decicions+in demand annotations. That is the job of 'finaliseArgBoxities',+which is defined here and called from demand analysis.++Here is a list of different Notes it has to take care of:++  * Note [No lazy, Unboxed demands in demand signature] such as `L!P(L)` in+    general, but still allow Note [Unboxing evaluated arguments]+  * Note [No nested Unboxed inside Boxed in demand signature] such as `1P(1!L)`+  * Implement fixes for corner cases Note [Do not unbox class dictionaries]+    and Note [mkWWstr and unsafeCoerce]++Then, in worker/wrapper blindly trusts the boxity info in the demand signature+and will not look at strictness info *at all*, in 'wantToUnboxArg'.++Note [Finalising boxity for let-bound Ids]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  let x = e in body+where the demand on 'x' is 1!P(blah).  We want to unbox x according to+Note [Thunk splitting] in GHC.Core.Opt.WorkWrap.  We must do this becuase+worker/wrapper ignores stricness and looks only at boxity flags; so if+x's demand is L!P(blah) we might still split it (wrongly).  We want to+switch to Boxed on any lazy demand.++That is what finaliseLetBoxity does.  It has no worker-arg budget, so it+is much simpler than finaliseArgBoxities.++Note [No nested Unboxed inside Boxed in demand signature]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+```+f p@(x,y)+  | even (x+y) = []+  | otherwise  = [p]+```+Demand analysis will infer that the function body puts a demand of `1P(1!L,1!L)`+on 'p', e.g., Boxed on the outside but Unboxed on the inside. But worker/wrapper+can't unbox the pair components without unboxing the pair! So we better say+`1P(1L,1L)` in the demand signature in order not to spread wrong Boxity info.+That happens via the call to trimBoxity in 'finaliseArgBoxities'/'finaliseLetBoxity'.++Note [No lazy, Unboxed demands in demand signature] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In 2013 I spotted this example, in shootout/binary_trees:+Consider T19407: -    Main.check' = \ b z ds. case z of z' { I# ip ->-                                case ds_d13s of-                                  Main.Nil -> z'-                                  Main.Node s14k s14l s14m ->-                                    Main.check' (not b)-                                      (Main.check' b-                                         (case b {-                                            False -> I# (-# s14h s14k);-                                            True  -> I# (+# s14h s14k)-                                          })-                                         s14l)-                                     s14m   }   }   }+  data Huge = Huge Bool () ... () -- think: DynFlags+  data T = T { h :: Huge, n :: Int }+  f t@(T h _) = g h t+  g (H b _ ... _) t = if b then 1 else n t -Here we *really* want to unbox z, even though it appears to be used boxed in-the Nil case.  Partly the Nil case is not a hot path.  But more specifically,-the whole function gets the CPR property if we do.+The body of `g` puts (approx.) demand `L!P(A,1)` on `t`. But we better+not put that demand in `g`'s demand signature, because worker/wrapper will not+in general unbox a lazy-and-unboxed demand like `L!P(..)`.+(The exception are known-to-be-evaluated arguments like strict fields,+see Note [Unboxing evaluated arguments].) -That motivated using a demand of C1(C1(C1(P(L,L)))) for the RHS, where-(solely because the result was a product) we used a product demand-(albeit with lazy components) for the body. But that gives very silly-behaviour -- see #17932.   Happily it turns out now to be entirely-unnecessary: we get good results with C1(C1(C1(L))).   So I simply-deleted the special case.+The program above is an example where spreading misinformed boxity through the+signature is particularly egregious. If we give `g` that signature, then `f`+puts demand `S!P(1!P(1L,A,..),ML)` on `t`. Now we will unbox `t` in `f` it and+we get++  f (T (H b _ ... _) n) = $wf b n+  $wf b n = $wg b (T (H b x ... x) n)+  $wg = ...++Massive reboxing in `$wf`! Solution: Trim boxity on lazy demands in+'trimBoxity', modulo Note [Unboxing evaluated arguments].++Note [Unboxing evaluated arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this program (due to Roman):++    data X a = X !a++    foo :: X Int -> Int -> Int+    foo x@(X a) n = go 0+     where+       go i | i < n     = a + go (i+1)+            | otherwise = 0++We want the worker for 'foo' to look like this:++    $wfoo :: Int# -> Int# -> Int#++with the first argument unboxed, so that it is not eval'd each time around the+'go' loop (which would otherwise happen, since 'foo' is not strict in 'a'). It+is sound for the wrapper to pass an unboxed arg because X is strict+(see Note [Strictness and Unboxing] in "GHC.Core.Opt.DmdAnal"), so its argument+must be evaluated. And if we *don't* pass an unboxed argument, we can't even+repair it by adding a `seq` thus:++    foo (X a) n = a `seq` go 0++because the seq is discarded (very early) since X is strict!++So here's what we do++* Since this has nothing to do with how 'foo' uses 'a', we leave demand+  analysis alone, but account for the additional evaluatedness when+  annotating the binder 'finaliseArgBoxities', which will retain the Unboxed+  boxity on 'a' in the definition of 'foo' in the demand 'L!P(L)'; meaning+  it's used lazily but unboxed nonetheless. This seems to contradict Note+  [No lazy, Unboxed demands in demand signature], but we know that 'a' is+  evaluated and thus can be unboxed.++* When 'finaliseArgBoxities' decides to unbox a record, it will zip the field demands+  together with the respective 'StrictnessMark'. In case of 'x', it will pair+  up the lazy field demand 'L!P(L)' on 'a' with 'MarkedStrict' to account for+  the strict field.++* Said 'StrictnessMark' is passed to the recursive invocation of 'go_args' in+  'finaliseArgBoxities' when deciding whether to unbox 'a'. 'a' was used lazily, but+  since it also says 'MarkedStrict', we'll retain the 'Unboxed' boxity on 'a'.++* Worker/wrapper will consult 'wantToUnboxArg' for its unboxing decision. It will+  /not/ look at the strictness bits of the demand, only at Boxity flags. As such,+  it will happily unbox 'a' despite the lazy demand on it.++The net effect is that boxity analysis and the w/w transformation are more+aggressive about unboxing the strict arguments of a data constructor than when+looking at strictness info exclusively. It is very much like (Nested) CPR, which+needs its nested fields to be evaluated in order for it to unbox nestedly.++There is the usual danger of reboxing, which as usual we ignore. But+if X is monomorphic, and has an UNPACK pragma, then this optimisation+is even more important.  We don't want the wrapper to rebox an unboxed+argument, and pass an Int to $wfoo!++This works in nested situations like T10482++    data family Bar a+    data instance Bar (a, b) = BarPair !(Bar a) !(Bar b)+    newtype instance Bar Int = Bar Int++    foo :: Bar ((Int, Int), Int) -> Int -> Int+    foo f k = case f of BarPair x y ->+              case burble of+                 True -> case x of+                           BarPair p q -> ...+                 False -> ...++The extra eagerness lets us produce a worker of type:+     $wfoo :: Int# -> Int# -> Int# -> Int -> Int+     $wfoo p# q# y# = ...++even though the `case x` is only lazily evaluated.++--------- Historical note ------------+We used to add data-con strictness demands when demand analysing case+expression. However, it was noticed in #15696 that this misses some cases. For+instance, consider the program (from T10482)++    data family Bar a+    data instance Bar (a, b) = BarPair !(Bar a) !(Bar b)+    newtype instance Bar Int = Bar Int++    foo :: Bar ((Int, Int), Int) -> Int -> Int+    foo f k =+      case f of+        BarPair x y -> case burble of+                          True -> case x of+                                    BarPair p q -> ...+                          False -> ...++We really should be able to assume that `p` is already evaluated since it came+from a strict field of BarPair. This strictness would allow us to produce a+worker of type:++    $wfoo :: Int# -> Int# -> Int# -> Int -> Int+    $wfoo p# q# y# = ...++even though the `case x` is only lazily evaluated++Indeed before we fixed #15696 this would happen since we would float the inner+`case x` through the `case burble` to get:++    foo f k =+      case f of+        BarPair x y -> case x of+                          BarPair p q -> case burble of+                                          True -> ...+                                          False -> ...++However, after fixing #15696 this could no longer happen (for the reasons+discussed in ticket:15696#comment:76). This means that the demand placed on `f`+would then be significantly weaker (since the False branch of the case on+`burble` is not strict in `p` or `q`).++Consequently, we now instead account for data-con strictness in mkWWstr_one,+applying the strictness demands to the final result of DmdAnal. The result is+that we get the strict demand signature we wanted even if we can't float+the case on `x` up through the case on `burble`.++Note [Do not unbox class dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have+   f :: Ord a => [a] -> Int -> a+   {-# INLINABLE f #-}+and we worker/wrapper f, we'll get a worker with an INLINABLE pragma+(see Note [Worker/wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap),+which can still be specialised by the type-class specialiser, something like+   fw :: Ord a => [a] -> Int# -> a++BUT if f is strict in the Ord dictionary, we might unpack it, to get+   fw :: (a->a->Bool) -> [a] -> Int# -> a+and the type-class specialiser can't specialise that. An example is #6056.++But in any other situation, a dictionary is just an ordinary value,+and can be unpacked.  So we track the INLINABLE pragma, and discard the boxity+flag in finaliseArgBoxities (see the isClassPred test).++Historical note: #14955 describes how I got this fix wrong the first time.++Note that the simplicity of this fix implies that INLINE functions (such as+wrapper functions after the WW run) will never say that they unbox class+dictionaries. That's not ideal, but not worth losing sleep over, as INLINE+functions will have been inlined by the time we run demand analysis so we'll+see the unboxing around the worker in client modules. I got aware of the issue+in T5075 by the change in boxity of loop between demand analysis runs.++Note [Worker argument budget]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In 'finaliseArgBoxities' we don't want to generate workers with zillions of+argument when, say given a strict record with zillions of fields.  So we+limit the maximum number of worker args to the maximum of+  - -fmax-worker-args=N+  - The number of args in the original function; if it already has has+    zillions of arguments we don't want to seek /fewer/ args in the worker.+(Maybe we should /add/ them instead of maxing?)++We pursue a "layered" strategy for unboxing: we unbox the top level of the+argument(s), subject to budget; if there are any arguments left we unbox the+next layer, using that depleted budget.++To achieve this, we use the classic almost-circular programming technique in+which we we write one pass that takes a lazy list of the Budgets for every+layer.++Note [The OPAQUE pragma and avoiding the reboxing of arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In https://gitlab.haskell.org/ghc/ghc/-/issues/13143 it was identified that when+a function 'f' with a NOINLINE pragma is W/W transformed, then the worker for+'f' should get the NOINLINE annotation, while the wrapper /should/ be inlined.++That's because if the wrapper for 'f' had stayed NOINLINE, then any worker of a+W/W-transformed /caller of/ 'f' would immediately rebox any unboxed arguments+that is applied to the wrapper of 'f'. When the wrapper is inlined, that kind of+reboxing does not happen.++But now we have functions with OPAQUE pragmas, which by definition (See Note+[OPAQUE pragma]) do not get W/W-transformed. So in order to avoid reboxing+workers of any W/W-transformed /callers of/ 'f' we need to strip all boxity+information from 'f' in the demand analysis. This will inform the+W/W-transformation code that boxed arguments of 'f' must definitely be passed+along in boxed form and as such dissuade the creation of reboxing workers. -} +data Budgets = MkB Arity Budgets   -- An infinite list of arity budgets++incTopBudget :: Budgets -> Budgets+incTopBudget (MkB n bg) = MkB (n+1) bg++positiveTopBudget :: Budgets -> Bool+positiveTopBudget (MkB n _) = n >= 0++finaliseArgBoxities :: AnalEnv -> Id -> Arity -> CoreExpr -> Divergence+                    -> Maybe ([Demand], CoreExpr)+finaliseArgBoxities env fn arity rhs div+  | arity > count isId bndrs  -- Can't find enough binders+  = Nothing  -- This happens if we have   f = g+             -- Then there are no binders; we don't worker/wrapper; and we+             -- simply want to give f the same demand signature as g++  | otherwise+  = Just (arg_dmds', add_demands arg_dmds' rhs)+    -- add_demands: we must attach the final boxities to the lambda-binders+    -- of the function, both because that's kosher, and because CPR analysis+    -- uses the info on the binders directly.+  where+    opts            = ae_opts env+    fam_envs        = ae_fam_envs env+    is_inlinable_fn = isStableUnfolding (realIdUnfolding fn)+    (bndrs, _body)  = collectBinders rhs+    max_wkr_args    = dmd_max_worker_args opts `max` arity+                      -- See Note [Worker argument budget]++    -- This is the key line, which uses almost-circular programming+    -- The remaining budget from one layer becomes the initial+    -- budget for the next layer down.  See Note [Worker argument budget]+    (remaining_budget, arg_dmds') = go_args (MkB max_wkr_args remaining_budget) arg_triples++    arg_triples :: [(Type, StrictnessMark, Demand)]+    arg_triples = take arity $+                  map mk_triple $+                  filter isRuntimeVar bndrs++    mk_triple :: Id -> (Type,StrictnessMark,Demand)+    mk_triple bndr | is_cls_arg ty = (ty, NotMarkedStrict, trimBoxity dmd)+                   | is_bot_fn     = (ty, NotMarkedStrict, unboxDeeplyDmd dmd)+                   -- See Note [OPAQUE pragma]+                   -- See Note [The OPAQUE pragma and avoiding the reboxing of arguments]+                   | is_opaque     = (ty, NotMarkedStrict, trimBoxity dmd)+                   | otherwise     = (ty, NotMarkedStrict, dmd)+                   where+                     ty        = idType bndr+                     dmd       = idDemandInfo bndr+                     is_opaque = isOpaquePragma (idInlinePragma fn)++    -- is_cls_arg: see Note [Do not unbox class dictionaries]+    is_cls_arg arg_ty = is_inlinable_fn && isClassPred arg_ty+    -- is_bot_fn:  see Note [Boxity for bottoming functions]+    is_bot_fn         = div == botDiv++    go_args :: Budgets -> [(Type,StrictnessMark,Demand)] -> (Budgets, [Demand])+    go_args bg triples = mapAccumL go_arg bg triples++    go_arg :: Budgets -> (Type,StrictnessMark,Demand) -> (Budgets, Demand)+    go_arg bg@(MkB bg_top bg_inner) (ty, str_mark, dmd@(n :* _))+      = case wantToUnboxArg False fam_envs ty dmd of+          StopUnboxing+            | not is_bot_fn+                -- If bot: Keep deep boxity even though WW won't unbox+                -- See Note [Boxity for bottoming functions]+            -> (MkB (bg_top-1) bg_inner, trimBoxity dmd)++          Unbox DataConPatContext{dcpc_dc=dc, dcpc_tc_args=tc_args} dmds+            -> (MkB (bg_top-1) final_bg_inner, final_dmd)+            where+              dc_arity = dataConRepArity dc+              arg_tys  = dubiousDataConInstArgTys dc tc_args+              (bg_inner', dmds') = go_args (incTopBudget bg_inner) $+                                   zip3 arg_tys (dataConRepStrictness dc) dmds+              dmd' = n :* (mkProd Unboxed $! dmds')+              (final_bg_inner, final_dmd)+                  | dmds `lengthIs` dc_arity+                  , isStrict n || isMarkedStrict str_mark+                     -- isStrict: see Note [No lazy, Unboxed demands in demand signature]+                     -- isMarkedStrict: see Note [Unboxing evaluated arguments]+                  , positiveTopBudget bg_inner'+                  , NonRecursiveOrUnsure <- ae_rec_dc env dc+                     -- See Note [Which types are unboxed?]+                     -- and Note [Demand analysis for recursive data constructors]+                  = (bg_inner', dmd')+                  | otherwise+                  = (bg_inner, trimBoxity dmd)+          _ -> (bg, dmd)++    add_demands :: [Demand] -> CoreExpr -> CoreExpr+    -- Attach the demands to the outer lambdas of this expression+    add_demands [] e = e+    add_demands (dmd:dmds) (Lam v e)+      | isTyVar v = Lam v (add_demands (dmd:dmds) e)+      | otherwise = Lam (v `setIdDemandInfo` dmd) (add_demands dmds e)+    add_demands dmds e = pprPanic "add_demands" (ppr dmds $$ ppr e)++finaliseLetBoxity+  :: FamInstEnvs+  -> Type                   -- ^ Type of the let-bound Id+  -> Demand                 -- ^ How the Id is used+  -> Demand+-- See Note [Finalising boxity for let-bound Ids]+-- This function is like finaliseArgBoxities, but much simpler because+-- it has no "budget".  It simply unboxes strict demands, and stops+-- when it reaches a lazy one.+finaliseLetBoxity env ty dmd+  = go ty NotMarkedStrict dmd+  where+    go ty mark dmd@(n :* _) =+      case wantToUnboxArg False env ty dmd of+        DropAbsent   -> dmd+        StopUnboxing -> trimBoxity dmd+        Unbox DataConPatContext{dcpc_dc=dc, dcpc_tc_args=tc_args} dmds+          | isStrict n || isMarkedStrict mark+          , dmds `lengthIs` dataConRepArity dc+          , let arg_tys = dubiousDataConInstArgTys dc tc_args+                dmds'   = strictZipWith3 go arg_tys (dataConRepStrictness dc) dmds+          -> n :* (mkProd Unboxed $! dmds')+          | otherwise+          -> trimBoxity dmd+        Unlift -> panic "No unlifting in DmdAnal"++ {- ********************************************************************* *                                                                      *                       Fixpoints@@ -1206,23 +1678,23 @@   = loop 1 initial_pairs   where     -- See Note [Initialising strictness]-    initial_pairs | ae_virgin env = [(setIdStrictness id botSig, rhs) | (id, rhs) <- orig_pairs ]+    initial_pairs | ae_virgin env = [(setIdDmdSig id botSig, rhs) | (id, rhs) <- orig_pairs ]                   | otherwise     = orig_pairs      -- If fixed-point iteration does not yield a result we use this instead     -- See Note [Safe abortion in the fixed-point iteration]     abort :: (AnalEnv, DmdEnv, [(Id,CoreExpr)])     abort = (env, lazy_fv', zapped_pairs)-      where (lazy_fv, pairs') = step True (zapIdStrictness orig_pairs)+      where (lazy_fv, pairs') = step True (zapIdDmdSig orig_pairs)             -- Note [Lazy and unleashable free variables]-            non_lazy_fvs = plusVarEnvList $ map (strictSigDmdEnv . idStrictness . fst) pairs'+            non_lazy_fvs = plusVarEnvList $ map (dmdSigDmdEnv . idDmdSig . fst) pairs'             lazy_fv'     = lazy_fv `plusVarEnv` mapVarEnv (const topDmd) non_lazy_fvs-            zapped_pairs = zapIdStrictness pairs'+            zapped_pairs = zapIdDmdSig pairs' -    -- The fixed-point varies the idStrictness field of the binders, and terminates if that+    -- The fixed-point varies the idDmdSig field of the binders, and terminates if that     -- annotation does not change any more.     loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, DmdEnv, [(Id,CoreExpr)])-    loop n pairs = -- pprTrace "dmdFix" (ppr n <+> vcat [ ppr id <+> ppr (idStrictness id)+    loop n pairs = -- pprTrace "dmdFix" (ppr n <+> vcat [ ppr id <+> ppr (idDmdSig id)                    --                                     | (id,_)<- pairs]) $                    loop' n pairs @@ -1231,7 +1703,7 @@       | n == 10        = abort       | otherwise      = loop (n+1) pairs'       where-        found_fixpoint    = map (idStrictness . fst) pairs' == map (idStrictness . fst) pairs+        found_fixpoint    = map (idDmdSig . fst) pairs' == map (idDmdSig . fst) pairs         first_round       = n == 1         (lazy_fv, pairs') = step first_round pairs         final_anal_env    = extendAnalEnvs top_lvl env (map fst pairs')@@ -1251,18 +1723,17 @@                 -- so this can significantly reduce the number of iterations needed          my_downRhs (env, lazy_fv) (id,rhs)-          = -- pprTrace "my_downRhs" (ppr id $$ ppr (idStrictness id) $$ ppr sig) $+          = -- pprTrace "my_downRhs" (ppr id $$ ppr (idDmdSig id) $$ ppr sig) $             ((env', lazy_fv'), (id', rhs'))           where             !(!env', !lazy_fv1, !id', !rhs') = dmdAnalRhsSig top_lvl Recursive env let_dmd id rhs             !lazy_fv'                    = plusVarEnv_C plusDmd lazy_fv lazy_fv1 -    zapIdStrictness :: [(Id, CoreExpr)] -> [(Id, CoreExpr)]-    zapIdStrictness pairs = [(setIdStrictness id nopSig, rhs) | (id, rhs) <- pairs ]+    zapIdDmdSig :: [(Id, CoreExpr)] -> [(Id, CoreExpr)]+    zapIdDmdSig pairs = [(setIdDmdSig id nopSig, rhs) | (id, rhs) <- pairs ]  {- Note [Safe abortion in the fixed-point iteration] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- Fixed-point iteration may fail to terminate. But we cannot simply give up and return the environment and code unchanged! We still need to do one additional round, for two reasons:@@ -1334,9 +1805,12 @@ unitDmdType dmd_env = DmdType dmd_env [] topDiv  coercionDmdEnv :: Coercion -> DmdEnv-coercionDmdEnv co = mapVarEnv (const topDmd) (getUniqSet $ coVarsOfCo co)-                    -- The VarSet from coVarsOfCo is really a VarEnv Var+coercionDmdEnv co = coercionsDmdEnv [co] +coercionsDmdEnv :: [Coercion] -> DmdEnv+coercionsDmdEnv cos = mapVarEnv (const topDmd) (getUniqSet $ coVarsOfCos cos)+                      -- The VarSet from coVarsOfCos is really a VarEnv Var+ addVarDmd :: DmdType -> Var -> Demand -> DmdType addVarDmd (DmdType fv ds res) var dmd   = DmdType (extendVarEnv_C plusDmd fv var dmd) ds res@@ -1376,52 +1850,32 @@ dictionaries. -} -setBndrsDemandInfo :: [Var] -> [Demand] -> [Var]+setBndrsDemandInfo :: HasCallStack => [Var] -> [Demand] -> [Var] setBndrsDemandInfo (b:bs) ds   | isTyVar b = b : setBndrsDemandInfo bs ds setBndrsDemandInfo (b:bs) (d:ds) =     let !new_info = setIdDemandInfo b d         !vars = setBndrsDemandInfo bs ds     in new_info : vars-setBndrsDemandInfo [] ds = ASSERT( null ds ) []+setBndrsDemandInfo [] ds = assert (null ds) [] setBndrsDemandInfo bs _  = pprPanic "setBndrsDemandInfo" (ppr bs) -annotateBndr :: AnalEnv -> DmdType -> Var -> WithDmdType Var--- The returned env has the var deleted--- The returned var is annotated with demand info--- according to the result demand of the provided demand type--- No effect on the argument demands-annotateBndr env dmd_ty var-  | isId var  = WithDmdType dmd_ty' new_id-  | otherwise = WithDmdType dmd_ty  var-  where-    new_id = setIdDemandInfo var dmd-    WithDmdType dmd_ty' dmd = findBndrDmd env False dmd_ty var- annotateLamIdBndr :: AnalEnv-                  -> DFunFlag   -- is this lambda at the top of the RHS of a dfun?                   -> DmdType    -- Demand type of body                   -> Id         -- Lambda binder                   -> WithDmdType Id  -- Demand type of lambda                                      -- and binder annotated with demand -annotateLamIdBndr env arg_of_dfun dmd_ty id+annotateLamIdBndr env dmd_ty id -- For lambdas we add the demand to the argument demands -- Only called for Ids-  = ASSERT( isId id )+  = assert (isId id) $     -- pprTrace "annLamBndr" (vcat [ppr id, ppr dmd_ty, ppr final_ty]) $-    WithDmdType final_ty new_id+    WithDmdType main_ty new_id   where-    new_id = setIdDemandInfo id dmd-      -- Watch out!  See note [Lambda-bound unfoldings]-    final_ty = case maybeUnfoldingTemplate (idUnfolding id) of-                 Nothing  -> main_ty-                 Just unf -> main_ty `plusDmdType` unf_ty-                          where-                             (unf_ty, _) = dmdAnalStar env dmd unf-+    new_id  = setIdDemandInfo id dmd     main_ty = addDemand dmd dmd_ty'-    WithDmdType dmd_ty' dmd = findBndrDmd env arg_of_dfun dmd_ty id+    WithDmdType dmd_ty' dmd = findBndrDmd env dmd_ty id  {- Note [NOINLINE and strictness] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1431,7 +1885,7 @@ any other function, and pin strictness information on them.  That in turn forces us to worker/wrapper them; see-Note [Worker-wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap.+Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap.   Note [Lazy and unleashable free variables]@@ -1491,16 +1945,6 @@ demand put on them (topDmd), and add that to the "lazy_fv" returned by "dmdFix".  -Note [Lambda-bound unfoldings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We allow a lambda-bound variable to carry an unfolding, a facility that is used-exclusively for join points; see Note [Case binders and join points].  If so,-we must be careful to demand-analyse the RHS of the unfolding!  Example-   \x. \y{=Just x}. <body>-Then if <body> uses 'y', then transitively it uses 'x', and we must not-forget that fact, otherwise we might make 'x' absent when it isn't.-- ************************************************************************ *                                                                      * \subsection{Strictness signatures}@@ -1508,18 +1952,17 @@ ************************************************************************ -} -type DFunFlag = Bool  -- indicates if the lambda being considered is in the-                      -- sequence of lambdas at the top of the RHS of a dfun-notArgOfDfun :: DFunFlag-notArgOfDfun = False  data AnalEnv = AE-   { ae_strict_dicts :: !Bool -- ^ Enable strict dict-   , ae_sigs         :: !SigEnv-   , ae_virgin       :: !Bool -- ^ True on first iteration only-                              -- See Note [Initialising strictness]-   , ae_fam_envs     :: !FamInstEnvs-   }+  { ae_opts      :: !DmdAnalOpts+  -- ^ Analysis options+  , ae_sigs      :: !SigEnv+  , ae_virgin    :: !Bool+  -- ^ True on first iteration only. See Note [Initialising strictness]+  , ae_fam_envs  :: !FamInstEnvs+  , ae_rec_dc    :: DataCon -> IsRecDataConResult+  -- ^ Memoised result of 'GHC.Core.Opt.WorkWrap.Utils.isRecDataCon'+  }          -- We use the se_env to tell us whether to         -- record info about a variable in the DmdEnv@@ -1528,51 +1971,45 @@         -- The DmdEnv gives the demand on the free vars of the function         -- when it is given enough args to satisfy the strictness signature -type SigEnv = VarEnv (StrictSig, TopLevelFlag)+type SigEnv = VarEnv (DmdSig, TopLevelFlag)  instance Outputable AnalEnv where   ppr env = text "AE" <+> braces (vcat          [ text "ae_virgin =" <+> ppr (ae_virgin env)-         , text "ae_strict_dicts =" <+> ppr (ae_strict_dicts env)          , text "ae_sigs =" <+> ppr (ae_sigs env)          ])  emptyAnalEnv :: DmdAnalOpts -> FamInstEnvs -> AnalEnv emptyAnalEnv opts fam_envs-    = AE { ae_strict_dicts = dmd_strict_dicts opts+    = AE { ae_opts         = opts          , ae_sigs         = emptySigEnv          , ae_virgin       = True          , ae_fam_envs     = fam_envs+         , ae_rec_dc       = memoiseUniqueFun (isRecDataCon fam_envs 3)          }  emptySigEnv :: SigEnv emptySigEnv = emptyVarEnv --- | Extend an environment with the strictness sigs attached to the Ids+-- | Extend an environment with the strictness IDs attached to the id extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv extendAnalEnvs top_lvl env vars   = env { ae_sigs = extendSigEnvs top_lvl (ae_sigs env) vars }  extendSigEnvs :: TopLevelFlag -> SigEnv -> [Id] -> SigEnv extendSigEnvs top_lvl sigs vars-  = extendVarEnvList sigs [ (var, (idStrictness var, top_lvl)) | var <- vars]+  = extendVarEnvList sigs [ (var, (idDmdSig var, top_lvl)) | var <- vars] -extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> StrictSig -> AnalEnv+extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> DmdSig -> AnalEnv extendAnalEnv top_lvl env var sig   = env { ae_sigs = extendSigEnv top_lvl (ae_sigs env) var sig } -extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> StrictSig -> SigEnv+extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> DmdSig -> SigEnv extendSigEnv top_lvl sigs var sig = extendVarEnv sigs var (sig, top_lvl) -lookupSigEnv :: AnalEnv -> Id -> Maybe (StrictSig, TopLevelFlag)+lookupSigEnv :: AnalEnv -> Id -> Maybe (DmdSig, TopLevelFlag) lookupSigEnv env id = lookupVarEnv (ae_sigs env) id -addInScopeAnalEnv :: AnalEnv -> Var -> AnalEnv-addInScopeAnalEnv env id = env { ae_sigs = delVarEnv (ae_sigs env) id }--addInScopeAnalEnvs :: AnalEnv -> [Var] -> AnalEnv-addInScopeAnalEnvs env ids = env { ae_sigs = delVarEnvList (ae_sigs env) ids }- nonVirgin :: AnalEnv -> AnalEnv nonVirgin env = env { ae_virgin = False } @@ -1584,13 +2021,13 @@     go dmd_ty []  = WithDmdType dmd_ty []     go dmd_ty (b:bs)       | isId b    = let WithDmdType dmd_ty1 dmds = go dmd_ty bs-                        WithDmdType dmd_ty2 dmd  = findBndrDmd env False dmd_ty1 b+                        WithDmdType dmd_ty2 dmd  = findBndrDmd env dmd_ty1 b                     in WithDmdType dmd_ty2  (dmd : dmds)       | otherwise = go dmd_ty bs -findBndrDmd :: AnalEnv -> Bool -> DmdType -> Id -> WithDmdType Demand+findBndrDmd :: AnalEnv -> DmdType -> Id -> WithDmdType Demand -- See Note [Trimming a demand to a type]-findBndrDmd env arg_of_dfun dmd_ty id+findBndrDmd env dmd_ty id   = -- pprTrace "findBndrDmd" (ppr id $$ ppr dmd_ty $$ ppr starting_dmd $$ ppr dmd') $     WithDmdType dmd_ty' dmd'   where@@ -1602,31 +2039,61 @@     id_ty = idType id      strictify dmd-      | ae_strict_dicts env+      -- See Note [Making dictionaries strict]+      | dmd_strict_dicts (ae_opts env)              -- We never want to strictify a recursive let. At the moment-             -- annotateBndr is only call for non-recursive lets; if that+             -- findBndrDmd is never called for recursive lets; if that              -- changes, we need a RecFlag parameter and another guard here.-      , not arg_of_dfun -- See Note [Do not strictify the argument dictionaries of a dfun]       = strictifyDictDmd id_ty dmd       | otherwise       = dmd      fam_envs = ae_fam_envs env -{- Note [Bringing a new variable into scope]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-   f x = blah-   g = ...(\f. ...f...)...+{- Note [Making dictionaries strict]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The Opt_DictsStrict flag makes GHC use call-by-value for dictionaries.  Why? -In the body of the '\f', any occurrence of `f` refers to the lambda-bound `f`,-not the top-level `f` (which will be in `ae_sigs`).  So it's very important-to delete `f` from `ae_sigs` when we pass a lambda/case/let-up binding of `f`.-Otherwise chaos results (#22718).+* Generally CBV is more efficient. -Note [Initialising strictness]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* Dictionaries are always non-bottom; and never take much work to+  compute.  E.g. a dfun from an instance decl always returns a dicionary+  record immediately.  See DFunUnfolding in CoreSyn.+  See also Note [Recursive superclasses] in TcInstDcls. +* The strictness analyser will then unbox dictionaries and pass the+  methods individually, rather than in a bundle.  If there are a lot of+  methods that might be bad; but worker/wrapper already does throttling.++* A newtype dictionary is *not* always non-bottom.  E.g.+      class C a where op :: a -> a+      instance C Int where op = error "urk"+  Now a value of type (C Int) is just a newtype wrapper (a cast) around+  the error thunk.  Don't strictify these!++See #17758 for more background and perf numbers.++The implementation is extremly simple: just make the strictness+analyser strictify the demand on a dictionary binder in+'findBndrDmd'.++However there is one case where this can make performance worse.+For the principle consider some function at the core level:+    myEq :: Eq a => a -> a -> Bool+    myEq eqDict x y = ((==) eqDict) x y+If we make the dictionary strict then WW can fire turning this into:+    $wmyEq :: (a -> a -> Bool) -> a -> a -> Bool+    $wmyEq eq x y = eq x y+Which *usually* performs better. However if the dictionary is known we+are far more likely to inline a function applied to the dictionary than+to inline one applied to a function. Sometimes this makes just enough+of a difference to stop a function from inlining. This is documented in #18421.++It's somewhat similar to Note [Do not unbox class dictionaries] although+here our problem is with the inliner, not the specializer.++Note [Initialising strictness]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ See section 9.2 (Finding fixpoints) of the paper.  Our basic plan is to initialise the strictness of each Id in a
compiler/GHC/Core/Opt/Exitify.hs view
@@ -41,7 +41,7 @@ import GHC.Types.Id.Info import GHC.Core import GHC.Core.Utils-import GHC.Utils.Monad.State+import GHC.Utils.Monad.State.Strict import GHC.Builtin.Uniques import GHC.Types.Var.Set import GHC.Types.Var.Env@@ -131,11 +131,11 @@     -- variables bound on the way and lifts it out as a join point.     --     -- ExitifyM is a state monad to keep track of floated binds-    go :: [Var]           -- ^ Variables that are in-scope here, but+    go :: [Var]           -- Variables that are in-scope here, but                           -- not in scope at the joinrec; that is,                           -- we must potentially abstract over them.                           -- Invariant: they are kept in dependency order-       -> CoreExprWithFVs -- ^ Current expression in tail position+       -> CoreExprWithFVs -- Current expression in tail position        -> ExitifyM CoreExpr      -- We first look at the expression (no matter what it shape is)@@ -310,7 +310,7 @@  Expressions are interesting when they move an occurrence of a variable outside the recursive `go` that can benefit from being obviously called once, for example:- * a local thunk that can then be inlined (see example in note [Exitification])+ * a local thunk that can then be inlined (see example in Note [Exitification])  * the parameter of a function, where the demand analyzer then can then    see that it is called at most once, and hence improve the function’s    strictness signature
compiler/GHC/Core/Opt/FloatIn.hs view
@@ -12,51 +12,38 @@ then discover that they aren't needed in the chosen branch. -} -{-# LANGUAGE CPP #-}+ {-# OPTIONS_GHC -fprof-auto #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  module GHC.Core.Opt.FloatIn ( floatInwards ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Platform -import GHC.Driver.Session- import GHC.Core import GHC.Core.Make hiding ( wrapFloats ) import GHC.Core.Utils import GHC.Core.FVs-import GHC.Core.Opt.Monad   ( CoreM ) import GHC.Core.Type -import GHC.Types.Basic      ( RecFlag(..), isRec )+import GHC.Types.Basic      ( RecFlag(..), isRec, Levity(Unlifted) ) import GHC.Types.Id         ( isOneShotBndr, idType, isJoinId, isJoinId_maybe ) import GHC.Types.Tickish import GHC.Types.Var import GHC.Types.Var.Set -import GHC.Unit.Module.ModGuts- import GHC.Utils.Misc import GHC.Utils.Panic--import GHC.Utils.Outputable--import Data.List        ( mapAccumL )+import GHC.Utils.Panic.Plain  {- Top-level interface function, @floatInwards@.  Note that we do not actually float any bindings downwards from the top-level. -} -floatInwards :: ModGuts -> CoreM ModGuts-floatInwards pgm@(ModGuts { mg_binds = binds })-  = do { dflags <- getDynFlags-       ; let platform = targetPlatform dflags-       ; return (pgm { mg_binds = map (fi_top_bind platform) binds }) }+floatInwards :: Platform -> CoreProgram -> CoreProgram+floatInwards platform binds = map (fi_top_bind platform) binds   where     fi_top_bind platform (NonRec binder rhs)       = NonRec binder (fiExpr platform [] (freeVars rhs))@@ -136,7 +123,7 @@ ************************************************************************ -} -type FreeVarSet  = DVarSet+type FreeVarSet  = DIdSet type BoundVarSet = DIdSet  data FloatInBind = FB BoundVarSet FreeVarSet FloatBind@@ -144,33 +131,28 @@         -- of recursive bindings, the set doesn't include the bound         -- variables. -type FloatInBinds    = [FloatInBind] -- In normal dependency order-                                     --    (outermost binder first)-type RevFloatInBinds = [FloatInBind] -- In reverse dependency order-                                     --    (innermost binder first)--instance Outputable FloatInBind where-  ppr (FB bvs fvs _) = text "FB" <> braces (sep [ text "bndrs =" <+> ppr bvs-                                                , text "fvs =" <+> ppr fvs ])+type FloatInBinds = [FloatInBind]+        -- In reverse dependency order (innermost binder first)  fiExpr :: Platform-       -> RevFloatInBinds   -- Binds we're trying to drop+       -> FloatInBinds      -- Binds we're trying to drop                             -- as far "inwards" as possible        -> CoreExprWithFVs   -- Input expr        -> CoreExpr          -- Result  fiExpr _ to_drop (_, AnnLit lit)     = wrapFloats to_drop (Lit lit)                                        -- See Note [Dead bindings]-fiExpr _ to_drop (_, AnnType ty)     = ASSERT( null to_drop ) Type ty+fiExpr _ to_drop (_, AnnType ty)     = assert (null to_drop) $ Type ty fiExpr _ to_drop (_, AnnVar v)       = wrapFloats to_drop (Var v) fiExpr _ to_drop (_, AnnCoercion co) = wrapFloats to_drop (Coercion co) fiExpr platform to_drop (_, AnnCast expr (co_ann, co))-  = wrapFloats drop_here $+  = wrapFloats (drop_here ++ co_drop) $     Cast (fiExpr platform e_drop expr) co   where-    (drop_here, [e_drop])-      = sepBindsByDropPoint platform False to_drop-          (freeVarsOfAnn co_ann) [freeVarsOf expr]+    [drop_here, e_drop, co_drop]+      = sepBindsByDropPoint platform False+          [freeVarsOf expr, freeVarsOfAnn co_ann]+          to_drop  {- Applications: we do float inside applications, mainly because we@@ -179,7 +161,7 @@ -}  fiExpr platform to_drop ann_expr@(_,AnnApp {})-  = wrapFloats drop_here $+  = wrapFloats drop_here $ wrapFloats extra_drop $     mkTicks ticks $     mkApps (fiExpr platform fun_drop ann_fun)            (zipWithEqual "fiExpr" (fiExpr platform) arg_drops ann_args)@@ -189,18 +171,19 @@     (ann_fun, ann_args, ticks) = collectAnnArgsTicks tickishFloatable ann_expr     fun_ty  = exprType (deAnnotate ann_fun)     fun_fvs = freeVarsOf ann_fun--    (drop_here, fun_drop : arg_drops)-       = sepBindsByDropPoint platform False to_drop-                             here_fvs (fun_fvs : arg_fvs)+    arg_fvs = map freeVarsOf ann_args +    (drop_here : extra_drop : fun_drop : arg_drops)+       = sepBindsByDropPoint platform False+                             (extra_fvs : fun_fvs : arg_fvs)+                             to_drop          -- Shortcut behaviour: if to_drop is empty,          -- sepBindsByDropPoint returns a suitable bunch of empty          -- lists without evaluating extra_fvs, and hence without          -- peering into each argument -    ((_,here_fvs), arg_fvs) = mapAccumL add_arg (fun_ty,here_fvs0) ann_args-    here_fvs0 = case ann_fun of+    (_, extra_fvs) = foldl' add_arg (fun_ty, extra_fvs0) ann_args+    extra_fvs0 = case ann_fun of                    (_, AnnVar _) -> fun_fvs                    _             -> emptyDVarSet           -- Don't float the binding for f into f x y z; see Note [Join points]@@ -208,13 +191,15 @@           -- join point, floating it in isn't especially harmful but it's           -- useless since the simplifier will immediately float it back out.) -    add_arg :: (Type,FreeVarSet) -> CoreExprWithFVs -> ((Type,FreeVarSet),FreeVarSet)-    add_arg (fun_ty, here_fvs) (arg_fvs, AnnType ty)-      = ((piResultTy fun_ty ty, here_fvs), arg_fvs)-    -- We can't float into some arguments, so put them into the here_fvs-    add_arg (fun_ty, here_fvs) (arg_fvs, arg)-      | noFloatIntoArg arg arg_ty = ((res_ty,here_fvs `unionDVarSet` arg_fvs), emptyDVarSet)-      | otherwise          = ((res_ty,here_fvs), arg_fvs)+    add_arg :: (Type,FreeVarSet) -> CoreExprWithFVs -> (Type,FreeVarSet)+    add_arg (fun_ty, extra_fvs) (_, AnnType ty)+      = (piResultTy fun_ty ty, extra_fvs)++    add_arg (fun_ty, extra_fvs) (arg_fvs, arg)+      | noFloatIntoArg arg arg_ty+      = (res_ty, extra_fvs `unionDVarSet` arg_fvs)+      | otherwise+      = (res_ty, extra_fvs)       where        (_, arg_ty, res_ty) = splitFunTy fun_ty @@ -298,6 +283,7 @@ Urk! if all are tyvars, and we don't float in, we may miss an       opportunity to float inside a nested case branch + Note [Floating coercions] ~~~~~~~~~~~~~~~~~~~~~~~~~ We could, in principle, have a coercion binding like@@ -317,36 +303,6 @@ bind a coercion variable mentioned in any of the types, that binder must be dropped right away. -Note [Shadowing and name capture]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have-    let x = y+1 in-    case p of-       (y:ys) -> ...x...-       [] -> blah-It is obviously bogus for FloatIn to transform to-    case p of-       (y:ys) -> ...(let x = y+1 in x)...-       [] -> blah-because the y is captured.  This doesn't happen much, because shadowing is-rare, but it did happen in #22662.--One solution would be to clone as we go.  But a simpler one is this:--  at a binding site (like that for (y:ys) above), abandon float-in for-  any floating bindings that mention the binders (y, ys in this case)--We achieve that by calling sepBindsByDropPoint with the binders in-the "used-here" set:--* In fiExpr (AnnLam ...).  For the body there is no need to delete-  the lambda-binders from the body_fvs, because any bindings that-  mention these binders will be dropped here anyway.--* In fiExpr (AnnCase ...). Remember to include the case_bndr in the-  binders.  Again, no need to delete the alt binders from the rhs-  free vars, beause any bindings mentioning them will be dropped-  here unconditionally. -}  fiExpr platform to_drop lam@(_, AnnLam _ _)@@ -355,18 +311,11 @@   = wrapFloats to_drop (mkLams bndrs (fiExpr platform [] body))    | otherwise           -- Float inside-  = wrapFloats drop_here $-    mkLams bndrs (fiExpr platform body_drop body)+  = mkLams bndrs (fiExpr platform to_drop body)    where     (bndrs, body) = collectAnnBndrs lam-    body_fvs      = freeVarsOf body -    -- Why sepBindsByDropPoint? Because of potential capture-    -- See Note [Shadowing and name capture]-    (drop_here, [body_drop]) = sepBindsByDropPoint platform False to_drop-                                  (mkDVarSet bndrs) [body_fvs]- {- We don't float lets inwards past an SCC.         ToDo: keep info on current cc, and when passing@@ -404,7 +353,7 @@ things to drop in the outer let's body, and let nature take its course. -Note [extra_fvs (1): avoid floating into RHS]+Note [extra_fvs (1)]: avoid floating into RHS ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider let x=\y....t... in body.  We do not necessarily want to float a binding for t into the RHS, because it'll immediately be floated out@@ -422,7 +371,7 @@ So we make "extra_fvs" which is the rhs_fvs of such bindings, and arrange to dump bindings that bind extra_fvs before the entire let. -Note [extra_fvs (2): free variables of rules]+Note [extra_fvs (2)]: free variables of rules ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider   let x{rule mentioning y} = rhs in body@@ -499,21 +448,22 @@  fiExpr platform to_drop (_, AnnCase scrut case_bndr _ [AnnAlt con alt_bndrs rhs])   | isUnliftedType (idType case_bndr)+     -- binders have a fixed RuntimeRep so it's OK to call isUnliftedType   , exprOkForSideEffects (deAnnotate scrut)       -- See Note [Floating primops]   = wrapFloats shared_binds $     fiExpr platform (case_float : rhs_binds) rhs   where-    case_float = FB all_bndrs scrut_fvs+    case_float = FB (mkDVarSet (case_bndr : alt_bndrs)) scrut_fvs                     (FloatCase scrut' case_bndr con alt_bndrs)     scrut'     = fiExpr platform scrut_binds scrut-    rhs_fvs    = freeVarsOf rhs    -- No need to delete alt_bndrs-    scrut_fvs  = freeVarsOf scrut  -- See Note [Shadowing and name capture]-    all_bndrs  = mkDVarSet alt_bndrs `extendDVarSet` case_bndr+    rhs_fvs    = freeVarsOf rhs `delDVarSetList` (case_bndr : alt_bndrs)+    scrut_fvs  = freeVarsOf scrut -    (shared_binds, [scrut_binds, rhs_binds])-       = sepBindsByDropPoint platform False to_drop-                     all_bndrs [scrut_fvs, rhs_fvs]+    [shared_binds, scrut_binds, rhs_binds]+       = sepBindsByDropPoint platform False+           [scrut_fvs, rhs_fvs]+           to_drop  fiExpr platform to_drop (_, AnnCase scrut case_bndr ty alts)   = wrapFloats drop_here1 $@@ -523,43 +473,39 @@          -- use zipWithEqual, we should have length alts_drops_s = length alts   where         -- Float into the scrut and alts-considered-together just like App-    (drop_here1, [scrut_drops, alts_drops])-       = sepBindsByDropPoint platform False to_drop-             all_alt_bndrs [scrut_fvs, all_alt_fvs]-             -- all_alt_bndrs: see Note [Shadowing and name capture]+    [drop_here1, scrut_drops, alts_drops]+       = sepBindsByDropPoint platform False+           [scrut_fvs, all_alts_fvs]+           to_drop          -- Float into the alts with the is_case flag set-    (drop_here2, alts_drops_s)-       = sepBindsByDropPoint platform True alts_drops emptyDVarSet alts_fvs--    scrut_fvs = freeVarsOf scrut--    all_alt_bndrs = foldr (unionDVarSet . ann_alt_bndrs) (unitDVarSet case_bndr) alts-    ann_alt_bndrs (AnnAlt _ bndrs _) = mkDVarSet bndrs--    alts_fvs :: [DVarSet]-    alts_fvs = [freeVarsOf rhs | AnnAlt _ _ rhs <- alts]-               -- No need to delete binders-               -- See Note [Shadowing and name capture]+    (drop_here2 : alts_drops_s)+      | [ _ ] <- alts = [] : [alts_drops]+      | otherwise     = sepBindsByDropPoint platform True alts_fvs alts_drops -    all_alt_fvs :: DVarSet-    all_alt_fvs = foldr unionDVarSet (unitDVarSet case_bndr) alts_fvs+    scrut_fvs    = freeVarsOf scrut+    alts_fvs     = map alt_fvs alts+    all_alts_fvs = unionDVarSets alts_fvs+    alt_fvs (AnnAlt _con args rhs)+      = foldl' delDVarSet (freeVarsOf rhs) (case_bndr:args)+           -- Delete case_bndr and args from free vars of rhs+           -- to get free vars of alt      fi_alt to_drop (AnnAlt con args rhs) = Alt con args (fiExpr platform to_drop rhs)  ------------------ fiBind :: Platform-       -> RevFloatInBinds    -- Binds we're trying to drop-                             -- as far "inwards" as possible-       -> CoreBindWithFVs    -- Input binding-       -> DVarSet            -- Free in scope of binding-       -> ( RevFloatInBinds  -- Land these before-          , FloatInBind      -- The binding itself-          , RevFloatInBinds) -- Land these after+       -> FloatInBinds      -- Binds we're trying to drop+                            -- as far "inwards" as possible+       -> CoreBindWithFVs   -- Input binding+       -> DVarSet           -- Free in scope of binding+       -> ( FloatInBinds    -- Land these before+          , FloatInBind     -- The binding itself+          , FloatInBinds)   -- Land these after  fiBind platform to_drop (AnnNonRec id ann_rhs@(rhs_fvs, rhs)) body_fvs-  = ( shared_binds          -- Land these before-                                           -- See Note [extra_fvs (1,2)]+  = ( extra_binds ++ shared_binds          -- Land these before+                                           -- See Note [extra_fvs (1)] and Note [extra_fvs (2)]     , FB (unitDVarSet id) rhs_fvs'         -- The new binding itself           (FloatLet (NonRec id rhs'))     , body_binds )                         -- Land these after@@ -567,19 +513,20 @@   where     body_fvs2 = body_fvs `delDVarSet` id -    rule_fvs = bndrRuleAndUnfoldingVarsDSet id        -- See Note [extra_fvs (2): free variables of rules]+    rule_fvs = bndrRuleAndUnfoldingVarsDSet id        -- See Note [extra_fvs (2)]     extra_fvs | noFloatIntoRhs NonRecursive id rhs               = rule_fvs `unionDVarSet` rhs_fvs               | otherwise               = rule_fvs-        -- See Note [extra_fvs (1): avoid floating into RHS]+        -- See Note [extra_fvs (1)]         -- No point in floating in only to float straight out again         -- We *can't* float into ok-for-speculation unlifted RHSs         -- But do float into join points -    (shared_binds, [rhs_binds, body_binds])-        = sepBindsByDropPoint platform False to_drop-                      extra_fvs [rhs_fvs, body_fvs2]+    [shared_binds, extra_binds, rhs_binds, body_binds]+        = sepBindsByDropPoint platform False+            [extra_fvs, rhs_fvs, body_fvs2]+            to_drop          -- Push rhs_binds into the right hand side of the binding     rhs'     = fiRhs platform rhs_binds id ann_rhs@@ -587,7 +534,7 @@                         -- Don't forget the rule_fvs; the binding mentions them!  fiBind platform to_drop (AnnRec bindings) body_fvs-  = ( shared_binds+  = ( extra_binds ++ shared_binds     , FB (mkDVarSet ids) rhs_fvs'          (FloatLet (Rec (fi_bind rhss_binds bindings)))     , body_binds )@@ -595,22 +542,23 @@     (ids, rhss) = unzip bindings     rhss_fvs = map freeVarsOf rhss -        -- See Note [extra_fvs (1,2)]+        -- See Note [extra_fvs (1)] and Note [extra_fvs (2)]     rule_fvs = mapUnionDVarSet bndrRuleAndUnfoldingVarsDSet ids     extra_fvs = rule_fvs `unionDVarSet`                 unionDVarSets [ rhs_fvs | (bndr, (rhs_fvs, rhs)) <- bindings                               , noFloatIntoRhs Recursive bndr rhs ] -    (shared_binds, body_binds:rhss_binds)-        = sepBindsByDropPoint platform False to_drop-                       extra_fvs (body_fvs:rhss_fvs)+    (shared_binds:extra_binds:body_binds:rhss_binds)+        = sepBindsByDropPoint platform False+            (extra_fvs:body_fvs:rhss_fvs)+            to_drop      rhs_fvs' = unionDVarSets rhss_fvs `unionDVarSet`                unionDVarSets (map floatedBindsFVs rhss_binds) `unionDVarSet`                rule_fvs         -- Don't forget the rule variables!      -- Push rhs_binds into the right hand side of the binding-    fi_bind :: [RevFloatInBinds]   -- One per "drop pt" conjured w/ fvs_of_rhss+    fi_bind :: [FloatInBinds]       -- one per "drop pt" conjured w/ fvs_of_rhss             -> [(Id, CoreExprWithFVs)]             -> [(Id, CoreExpr)] @@ -619,7 +567,7 @@         | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ]  -------------------fiRhs :: Platform -> RevFloatInBinds -> CoreBndr -> CoreExprWithFVs -> CoreExpr+fiRhs :: Platform -> FloatInBinds -> CoreBndr -> CoreExprWithFVs -> CoreExpr fiRhs platform to_drop bndr rhs   | Just join_arity <- isJoinId_maybe bndr   , let (bndrs, body) = collectNAnnBndrs join_arity rhs@@ -645,7 +593,7 @@  noFloatIntoArg :: CoreExprWithFVs' -> Type -> Bool noFloatIntoArg expr expr_ty-  | isUnliftedType expr_ty+  | Just Unlifted <- typeLevity_maybe expr_ty   = True  -- See Note [Do not destroy the let/app invariant]     | AnnLam bndr e <- expr@@ -654,7 +602,7 @@    || all isTyVar (bndr:bndrs)     -- Wrinkle 1 (b)       -- See Note [noFloatInto considerations] wrinkle 2 -  | otherwise  -- Note [noFloatInto considerations] wrinkle 2+  | otherwise  -- See Note [noFloatInto considerations] wrinkle 2   = exprIsTrivial deann_expr || exprIsHNF deann_expr   where     deann_expr = deAnnotate' expr@@ -719,84 +667,68 @@ We have to maintain the order on these drop-point-related lists. -} --- pprFIB :: RevFloatInBinds -> SDoc+-- pprFIB :: FloatInBinds -> SDoc -- pprFIB fibs = text "FIB:" <+> ppr [b | FB _ _ b <- fibs]  sepBindsByDropPoint     :: Platform-    -> Bool                  -- True <=> is case expression-    -> RevFloatInBinds       -- Candidate floaters-    -> FreeVarSet            -- here_fvs: if these vars are free in a binding,-                             --   don't float that binding inside any drop point-    -> [FreeVarSet]          -- fork_fvs: one set of FVs per drop point-    -> ( RevFloatInBinds     -- Bindings which must not be floated inside-       , [RevFloatInBinds] ) -- Corresponds 1-1 with the input list of FV sets+    -> Bool                -- True <=> is case expression+    -> [FreeVarSet]        -- One set of FVs per drop point+                           -- Always at least two long!+    -> FloatInBinds        -- Candidate floaters+    -> [FloatInBinds]      -- FIRST one is bindings which must not be floated+                           -- inside any drop point; the rest correspond+                           -- one-to-one with the input list of FV sets  -- Every input floater is returned somewhere in the result; -- none are dropped, not even ones which don't seem to be -- free in *any* of the drop-point fvs.  Why?  Because, for example, -- a binding (let x = E in B) might have a specialised version of -- x (say x') stored inside x, but x' isn't free in E or B.------ The here_fvs argument is used for two things:--- * Avoid shadowing bugs: see Note [Shadowing and name capture]--- * Drop some of the bindings at the top, e.g. of an application  type DropBox = (FreeVarSet, FloatInBinds) -dropBoxFloats :: DropBox -> RevFloatInBinds-dropBoxFloats (_, floats) = reverse floats--usedInDropBox :: DIdSet -> DropBox -> Bool-usedInDropBox bndrs (db_fvs, _) = db_fvs `intersectsDVarSet` bndrs--initDropBox :: DVarSet -> DropBox-initDropBox fvs = (fvs, [])--sepBindsByDropPoint platform is_case floaters here_fvs fork_fvs+sepBindsByDropPoint platform is_case drop_pts floaters   | null floaters  -- Shortcut common case-  = ([], [[] | _ <- fork_fvs])+  = [] : [[] | _ <- drop_pts]    | otherwise-  = go floaters (initDropBox here_fvs) (map initDropBox fork_fvs)+  = assert (drop_pts `lengthAtLeast` 2) $+    go floaters (map (\fvs -> (fvs, [])) (emptyDVarSet : drop_pts))   where-    n_alts = length fork_fvs+    n_alts = length drop_pts -    go :: RevFloatInBinds -> DropBox -> [DropBox]-       -> (RevFloatInBinds, [RevFloatInBinds])-        -- The *first* one in the pair is the drop_here set+    go :: FloatInBinds -> [DropBox] -> [FloatInBinds]+        -- The *first* one in the argument list is the drop_here set+        -- The FloatInBinds in the lists are in the reverse of+        -- the normal FloatInBinds order; that is, they are the right way round! -    go [] here_box fork_boxes-        = (dropBoxFloats here_box, map dropBoxFloats fork_boxes)+    go [] drop_boxes = map (reverse . snd) drop_boxes -    go (bind_w_fvs@(FB bndrs bind_fvs bind) : binds) here_box fork_boxes-        | drop_here = go binds (insert here_box) fork_boxes-        | otherwise = go binds here_box          new_fork_boxes+    go (bind_w_fvs@(FB bndrs bind_fvs bind) : binds) drop_boxes@(here_box : fork_boxes)+        = go binds new_boxes         where           -- "here" means the group of bindings dropped at the top of the fork -          used_here     = bndrs `usedInDropBox` here_box-          used_in_flags = case fork_boxes of-                            []  -> []-                            [_] -> [True]  -- Push all bindings into a single branch-                                           -- No need to look at its free vars-                            _   -> map (bndrs `usedInDropBox`) fork_boxes-               -- Short-cut for the singleton case;-               -- used for lambdas and singleton cases+          (used_here : used_in_flags) = [ fvs `intersectsDVarSet` bndrs+                                        | (fvs, _) <- drop_boxes]            drop_here = used_here || cant_push            n_used_alts = count id used_in_flags -- returns number of Trues in list.            cant_push-            | is_case   = (n_alts > 1 && n_used_alts == n_alts)-                             -- Used in all, muliple branches, don't push+            | is_case   = n_used_alts == n_alts   -- Used in all, don't push+                                                  -- Remember n_alts > 1                           || (n_used_alts > 1 && not (floatIsDupable platform bind))                              -- floatIsDupable: see Note [Duplicating floats]              | otherwise = floatIsCase bind || n_used_alts > 1                              -- floatIsCase: see Note [Floating primops] +          new_boxes | drop_here = (insert here_box : fork_boxes)+                    | otherwise = (here_box : new_fork_boxes)+           new_fork_boxes = zipWithEqual "FloatIn.sepBinds" insert_maybe                                         fork_boxes used_in_flags @@ -806,10 +738,11 @@           insert_maybe box True  = insert box           insert_maybe box False = box +    go _ _ = panic "sepBindsByDropPoint/go" + {- Note [Duplicating floats] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~- For case expressions we duplicate the binding if it is reasonably small, and if it is not used in all the RHSs This is good for situations like@@ -823,14 +756,14 @@ so we don't duplicate then. -} -floatedBindsFVs :: RevFloatInBinds -> FreeVarSet+floatedBindsFVs :: FloatInBinds -> FreeVarSet floatedBindsFVs binds = mapUnionDVarSet fbFVs binds  fbFVs :: FloatInBind -> DVarSet fbFVs (FB _ fvs _) = fvs -wrapFloats :: RevFloatInBinds -> CoreExpr -> CoreExpr--- Remember RevFloatInBinds is in *reverse* dependency order+wrapFloats :: FloatInBinds -> CoreExpr -> CoreExpr+-- Remember FloatInBinds is in *reverse* dependency order wrapFloats []               e = e wrapFloats (FB _ _ fl : bs) e = wrapFloats bs (wrapFloat fl e)
compiler/GHC/Core/Opt/FloatOut.hs view
@@ -6,8 +6,8 @@ ``Long-distance'' floating of bindings towards the top level. -} -{-# LANGUAGE CPP #-} + module GHC.Core.Opt.FloatOut ( floatOutwards ) where  import GHC.Prelude@@ -19,7 +19,7 @@ import GHC.Core.Opt.Monad ( FloatOutSwitches(..) )  import GHC.Driver.Session-import GHC.Utils.Logger  ( dumpIfSet_dyn, DumpFormat (..), Logger )+import GHC.Utils.Logger import GHC.Types.Id      ( Id, idArity, idType, isDeadEndId,                            isJoinId, isJoinId_maybe ) import GHC.Types.Tickish@@ -35,8 +35,6 @@  import Data.List        ( partition ) -#include "GhclibHsVersions.h"- {-         -----------------         Overall game plan@@ -166,23 +164,22 @@  floatOutwards :: Logger               -> FloatOutSwitches-              -> DynFlags               -> UniqSupply               -> CoreProgram -> IO CoreProgram -floatOutwards logger float_sws dflags us pgm+floatOutwards logger float_sws us pgm   = do {         let { annotated_w_levels = setLevels float_sws pgm us ;               (fss, binds_s')    = unzip (map floatTopBind annotated_w_levels)             } ; -        dumpIfSet_dyn logger dflags Opt_D_verbose_core2core "Levels added:"+        putDumpFileMaybe logger Opt_D_verbose_core2core "Levels added:"                   FormatCore                   (vcat (map ppr annotated_w_levels));          let { (tlets, ntlets, lams) = get_stats (sum_stats fss) }; -        dumpIfSet_dyn logger dflags Opt_D_dump_simpl_stats "FloatOut stats:"+        putDumpFileMaybe logger Opt_D_dump_simpl_stats "FloatOut stats:"                 FormatText                 (hcat [ int tlets,  text " Lets floated to top level; ",                         int ntlets, text " Lets floated elsewhere; from ",@@ -272,6 +269,8 @@   = go [] [] (bagToList fs)   where     go ul_prs prs (FloatLet (NonRec b r) : fs) | isUnliftedType (idType b)+                                               -- NB: isUnliftedType is OK here as binders always+                                               -- have a fixed RuntimeRep.                                                , not (isJoinId b)                                                = go ((b,r):ul_prs) prs fs                                                | otherwise@@ -283,7 +282,7 @@                                                    -- non-rec  installUnderLambdas :: Bag FloatBind -> CoreExpr -> CoreExpr--- Note [Floating out of Rec rhss]+-- See Note [Floating out of Rec rhss] installUnderLambdas floats e   | isEmptyBag floats = e   | otherwise         = go e@@ -377,7 +376,6 @@  {- Note [Floating past breakpoints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- We used to disallow floating out of breakpoint ticks (see #10052). However, I think this is too restrictive. @@ -431,7 +429,7 @@     in     (fs, annotated_defns, Tick tickish expr') } -  -- Note [Floating past breakpoints]+  -- See Note [Floating past breakpoints]   | Breakpoint{} <- tickish   = case (floatExpr expr)    of { (fs, floating_defns, expr') ->     (fs, floating_defns, Tick tickish expr') }@@ -629,8 +627,8 @@  flattenTopFloats :: FloatBinds -> Bag CoreBind flattenTopFloats (FB tops ceils defs)-  = ASSERT2( isEmptyBag (flattenMajor defs), ppr defs )-    ASSERT2( isEmptyBag ceils, ppr ceils )+  = assertPpr (isEmptyBag (flattenMajor defs)) (ppr defs) $+    assertPpr (isEmptyBag ceils) (ppr ceils)     tops  addTopFloatPairs :: Bag CoreBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
compiler/GHC/Core/Opt/LiberateCase.hs view
@@ -4,10 +4,8 @@ \section[LiberateCase]{Unroll recursion to allow evals to be lifted from a loop} -} -{-# LANGUAGE CPP #-}-module GHC.Core.Opt.LiberateCase ( liberateCase ) where -#include "GhclibHsVersions.h"+module GHC.Core.Opt.LiberateCase ( liberateCase ) where  import GHC.Prelude @@ -170,7 +168,7 @@      ok_pair (id,_)         =  idArity id > 0       -- Note [Only functions!]-        && not (isDeadEndId id) -- Note [Not bottoming ids]+        && not (isDeadEndId id) -- Note [Not bottoming Ids]  {- Note [Not bottoming Ids] ~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Core/Opt/Pipeline.hs view
@@ -8,19 +8,16 @@  module GHC.Core.Opt.Pipeline ( core2core, simplifyExpr ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Driver.Session-import GHC.Driver.Ppr import GHC.Driver.Plugins ( withPlugins, installCoreToDos ) import GHC.Driver.Env import GHC.Platform.Ways  ( hasWay, Way(WayProf) )  import GHC.Core import GHC.Core.Opt.CSE  ( cseProgram )-import GHC.Core.Rules   ( mkRuleBase, unionRuleBase,+import GHC.Core.Rules   ( mkRuleBase,                           extendRuleBaseList, ruleCheckProgram, addRuleInfo,                           getRules, initRuleOpts ) import GHC.Core.Ppr     ( pprCoreBindings, pprCoreExpr )@@ -29,7 +26,7 @@ import GHC.Core.Utils   ( mkTicks, stripTicksTop, dumpIdInfoOfProgram ) import GHC.Core.Lint    ( endPass, lintPassResult, dumpPassResult,                           lintAnnots )-import GHC.Core.Opt.Simplify       ( simplTopBinds, simplExpr, simplRules )+import GHC.Core.Opt.Simplify       ( simplTopBinds, simplExpr, simplImpRules ) import GHC.Core.Opt.Simplify.Utils ( simplEnvForGHCi, activeRule, activeUnfolding ) import GHC.Core.Opt.Simplify.Env import GHC.Core.Opt.Simplify.Monad@@ -46,15 +43,16 @@ import GHC.Core.Opt.Exitify      ( exitifyProgram ) import GHC.Core.Opt.WorkWrap     ( wwTopBinds ) import GHC.Core.Opt.CallerCC     ( addCallerCostCentres )+import GHC.Core.LateCC           (addLateCostCentresMG) import GHC.Core.Seq (seqBinds) import GHC.Core.FamInstEnv -import qualified GHC.Utils.Error as Err import GHC.Utils.Error  ( withTiming ) import GHC.Utils.Logger as Logger-import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.Trace  import GHC.Unit.External import GHC.Unit.Module.Env@@ -63,7 +61,6 @@  import GHC.Runtime.Context -import GHC.Types.SrcLoc import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Basic@@ -71,12 +68,12 @@ import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Tickish-import GHC.Types.Unique.Supply ( UniqSupply ) import GHC.Types.Unique.FM import GHC.Types.Name.Ppr  import Control.Monad import qualified GHC.LanguageExtensions as LangExt+import GHC.Unit.Module {- ************************************************************************ *                                                                      *@@ -97,12 +94,12 @@        ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_mask mod                                     orph_mods print_unqual loc $                            do { hsc_env' <- getHscEnv-                              ; all_passes <- withPlugins hsc_env'+                              ; all_passes <- withPlugins (hsc_plugins hsc_env')                                                 installCoreToDos                                                 builtin_passes                               ; runCorePasses all_passes guts } -       ; Logger.dumpIfSet_dyn logger dflags Opt_D_dump_simpl_stats+       ; Logger.putDumpFileMaybe logger Opt_D_dump_simpl_stats              "Grand total simplifier statistics"              FormatText              (pprSimplCount stats)@@ -111,7 +108,8 @@   where     logger         = hsc_logger hsc_env     dflags         = hsc_dflags hsc_env-    home_pkg_rules = hptRules hsc_env (dep_mods deps)+    home_pkg_rules = hptRules hsc_env (moduleUnitId mod) (GWIB { gwib_mod = moduleName mod+                                                               , gwib_isBoot = NotBoot })     hpt_rule_base  = mkRuleBase home_pkg_rules     print_unqual   = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env     -- mod: get the module out of the current HscEnv so we can retrieve it from the monad.@@ -132,10 +130,10 @@ getCoreToDo logger dflags   = flatten_todos core_todo   where-    opt_level     = optLevel           dflags     phases        = simplPhases        dflags     max_iter      = maxSimplIterations dflags     rule_check    = ruleCheck          dflags+    const_fold    = gopt Opt_CoreConstantFolding          dflags     call_arity    = gopt Opt_CallArity                    dflags     exitification = gopt Opt_Exitification                dflags     strictness    = gopt Opt_Strictness                   dflags@@ -155,6 +153,9 @@     static_ptrs   = xopt LangExt.StaticPointers           dflags     profiling     = ways dflags `hasWay` WayProf +    do_presimplify = do_specialise -- TODO: any other optimizations benefit from pre-simplification?+    do_simpl3      = const_fold || rules_on -- TODO: any other optimizations benefit from three-phase simplification?+     maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)      maybe_strictness_before (Phase phase)@@ -225,17 +226,11 @@     add_caller_ccs =         runWhen (profiling && not (null $ callerCcFilters dflags)) CoreAddCallerCcs -    core_todo =-     if opt_level == 0 then-       [ static_ptrs_float_outwards,-         CoreDoSimplify max_iter-             (base_mode { sm_phase = FinalPhase-                        , sm_names = ["Non-opt simplification"] })-       , add_caller_ccs-       ]--     else {- opt_level >= 1 -} [+    add_late_ccs =+        runWhen (profiling && gopt Opt_ProfLateInlineCcs dflags) $ CoreAddLateCcs +    core_todo =+     [     -- We want to do the static argument transform before full laziness as it     -- may expose extra opportunities to float things outwards. However, to fix     -- up the output of the transformation we need at do at least one simplify@@ -243,7 +238,7 @@         runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]),          -- initial simplify: mk specialiser happy: minimum effort please-        simpl_gently,+        runWhen do_presimplify simpl_gently,          -- Specialisation is best done before full laziness         -- so that overloaded functions have all their dictionary lambdas manifest@@ -279,9 +274,10 @@            static_ptrs_float_outwards,          -- Run the simplier phases 2,1,0 to allow rewrite rules to fire-        CoreDoPasses [ simpl_phase (Phase phase) "main" max_iter-                     | phase <- [phases, phases-1 .. 1] ],-        simpl_phase (Phase 0) "main" (max max_iter 3),+        runWhen do_simpl3+            (CoreDoPasses $ [ simpl_phase (Phase phase) "main" max_iter+                            | phase <- [phases, phases-1 .. 1] ] +++                            [ simpl_phase (Phase 0) "main" (max max_iter 3) ]),                 -- Phase 0: allow all Ids to be inlined now                 -- This gets foldr inlined before strictness analysis @@ -309,7 +305,7 @@         runWhen strictness demand_analyser,          runWhen exitification CoreDoExitify,-            -- See note [Placement of the exitification pass]+            -- See Note [Placement of the exitification pass]          runWhen full_laziness $            CoreDoFloatOutwards FloatOutSwitches {@@ -377,7 +373,8 @@          maybe_rule_check FinalPhase, -        add_caller_ccs+        add_caller_ccs,+        add_late_ccs      ]      -- Remove 'CoreDoNothing' and flatten 'CoreDoPasses' for clarity.@@ -468,9 +465,8 @@     do_pass guts CoreDoNothing = return guts     do_pass guts (CoreDoPasses ps) = runCorePasses ps guts     do_pass guts pass = do-      dflags <- getDynFlags       logger <- getLogger-      withTiming logger dflags (ppr pass <+> brackets (ppr mod))+      withTiming logger (ppr pass <+> brackets (ppr mod))                    (const ()) $ do             guts' <- lintAnnots (ppr pass) (doCorePass pass) guts             endPass pass (mg_binds guts') (mg_rules guts')@@ -480,40 +476,48 @@  doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts doCorePass pass guts = do-  logger <- getLogger+  logger    <- getLogger+  dflags    <- getDynFlags+  us        <- getUniqueSupplyM+  p_fam_env <- getPackageFamInstEnv+  let platform = targetPlatform dflags+  let fam_envs = (p_fam_env, mg_fam_inst_env guts)+  let updateBinds  f = return $ guts { mg_binds = f (mg_binds guts) }+  let updateBindsM f = f (mg_binds guts) >>= \b' -> return $ guts { mg_binds = b' }+   case pass of     CoreDoSimplify {}         -> {-# SCC "Simplify" #-}                                  simplifyPgm pass guts      CoreCSE                   -> {-# SCC "CommonSubExpr" #-}-                                 doPass cseProgram guts+                                 updateBinds cseProgram      CoreLiberateCase          -> {-# SCC "LiberateCase" #-}-                                 doPassD liberateCase guts+                                 updateBinds (liberateCase dflags)      CoreDoFloatInwards        -> {-# SCC "FloatInwards" #-}-                                 floatInwards guts+                                 updateBinds (floatInwards platform)      CoreDoFloatOutwards f     -> {-# SCC "FloatOutwards" #-}-                                 doPassDUM (floatOutwards logger f) guts+                                 updateBindsM (liftIO . floatOutwards logger f us)      CoreDoStaticArgs          -> {-# SCC "StaticArgs" #-}-                                 doPassU doStaticArgs guts+                                 updateBinds (doStaticArgs us)      CoreDoCallArity           -> {-# SCC "CallArity" #-}-                                 doPassD callArityAnalProgram guts+                                 updateBinds callArityAnalProgram      CoreDoExitify             -> {-# SCC "Exitify" #-}-                                 doPass exitifyProgram guts+                                 updateBinds exitifyProgram      CoreDoDemand              -> {-# SCC "DmdAnal" #-}-                                 doPassDFRM (dmdAnal logger) guts+                                 updateBindsM (liftIO . dmdAnal logger dflags fam_envs (mg_rules guts))      CoreDoCpr                 -> {-# SCC "CprAnal" #-}-                                 doPassDFM (cprAnalProgram logger) guts+                                 updateBindsM (liftIO . cprAnalProgram logger fam_envs)      CoreDoWorkerWrapper       -> {-# SCC "WorkWrap" #-}-                                 doPassDFU wwTopBinds guts+                                 updateBinds (wwTopBinds (mg_module guts) dflags fam_envs us)      CoreDoSpecialising        -> {-# SCC "Specialise" #-}                                  specProgram guts@@ -524,9 +528,14 @@     CoreAddCallerCcs          -> {-# SCC "AddCallerCcs" #-}                                  addCallerCostCentres guts -    CoreDoPrintCore           -> observe (printCore logger) guts+    CoreAddLateCcs            -> {-# SCC "AddLateCcs" #-}+                                 addLateCostCentresMG guts -    CoreDoRuleCheck phase pat -> ruleCheckPass phase pat guts+    CoreDoPrintCore           -> {-# SCC "PrintCore" #-}+                                 liftIO $ printCore logger (mg_binds guts) >> return guts++    CoreDoRuleCheck phase pat -> {-# SCC "RuleCheck" #-}+                                 ruleCheckPass phase pat guts     CoreDoNothing             -> return guts     CoreDoPasses passes       -> runCorePasses passes guts @@ -546,84 +555,26 @@ ************************************************************************ -} -printCore :: Logger -> DynFlags -> CoreProgram -> IO ()-printCore logger dflags binds-    = Logger.dumpIfSet logger dflags True "Print Core" (pprCoreBindings binds)+printCore :: Logger -> CoreProgram -> IO ()+printCore logger binds+    = Logger.logDumpMsg logger "Print Core" (pprCoreBindings binds)  ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts ruleCheckPass current_phase pat guts = do     dflags <- getDynFlags     logger <- getLogger-    withTiming logger dflags (text "RuleCheck"<+>brackets (ppr $ mg_module guts))+    withTiming logger (text "RuleCheck"<+>brackets (ppr $ mg_module guts))                 (const ()) $ do         rb <- getRuleBase         vis_orphs <- getVisibleOrphanMods-        let rule_fn fn = getRules (RuleEnv rb vis_orphs) fn+        let rule_fn fn = getRules (RuleEnv [rb] vis_orphs) fn                           ++ (mg_rules guts)         let ropts = initRuleOpts dflags-        liftIO $ putLogMsg logger dflags NoReason Err.SevDump noSrcSpan-                     $ withPprStyle defaultDumpStyle+        liftIO $ logDumpMsg logger "Rule check"                      (ruleCheckProgram ropts current_phase pat                         rule_fn (mg_binds guts))         return guts -doPassDUM :: (DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts-doPassDUM do_pass = doPassM $ \binds -> do-    dflags <- getDynFlags-    us     <- getUniqueSupplyM-    liftIO $ do_pass dflags us binds--doPassDM :: (DynFlags -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts-doPassDM do_pass = doPassDUM (\dflags -> const (do_pass dflags))--doPassD :: (DynFlags -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts-doPassD do_pass = doPassDM (\dflags -> return . do_pass dflags)--doPassDU :: (DynFlags -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts-doPassDU do_pass = doPassDUM (\dflags us -> return . do_pass dflags us)--doPassU :: (UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts-doPassU do_pass = doPassDU (const do_pass)--doPassDFM :: (DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts-doPassDFM do_pass guts = do-    dflags <- getDynFlags-    p_fam_env <- getPackageFamInstEnv-    let fam_envs = (p_fam_env, mg_fam_inst_env guts)-    doPassM (liftIO . do_pass dflags fam_envs) guts--doPassDFRM :: (DynFlags -> FamInstEnvs -> [CoreRule] -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts-doPassDFRM do_pass guts = do-    dflags <- getDynFlags-    p_fam_env <- getPackageFamInstEnv-    let fam_envs = (p_fam_env, mg_fam_inst_env guts)-    doPassM (liftIO . do_pass dflags fam_envs (mg_rules guts)) guts--doPassDFU :: (DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts-doPassDFU do_pass guts = do-    dflags <- getDynFlags-    us     <- getUniqueSupplyM-    p_fam_env <- getPackageFamInstEnv-    let fam_envs = (p_fam_env, mg_fam_inst_env guts)-    doPass (do_pass dflags fam_envs us) guts---- Most passes return no stats and don't change rules: these combinators--- let us lift them to the full blown ModGuts+CoreM world-doPassM :: Monad m => (CoreProgram -> m CoreProgram) -> ModGuts -> m ModGuts-doPassM bind_f guts = do-    binds' <- bind_f (mg_binds guts)-    return (guts { mg_binds = binds' })--doPass :: (CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts-doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) }---- Observer passes just peek; don't modify the bindings at all-observe :: (DynFlags -> CoreProgram -> IO a) -> ModGuts -> CoreM ModGuts-observe do_pass = doPassM $ \binds -> do-    dflags <- getDynFlags-    _ <- liftIO $ do_pass dflags binds-    return binds- {- ************************************************************************ *                                                                      *@@ -638,23 +589,22 @@ -- simplifyExpr is called by the driver to simplify an -- expression typed in at the interactive prompt simplifyExpr hsc_env expr-  = withTiming logger dflags (text "Simplify [expr]") (const ()) $+  = withTiming logger (text "Simplify [expr]") (const ()) $     do  { eps <- hscEPS hsc_env ;-        ; let rule_env  = mkRuleEnv (eps_rule_base eps) []-              fi_env    = ( eps_fam_inst_env eps+        ; let fi_env    = ( eps_fam_inst_env eps                           , extendFamInstEnvList emptyFamInstEnv $                             snd $ ic_instances $ hsc_IC hsc_env )               simpl_env = simplEnvForGHCi logger dflags          ; let sz = exprSize expr -        ; (expr', counts) <- initSmpl logger dflags rule_env fi_env sz $+        ; (expr', counts) <- initSmpl logger dflags (eps_rule_base <$> hscEPS hsc_env) emptyRuleEnv fi_env sz $                              simplExprGently simpl_env expr -        ; Logger.dumpIfSet logger dflags (dopt Opt_D_dump_simpl_stats dflags)-                  "Simplifier statistics" (pprSimplCount counts)+        ; Logger.putDumpFileMaybe logger Opt_D_dump_simpl_stats+                  "Simplifier statistics" FormatText (pprSimplCount counts) -        ; Logger.dumpIfSet_dyn logger dflags Opt_D_dump_simpl "Simplified expression"+        ; Logger.putDumpFileMaybe logger Opt_D_dump_simpl "Simplified expression"                         FormatCore                         (pprCoreExpr expr') @@ -678,7 +628,7 @@ -- enforce that; it just simplifies the expression twice  -- It's important that simplExprGently does eta reduction; see--- Note [Simplifying the left-hand side of a RULE] above.  The+-- Note [Simplify rule LHS] above.  The -- simplifier does indeed do eta reduction (it's in GHC.Core.Opt.Simplify.completeLam) -- but only if -O is on. @@ -717,8 +667,9 @@   = do { (termination_msg, it_count, counts_out, guts')            <- do_iteration 1 [] binds rules -        ; Logger.dumpIfSet logger dflags (dopt Opt_D_verbose_core2core dflags &&-                                dopt Opt_D_dump_simpl_stats  dflags)+        ; when (logHasDumpFlag logger Opt_D_verbose_core2core+                && logHasDumpFlag logger Opt_D_dump_simpl_stats) $+          logDumpMsg logger                   "Simplifier statistics for following pass"                   (vcat [text termination_msg <+> text "after" <+> ppr it_count                                               <+> text "iterations",@@ -746,12 +697,13 @@         -- iteration_no is the number of the iteration we are         -- about to begin, with '1' for the first       | iteration_no > max_iterations   -- Stop if we've run out of iterations-      = WARN( debugIsOn && (max_iterations > 2)-            , hang (text "Simplifier bailing out after" <+> int max_iterations-                    <+> text "iterations"+      = warnPprTrace (debugIsOn && (max_iterations > 2))+            "Simplifier bailing out"+            ( hang (ppr this_mod <> text ", after"+                    <+> int max_iterations <+> text "iterations"                     <+> (brackets $ hsep $ punctuate comma $                          map (int . simplCountN) (reverse counts_so_far)))-                 2 (text "Size =" <+> ppr (coreBindsStats binds)))+                 2 (text "Size =" <+> ppr (coreBindsStats binds))) $                  -- Subtract 1 from iteration_no to get the                 -- number of iterations we actually completed@@ -769,25 +721,27 @@                      occurAnalysePgm this_mod active_unf active_rule rules                                      binds                } ;-           Logger.dumpIfSet_dyn logger dflags Opt_D_dump_occur_anal "Occurrence analysis"+           Logger.putDumpFileMaybe logger Opt_D_dump_occur_anal "Occurrence analysis"                      FormatCore                      (pprCoreBindings tagged_binds); -                -- Get any new rules, and extend the rule base-                -- See Note [Overall plumbing for rules] in GHC.Core.Rules-                -- We need to do this regularly, because simplification can+                -- read_eps_rules:+                -- We need to read rules from the EPS regularly because simplification can                 -- poke on IdInfo thunks, which in turn brings in new rules                 -- behind the scenes.  Otherwise there's a danger we'll simply                 -- miss the rules for Ids hidden inside imported inlinings+                -- Hence just before attempting to match rules we read on the EPS+                -- value and then combine it when the existing rule base.+                -- See `GHC.Core.Opt.Simplify.Monad.getSimplRules`.            eps <- hscEPS hsc_env ;-           let  { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps)-                ; rule_base2 = extendRuleBaseList rule_base1 rules+           let  { read_eps_rules = eps_rule_base <$> hscEPS hsc_env+                ; rule_base = extendRuleBaseList hpt_rule_base rules                 ; fam_envs = (eps_fam_inst_env eps, fam_inst_env)                 ; vis_orphs = this_mod : dep_orphs deps } ;                  -- Simplify the program            ((binds1, rules1), counts1) <--             initSmpl logger dflags (mkRuleEnv rule_base2 vis_orphs) fam_envs sz $+             initSmpl logger dflags read_eps_rules (mkRuleEnv rule_base vis_orphs) fam_envs sz $                do { (floats, env1) <- {-# SCC "SimplTopBinds" #-}                                       simplTopBinds simpl_env tagged_binds @@ -795,7 +749,7 @@                       -- for imported Ids.  Eg  RULE map my_f = blah                       -- If we have a substitution my_f :-> other_f, we'd better                       -- apply it to the rule to, or it'll never match-                  ; rules1 <- simplRules env1 Nothing rules Nothing+                  ; rules1 <- simplImpRules env1 rules                    ; return (getTopFloatBinds floats, rules1) } ; @@ -817,7 +771,8 @@            let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ;                  -- Dump the result of this iteration-           dump_end_iteration logger dflags print_unqual iteration_no counts1 binds2 rules1 ;+           let { dump_core_sizes = not (gopt Opt_SuppressCoreSizes dflags) } ;+           dump_end_iteration logger dump_core_sizes print_unqual iteration_no counts1 binds2 rules1 ;            lintPassResult hsc_env pass binds2 ;                  -- Loop@@ -835,19 +790,19 @@ simplifyPgmIO _ _ _ _ = panic "simplifyPgmIO"  --------------------dump_end_iteration :: Logger -> DynFlags -> PrintUnqualified -> Int+dump_end_iteration :: Logger -> Bool -> PrintUnqualified -> Int                    -> SimplCount -> CoreProgram -> [CoreRule] -> IO ()-dump_end_iteration logger dflags print_unqual iteration_no counts binds rules-  = dumpPassResult logger dflags print_unqual mb_flag hdr pp_counts binds rules+dump_end_iteration logger dump_core_sizes print_unqual iteration_no counts binds rules+  = dumpPassResult logger dump_core_sizes print_unqual mb_flag hdr pp_counts binds rules   where-    mb_flag | dopt Opt_D_dump_simpl_iterations dflags = Just Opt_D_dump_simpl_iterations-            | otherwise                               = Nothing+    mb_flag | logHasDumpFlag logger Opt_D_dump_simpl_iterations = Just Opt_D_dump_simpl_iterations+            | otherwise                                         = Nothing             -- Show details if Opt_D_dump_simpl_iterations is on -    hdr = text "Simplifier iteration=" <> int iteration_no-    pp_counts = vcat [ text "---- Simplifier counts for" <+> hdr+    hdr = "Simplifier iteration=" ++ show iteration_no+    pp_counts = vcat [ text "---- Simplifier counts for" <+> text hdr                      , pprSimplCount counts-                     , text "---- End of simplifier counts for" <+> hdr ]+                     , text "---- End of simplifier counts for" <+> text hdr ]  {- ************************************************************************@@ -988,7 +943,7 @@ shortOutIndirections :: CoreProgram -> CoreProgram shortOutIndirections binds   | isEmptyVarEnv ind_env = binds-  | no_need_to_flatten    = binds'                      -- See Note [Rules and indirect-zapping]+  | no_need_to_flatten    = binds'                      -- See Note [Rules and indirection-zapping]   | otherwise             = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff   where     ind_env            = makeIndEnv binds@@ -1050,9 +1005,8 @@        not (local_id `elemVarEnv` ind_env)      -- Only if not already substituted for     then         if hasShortableIdInfo exported_id-        then True       -- See Note [Messing up the exported Id's IdInfo]-        else WARN( True, text "Not shorting out:" <+> ppr exported_id )-             False+        then True       -- See Note [Messing up the exported Id's RULES]+        else warnPprTrace True "Not shorting out" (ppr exported_id) False     else         False @@ -1060,11 +1014,11 @@ hasShortableIdInfo :: Id -> Bool -- True if there is no user-attached IdInfo on exported_id, -- so we can safely discard it--- See Note [Messing up the exported Id's IdInfo]+-- See Note [Messing up the exported Id's RULES] hasShortableIdInfo id   =  isEmptyRuleInfo (ruleInfo info)   && isDefaultInlinePragma (inlinePragInfo info)-  && not (isStableUnfolding (unfoldingInfo info))+  && not (isStableUnfolding (realUnfoldingInfo info))   where      info = idInfo id @@ -1085,37 +1039,47 @@  Overwriting, rather than merging, seems to work ok. -We also zap the InlinePragma on the lcl_id. It might originally-have had a NOINLINE, which we have now transferred; and we really-want the lcl_id to inline now that its RHS is trivial!+For the lcl_id we++* Zap the InlinePragma. It might originally have had a NOINLINE, which+  we have now transferred; and we really want the lcl_id to inline now+  that its RHS is trivial!++* Zap any Stable unfolding.  agian, we want lcl_id = gbl_id to inline,+  replacing lcl_id by gbl_id. That won't happen if lcl_id has its original+  great big Stable unfolding -}  transferIdInfo :: Id -> Id -> (Id, Id) -- See Note [Transferring IdInfo] transferIdInfo exported_id local_id   = ( modifyIdInfo transfer exported_id-    , local_id `setInlinePragma` defaultInlinePragma )+    , modifyIdInfo zap_info local_id )   where     local_info = idInfo local_id-    transfer exp_info = exp_info `setStrictnessInfo`    strictnessInfo local_info-                                 `setCprInfo`           cprInfo local_info-                                 `setUnfoldingInfo`     unfoldingInfo local_info-                                 `setInlinePragInfo`    inlinePragInfo local_info-                                 `setRuleInfo`          addRuleInfo (ruleInfo exp_info) new_info+    transfer exp_info = exp_info `setDmdSigInfo`     dmdSigInfo local_info+                                 `setCprSigInfo`     cprSigInfo local_info+                                 `setUnfoldingInfo`  realUnfoldingInfo local_info+                                 `setInlinePragInfo` inlinePragInfo local_info+                                 `setRuleInfo`       addRuleInfo (ruleInfo exp_info) new_info     new_info = setRuleInfoHead (idName exported_id)                                (ruleInfo local_info)         -- Remember to set the function-name field of the         -- rules as we transfer them from one function to another +    zap_info lcl_info = lcl_info `setInlinePragInfo` defaultInlinePragma+                                 `setUnfoldingInfo`  noUnfolding   dmdAnal :: Logger -> DynFlags -> FamInstEnvs -> [CoreRule] -> CoreProgram -> IO CoreProgram dmdAnal logger dflags fam_envs rules binds = do   let !opts = DmdAnalOpts-               { dmd_strict_dicts = gopt Opt_DictsStrict dflags+               { dmd_strict_dicts    = gopt Opt_DictsStrict dflags+               , dmd_unbox_width     = dmdUnboxWidth dflags+               , dmd_max_worker_args = maxWorkerArgs dflags                }       binds_plus_dmds = dmdAnalProgram opts fam_envs rules binds-  Logger.dumpIfSet_dyn logger dflags Opt_D_dump_str_signatures "Strictness signatures" FormatText $-    dumpIdInfoOfProgram (ppr . zapDmdEnvSig . strictnessInfo) binds_plus_dmds+  Logger.putDumpFileMaybe logger Opt_D_dump_str_signatures "Strictness signatures" FormatText $+    dumpIdInfoOfProgram (hasPprDebug dflags) (ppr . zapDmdEnvSig . dmdSigInfo) binds_plus_dmds   -- See Note [Stamp out space leaks in demand analysis] in GHC.Core.Opt.DmdAnal   seqBinds binds_plus_dmds `seq` return binds_plus_dmds
compiler/GHC/Core/Opt/SetLevels.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP             #-}+ {-# LANGUAGE PatternSynonyms #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}@@ -55,9 +55,9 @@    This can only work if @wild@ is an unrestricted binder. Indeed, even with the   extended typing rule (in the linter) for case expressions, if-       case x of wild # 1 { p -> e}+       case x of wild % 1 { p -> e}   is well-typed, then-       case x of wild # 1 { p -> e[wild\x] }+       case x of wild % 1 { p -> e[wild\x] }   is only well-typed if @e[wild\x] = e@ (that is, if @wild@ is not used in @e@   at all). In which case, it is, of course, pointless to do the substitution   anyway. So for a linear binder (and really anything which isn't unrestricted),@@ -75,18 +75,13 @@         incMinorLvl, ltMajLvl, ltLvl, isTopLvl     ) where -#include "GhclibHsVersions.h"- import GHC.Prelude -import GHC.Driver.Ppr- import GHC.Core import GHC.Core.Opt.Monad ( FloatOutSwitches(..) ) import GHC.Core.Utils   ( exprType, exprIsHNF                         , exprOkForSpeculation                         , exprIsTopLevelBindable-                        , isExprLevPoly                         , collectMakeStaticArgs                         , mkLamTypes                         )@@ -94,6 +89,12 @@ import GHC.Core.FVs     -- all of it import GHC.Core.Subst import GHC.Core.Make    ( sortQuantVars )+import GHC.Core.Type    ( Type, splitTyConApp_maybe, tyCoVarsOfType+                        , mightBeUnliftedType, closeOverKindsDSet+                        , typeHasFixedRuntimeRep+                        )+import GHC.Core.Multiplicity     ( pattern Many )+import GHC.Core.DataCon ( dataConOrigResTy )  import GHC.Types.Id import GHC.Types.Id.Info@@ -103,28 +104,30 @@ import GHC.Types.Unique.DSet  ( getUniqDSet ) import GHC.Types.Var.Env import GHC.Types.Literal      ( litIsTrivial )-import GHC.Types.Demand       ( StrictSig, Demand, isStrUsedDmd, splitStrictSig, prependArgsStrictSig )+import GHC.Types.Demand       ( DmdSig, Demand, isStrUsedDmd, splitDmdSig, prependArgsDmdSig ) import GHC.Types.Cpr          ( mkCprSig, botCpr ) import GHC.Types.Name         ( getOccName, mkSystemVarName ) import GHC.Types.Name.Occurrence ( occNameString ) import GHC.Types.Unique       ( hasKey ) import GHC.Types.Tickish      ( tickishIsCode )-import GHC.Core.Type    ( Type, splitTyConApp_maybe, tyCoVarsOfType-                        , mightBeUnliftedType, closeOverKindsDSet )-import GHC.Core.Multiplicity     ( pattern Many )+import GHC.Types.Unique.Supply+import GHC.Types.Unique.DFM import GHC.Types.Basic  ( Arity, RecFlag(..), isRec )-import GHC.Core.DataCon ( dataConOrigResTy )+ import GHC.Builtin.Types import GHC.Builtin.Names      ( runRWKey )-import GHC.Types.Unique.Supply++import GHC.Data.FastString++import GHC.Utils.FV+import GHC.Utils.Monad  ( mapAccumLM ) import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Data.FastString-import GHC.Types.Unique.DFM-import GHC.Utils.FV+import GHC.Utils.Panic.Plain+import GHC.Utils.Trace+ import Data.Maybe-import GHC.Utils.Monad  ( mapAccumLM )  {- ************************************************************************@@ -288,35 +291,35 @@           -> [LevelledBind]  setLevels float_lams binds us-  = initLvl us (do_them init_env binds)+  = initLvl us (do_them binds)   where-    init_env = initialEnv float_lams+    env = initialEnv float_lams binds -    do_them :: LevelEnv -> [CoreBind] -> LvlM [LevelledBind]-    do_them _ [] = return []-    do_them env (b:bs)-      = do { (lvld_bind, env') <- lvlTopBind env b-           ; lvld_binds <- do_them env' bs+    do_them :: [CoreBind] -> LvlM [LevelledBind]+    do_them [] = return []+    do_them (b:bs)+      = do { lvld_bind <- lvlTopBind env b+           ; lvld_binds <- do_them bs            ; return (lvld_bind : lvld_binds) } -lvlTopBind :: LevelEnv -> Bind Id -> LvlM (LevelledBind, LevelEnv)+lvlTopBind :: LevelEnv -> Bind Id -> LvlM LevelledBind lvlTopBind env (NonRec bndr rhs)-  = do { rhs' <- lvl_top env NonRecursive bndr rhs-       ; let (env', [bndr']) = substAndLvlBndrs NonRecursive env tOP_LEVEL [bndr]-       ; return (NonRec bndr' rhs', env') }+  = do { (bndr', rhs') <- lvl_top env NonRecursive bndr rhs+       ; return (NonRec bndr' rhs') }  lvlTopBind env (Rec pairs)-  = do { let (env', bndrs') = substAndLvlBndrs Recursive env tOP_LEVEL-                                               (map fst pairs)-       ; rhss' <- mapM (\(b,r) -> lvl_top env' Recursive b r) pairs-       ; return (Rec (bndrs' `zip` rhss'), env') }+  = do { prs' <- mapM (\(b,r) -> lvl_top env Recursive b r) pairs+       ; return (Rec prs') } -lvl_top :: LevelEnv -> RecFlag -> Id -> CoreExpr -> LvlM LevelledExpr+lvl_top :: LevelEnv -> RecFlag -> Id -> CoreExpr+        -> LvlM (LevelledBndr, LevelledExpr)+-- NB: 'env' has all the top-level binders in scope, so+--     there is no need call substAndLvlBndrs here lvl_top env is_rec bndr rhs-  = lvlRhs env is_rec-           (isDeadEndId bndr)-           Nothing  -- Not a join point-           (freeVars rhs)+  = do { rhs' <- lvlRhs env is_rec (isDeadEndId bndr)+                                   Nothing  -- Not a join point+                                   (freeVars rhs)+       ; return (stayPut tOP_LEVEL bndr, rhs') }  {- ************************************************************************@@ -446,7 +449,7 @@     arity      = idArity fn      stricts :: [Demand]   -- True for strict /value/ arguments-    stricts = case splitStrictSig (idStrictness fn) of+    stricts = case splitDmdSig (idDmdSig fn) of                 (arg_ds, _) | arg_ds `lengthExceeds` n_val_args                             -> []                             | otherwise@@ -666,9 +669,10 @@          -- Only floating to the top level is allowed.   || hasFreeJoin env fvs   -- If there is a free join, don't float                            -- See Note [Free join points]-  || isExprLevPoly expr-         -- We can't let-bind levity polymorphic expressions-         -- See Note [Levity polymorphism invariants] in GHC.Core+  || not (typeHasFixedRuntimeRep (exprType expr))+         -- We can't let-bind an expression if we don't know+         -- how it will be represented at runtime.+         -- See Note [Representation polymorphism invariants] in GHC.Core   || notWorthFloating expr abs_vars   || not float_me   =     -- Don't float it out@@ -822,7 +826,7 @@      t = f (g True)   If f is lazy, we /do/ float (g True) because then we can allocate   the thunk statically rather than dynamically.  But if f is strict-  we don't (see the use of idStrictness in lvlApp).  It's not clear+  we don't (see the use of idDmdSig in lvlApp).  It's not clear   if this test is worth the bother: it's only about CAFs!  It's controlled by a flag (floatConsts), because doing this too@@ -1024,7 +1028,7 @@  -} -annotateBotStr :: Id -> Arity -> Maybe (Arity, StrictSig) -> Id+annotateBotStr :: Id -> Arity -> Maybe (Arity, DmdSig) -> Id -- See Note [Bottoming floats] for why we want to add -- bottoming information right now --@@ -1033,8 +1037,8 @@   = case mb_str of       Nothing           -> id       Just (arity, sig) -> id `setIdArity`      (arity + n_extra)-                              `setIdStrictness` (prependArgsStrictSig n_extra sig)-                              `setIdCprInfo`    mkCprSig (arity + n_extra) botCpr+                              `setIdDmdSig` (prependArgsDmdSig n_extra sig)+                              `setIdCprSig`    mkCprSig (arity + n_extra) botCpr  notWorthFloating :: CoreExpr -> [Var] -> Bool -- Returns True if the expression would be replaced by@@ -1052,7 +1056,7 @@   = go e (count isId abs_vars)   where     go (Var {}) n    = n >= 0-    go (Lit lit) n   = ASSERT( n==0 )+    go (Lit lit) n   = assert (n==0) $                        litIsTrivial lit   -- Note [Floating literals]     go (Tick t e) n  = not (tickishIsCode t) && go e n     go (Cast e _)  n = go e n@@ -1551,9 +1555,9 @@  {- Note [le_subst and le_env] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We clone let- and case-bound variables so that they are still distinct-when floated out; hence the le_subst/le_env.  (see point 3 of the-module overview comment).  We also use these envs when making a+We clone nested let- and case-bound variables so that they are still+distinct when floated out; hence the le_subst/le_env.  (see point 3 of+the module overview comment).  We also use these envs when making a variable polymorphic because we want to float it out past a big lambda. @@ -1580,14 +1584,21 @@ The domain of the le_lvl_env is the *post-cloned* Ids -} -initialEnv :: FloatOutSwitches -> LevelEnv-initialEnv float_lams-  = LE { le_switches = float_lams-       , le_ctxt_lvl = tOP_LEVEL+initialEnv :: FloatOutSwitches -> CoreProgram -> LevelEnv+initialEnv float_lams binds+  = LE { le_switches  = float_lams+       , le_ctxt_lvl  = tOP_LEVEL        , le_join_ceil = panic "initialEnv"-       , le_lvl_env = emptyVarEnv-       , le_subst = emptySubst-       , le_env = emptyVarEnv }+       , le_lvl_env   = emptyVarEnv+       , le_subst     = mkEmptySubst in_scope_toplvl+       , le_env       = emptyVarEnv }+  where+    in_scope_toplvl = emptyInScopeSet `extendInScopeSetList` bindersOfBinds binds+      -- The Simplifier (see Note [Glomming] in GHC.Core.Opt.OccurAnal) and+      -- the specialiser (see Note [Top level scope] in GHC.Core.Opt.Specialise)+      -- may both produce top-level bindings where an early binding refers+      -- to a later one.  So here we put all the top-level binders in scope before+      -- we start, to satisfy the lookupIdSubst invariants (#20200 and #20294)  addLvl :: Level -> VarEnv Level -> OutVar -> VarEnv Level addLvl dest_lvl env v' = extendVarEnv env v' dest_lvl@@ -1690,9 +1701,9 @@          -- We are going to lambda-abstract, so nuke any IdInfo,         -- and add the tyvars of the Id (if necessary)-    zap v | isId v = WARN( isStableUnfolding (idUnfolding v) ||-                           not (isEmptyRuleInfo (idSpecialisation v)),-                           text "absVarsOf: discarding info on" <+> ppr v )+    zap v | isId v = warnPprTrace (isStableUnfolding (idUnfolding v) ||+                           not (isEmptyRuleInfo (idSpecialisation v)))+                           "absVarsOf: discarding info on" (ppr v) $                      setIdInfo v vanillaIdInfo           | otherwise = v @@ -1708,7 +1719,7 @@ newPolyBndrs dest_lvl              env@(LE { le_lvl_env = lvl_env, le_subst = subst, le_env = id_env })              abs_vars bndrs- = ASSERT( all (not . isCoVar) bndrs )   -- What would we add to the CoSubst in this case. No easy answer.+ = assert (all (not . isCoVar) bndrs) $   -- What would we add to the CoSubst in this case. No easy answer.    do { uniqs <- getUniquesM       ; let new_bndrs = zipWith mk_poly_bndr bndrs uniqs             bndr_prs  = bndrs `zip` new_bndrs@@ -1807,7 +1818,7 @@ add_id :: IdEnv ([Var], LevelledExpr) -> (Var, Var) -> IdEnv ([Var], LevelledExpr) add_id id_env (v, v1)   | isTyVar v = delVarEnv    id_env v-  | otherwise = extendVarEnv id_env v ([v1], ASSERT(not (isCoVar v1)) Var v1)+  | otherwise = extendVarEnv id_env v ([v1], assert (not (isCoVar v1)) $ Var v1)  {- Note [Zapping the demand info]
compiler/GHC/Core/Opt/Simplify.hs view
@@ -4,4202 +4,4281 @@ \section[Simplify]{The main module of the simplifier} -} -{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeFamilies #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates -Wno-incomplete-uni-patterns #-}-module GHC.Core.Opt.Simplify ( simplTopBinds, simplExpr, simplRules ) where--#include "GhclibHsVersions.h"--import GHC.Prelude--import GHC.Platform-import GHC.Driver.Session-import GHC.Driver.Ppr-import GHC.Driver.Config-import GHC.Core.Opt.Simplify.Monad-import GHC.Core.Type hiding ( substTy, substTyVar, extendTvSubst, extendCvSubst )-import GHC.Core.Opt.Simplify.Env-import GHC.Core.Opt.Simplify.Utils-import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr )-import GHC.Types.Literal   ( litIsLifted ) --, mkLitInt ) -- temporalily commented out. See #8326-import GHC.Types.SourceText-import GHC.Types.Id-import GHC.Types.Id.Make   ( seqId )-import GHC.Core.Make       ( FloatBind, mkImpossibleExpr, castBottomExpr )-import qualified GHC.Core.Make-import GHC.Types.Id.Info-import GHC.Types.Name           ( mkSystemVarName, isExternalName, getOccFS )-import GHC.Core.Coercion hiding ( substCo, substCoVar )-import GHC.Core.Coercion.Opt    ( optCoercion )-import GHC.Core.FamInstEnv      ( FamInstEnv, topNormaliseType_maybe )-import GHC.Core.DataCon-   ( DataCon, dataConWorkId, dataConRepStrictness-   , dataConRepArgTys, isUnboxedTupleDataCon-   , StrictnessMark (..) )-import GHC.Core.Opt.Monad ( Tick(..), SimplMode(..) )-import GHC.Core-import GHC.Builtin.Types.Prim( realWorldStatePrimTy )-import GHC.Builtin.Names( runRWKey )-import GHC.Types.Demand ( StrictSig(..), Demand, dmdTypeDepth, isStrUsedDmd-                        , mkClosedStrictSig, topDmd, seqDmd, isDeadEndDiv )-import GHC.Types.Cpr    ( mkCprSig, botCpr )-import GHC.Core.Ppr     ( pprCoreExpr )-import GHC.Types.Unique ( hasKey )-import GHC.Core.Unfold-import GHC.Core.Unfold.Make-import GHC.Core.Utils-import GHC.Core.Opt.Arity ( ArityType(..)-                          , pushCoTyArg, pushCoValArg-                          , idArityType, etaExpandAT )-import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe )-import GHC.Core.FVs     ( mkRuleInfo )-import GHC.Core.Rules   ( lookupRule, getRules, initRuleOpts )-import GHC.Types.Basic-import GHC.Utils.Monad  ( mapAccumLM, liftIO )-import GHC.Utils.Logger-import GHC.Types.Tickish-import GHC.Types.Var    ( isTyCoVar )-import GHC.Data.Maybe   ( isNothing, orElse )-import Control.Monad-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Data.FastString-import GHC.Utils.Misc-import GHC.Unit.Module ( moduleName, pprModuleName )-import GHC.Core.Multiplicity-import GHC.Builtin.PrimOps ( PrimOp (SeqOp) )---{--The guts of the simplifier is in this module, but the driver loop for-the simplifier is in GHC.Core.Opt.Pipeline--Note [The big picture]-~~~~~~~~~~~~~~~~~~~~~~-The general shape of the simplifier is this:--  simplExpr :: SimplEnv -> InExpr -> SimplCont -> SimplM (SimplFloats, OutExpr)-  simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv)-- * SimplEnv contains-     - Simplifier mode (which includes DynFlags for convenience)-     - Ambient substitution-     - InScopeSet-- * SimplFloats contains-     - Let-floats (which includes ok-for-spec case-floats)-     - Join floats-     - InScopeSet (including all the floats)-- * Expressions-      simplExpr :: SimplEnv -> InExpr -> SimplCont-                -> SimplM (SimplFloats, OutExpr)-   The result of simplifying an /expression/ is (floats, expr)-      - A bunch of floats (let bindings, join bindings)-      - A simplified expression.-   The overall result is effectively (let floats in expr)-- * Bindings-      simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv)-   The result of simplifying a binding is-     - A bunch of floats, the last of which is the simplified binding-       There may be auxiliary bindings too; see prepareRhs-     - An environment suitable for simplifying the scope of the binding--   The floats may also be empty, if the binding is inlined unconditionally;-   in that case the returned SimplEnv will have an augmented substitution.--   The returned floats and env both have an in-scope set, and they are-   guaranteed to be the same.---Note [Shadowing]-~~~~~~~~~~~~~~~~-The simplifier used to guarantee that the output had no shadowing, but-it does not do so any more.   (Actually, it never did!)  The reason is-documented with simplifyArgs.---Eta expansion-~~~~~~~~~~~~~~-For eta expansion, we want to catch things like--        case e of (a,b) -> \x -> case a of (p,q) -> \y -> r--If the \x was on the RHS of a let, we'd eta expand to bring the two-lambdas together.  And in general that's a good thing to do.  Perhaps-we should eta expand wherever we find a (value) lambda?  Then the eta-expansion at a let RHS can concentrate solely on the PAP case.--Note [In-scope set as a substitution]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-As per Note [Lookups in in-scope set], an in-scope set can act as-a substitution. Specifically, it acts as a substitution from variable to-variables /with the same unique/.--Why do we need this? Well, during the course of the simplifier, we may want to-adjust inessential properties of a variable. For instance, when performing a-beta-reduction, we change--    (\x. e) u ==> let x = u in e--We typically want to add an unfolding to `x` so that it inlines to (the-simplification of) `u`.--We do that by adding the unfolding to the binder `x`, which is added to the-in-scope set. When simplifying occurrences of `x` (every occurrence!), they are-replaced by their “updated” version from the in-scope set, hence inherit the-unfolding. This happens in `SimplEnv.substId`.--Another example. Consider--   case x of y { Node a b -> ...y...-               ; Leaf v   -> ...y... }--In the Node branch want y's unfolding to be (Node a b); in the Leaf branch we-want y's unfolding to be (Leaf v). We achieve this by adding the appropriate-unfolding to y, and re-adding it to the in-scope set. See the calls to-`addBinderUnfolding` in `Simplify.addAltUnfoldings` and elsewhere.--It's quite convenient. This way we don't need to manipulate the substitution all-the time: every update to a binder is automatically reflected to its bound-occurrences.--Note [Bangs in the Simplifier]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Both SimplFloats and SimplEnv do *not* generally benefit from making-their fields strict. I don't know if this is because of good use of-laziness or unintended side effects like closures capturing more variables-after WW has run.--But the end result is that we keep these lazy, but force them in some places-where we know it's beneficial to the compiler.--Similarly environments returned from functions aren't *always* beneficial to-force. In some places they would never be demanded so forcing them early-increases allocation. In other places they almost always get demanded so-it's worthwhile to force them early.--Would it be better to through every allocation of e.g. SimplEnv and decide-wether or not to make this one strict? Absolutely! Would be a good use of-someones time? Absolutely not! I made these strict that showed up during-a profiled build or which I noticed while looking at core for one reason-or another.--The result sadly is that we end up with "random" bangs in the simplifier-where we sometimes force e.g. the returned environment from a function and-sometimes we don't for the same function. Depending on the context around-the call. The treatment is also not very consistent. I only added bangs-where I saw it making a difference either in the core or benchmarks. Some-patterns where it would be beneficial aren't convered as a consequence as-I neither have the time to go through all of the core and some cases are-too small to show up in benchmarks.----************************************************************************-*                                                                      *-\subsection{Bindings}-*                                                                      *-************************************************************************--}--simplTopBinds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv)--- See Note [The big picture]-simplTopBinds env0 binds0-  = do  {       -- Put all the top-level binders into scope at the start-                -- so that if a rewrite rule has unexpectedly brought-                -- anything into scope, then we don't get a complaint about that.-                -- It's rather as if the top-level binders were imported.-                -- See note [Glomming] in "GHC.Core.Opt.OccurAnal".-        -- See Note [Bangs in the Simplifier]-        ; !env1 <- {-#SCC "simplTopBinds-simplRecBndrs" #-} simplRecBndrs env0 (bindersOfBinds binds0)-        ; (floats, env2) <- {-#SCC "simplTopBinds-simpl_binds" #-} simpl_binds env1 binds0-        ; freeTick SimplifierDone-        ; return (floats, env2) }-  where-        -- We need to track the zapped top-level binders, because-        -- they should have their fragile IdInfo zapped (notably occurrence info)-        -- That's why we run down binds and bndrs' simultaneously.-        ---    simpl_binds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv)-    simpl_binds env []           = return (emptyFloats env, env)-    simpl_binds env (bind:binds) = do { (float,  env1) <- simpl_bind env bind-                                      ; (floats, env2) <- simpl_binds env1 binds-                                      -- See Note [Bangs in the Simplifier]-                                      ; let !floats1 = float `addFloats` floats-                                      ; return (floats1, env2) }--    simpl_bind env (Rec pairs)-      = simplRecBind env TopLevel Nothing pairs-    simpl_bind env (NonRec b r)-      = do { (env', b') <- addBndrRules env b (lookupRecBndr env b) Nothing-           ; simplRecOrTopPair env' TopLevel NonRecursive Nothing b b' r }--{--************************************************************************-*                                                                      *-        Lazy bindings-*                                                                      *-************************************************************************--simplRecBind is used for-        * recursive bindings only--}--simplRecBind :: SimplEnv -> TopLevelFlag -> MaybeJoinCont-             -> [(InId, InExpr)]-             -> SimplM (SimplFloats, SimplEnv)-simplRecBind env0 top_lvl mb_cont pairs0-  = do  { (env_with_info, triples) <- mapAccumLM add_rules env0 pairs0-        ; (rec_floats, env1) <- go env_with_info triples-        ; return (mkRecFloats rec_floats, env1) }-  where-    add_rules :: SimplEnv -> (InBndr,InExpr) -> SimplM (SimplEnv, (InBndr, OutBndr, InExpr))-        -- Add the (substituted) rules to the binder-    add_rules env (bndr, rhs)-        = do { (env', bndr') <- addBndrRules env bndr (lookupRecBndr env bndr) mb_cont-             ; return (env', (bndr, bndr', rhs)) }--    go env [] = return (emptyFloats env, env)--    go env ((old_bndr, new_bndr, rhs) : pairs)-        = do { (float, env1) <- simplRecOrTopPair env top_lvl Recursive mb_cont-                                                  old_bndr new_bndr rhs-             ; (floats, env2) <- go env1 pairs-             ; return (float `addFloats` floats, env2) }--{--simplOrTopPair is used for-        * recursive bindings (whether top level or not)-        * top-level non-recursive bindings--It assumes the binder has already been simplified, but not its IdInfo.--}--simplRecOrTopPair :: SimplEnv-                  -> TopLevelFlag -> RecFlag -> MaybeJoinCont-                  -> InId -> OutBndr -> InExpr  -- Binder and rhs-                  -> SimplM (SimplFloats, SimplEnv)--simplRecOrTopPair env top_lvl is_rec mb_cont old_bndr new_bndr rhs-  | Just env' <- preInlineUnconditionally env top_lvl old_bndr rhs env-  = {-#SCC "simplRecOrTopPair-pre-inline-uncond" #-}-    trace_bind "pre-inline-uncond" $-    do { tick (PreInlineUnconditionally old_bndr)-       ; return ( emptyFloats env, env' ) }--  | Just cont <- mb_cont-  = {-#SCC "simplRecOrTopPair-join" #-}-    ASSERT( isNotTopLevel top_lvl && isJoinId new_bndr )-    trace_bind "join" $-    simplJoinBind env cont old_bndr new_bndr rhs env--  | otherwise-  = {-#SCC "simplRecOrTopPair-normal" #-}-    trace_bind "normal" $-    simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env--  where-    dflags = seDynFlags env-    logger = seLogger env--    -- trace_bind emits a trace for each top-level binding, which-    -- helps to locate the tracing for inlining and rule firing-    trace_bind what thing_inside-      | not (dopt Opt_D_verbose_core2core dflags)-      = thing_inside-      | otherwise-      = putTraceMsg logger dflags ("SimplBind " ++ what)-         (ppr old_bndr) thing_inside-----------------------------simplLazyBind :: SimplEnv-              -> TopLevelFlag -> RecFlag-              -> InId -> OutId          -- Binder, both pre-and post simpl-                                        -- Not a JoinId-                                        -- The OutId has IdInfo, except arity, unfolding-                                        -- Ids only, no TyVars-              -> InExpr -> SimplEnv     -- The RHS and its environment-              -> SimplM (SimplFloats, SimplEnv)--- Precondition: not a JoinId--- Precondition: rhs obeys the let/app invariant--- NOT used for JoinIds-simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se-  = ASSERT( isId bndr )-    ASSERT2( not (isJoinId bndr), ppr bndr )-    -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $-    do  { let   !rhs_env     = rhs_se `setInScopeFromE` env -- See Note [Bangs in the Simplifier]-                (tvs, body) = case collectTyAndValBinders rhs of-                                (tvs, [], body)-                                  | surely_not_lam body -> (tvs, body)-                                _                       -> ([], rhs)--                surely_not_lam (Lam {})     = False-                surely_not_lam (Tick t e)-                  | not (tickishFloatable t) = surely_not_lam e-                   -- eta-reduction could float-                surely_not_lam _            = True-                        -- Do not do the "abstract tyvar" thing if there's-                        -- a lambda inside, because it defeats eta-reduction-                        --    f = /\a. \x. g a x-                        -- should eta-reduce.---        ; (body_env, tvs') <- {-#SCC "simplBinders" #-} simplBinders rhs_env tvs-                -- See Note [Floating and type abstraction] in GHC.Core.Opt.Simplify.Utils--        -- Simplify the RHS-        ; let rhs_cont = mkRhsStop (substTy body_env (exprType body))-        ; (body_floats0, body0) <- {-#SCC "simplExprF" #-} simplExprF body_env body rhs_cont--              -- Never float join-floats out of a non-join let-binding (which this is)-              -- So wrap the body in the join-floats right now-              -- Hence: body_floats1 consists only of let-floats-        ; let (body_floats1, body1) = wrapJoinFloatsX body_floats0 body0--        -- ANF-ise a constructor or PAP rhs-        -- We get at most one float per argument here-        ; let body_env1 = body_env `setInScopeFromF` body_floats1-              -- body_env1: add to in-scope set the binders from body_floats1-              -- so that prepareBinding knows what is in scope in body1-        ; (let_floats, bndr2, body2) <- {-#SCC "prepareBinding" #-}-                                        prepareBinding body_env1 top_lvl bndr bndr1 body1-        ; let body_floats2 = body_floats1 `addLetFloats` let_floats--        ; (rhs_floats, body3)-            <-  if not (doFloatFromRhs top_lvl is_rec False body_floats2 body2)-                then                    -- No floating, revert to body1-                     return (emptyFloats env, wrapFloats body_floats2 body1)--                else if null tvs then   -- Simple floating-                     {-#SCC "simplLazyBind-simple-floating" #-}-                     do { tick LetFloatFromLet-                        ; return (body_floats2, body2) }--                else                    -- Do type-abstraction first-                     {-#SCC "simplLazyBind-type-abstraction-first" #-}-                     do { tick LetFloatFromLet-                        ; (poly_binds, body3) <- abstractFloats (seUnfoldingOpts env) top_lvl-                                                                tvs' body_floats2 body2-                        ; let floats = foldl' extendFloats (emptyFloats env) poly_binds-                        ; return (floats, body3) }--        ; let env' = env `setInScopeFromF` rhs_floats-        ; rhs' <- mkLam env' tvs' body3 rhs_cont-        ; (bind_float, env2) <- completeBind env' top_lvl Nothing bndr bndr2 rhs'-        ; return (rhs_floats `addFloats` bind_float, env2) }-----------------------------simplJoinBind :: SimplEnv-              -> SimplCont-              -> InId -> OutId          -- Binder, both pre-and post simpl-                                        -- The OutId has IdInfo, except arity,-                                        --   unfolding-              -> InExpr -> SimplEnv     -- The right hand side and its env-              -> SimplM (SimplFloats, SimplEnv)-simplJoinBind env cont old_bndr new_bndr rhs rhs_se-  = do  { let rhs_env = rhs_se `setInScopeFromE` env-        ; rhs' <- simplJoinRhs rhs_env old_bndr rhs cont-        ; completeBind env NotTopLevel (Just cont) old_bndr new_bndr rhs' }-----------------------------simplNonRecX :: SimplEnv-             -> InId            -- Old binder; not a JoinId-             -> OutExpr         -- Simplified RHS-             -> SimplM (SimplFloats, SimplEnv)--- A specialised variant of simplNonRec used when the RHS is already--- simplified, notably in knownCon.  It uses case-binding where necessary.------ Precondition: rhs satisfies the let/app invariant--simplNonRecX env bndr new_rhs-  | ASSERT2( not (isJoinId bndr), ppr bndr )-    isDeadBinder bndr   -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p }-  = return (emptyFloats env, env)    --  Here c is dead, and we avoid-                                         --  creating the binding c = (a,b)--  | Coercion co <- new_rhs-  = return (emptyFloats env, extendCvSubst env bndr co)--  | otherwise-  = do  { (env', bndr') <- simplBinder env bndr-        ; completeNonRecX NotTopLevel env' (isStrictId bndr') bndr bndr' new_rhs }-          -- NotTopLevel: simplNonRecX is only used for NotTopLevel things-          ---          -- isStrictId: use bndr' because in a levity-polymorphic setting-          -- the InId bndr might have a levity-polymorphic type, which-          -- which isStrictId doesn't expect-          -- c.f. Note [Dark corner with levity polymorphism]-----------------------------completeNonRecX :: TopLevelFlag -> SimplEnv-                -> Bool-                -> InId                 -- Old binder; not a JoinId-                -> OutId                -- New binder-                -> OutExpr              -- Simplified RHS-                -> SimplM (SimplFloats, SimplEnv)    -- The new binding is in the floats--- Precondition: rhs satisfies the let/app invariant---               See Note [Core let/app invariant] in GHC.Core--completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs-  = ASSERT2( not (isJoinId new_bndr), ppr new_bndr )-    do  { (prepd_floats, new_bndr, new_rhs)-              <- prepareBinding env top_lvl old_bndr new_bndr new_rhs-        ; let floats = emptyFloats env `addLetFloats` prepd_floats-        ; (rhs_floats, rhs2) <--                if doFloatFromRhs NotTopLevel NonRecursive is_strict floats new_rhs-                then    -- Add the floats to the main env-                     do { tick LetFloatFromLet-                        ; return (floats, new_rhs) }-                else    -- Do not float; wrap the floats around the RHS-                     return (emptyFloats env, wrapFloats floats new_rhs)--        ; (bind_float, env2) <- completeBind (env `setInScopeFromF` rhs_floats)-                                             NotTopLevel Nothing-                                             old_bndr new_bndr rhs2-        ; return (rhs_floats `addFloats` bind_float, env2) }---{- *********************************************************************-*                                                                      *-           prepareBinding, prepareRhs, makeTrivial-*                                                                      *-************************************************************************--Note [Cast worker/wrappers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we have a binding-   x = e |> co-we want to do something very similar to worker/wrapper:-   $wx = e-   x = $wx |> co--So now x can be inlined freely.  There's a chance that e will be a-constructor application or function, or something like that, so moving-the coercion to the usage site may well cancel the coercions and lead-to further optimisation.  Example:--     data family T a :: *-     data instance T Int = T Int--     foo :: Int -> Int -> Int-     foo m n = ...-        where-          t = T m-          go 0 = 0-          go n = case t of { T m -> go (n-m) }-                -- This case should optimise--We call this making a cast worker/wrapper, and it's done by prepareBinding.--We need to be careful with inline/noinline pragmas:-  rec { {-# NOINLINE f #-}-        f = (...g...) |> co-      ; g = ...f... }-This is legitimate -- it tells GHC to use f as the loop breaker-rather than g.  Now we do the cast thing, to get something like-  rec { $wf = ...g...-      ; f = $wf |> co-      ; g = ...f... }-Where should the NOINLINE pragma go?  If we leave it on f we'll get-  rec { $wf = ...g...-      ; {-# NOINLINE f #-}-        f = $wf |> co-      ; g = ...f... }-and that is bad: the whole point is that we want to inline that-cast!  We want to transfer the pagma to $wf:-  rec { {-# NOINLINE $wf #-}-        $wf = ...g...-      ; f = $wf |> co-      ; g = ...f... }-It's exactly like worker/wrapper for strictness analysis:-  f is the wrapper and must inline like crazy-  $wf is the worker and must carry f's original pragma-See Note [Worker-wrapper for NOINLINE functions] in-GHC.Core.Opt.WorkWrap.--See #17673, #18093, #18078.--Note [Preserve strictness in cast w/w]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In the Note [Cast worker/wrappers] transformation, keep the strictness info.-Eg-        f = e `cast` co    -- f has strictness SSL-When we transform to-        f' = e             -- f' also has strictness SSL-        f = f' `cast` co   -- f still has strictness SSL--Its not wrong to drop it on the floor, but better to keep it.--Note [Cast w/w: unlifted]-~~~~~~~~~~~~~~~~~~~~~~~~~-BUT don't do cast worker/wrapper if 'e' has an unlifted type.-This *can* happen:--     foo :: Int = (error (# Int,Int #) "urk")-                  `cast` CoUnsafe (# Int,Int #) Int--If do the makeTrivial thing to the error call, we'll get-    foo = case error (# Int,Int #) "urk" of v -> v `cast` ...-But 'v' isn't in scope!--These strange casts can happen as a result of case-of-case-        bar = case (case x of { T -> (# 2,3 #); F -> error "urk" }) of-                (# p,q #) -> p+q--NOTE: Nowadays we don't use casts for these error functions;-instead, we use (case erorr ... of {}). So I'm not sure-this Note makes much sense any more.--}--prepareBinding :: SimplEnv -> TopLevelFlag-               -> InId -> OutId -> OutExpr-               -> SimplM (LetFloats, OutId, OutExpr)--prepareBinding env top_lvl old_bndr bndr rhs-  | Cast rhs1 co <- rhs-    -- Try for cast worker/wrapper-    -- See Note [Cast worker/wrappers]-  , not (isStableUnfolding (realIdUnfolding old_bndr))-        -- Don't make a cast w/w if the thing is going to be inlined anyway-  , not (exprIsTrivial rhs1)-        -- Nor if the RHS is trivial; then again it'll be inlined-  , let ty1 = coercionLKind co-  , not (isUnliftedType ty1)-        -- Not if rhs has an unlifted type; see Note [Cast w/w: unlifted]-  = do { (floats, new_id) <- makeTrivialBinding (getMode env) top_lvl-                                   (getOccFS bndr) worker_info rhs1 ty1-       ; let bndr' = bndr `setInlinePragma` mkCastWrapperInlinePrag (idInlinePragma bndr)-       ; return (floats, bndr', Cast (Var new_id) co) }--  | otherwise-  = do { (floats, rhs') <- prepareRhs (getMode env) top_lvl (getOccFS bndr) rhs-       ; return (floats, bndr, rhs') }- where-   info = idInfo bndr-   worker_info = vanillaIdInfo `setStrictnessInfo` strictnessInfo info-                               `setCprInfo`        cprInfo info-                               `setDemandInfo`     demandInfo info-                               `setInlinePragInfo` inlinePragInfo info-                               `setArityInfo`      arityInfo info-          -- We do /not/ want to transfer OccInfo, Rules, Unfolding-          -- Note [Preserve strictness in cast w/w]--mkCastWrapperInlinePrag :: InlinePragma -> InlinePragma--- See Note [Cast wrappers]-mkCastWrapperInlinePrag (InlinePragma { inl_act = act, inl_rule = rule_info })-  = InlinePragma { inl_src    = SourceText "{-# INLINE"-                 , inl_inline = NoUserInlinePrag -- See Note [Wrapper NoUserInline]-                 , inl_sat    = Nothing      --     in GHC.Core.Opt.WorkWrap-                 , inl_act    = wrap_act     -- See Note [Wrapper activation]-                 , inl_rule   = rule_info }  --     in GHC.Core.Opt.WorkWrap-                                -- RuleMatchInfo is (and must be) unaffected-  where-    -- See Note [Wrapper activation] in GHC.Core.Opt.WorkWrap-    -- But simpler, because we don't need to disable during InitialPhase-    wrap_act | isNeverActive act = activateDuringFinal-             | otherwise         = act--{- Note [prepareRhs]-~~~~~~~~~~~~~~~~~~~~-prepareRhs takes a putative RHS, checks whether it's a PAP or-constructor application and, if so, converts it to ANF, so that the-resulting thing can be inlined more easily.  Thus-        x = (f a, g b)-becomes-        t1 = f a-        t2 = g b-        x = (t1,t2)--We also want to deal well cases like this-        v = (f e1 `cast` co) e2-Here we want to make e1,e2 trivial and get-        x1 = e1; x2 = e2; v = (f x1 `cast` co) v2-That's what the 'go' loop in prepareRhs does--}--prepareRhs :: SimplMode -> TopLevelFlag-           -> FastString    -- Base for any new variables-           -> OutExpr-           -> SimplM (LetFloats, OutExpr)--- Transforms a RHS into a better RHS by ANF'ing args--- for expandable RHSs: constructors and PAPs--- e.g        x = Just e--- becomes    a = e               -- 'a' is fresh---            x = Just a--- See Note [prepareRhs]-prepareRhs mode top_lvl occ rhs0-  = do  { (_is_exp, floats, rhs1) <- go 0 rhs0-        ; return (floats, rhs1) }-  where-    go :: Int -> OutExpr -> SimplM (Bool, LetFloats, OutExpr)-    go n_val_args (Cast rhs co)-        = do { (is_exp, floats, rhs') <- go n_val_args rhs-             ; return (is_exp, floats, Cast rhs' co) }-    go n_val_args (App fun (Type ty))-        = do { (is_exp, floats, rhs') <- go n_val_args fun-             ; return (is_exp, floats, App rhs' (Type ty)) }-    go n_val_args (App fun arg)-        = do { (is_exp, floats1, fun') <- go (n_val_args+1) fun-             ; case is_exp of-                False -> return (False, emptyLetFloats, App fun arg)-                True  -> do { (floats2, arg') <- makeTrivial mode top_lvl topDmd occ arg-                            ; return (True, floats1 `addLetFlts` floats2, App fun' arg') } }-    go n_val_args (Var fun)-        = return (is_exp, emptyLetFloats, Var fun)-        where-          is_exp = isExpandableApp fun n_val_args   -- The fun a constructor or PAP-                        -- See Note [CONLIKE pragma] in GHC.Types.Basic-                        -- The definition of is_exp should match that in-                        -- 'GHC.Core.Opt.OccurAnal.occAnalApp'--    go n_val_args (Tick t rhs)-        -- We want to be able to float bindings past this-        -- tick. Non-scoping ticks don't care.-        | tickishScoped t == NoScope-        = do { (is_exp, floats, rhs') <- go n_val_args rhs-             ; return (is_exp, floats, Tick t rhs') }--        -- On the other hand, for scoping ticks we need to be able to-        -- copy them on the floats, which in turn is only allowed if-        -- we can obtain non-counting ticks.-        | (not (tickishCounts t) || tickishCanSplit t)-        = do { (is_exp, floats, rhs') <- go n_val_args rhs-             ; let tickIt (id, expr) = (id, mkTick (mkNoCount t) expr)-                   floats' = mapLetFloats floats tickIt-             ; return (is_exp, floats', Tick t rhs') }--    go _ other-        = return (False, emptyLetFloats, other)--makeTrivialArg :: SimplMode -> ArgSpec -> SimplM (LetFloats, ArgSpec)-makeTrivialArg mode arg@(ValArg { as_arg = e, as_dmd = dmd })-  = do { (floats, e') <- makeTrivial mode NotTopLevel dmd (fsLit "arg") e-       ; return (floats, arg { as_arg = e' }) }-makeTrivialArg _ arg-  = return (emptyLetFloats, arg)  -- CastBy, TyArg--makeTrivial :: SimplMode -> TopLevelFlag -> Demand-            -> FastString  -- ^ A "friendly name" to build the new binder from-            -> OutExpr     -- ^ This expression satisfies the let/app invariant-            -> SimplM (LetFloats, OutExpr)--- Binds the expression to a variable, if it's not trivial, returning the variable--- For the Demand argument, see Note [Keeping demand info in StrictArg Plan A]-makeTrivial mode top_lvl dmd occ_fs expr-  | exprIsTrivial expr                          -- Already trivial-  || not (bindingOk top_lvl expr expr_ty)       -- Cannot trivialise-                                                --   See Note [Cannot trivialise]-  = return (emptyLetFloats, expr)--  | Cast expr' co <- expr-  = do { (floats, triv_expr) <- makeTrivial mode top_lvl dmd occ_fs expr'-       ; return (floats, Cast triv_expr co) }--  | otherwise-  = do { (floats, new_id) <- makeTrivialBinding mode top_lvl occ_fs-                                                id_info expr expr_ty-       ; return (floats, Var new_id) }-  where-    id_info = vanillaIdInfo `setDemandInfo` dmd-    expr_ty = exprType expr--makeTrivialBinding :: SimplMode -> TopLevelFlag-                   -> FastString  -- ^ a "friendly name" to build the new binder from-                   -> IdInfo-                   -> OutExpr     -- ^ This expression satisfies the let/app invariant-                   -> OutType     -- Type of the expression-                   -> SimplM (LetFloats, OutId)-makeTrivialBinding mode top_lvl occ_fs info expr expr_ty-  = do  { (floats, expr1) <- prepareRhs mode top_lvl occ_fs expr-        ; uniq <- getUniqueM-        ; let name = mkSystemVarName uniq occ_fs-              var  = mkLocalIdWithInfo name Many expr_ty info--        -- Now something very like completeBind,-        -- but without the postInlineUnconditionally part-        ; (arity_type, expr2) <- tryEtaExpandRhs mode var expr1-          -- Technically we should extend the in-scope set in 'env' with-          -- the 'floats' from prepareRHS; but they are all fresh, so there is-          -- no danger of introducing name shadowig in eta expansion--        ; unf <- mkLetUnfolding (sm_uf_opts mode) top_lvl InlineRhs var expr2--        ; let final_id = addLetBndrInfo var arity_type unf-              bind     = NonRec final_id expr2--        ; return ( floats `addLetFlts` unitLetFloat bind, final_id ) }--bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool--- True iff we can have a binding of this expression at this level--- Precondition: the type is the type of the expression-bindingOk top_lvl expr expr_ty-  | isTopLevel top_lvl = exprIsTopLevelBindable expr expr_ty-  | otherwise          = True--{- Note [Cannot trivialise]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider:-   f :: Int -> Addr#--   foo :: Bar-   foo = Bar (f 3)--Then we can't ANF-ise foo, even though we'd like to, because-we can't make a top-level binding for the Addr# (f 3). And if-so we don't want to turn it into-   foo = let x = f 3 in Bar x-because we'll just end up inlining x back, and that makes the-simplifier loop.  Better not to ANF-ise it at all.--Literal strings are an exception.--   foo = Ptr "blob"#--We want to turn this into:--   foo1 = "blob"#-   foo = Ptr foo1--See Note [Core top-level string literals] in GHC.Core.--************************************************************************-*                                                                      *-          Completing a lazy binding-*                                                                      *-************************************************************************--completeBind-  * deals only with Ids, not TyVars-  * takes an already-simplified binder and RHS-  * is used for both recursive and non-recursive bindings-  * is used for both top-level and non-top-level bindings--It does the following:-  - tries discarding a dead binding-  - tries PostInlineUnconditionally-  - add unfolding [this is the only place we add an unfolding]-  - add arity--It does *not* attempt to do let-to-case.  Why?  Because it is used for-  - top-level bindings (when let-to-case is impossible)-  - many situations where the "rhs" is known to be a WHNF-                (so let-to-case is inappropriate).--Nor does it do the atomic-argument thing--}--completeBind :: SimplEnv-             -> TopLevelFlag            -- Flag stuck into unfolding-             -> MaybeJoinCont           -- Required only for join point-             -> InId                    -- Old binder-             -> OutId -> OutExpr        -- New binder and RHS-             -> SimplM (SimplFloats, SimplEnv)--- completeBind may choose to do its work---      * by extending the substitution (e.g. let x = y in ...)---      * or by adding to the floats in the envt------ Binder /can/ be a JoinId--- Precondition: rhs obeys the let/app invariant-completeBind env top_lvl mb_cont old_bndr new_bndr new_rhs- | isCoVar old_bndr- = case new_rhs of-     Coercion co -> return (emptyFloats env, extendCvSubst env old_bndr co)-     _           -> return (mkFloatBind env (NonRec new_bndr new_rhs))-- | otherwise- = ASSERT( isId new_bndr )-   do { let old_info = idInfo old_bndr-            old_unf  = unfoldingInfo old_info-            occ_info = occInfo old_info--         -- Do eta-expansion on the RHS of the binding-         -- See Note [Eta-expanding at let bindings] in GHC.Core.Opt.Simplify.Utils-      ; (new_arity, final_rhs) <- tryEtaExpandRhs (getMode env) new_bndr new_rhs--        -- Simplify the unfolding-      ; new_unfolding <- simplLetUnfolding env top_lvl mb_cont old_bndr-                          final_rhs (idType new_bndr) new_arity old_unf--      ; let final_bndr = addLetBndrInfo new_bndr new_arity new_unfolding-        -- See Note [In-scope set as a substitution]--      ; if postInlineUnconditionally env top_lvl final_bndr occ_info final_rhs--        then -- Inline and discard the binding-             do  { tick (PostInlineUnconditionally old_bndr)-                 ; return ( emptyFloats env-                          , extendIdSubst env old_bndr $-                            DoneEx final_rhs (isJoinId_maybe new_bndr)) }-                -- Use the substitution to make quite, quite sure that the-                -- substitution will happen, since we are going to discard the binding--        else -- Keep the binding-             -- pprTrace "Binding" (ppr final_bndr <+> ppr new_unfolding) $-             return (mkFloatBind env (NonRec final_bndr final_rhs)) }--addLetBndrInfo :: OutId -> ArityType -> Unfolding -> OutId-addLetBndrInfo new_bndr new_arity_type new_unf-  = new_bndr `setIdInfo` info5-  where-    AT oss div = new_arity_type-    new_arity  = length oss--    info1 = idInfo new_bndr `setArityInfo` new_arity--    -- Unfolding info: Note [Setting the new unfolding]-    info2 = info1 `setUnfoldingInfo` new_unf--    -- Demand info: Note [Setting the demand info]-    -- We also have to nuke demand info if for some reason-    -- eta-expansion *reduces* the arity of the binding to less-    -- than that of the strictness sig. This can happen: see Note [Arity decrease].-    info3 | isEvaldUnfolding new_unf-            || (case strictnessInfo info2 of-                  StrictSig dmd_ty -> new_arity < dmdTypeDepth dmd_ty)-          = zapDemandInfo info2 `orElse` info2-          | otherwise-          = info2--    -- Bottoming bindings: see Note [Bottoming bindings]-    info4 | isDeadEndDiv div = info3 `setStrictnessInfo` bot_sig-                                     `setCprInfo`        bot_cpr-          | otherwise        = info3--    bot_sig = mkClosedStrictSig (replicate new_arity topDmd) div-    bot_cpr = mkCprSig new_arity botCpr--     -- Zap call arity info. We have used it by now (via-     -- `tryEtaExpandRhs`), and the simplifier can invalidate this-     -- information, leading to broken code later (e.g. #13479)-    info5 = zapCallArityInfo info4---{- Note [Arity decrease]-~~~~~~~~~~~~~~~~~~~~~~~~-Generally speaking the arity of a binding should not decrease.  But it *can*-legitimately happen because of RULES.  Eg-        f = g @Int-where g has arity 2, will have arity 2.  But if there's a rewrite rule-        g @Int --> h-where h has arity 1, then f's arity will decrease.  Here's a real-life example,-which is in the output of Specialise:--     Rec {-        $dm {Arity 2} = \d.\x. op d-        {-# RULES forall d. $dm Int d = $s$dm #-}--        dInt = MkD .... opInt ...-        opInt {Arity 1} = $dm dInt--        $s$dm {Arity 0} = \x. op dInt }--Here opInt has arity 1; but when we apply the rule its arity drops to 0.-That's why Specialise goes to a little trouble to pin the right arity-on specialised functions too.--Note [Bottoming bindings]-~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have-   let x = error "urk"-   in ...(case x of <alts>)...-or-   let f = \x. error (x ++ "urk")-   in ...(case f "foo" of <alts>)...--Then we'd like to drop the dead <alts> immediately.  So it's good to-propagate the info that x's RHS is bottom to x's IdInfo as rapidly as-possible.--We use tryEtaExpandRhs on every binding, and it turns out that the-arity computation it performs (via GHC.Core.Opt.Arity.findRhsArity) already-does a simple bottoming-expression analysis.  So all we need to do-is propagate that info to the binder's IdInfo.--This showed up in #12150; see comment:16.--Note [Setting the demand info]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If the unfolding is a value, the demand info may-go pear-shaped, so we nuke it.  Example:-     let x = (a,b) in-     case x of (p,q) -> h p q x-Here x is certainly demanded. But after we've nuked-the case, we'll get just-     let x = (a,b) in h a b x-and now x is not demanded (I'm assuming h is lazy)-This really happens.  Similarly-     let f = \x -> e in ...f..f...-After inlining f at some of its call sites the original binding may-(for example) be no longer strictly demanded.-The solution here is a bit ad hoc...---************************************************************************-*                                                                      *-\subsection[Simplify-simplExpr]{The main function: simplExpr}-*                                                                      *-************************************************************************--The reason for this OutExprStuff stuff is that we want to float *after*-simplifying a RHS, not before.  If we do so naively we get quadratic-behaviour as things float out.--To see why it's important to do it after, consider this (real) example:--        let t = f x-        in fst t-==>-        let t = let a = e1-                    b = e2-                in (a,b)-        in fst t-==>-        let a = e1-            b = e2-            t = (a,b)-        in-        a       -- Can't inline a this round, cos it appears twice-==>-        e1--Each of the ==> steps is a round of simplification.  We'd save a-whole round if we float first.  This can cascade.  Consider--        let f = g d-        in \x -> ...f...-==>-        let f = let d1 = ..d.. in \y -> e-        in \x -> ...f...-==>-        let d1 = ..d..-        in \x -> ...(\y ->e)...--Only in this second round can the \y be applied, and it-might do the same again.--}--simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr-simplExpr !env (Type ty) -- See Note [Bangs in the Simplifier]-  = do { ty' <- simplType env ty  -- See Note [Avoiding space leaks in OutType]-       ; return (Type ty') }--simplExpr env expr-  = simplExprC env expr (mkBoringStop expr_out_ty)-  where-    expr_out_ty :: OutType-    expr_out_ty = substTy env (exprType expr)-    -- NB: Since 'expr' is term-valued, not (Type ty), this call-    --     to exprType will succeed.  exprType fails on (Type ty).--simplExprC :: SimplEnv-           -> InExpr     -- A term-valued expression, never (Type ty)-           -> SimplCont-           -> SimplM OutExpr-        -- Simplify an expression, given a continuation-simplExprC env expr cont-  = -- pprTrace "simplExprC" (ppr expr $$ ppr cont {- $$ ppr (seIdSubst env) -} $$ ppr (seLetFloats env) ) $-    do  { (floats, expr') <- simplExprF env expr cont-        ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $-          -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $-          -- pprTrace "simplExprC ret4" (ppr (seLetFloats env')) $-          return $! wrapFloats floats expr' }-----------------------------------------------------simplExprF :: SimplEnv-           -> InExpr     -- A term-valued expression, never (Type ty)-           -> SimplCont-           -> SimplM (SimplFloats, OutExpr)--simplExprF !env e !cont -- See Note [Bangs in the Simplifier]-  = {- pprTrace "simplExprF" (vcat-      [ ppr e-      , text "cont =" <+> ppr cont-      , text "inscope =" <+> ppr (seInScope env)-      , text "tvsubst =" <+> ppr (seTvSubst env)-      , text "idsubst =" <+> ppr (seIdSubst env)-      , text "cvsubst =" <+> ppr (seCvSubst env)-      ]) $ -}-    simplExprF1 env e cont--simplExprF1 :: SimplEnv -> InExpr -> SimplCont-            -> SimplM (SimplFloats, OutExpr)--simplExprF1 _ (Type ty) cont-  = pprPanic "simplExprF: type" (ppr ty <+> text"cont: " <+> ppr cont)-    -- simplExprF does only with term-valued expressions-    -- The (Type ty) case is handled separately by simplExpr-    -- and by the other callers of simplExprF--simplExprF1 env (Var v)        cont = {-#SCC "simplIdF" #-} simplIdF env v cont-simplExprF1 env (Lit lit)      cont = {-#SCC "rebuild" #-} rebuild env (Lit lit) cont-simplExprF1 env (Tick t expr)  cont = {-#SCC "simplTick" #-} simplTick env t expr cont-simplExprF1 env (Cast body co) cont = {-#SCC "simplCast" #-} simplCast env body co cont-simplExprF1 env (Coercion co)  cont = {-#SCC "simplCoercionF" #-} simplCoercionF env co cont--simplExprF1 env (App fun arg) cont-  = {-#SCC "simplExprF1-App" #-} case arg of-      Type ty -> do { -- The argument type will (almost) certainly be used-                      -- in the output program, so just force it now.-                      -- See Note [Avoiding space leaks in OutType]-                      arg' <- simplType env ty--                      -- But use substTy, not simplType, to avoid forcing-                      -- the hole type; it will likely not be needed.-                      -- See Note [The hole type in ApplyToTy]-                    ; let hole' = substTy env (exprType fun)--                    ; simplExprF env fun $-                      ApplyToTy { sc_arg_ty  = arg'-                                , sc_hole_ty = hole'-                                , sc_cont    = cont } }-      _       ->-          -- Crucially, sc_hole_ty is a /lazy/ binding.  It will-          -- be forced only if we need to run contHoleType.-          -- When these are forced, we might get quadratic behavior;-          -- this quadratic blowup could be avoided by drilling down-          -- to the function and getting its multiplicities all at once-          -- (instead of one-at-a-time). But in practice, we have not-          -- observed the quadratic behavior, so this extra entanglement-          -- seems not worthwhile.-        simplExprF env fun $-        ApplyToVal { sc_arg = arg, sc_env = env-                   , sc_hole_ty = substTy env (exprType fun)-                   , sc_dup = NoDup, sc_cont = cont }--simplExprF1 env expr@(Lam {}) cont-  = {-#SCC "simplExprF1-Lam" #-}-    simplLam env zapped_bndrs body cont-        -- The main issue here is under-saturated lambdas-        --   (\x1. \x2. e) arg1-        -- Here x1 might have "occurs-once" occ-info, because occ-info-        -- is computed assuming that a group of lambdas is applied-        -- all at once.  If there are too few args, we must zap the-        -- occ-info, UNLESS the remaining binders are one-shot-  where-    (bndrs, body) = collectBinders expr-    zapped_bndrs = zapLamBndrs n_args bndrs-    n_args = countArgs cont-        -- NB: countArgs counts all the args (incl type args)-        -- and likewise drop counts all binders (incl type lambdas)--simplExprF1 env (Case scrut bndr _ alts) cont-  = {-#SCC "simplExprF1-Case" #-}-    simplExprF env scrut (Select { sc_dup = NoDup, sc_bndr = bndr-                                 , sc_alts = alts-                                 , sc_env = env, sc_cont = cont })--simplExprF1 env (Let (Rec pairs) body) cont-  | Just pairs' <- joinPointBindings_maybe pairs-  = {-#SCC "simplRecJoinPoin" #-} simplRecJoinPoint env pairs' body cont--  | otherwise-  = {-#SCC "simplRecE" #-} simplRecE env pairs body cont--simplExprF1 env (Let (NonRec bndr rhs) body) cont-  | Type ty <- rhs    -- First deal with type lets (let a = Type ty in e)-  = {-#SCC "simplExprF1-NonRecLet-Type" #-}-    ASSERT( isTyVar bndr )-    do { ty' <- simplType env ty-       ; simplExprF (extendTvSubst env bndr ty') body cont }--  | Just (bndr', rhs') <- joinPointBinding_maybe bndr rhs-  = {-#SCC "simplNonRecJoinPoint" #-} simplNonRecJoinPoint env bndr' rhs' body cont--  | otherwise-  = {-#SCC "simplNonRecE" #-} simplNonRecE env bndr (rhs, env) ([], body) cont--{- Note [Avoiding space leaks in OutType]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Since the simplifier is run for multiple iterations, we need to ensure-that any thunks in the output of one simplifier iteration are forced-by the evaluation of the next simplifier iteration. Otherwise we may-retain multiple copies of the Core program and leak a terrible amount-of memory (as in #13426).--The simplifier is naturally strict in the entire "Expr part" of the-input Core program, because any expression may contain binders, which-we must find in order to extend the SimplEnv accordingly. But types-do not contain binders and so it is tempting to write things like--    simplExpr env (Type ty) = return (Type (substTy env ty))   -- Bad!--This is Bad because the result includes a thunk (substTy env ty) which-retains a reference to the whole simplifier environment; and the next-simplifier iteration will not force this thunk either, because the-line above is not strict in ty.--So instead our strategy is for the simplifier to fully evaluate-OutTypes when it emits them into the output Core program, for example--    simplExpr env (Type ty) = do { ty' <- simplType env ty     -- Good-                                 ; return (Type ty') }--where the only difference from above is that simplType calls seqType-on the result of substTy.--However, SimplCont can also contain OutTypes and it's not necessarily-a good idea to force types on the way in to SimplCont, because they-may end up not being used and forcing them could be a lot of wasted-work. T5631 is a good example of this.--- For ApplyToTy's sc_arg_ty, we force the type on the way in because-  the type will almost certainly appear as a type argument in the-  output program.--- For the hole types in Stop and ApplyToTy, we force the type when we-  emit it into the output program, after obtaining it from-  contResultType. (The hole type in ApplyToTy is only directly used-  to form the result type in a new Stop continuation.)--}-------------------------------------- Simplify a join point, adding the context.--- Context goes *inside* the lambdas. IOW, if the join point has arity n, we do:---   \x1 .. xn -> e => \x1 .. xn -> E[e]--- Note that we need the arity of the join point, since e may be a lambda--- (though this is unlikely). See Note [Join points and case-of-case].-simplJoinRhs :: SimplEnv -> InId -> InExpr -> SimplCont-             -> SimplM OutExpr-simplJoinRhs env bndr expr cont-  | Just arity <- isJoinId_maybe bndr-  =  do { let (join_bndrs, join_body) = collectNBinders arity expr-              mult = contHoleScaling cont-        ; (env', join_bndrs') <- simplLamBndrs env (map (scaleVarBy mult) join_bndrs)-        ; join_body' <- simplExprC env' join_body cont-        ; return $ mkLams join_bndrs' join_body' }--  | otherwise-  = pprPanic "simplJoinRhs" (ppr bndr)------------------------------------simplType :: SimplEnv -> InType -> SimplM OutType-        -- Kept monadic just so we can do the seqType-        -- See Note [Avoiding space leaks in OutType]-simplType env ty-  = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $-    seqType new_ty `seq` return new_ty-  where-    new_ty = substTy env ty------------------------------------simplCoercionF :: SimplEnv -> InCoercion -> SimplCont-               -> SimplM (SimplFloats, OutExpr)-simplCoercionF env co cont-  = do { co' <- simplCoercion env co-       ; rebuild env (Coercion co') cont }--simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion-simplCoercion env co-  = do { opts <- getOptCoercionOpts-       ; let opt_co = optCoercion opts (getTCvSubst env) co-       ; seqCo opt_co `seq` return opt_co }---------------------------------------- | Push a TickIt context outwards past applications and cases, as--- long as this is a non-scoping tick, to let case and application--- optimisations apply.--simplTick :: SimplEnv -> CoreTickish -> InExpr -> SimplCont-          -> SimplM (SimplFloats, OutExpr)-simplTick env tickish expr cont-  -- A scoped tick turns into a continuation, so that we can spot-  -- (scc t (\x . e)) in simplLam and eliminate the scc.  If we didn't do-  -- it this way, then it would take two passes of the simplifier to-  -- reduce ((scc t (\x . e)) e').-  -- NB, don't do this with counting ticks, because if the expr is-  -- bottom, then rebuildCall will discard the continuation.---- XXX: we cannot do this, because the simplifier assumes that--- the context can be pushed into a case with a single branch. e.g.---    scc<f>  case expensive of p -> e--- becomes---    case expensive of p -> scc<f> e------ So I'm disabling this for now.  It just means we will do more--- simplifier iterations that necessary in some cases.----  | tickishScoped tickish && not (tickishCounts tickish)---  = simplExprF env expr (TickIt tickish cont)--  -- For unscoped or soft-scoped ticks, we are allowed to float in new-  -- cost, so we simply push the continuation inside the tick.  This-  -- has the effect of moving the tick to the outside of a case or-  -- application context, allowing the normal case and application-  -- optimisations to fire.-  | tickish `tickishScopesLike` SoftScope-  = do { (floats, expr') <- simplExprF env expr cont-       ; return (floats, mkTick tickish expr')-       }--  -- Push tick inside if the context looks like this will allow us to-  -- do a case-of-case - see Note [case-of-scc-of-case]-  | Select {} <- cont, Just expr' <- push_tick_inside-  = simplExprF env expr' cont--  -- We don't want to move the tick, but we might still want to allow-  -- floats to pass through with appropriate wrapping (or not, see-  -- wrap_floats below)-  --- | not (tickishCounts tickish) || tickishCanSplit tickish-  -- = wrap_floats--  | otherwise-  = no_floating_past_tick-- where--  -- Try to push tick inside a case, see Note [case-of-scc-of-case].-  push_tick_inside =-    case expr0 of-      Case scrut bndr ty alts-             -> Just $ Case (tickScrut scrut) bndr ty (map tickAlt alts)-      _other -> Nothing-   where (ticks, expr0) = stripTicksTop movable (Tick tickish expr)-         movable t      = not (tickishCounts t) ||-                          t `tickishScopesLike` NoScope ||-                          tickishCanSplit t-         tickScrut e    = foldr mkTick e ticks-         -- Alternatives get annotated with all ticks that scope in some way,-         -- but we don't want to count entries.-         tickAlt (Alt c bs e) = Alt c bs (foldr mkTick e ts_scope)-         ts_scope         = map mkNoCount $-                            filter (not . (`tickishScopesLike` NoScope)) ticks--  no_floating_past_tick =-    do { let (inc,outc) = splitCont cont-       ; (floats, expr1) <- simplExprF env expr inc-       ; let expr2    = wrapFloats floats expr1-             tickish' = simplTickish env tickish-       ; rebuild env (mkTick tickish' expr2) outc-       }---- Alternative version that wraps outgoing floats with the tick.  This--- results in ticks being duplicated, as we don't make any attempt to--- eliminate the tick if we re-inline the binding (because the tick--- semantics allows unrestricted inlining of HNFs), so I'm not doing--- this any more.  FloatOut will catch any real opportunities for--- floating.------  wrap_floats =---    do { let (inc,outc) = splitCont cont---       ; (env', expr') <- simplExprF (zapFloats env) expr inc---       ; let tickish' = simplTickish env tickish---       ; let wrap_float (b,rhs) = (zapIdStrictness (setIdArity b 0),---                                   mkTick (mkNoCount tickish') rhs)---              -- when wrapping a float with mkTick, we better zap the Id's---              -- strictness info and arity, because it might be wrong now.---       ; let env'' = addFloats env (mapFloats env' wrap_float)---       ; rebuild env'' expr' (TickIt tickish' outc)---       }---  simplTickish env tickish-    | Breakpoint ext n ids <- tickish-          = Breakpoint ext n (map (getDoneId . substId env) ids)-    | otherwise = tickish--  -- Push type application and coercion inside a tick-  splitCont :: SimplCont -> (SimplCont, SimplCont)-  splitCont cont@(ApplyToTy { sc_cont = tail }) = (cont { sc_cont = inc }, outc)-    where (inc,outc) = splitCont tail-  splitCont (CastIt co c) = (CastIt co inc, outc)-    where (inc,outc) = splitCont c-  splitCont other = (mkBoringStop (contHoleType other), other)--  getDoneId (DoneId id)  = id-  getDoneId (DoneEx e _) = getIdFromTrivialExpr e -- Note [substTickish] in GHC.Core.Subst-  getDoneId other = pprPanic "getDoneId" (ppr other)---- Note [case-of-scc-of-case]--- It's pretty important to be able to transform case-of-case when--- there's an SCC in the way.  For example, the following comes up--- in nofib/real/compress/Encode.hs:------        case scctick<code_string.r1>---             case $wcode_string_r13s wild_XC w1_s137 w2_s138 l_aje---             of _ { (# ww1_s13f, ww2_s13g, ww3_s13h #) ->---             (ww1_s13f, ww2_s13g, ww3_s13h)---             }---        of _ { (ww_s12Y, ww1_s12Z, ww2_s130) ->---        tick<code_string.f1>---        (ww_s12Y,---         ww1_s12Z,---         PTTrees.PT---           @ GHC.Types.Char @ GHC.Types.Int wild2_Xj ww2_s130 r_ajf)---        }------ We really want this case-of-case to fire, because then the 3-tuple--- will go away (indeed, the CPR optimisation is relying on this--- happening).  But the scctick is in the way - we need to push it--- inside to expose the case-of-case.  So we perform this--- transformation on the inner case:------   scctick c (case e of { p1 -> e1; ...; pn -> en })---    ==>---   case (scctick c e) of { p1 -> scc c e1; ...; pn -> scc c en }------ So we've moved a constant amount of work out of the scc to expose--- the case.  We only do this when the continuation is interesting: in--- for now, it has to be another Case (maybe generalise this later).--{--************************************************************************-*                                                                      *-\subsection{The main rebuilder}-*                                                                      *-************************************************************************--}--rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplFloats, OutExpr)--- At this point the substitution in the SimplEnv should be irrelevant;--- only the in-scope set matters-rebuild env expr cont-  = case cont of-      Stop {}          -> return (emptyFloats env, expr)-      TickIt t cont    -> rebuild env (mkTick t expr) cont-      CastIt co cont   -> rebuild env (mkCast expr co) cont-                       -- NB: mkCast implements the (Coercion co |> g) optimisation--      Select { sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont }-        -> rebuildCase (se `setInScopeFromE` env) expr bndr alts cont--      StrictArg { sc_fun = fun, sc_cont = cont, sc_fun_ty = fun_ty }-        -> rebuildCall env (addValArgTo fun expr fun_ty ) cont-      StrictBind { sc_bndr = b, sc_bndrs = bs, sc_body = body-                 , sc_env = se, sc_cont = cont }-        -> do { (floats1, env') <- simplNonRecX (se `setInScopeFromE` env) b expr-                                  -- expr satisfies let/app since it started life-                                  -- in a call to simplNonRecE-              ; (floats2, expr') <- simplLam env' bs body cont-              ; return (floats1 `addFloats` floats2, expr') }--      ApplyToTy  { sc_arg_ty = ty, sc_cont = cont}-        -> rebuild env (App expr (Type ty)) cont--      ApplyToVal { sc_arg = arg, sc_env = se, sc_dup = dup_flag, sc_cont = cont}-        -- See Note [Avoid redundant simplification]-        -> do { (_, _, arg') <- simplArg env dup_flag se arg-              ; rebuild env (App expr arg') cont }--{--************************************************************************-*                                                                      *-\subsection{Lambdas}-*                                                                      *-************************************************************************--}--{- Note [Optimising reflexivity]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's important (for compiler performance) to get rid of reflexivity as soon-as it appears.  See #11735, #14737, and #15019.--In particular, we want to behave well on-- *  e |> co1 |> co2-    where the two happen to cancel out entirely. That is quite common;-    e.g. a newtype wrapping and unwrapping cancel.--- * (f |> co) @t1 @t2 ... @tn x1 .. xm-   Here we will use pushCoTyArg and pushCoValArg successively, which-   build up NthCo stacks.  Silly to do that if co is reflexive.--However, we don't want to call isReflexiveCo too much, because it uses-type equality which is expensive on big types (#14737 comment:7).--A good compromise (determined experimentally) seems to be to call-isReflexiveCo- * when composing casts, and- * at the end--In investigating this I saw missed opportunities for on-the-fly-coercion shrinkage. See #15090.--}---simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont-          -> SimplM (SimplFloats, OutExpr)-simplCast env body co0 cont0-  = do  { co1   <- {-#SCC "simplCast-simplCoercion" #-} simplCoercion env co0-        ; cont1 <- {-#SCC "simplCast-addCoerce" #-}-                   if isReflCo co1-                   then return cont0  -- See Note [Optimising reflexivity]-                   else addCoerce co1 cont0-        ; {-#SCC "simplCast-simplExprF" #-} simplExprF env body cont1 }-  where-        -- If the first parameter is MRefl, then simplifying revealed a-        -- reflexive coercion. Omit.-        addCoerceM :: MOutCoercion -> SimplCont -> SimplM SimplCont-        addCoerceM MRefl   cont = return cont-        addCoerceM (MCo co) cont = addCoerce co cont--        addCoerce :: OutCoercion -> SimplCont -> SimplM SimplCont-        addCoerce co1 (CastIt co2 cont)  -- See Note [Optimising reflexivity]-          | isReflexiveCo co' = return cont-          | otherwise         = addCoerce co' cont-          where-            co' = mkTransCo co1 co2--        addCoerce co (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail })-          | Just (arg_ty', m_co') <- pushCoTyArg co arg_ty-          = {-#SCC "addCoerce-pushCoTyArg" #-}-            do { tail' <- addCoerceM m_co' tail-               ; return (ApplyToTy { sc_arg_ty  = arg_ty'-                                   , sc_cont    = tail'-                                   , sc_hole_ty = coercionLKind co }) }-                                        -- NB!  As the cast goes past, the-                                        -- type of the hole changes (#16312)--        -- (f |> co) e   ===>   (f (e |> co1)) |> co2-        -- where   co :: (s1->s2) ~ (t1->t2)-        --         co1 :: t1 ~ s1-        --         co2 :: s2 ~ t2-        addCoerce co cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se-                                      , sc_dup = dup, sc_cont = tail })-          | Just (m_co1, m_co2) <- pushCoValArg co-          , levity_ok m_co1-          = {-#SCC "addCoerce-pushCoValArg" #-}-            do { tail' <- addCoerceM m_co2 tail-               ; case m_co1 of {-                   MRefl -> return (cont { sc_cont = tail'-                                         , sc_hole_ty = coercionLKind co }) ;-                      -- Avoid simplifying if possible;-                      -- See Note [Avoiding exponential behaviour]--                   MCo co1 ->-            do { (dup', arg_se', arg') <- simplArg env dup arg_se arg-                    -- When we build the ApplyTo we can't mix the OutCoercion-                    -- 'co' with the InExpr 'arg', so we simplify-                    -- to make it all consistent.  It's a bit messy.-                    -- But it isn't a common case.-                    -- Example of use: #995-               ; return (ApplyToVal { sc_arg  = mkCast arg' co1-                                    , sc_env  = arg_se'-                                    , sc_dup  = dup'-                                    , sc_cont = tail'-                                    , sc_hole_ty = coercionLKind co }) } } }--        addCoerce co cont-          | isReflexiveCo co = return cont  -- Having this at the end makes a huge-                                            -- difference in T12227, for some reason-                                            -- See Note [Optimising reflexivity]-          | otherwise        = return (CastIt co cont)--        levity_ok :: MCoercionR -> Bool-        levity_ok MRefl = True-        levity_ok (MCo co) = not $ isTypeLevPoly $ coercionRKind co-          -- Without this check, we get a lev-poly arg-          -- See Note [Levity polymorphism invariants] in GHC.Core-          -- test: typecheck/should_run/EtaExpandLevPoly--simplArg :: SimplEnv -> DupFlag -> StaticEnv -> CoreExpr-         -> SimplM (DupFlag, StaticEnv, OutExpr)-simplArg env dup_flag arg_env arg-  | isSimplified dup_flag-  = return (dup_flag, arg_env, arg)-  | otherwise-  = do { let arg_env' = arg_env `setInScopeFromE` env-       ; arg' <- simplExpr arg_env'  arg-       ; return (Simplified, zapSubstEnv arg_env', arg') }-         -- Return a StaticEnv that includes the in-scope set from 'env',-         -- because arg' may well mention those variables (#20639)--{--************************************************************************-*                                                                      *-\subsection{Lambdas}-*                                                                      *-************************************************************************--}--simplLam :: SimplEnv -> [InId] -> InExpr -> SimplCont-         -> SimplM (SimplFloats, OutExpr)--simplLam env [] body cont-  = simplExprF env body cont--simplLam env (bndr:bndrs) body (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont })-  = do { tick (BetaReduction bndr)-       ; simplLam (extendTvSubst env bndr arg_ty) bndrs body cont }--simplLam env (bndr:bndrs) body (ApplyToVal { sc_arg = arg, sc_env = arg_se-                                           , sc_cont = cont, sc_dup = dup })-  | isSimplified dup  -- Don't re-simplify if we've simplified it once-                      -- See Note [Avoiding exponential behaviour]-  = do  { tick (BetaReduction bndr)-        ; (floats1, env') <- simplNonRecX env zapped_bndr arg-        ; (floats2, expr') <- simplLam env' bndrs body cont-        ; return (floats1 `addFloats` floats2, expr') }--  | otherwise-  = do  { tick (BetaReduction bndr)-        ; simplNonRecE env zapped_bndr (arg, arg_se) (bndrs, body) cont }-  where-    zapped_bndr  -- See Note [Zap unfolding when beta-reducing]-      | isId bndr = zapStableUnfolding bndr-      | otherwise = bndr--      -- Discard a non-counting tick on a lambda.  This may change the-      -- cost attribution slightly (moving the allocation of the-      -- lambda elsewhere), but we don't care: optimisation changes-      -- cost attribution all the time.-simplLam env bndrs body (TickIt tickish cont)-  | not (tickishCounts tickish)-  = simplLam env bndrs body cont--        -- Not enough args, so there are real lambdas left to put in the result-simplLam env bndrs body cont-  = do  { (env', bndrs') <- simplLamBndrs env bndrs-        ; body' <- simplExpr env' body-        ; new_lam <- mkLam env bndrs' body' cont-        ; rebuild env' new_lam cont }----------------simplLamBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)--- Used for lambda binders.  These sometimes have unfoldings added by--- the worker/wrapper pass that must be preserved, because they can't--- be reconstructed from context.  For example:---      f x = case x of (a,b) -> fw a b x---      fw a b x{=(a,b)} = ...--- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise.-simplLamBndr env bndr-  | isId bndr && hasCoreUnfolding old_unf   -- Special case-  = do { (env1, bndr1) <- simplBinder env bndr-       ; unf'          <- simplStableUnfolding env1 NotTopLevel Nothing bndr-                                      (idType bndr1) (idArityType bndr1) old_unf-       ; let bndr2 = bndr1 `setIdUnfolding` unf'-       ; return (modifyInScope env1 bndr2, bndr2) }--  | otherwise-  = simplBinder env bndr                -- Normal case-  where-    old_unf = idUnfolding bndr--simplLamBndrs :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])-simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs---------------------simplNonRecE :: SimplEnv-             -> InId                    -- The binder, always an Id-                                        -- Never a join point-             -> (InExpr, SimplEnv)      -- Rhs of binding (or arg of lambda)-             -> ([InBndr], InExpr)      -- Body of the let/lambda-                                        --      \xs.e-             -> SimplCont-             -> SimplM (SimplFloats, OutExpr)---- simplNonRecE is used for---  * non-top-level non-recursive non-join-point lets in expressions---  * beta reduction------ simplNonRec env b (rhs, rhs_se) (bs, body) k---   = let env in---     cont< let b = rhs_se(rhs) in \bs.body >------ It deals with strict bindings, via the StrictBind continuation,--- which may abort the whole process------ Precondition: rhs satisfies the let/app invariant---               Note [Core let/app invariant] in GHC.Core------ The "body" of the binding comes as a pair of ([InId],InExpr)--- representing a lambda; so we recurse back to simplLam--- Why?  Because of the binder-occ-info-zapping done before---       the call to simplLam in simplExprF (Lam ...)--simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont-  | ASSERT( isId bndr && not (isJoinId bndr) ) True-  , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs rhs_se-  = do { tick (PreInlineUnconditionally bndr)-       ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $-         simplLam env' bndrs body cont }--  | otherwise-  = do { (env1, bndr1) <- simplNonRecBndr env bndr--       -- Deal with strict bindings-       -- See Note [Dark corner with levity polymorphism]-       ; if isStrictId bndr1 && sm_case_case (getMode env)-         then simplExprF (rhs_se `setInScopeFromE` env) rhs-                   (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs, sc_body = body-                               , sc_env = env, sc_cont = cont, sc_dup = NoDup })--       -- Deal with lazy bindings-         else do-       { (env2, bndr2) <- addBndrRules env1 bndr bndr1 Nothing-       ; (floats1, env3) <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se-       ; (floats2, expr') <- simplLam env3 bndrs body cont-       ; return (floats1 `addFloats` floats2, expr') } }---------------------simplRecE :: SimplEnv-          -> [(InId, InExpr)]-          -> InExpr-          -> SimplCont-          -> SimplM (SimplFloats, OutExpr)---- simplRecE is used for---  * non-top-level recursive lets in expressions-simplRecE env pairs body cont-  = do  { let bndrs = map fst pairs-        ; MASSERT(all (not . isJoinId) bndrs)-        ; env1 <- simplRecBndrs env bndrs-                -- NB: bndrs' don't have unfoldings or rules-                -- We add them as we go down-        ; (floats1, env2) <- simplRecBind env1 NotTopLevel Nothing pairs-        ; (floats2, expr') <- simplExprF env2 body cont-        ; return (floats1 `addFloats` floats2, expr') }--{- Note [Dark corner with levity polymorphism]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In `simplNonRecE`, the call to `isStrictId` will fail if the binder-has a levity-polymorphic type, of kind (TYPE r).  So we are careful to-call `isStrictId` on the OutId, not the InId, in case we have-     ((\(r::RuntimeRep) \(x::Type r). blah) Lifted arg)-That will lead to `simplNonRecE env (x::Type r) arg`, and we can't tell-if x is lifted or unlifted from that.--We only get such redexes from the compulsory inlining of a wired-in,-levity-polymorphic function like `rightSection` (see-GHC.Types.Id.Make).  Mind you, SimpleOpt should probably have inlined-such compulsory inlinings already, but belt and braces does no harm.--Plus, it turns out that GHC.Driver.Main.hscCompileCoreExpr calls the-Simplifier without first calling SimpleOpt, so anything involving-GHCi or TH and operator sections will fall over if we don't take-care here.--Note [Avoiding exponential behaviour]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-One way in which we can get exponential behaviour is if we simplify a-big expression, and the re-simplify it -- and then this happens in a-deeply-nested way.  So we must be jolly careful about re-simplifying-an expression.  That is why completeNonRecX does not try-preInlineUnconditionally.--Example:-  f BIG, where f has a RULE-Then- * We simplify BIG before trying the rule; but the rule does not fire- * We inline f = \x. x True- * So if we did preInlineUnconditionally we'd re-simplify (BIG True)--However, if BIG has /not/ already been simplified, we'd /like/ to-simplify BIG True; maybe good things happen.  That is why--* simplLam has-    - a case for (isSimplified dup), which goes via simplNonRecX, and-    - a case for the un-simplified case, which goes via simplNonRecE--* We go to some efforts to avoid unnecessarily simplifying ApplyToVal,-  in at least two places-    - In simplCast/addCoerce, where we check for isReflCo-    - In rebuildCall we avoid simplifying arguments before we have to-      (see Note [Trying rewrite rules])---Note [Zap unfolding when beta-reducing]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Lambda-bound variables can have stable unfoldings, such as-   $j = \x. \b{Unf=Just x}. e-See Note [Case binders and join points] below; the unfolding for lets-us optimise e better.  However when we beta-reduce it we want to-revert to using the actual value, otherwise we can end up in the-stupid situation of-          let x = blah in-          let b{Unf=Just x} = y-          in ...b...-Here it'd be far better to drop the unfolding and use the actual RHS.--************************************************************************-*                                                                      *-                     Join points-*                                                                      *-********************************************************************* -}--{- Note [Rules and unfolding for join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have--   simplExpr (join j x = rhs                         ) cont-             (      {- RULE j (p:ps) = blah -}       )-             (      {- StableUnfolding j = blah -}   )-             (in blah                                )--Then we will push 'cont' into the rhs of 'j'.  But we should *also* push-'cont' into the RHS of-  * Any RULEs for j, e.g. generated by SpecConstr-  * Any stable unfolding for j, e.g. the result of an INLINE pragma--Simplifying rules and stable-unfoldings happens a bit after-simplifying the right-hand side, so we remember whether or not it-is a join point, and what 'cont' is, in a value of type MaybeJoinCont--#13900 was caused by forgetting to push 'cont' into the RHS-of a SpecConstr-generated RULE for a join point.--}--type MaybeJoinCont = Maybe SimplCont-  -- Nothing => Not a join point-  -- Just k  => This is a join binding with continuation k-  -- See Note [Rules and unfolding for join points]--simplNonRecJoinPoint :: SimplEnv -> InId -> InExpr-                     -> InExpr -> SimplCont-                     -> SimplM (SimplFloats, OutExpr)-simplNonRecJoinPoint env bndr rhs body cont-  | ASSERT( isJoinId bndr ) True-  , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs env-  = do { tick (PreInlineUnconditionally bndr)-       ; simplExprF env' body cont }--   | otherwise-   = wrapJoinCont env cont $ \ env cont ->-     do { -- We push join_cont into the join RHS and the body;-          -- and wrap wrap_cont around the whole thing-        ; let mult   = contHoleScaling cont-              res_ty = contResultType cont-        ; (env1, bndr1)    <- simplNonRecJoinBndr env bndr mult res_ty-        ; (env2, bndr2)    <- addBndrRules env1 bndr bndr1 (Just cont)-        ; (floats1, env3)  <- simplJoinBind env2 cont bndr bndr2 rhs env-        ; (floats2, body') <- simplExprF env3 body cont-        ; return (floats1 `addFloats` floats2, body') }----------------------simplRecJoinPoint :: SimplEnv -> [(InId, InExpr)]-                  -> InExpr -> SimplCont-                  -> SimplM (SimplFloats, OutExpr)-simplRecJoinPoint env pairs body cont-  = wrapJoinCont env cont $ \ env cont ->-    do { let bndrs  = map fst pairs-             mult   = contHoleScaling cont-             res_ty = contResultType cont-       ; env1 <- simplRecJoinBndrs env bndrs mult res_ty-               -- NB: bndrs' don't have unfoldings or rules-               -- We add them as we go down-       ; (floats1, env2)  <- simplRecBind env1 NotTopLevel (Just cont) pairs-       ; (floats2, body') <- simplExprF env2 body cont-       ; return (floats1 `addFloats` floats2, body') }-----------------------wrapJoinCont :: SimplEnv -> SimplCont-             -> (SimplEnv -> SimplCont -> SimplM (SimplFloats, OutExpr))-             -> SimplM (SimplFloats, OutExpr)--- Deal with making the continuation duplicable if necessary,--- and with the no-case-of-case situation.-wrapJoinCont env cont thing_inside-  | contIsStop cont        -- Common case; no need for fancy footwork-  = thing_inside env cont--  | not (sm_case_case (getMode env))-    -- See Note [Join points with -fno-case-of-case]-  = do { (floats1, expr1) <- thing_inside env (mkBoringStop (contHoleType cont))-       ; let (floats2, expr2) = wrapJoinFloatsX floats1 expr1-       ; (floats3, expr3) <- rebuild (env `setInScopeFromF` floats2) expr2 cont-       ; return (floats2 `addFloats` floats3, expr3) }--  | otherwise-    -- Normal case; see Note [Join points and case-of-case]-  = do { (floats1, cont')  <- mkDupableCont env cont-       ; (floats2, result) <- thing_inside (env `setInScopeFromF` floats1) cont'-       ; return (floats1 `addFloats` floats2, result) }------------------------trimJoinCont :: Id -> Maybe JoinArity -> SimplCont -> SimplCont--- Drop outer context from join point invocation (jump)--- See Note [Join points and case-of-case]--trimJoinCont _ Nothing cont-  = cont -- Not a jump-trimJoinCont var (Just arity) cont-  = trim arity cont-  where-    trim 0 cont@(Stop {})-      = cont-    trim 0 cont-      = mkBoringStop (contResultType cont)-    trim n cont@(ApplyToVal { sc_cont = k })-      = cont { sc_cont = trim (n-1) k }-    trim n cont@(ApplyToTy { sc_cont = k })-      = cont { sc_cont = trim (n-1) k } -- join arity counts types!-    trim _ cont-      = pprPanic "completeCall" $ ppr var $$ ppr cont---{- Note [Join points and case-of-case]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we perform the case-of-case transform (or otherwise push continuations-inward), we want to treat join points specially. Since they're always-tail-called and we want to maintain this invariant, we can do this (for any-evaluation context E):--  E[join j = e-    in case ... of-         A -> jump j 1-         B -> jump j 2-         C -> f 3]--    -->--  join j = E[e]-  in case ... of-       A -> jump j 1-       B -> jump j 2-       C -> E[f 3]--As is evident from the example, there are two components to this behavior:--  1. When entering the RHS of a join point, copy the context inside.-  2. When a join point is invoked, discard the outer context.--We need to be very careful here to remain consistent---neither part is-optional!--We need do make the continuation E duplicable (since we are duplicating it)-with mkDupableCont.---Note [Join points with -fno-case-of-case]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Supose case-of-case is switched off, and we are simplifying--    case (join j x = <j-rhs> in-          case y of-             A -> j 1-             B -> j 2-             C -> e) of <outer-alts>--Usually, we'd push the outer continuation (case . of <outer-alts>) into-both the RHS and the body of the join point j.  But since we aren't doing-case-of-case we may then end up with this totally bogus result--    join x = case <j-rhs> of <outer-alts> in-    case (case y of-             A -> j 1-             B -> j 2-             C -> e) of <outer-alts>--This would be OK in the language of the paper, but not in GHC: j is no longer-a join point.  We can only do the "push continuation into the RHS of the-join point j" if we also push the continuation right down to the /jumps/ to-j, so that it can evaporate there.  If we are doing case-of-case, we'll get to--    join x = case <j-rhs> of <outer-alts> in-    case y of-      A -> j 1-      B -> j 2-      C -> case e of <outer-alts>--which is great.--Bottom line: if case-of-case is off, we must stop pushing the continuation-inwards altogether at any join point.  Instead simplify the (join ... in ...)-with a Stop continuation, and wrap the original continuation around the-outside.  Surprisingly tricky!---************************************************************************-*                                                                      *-                     Variables-*                                                                      *-************************************************************************--}--simplVar :: SimplEnv -> InVar -> SimplM OutExpr--- Look up an InVar in the environment-simplVar env var-  -- Why $! ? See Note [Bangs in the Simplifier]-  | isTyVar var = return $! Type $! (substTyVar env var)-  | isCoVar var = return $! Coercion $! (substCoVar env var)-  | otherwise-  = case substId env var of-        ContEx tvs cvs ids e -> let env' = setSubstEnv env tvs cvs ids-                                in simplExpr env' e-        DoneId var1          -> return (Var var1)-        DoneEx e _           -> return e--simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr)-simplIdF env var cont-  = case substId env var of-      ContEx tvs cvs ids e ->-          let env' = setSubstEnv env tvs cvs ids-          in simplExprF env' e cont-          -- Don't trim; haven't already simplified e,-          -- so the cont is not embodied in e--      DoneId var1 ->-          let cont' = trimJoinCont var (isJoinId_maybe var1) cont-          in completeCall env var1 cont'--      DoneEx e mb_join ->-          let env' = zapSubstEnv env-              cont' = trimJoinCont var mb_join cont-          in simplExprF env' e cont'-              -- Note [zapSubstEnv]-              -- The template is already simplified, so don't re-substitute.-              -- This is VITAL.  Consider-              --      let x = e in-              --      let y = \z -> ...x... in-              --      \ x -> ...y...-              -- We'll clone the inner \x, adding x->x' in the id_subst-              -- Then when we inline y, we must *not* replace x by x' in-              -- the inlined copy!!--------------------------------------------------------------      Dealing with a call site--completeCall :: SimplEnv -> OutId -> SimplCont -> SimplM (SimplFloats, OutExpr)-completeCall env var cont-  | Just expr <- callSiteInline logger dflags case_depth var active_unf-                                lone_variable arg_infos interesting_cont-  -- Inline the variable's RHS-  = do { checkedTick (UnfoldingDone var)-       ; dump_inline expr cont-       ; let env1 = zapSubstEnv env-       ; simplExprF env1 expr cont }--  | otherwise-  -- Don't inline; instead rebuild the call-  = do { rule_base <- getSimplRules-       ; let rules = getRules rule_base var-             info = mkArgInfo env var rules-                              n_val_args call_cont-       ; rebuildCall env info cont }--  where-    dflags     = seDynFlags env-    case_depth = seCaseDepth env-    logger     = seLogger env-    (lone_variable, arg_infos, call_cont) = contArgs cont-    n_val_args       = length arg_infos-    interesting_cont = interestingCallContext env call_cont-    active_unf       = activeUnfolding (getMode env) var--    log_inlining doc-      = liftIO $ putDumpMsg logger dflags-           (mkDumpStyle alwaysQualify)-           Opt_D_dump_inlinings-           "" FormatText doc--    dump_inline unfolding cont-      | not (dopt Opt_D_dump_inlinings dflags) = return ()-      | not (dopt Opt_D_verbose_core2core dflags)-      = when (isExternalName (idName var)) $-            log_inlining $-                sep [text "Inlining done:", nest 4 (ppr var)]-      | otherwise-      = log_inlining $-           sep [text "Inlining done: " <> ppr var,-                nest 4 (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding),-                              text "Cont:  " <+> ppr cont])]--rebuildCall :: SimplEnv-            -> ArgInfo-            -> SimplCont-            -> SimplM (SimplFloats, OutExpr)--- We decided not to inline, so---    - simplify the arguments---    - try rewrite rules---    - and rebuild------------ Bottoming applications ---------------rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_dmds = [] }) cont-  -- When we run out of strictness args, it means-  -- that the call is definitely bottom; see GHC.Core.Opt.Simplify.Utils.mkArgInfo-  -- Then we want to discard the entire strict continuation.  E.g.-  --    * case (error "hello") of { ... }-  --    * (error "Hello") arg-  --    * f (error "Hello") where f is strict-  --    etc-  -- Then, especially in the first of these cases, we'd like to discard-  -- the continuation, leaving just the bottoming expression.  But the-  -- type might not be right, so we may have to add a coerce.-  | not (contIsTrivial cont)     -- Only do this if there is a non-trivial-                                 -- continuation to discard, else we do it-                                 -- again and again!-  = seqType cont_ty `seq`        -- See Note [Avoiding space leaks in OutType]-    return (emptyFloats env, castBottomExpr res cont_ty)-  where-    res     = argInfoExpr fun rev_args-    cont_ty = contResultType cont------------ Try rewrite RULES ----------------- See Note [Trying rewrite rules]-rebuildCall env info@(ArgInfo { ai_fun = fun, ai_args = rev_args-                              , ai_rules = Just (nr_wanted, rules) }) cont-  | nr_wanted == 0 || no_more_args-  , let info' = info { ai_rules = Nothing }-  = -- We've accumulated a simplified call in <fun,rev_args>-    -- so try rewrite rules; see Note [RULEs apply to simplified arguments]-    -- See also Note [Rules for recursive functions]-    do { mb_match <- tryRules env rules fun (reverse rev_args) cont-       ; case mb_match of-             Just (env', rhs, cont') -> simplExprF env' rhs cont'-             Nothing                 -> rebuildCall env info' cont }-  where-    no_more_args = case cont of-                      ApplyToTy  {} -> False-                      ApplyToVal {} -> False-                      _             -> True------------- Simplify applications and casts ---------------rebuildCall env info (CastIt co cont)-  = rebuildCall env (addCastTo info co) cont--rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = cont })-  = rebuildCall env (addTyArgTo info arg_ty hole_ty) cont------------ The runRW# rule. Do this after absorbing all arguments --------- See Note [Simplification of runRW#] in GHC.CoreToSTG.Prep.------ runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). (State# RealWorld -> o) -> o--- K[ runRW# rr ty body ]   -->   runRW rr' ty' (\s. K[ body s ])-rebuildCall env (ArgInfo { ai_fun = fun_id, ai_args = rev_args })-            (ApplyToVal { sc_arg = arg, sc_env = arg_se-                        , sc_cont = cont, sc_hole_ty = fun_ty })-  | fun_id `hasKey` runRWKey-  , [ TyArg {}, TyArg {} ] <- rev_args-  -- Do this even if (contIsStop cont)-  -- See Note [No eta-expansion in runRW#]-  = do { let arg_env = arg_se `setInScopeFromE` env-             ty'   = contResultType cont--       -- If the argument is a literal lambda already, take a short cut-       -- This isn't just efficiency; if we don't do this we get a beta-redex-       -- every time, so the simplifier keeps doing more iterations.-       ; arg' <- case arg of-           Lam s body -> do { (env', s') <- simplBinder arg_env s-                            ; body' <- simplExprC env' body cont-                            ; return (Lam s' body') }-                            -- Important: do not try to eta-expand this lambda-                            -- See Note [No eta-expansion in runRW#]-           _ -> do { s' <- newId (fsLit "s") Many realWorldStatePrimTy-                   ; let (m,_,_) = splitFunTy fun_ty-                         env'  = arg_env `addNewInScopeIds` [s']-                         cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s'-                                            , sc_env = env', sc_cont = cont-                                            , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy ty' }-                                -- cont' applies to s', then K-                   ; body' <- simplExprC env' arg cont'-                   ; return (Lam s' body') }--       ; let rr'   = getRuntimeRep ty'-             call' = mkApps (Var fun_id) [mkTyArg rr', mkTyArg ty', arg']-       ; return (emptyFloats env, call') }--rebuildCall env fun_info-            (ApplyToVal { sc_arg = arg, sc_env = arg_se-                        , sc_dup = dup_flag, sc_hole_ty = fun_ty-                        , sc_cont = cont })-  -- Argument is already simplified-  | isSimplified dup_flag     -- See Note [Avoid redundant simplification]-  = rebuildCall env (addValArgTo fun_info arg fun_ty) cont--  -- Strict arguments-  | isStrictArgInfo fun_info-  , sm_case_case (getMode env)-  = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $-    simplExprF (arg_se `setInScopeFromE` env) arg-               (StrictArg { sc_fun = fun_info, sc_fun_ty = fun_ty-                          , sc_dup = Simplified-                          , sc_cont = cont })-                -- Note [Shadowing]--  -- Lazy arguments-  | otherwise-        -- DO NOT float anything outside, hence simplExprC-        -- There is no benefit (unlike in a let-binding), and we'd-        -- have to be very careful about bogus strictness through-        -- floating a demanded let.-  = do  { arg' <- simplExprC (arg_se `setInScopeFromE` env) arg-                             (mkLazyArgStop arg_ty (lazyArgContext fun_info))-        ; rebuildCall env (addValArgTo fun_info  arg' fun_ty) cont }-  where-    arg_ty = funArgTy fun_ty------------- No further useful info, revert to generic rebuild -------------rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args }) cont-  = rebuild env (argInfoExpr fun rev_args) cont--{- Note [Trying rewrite rules]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider an application (f e1 e2 e3) where the e1,e2,e3 are not yet-simplified.  We want to simplify enough arguments to allow the rules-to apply, but it's more efficient to avoid simplifying e2,e3 if e1 alone-is sufficient.  Example: class ops-   (+) dNumInt e2 e3-If we rewrite ((+) dNumInt) to plusInt, we can take advantage of the-latter's strictness when simplifying e2, e3.  Moreover, suppose we have-  RULE  f Int = \x. x True--Then given (f Int e1) we rewrite to-   (\x. x True) e1-without simplifying e1.  Now we can inline x into its unique call site,-and absorb the True into it all in the same pass.  If we simplified-e1 first, we couldn't do that; see Note [Avoiding exponential behaviour].--So we try to apply rules if either-  (a) no_more_args: we've run out of argument that the rules can "see"-  (b) nr_wanted: none of the rules wants any more arguments---Note [RULES apply to simplified arguments]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's very desirable to try RULES once the arguments have been simplified, because-doing so ensures that rule cascades work in one pass.  Consider-   {-# RULES g (h x) = k x-             f (k x) = x #-}-   ...f (g (h x))...-Then we want to rewrite (g (h x)) to (k x) and only then try f's rules. If-we match f's rules against the un-simplified RHS, it won't match.  This-makes a particularly big difference when superclass selectors are involved:-        op ($p1 ($p2 (df d)))-We want all this to unravel in one sweep.--Note [Avoid redundant simplification]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Because RULES apply to simplified arguments, there's a danger of repeatedly-simplifying already-simplified arguments.  An important example is that of-        (>>=) d e1 e2-Here e1, e2 are simplified before the rule is applied, but don't really-participate in the rule firing. So we mark them as Simplified to avoid-re-simplifying them.--Note [Shadowing]-~~~~~~~~~~~~~~~~-This part of the simplifier may break the no-shadowing invariant-Consider-        f (...(\a -> e)...) (case y of (a,b) -> e')-where f is strict in its second arg-If we simplify the innermost one first we get (...(\a -> e)...)-Simplifying the second arg makes us float the case out, so we end up with-        case y of (a,b) -> f (...(\a -> e)...) e'-So the output does not have the no-shadowing invariant.  However, there is-no danger of getting name-capture, because when the first arg was simplified-we used an in-scope set that at least mentioned all the variables free in its-static environment, and that is enough.--We can't just do innermost first, or we'd end up with a dual problem:-        case x of (a,b) -> f e (...(\a -> e')...)--I spent hours trying to recover the no-shadowing invariant, but I just could-not think of an elegant way to do it.  The simplifier is already knee-deep in-continuations.  We have to keep the right in-scope set around; AND we have-to get the effect that finding (error "foo") in a strict arg position will-discard the entire application and replace it with (error "foo").  Getting-all this at once is TOO HARD!--Note [No eta-expansion in runRW#]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we see `runRW# (\s. blah)` we must not attempt to eta-expand that-lambda.  Why not?  Because-* `blah` can mention join points bound outside the runRW#-* eta-expansion uses arityType, and-* `arityType` cannot cope with free join Ids:--So the simplifier spots the literal lambda, and simplifies inside it.-It's a very special lambda, because it is the one the OccAnal spots and-allows join points bound /outside/ to be called /inside/.--See Note [No free join points in arityType] in GHC.Core.Opt.Arity--************************************************************************-*                                                                      *-                Rewrite rules-*                                                                      *-************************************************************************--}--tryRules :: SimplEnv -> [CoreRule]-         -> Id -> [ArgSpec]-         -> SimplCont-         -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont))--tryRules env rules fn args call_cont-  | null rules-  = return Nothing--{- Disabled until we fix #8326-  | fn `hasKey` tagToEnumKey   -- See Note [Optimising tagToEnum#]-  , [_type_arg, val_arg] <- args-  , Select dup bndr ((_,[],rhs1) : rest_alts) se cont <- call_cont-  , isDeadBinder bndr-  = do { let enum_to_tag :: CoreAlt -> CoreAlt-                -- Takes   K -> e  into   tagK# -> e-                -- where tagK# is the tag of constructor K-             enum_to_tag (DataAlt con, [], rhs)-               = ASSERT( isEnumerationTyCon (dataConTyCon con) )-                (LitAlt tag, [], rhs)-              where-                tag = mkLitInt dflags (toInteger (dataConTag con - fIRST_TAG))-             enum_to_tag alt = pprPanic "tryRules: tagToEnum" (ppr alt)--             new_alts = (DEFAULT, [], rhs1) : map enum_to_tag rest_alts-             new_bndr = setIdType bndr intPrimTy-                 -- The binder is dead, but should have the right type-      ; return (Just (val_arg, Select dup new_bndr new_alts se cont)) }--}--  | Just (rule, rule_rhs) <- lookupRule ropts (getUnfoldingInRuleMatch env)-                                        (activeRule (getMode env)) fn-                                        (argInfoAppArgs args) rules-  -- Fire a rule for the function-  = do { checkedTick (RuleFired (ruleName rule))-       ; let cont' = pushSimplifiedArgs zapped_env-                                        (drop (ruleArity rule) args)-                                        call_cont-                     -- (ruleArity rule) says how-                     -- many args the rule consumed--             occ_anald_rhs = occurAnalyseExpr rule_rhs-                 -- See Note [Occurrence-analyse after rule firing]-       ; dump rule rule_rhs-       ; return (Just (zapped_env, occ_anald_rhs, cont')) }-            -- The occ_anald_rhs and cont' are all Out things-            -- hence zapping the environment--  | otherwise  -- No rule fires-  = do { nodump  -- This ensures that an empty file is written-       ; return Nothing }--  where-    -- Force this to avoid retaining DynFlags and hence SimplEnv-    !ropts     = initRuleOpts dflags-    dflags     = seDynFlags env-    logger     = seLogger env-    zapped_env = zapSubstEnv env  -- See Note [zapSubstEnv]--    printRuleModule rule-      = parens (maybe (text "BUILTIN")-                      (pprModuleName . moduleName)-                      (ruleModule rule))--    dump rule rule_rhs-      | dopt Opt_D_dump_rule_rewrites dflags-      = log_rule dflags Opt_D_dump_rule_rewrites "Rule fired" $ vcat-          [ text "Rule:" <+> ftext (ruleName rule)-          , text "Module:" <+>  printRuleModule rule-          , text "Before:" <+> hang (ppr fn) 2 (sep (map ppr args))-          , text "After: " <+> hang (pprCoreExpr rule_rhs) 2-                               (sep $ map ppr $ drop (ruleArity rule) args)-          , text "Cont:  " <+> ppr call_cont ]--      | dopt Opt_D_dump_rule_firings dflags-      = log_rule dflags Opt_D_dump_rule_firings "Rule fired:" $-          ftext (ruleName rule)-            <+> printRuleModule rule--      | otherwise-      = return ()--    nodump-      | dopt Opt_D_dump_rule_rewrites dflags-      = liftIO $-          touchDumpFile logger dflags Opt_D_dump_rule_rewrites--      | dopt Opt_D_dump_rule_firings dflags-      = liftIO $-          touchDumpFile logger dflags Opt_D_dump_rule_firings--      | otherwise-      = return ()--    log_rule dflags flag hdr details-      = liftIO $ do-          let sty = mkDumpStyle alwaysQualify-          putDumpMsg logger dflags sty flag "" FormatText $-              sep [text hdr, nest 4 details]--trySeqRules :: SimplEnv-            -> OutExpr -> InExpr   -- Scrutinee and RHS-            -> SimplCont-            -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont))--- See Note [User-defined RULES for seq]-trySeqRules in_env scrut rhs cont-  = do { rule_base <- getSimplRules-       ; tryRules in_env (getRules rule_base seqId) seqId out_args rule_cont }-  where-    no_cast_scrut = drop_casts scrut-    scrut_ty  = exprType no_cast_scrut-    seq_id_ty = idType seqId                    -- forall r a (b::TYPE r). a -> b -> b-    res1_ty   = piResultTy seq_id_ty rhs_rep    -- forall a (b::TYPE rhs_rep). a -> b -> b-    res2_ty   = piResultTy res1_ty   scrut_ty   -- forall (b::TYPE rhs_rep). scrut_ty -> b -> b-    res3_ty   = piResultTy res2_ty   rhs_ty     -- scrut_ty -> rhs_ty -> rhs_ty-    res4_ty   = funResultTy res3_ty             -- rhs_ty -> rhs_ty-    rhs_ty    = substTy in_env (exprType rhs)-    rhs_rep   = getRuntimeRep rhs_ty-    out_args  = [ TyArg { as_arg_ty  = rhs_rep-                        , as_hole_ty = seq_id_ty }-                , TyArg { as_arg_ty  = scrut_ty-                        , as_hole_ty = res1_ty }-                , TyArg { as_arg_ty  = rhs_ty-                        , as_hole_ty = res2_ty }-                , ValArg { as_arg = no_cast_scrut-                         , as_dmd = seqDmd-                         , as_hole_ty = res3_ty } ]-    rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs-                           , sc_env = in_env, sc_cont = cont-                           , sc_hole_ty = res4_ty }--    -- Lazily evaluated, so we don't do most of this--    drop_casts (Cast e _) = drop_casts e-    drop_casts e          = e--{- Note [User-defined RULES for seq]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Given-   case (scrut |> co) of _ -> rhs-look for rules that match the expression-   seq @t1 @t2 scrut-where scrut :: t1-      rhs   :: t2--If you find a match, rewrite it, and apply to 'rhs'.--Notice that we can simply drop casts on the fly here, which-makes it more likely that a rule will match.--See Note [User-defined RULES for seq] in GHC.Types.Id.Make.--Note [Occurrence-analyse after rule firing]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-After firing a rule, we occurrence-analyse the instantiated RHS before-simplifying it.  Usually this doesn't make much difference, but it can-be huge.  Here's an example (simplCore/should_compile/T7785)--  map f (map f (map f xs)--= -- Use build/fold form of map, twice-  map f (build (\cn. foldr (mapFB c f) n-                           (build (\cn. foldr (mapFB c f) n xs))))--= -- Apply fold/build rule-  map f (build (\cn. (\cn. foldr (mapFB c f) n xs) (mapFB c f) n))--= -- Beta-reduce-  -- Alas we have no occurrence-analysed, so we don't know-  -- that c is used exactly once-  map f (build (\cn. let c1 = mapFB c f in-                     foldr (mapFB c1 f) n xs))--= -- Use mapFB rule:   mapFB (mapFB c f) g = mapFB c (f.g)-  -- We can do this because (mapFB c n) is a PAP and hence expandable-  map f (build (\cn. let c1 = mapFB c n in-                     foldr (mapFB c (f.f)) n x))--This is not too bad.  But now do the same with the outer map, and-we get another use of mapFB, and t can interact with /both/ remaining-mapFB calls in the above expression.  This is stupid because actually-that 'c1' binding is dead.  The outer map introduces another c2. If-there is a deep stack of maps we get lots of dead bindings, and lots-of redundant work as we repeatedly simplify the result of firing rules.--The easy thing to do is simply to occurrence analyse the result of-the rule firing.  Note that this occ-anals not only the RHS of the-rule, but also the function arguments, which by now are OutExprs.-E.g.-      RULE f (g x) = x+1--Call   f (g BIG)  -->   (\x. x+1) BIG--The rule binders are lambda-bound and applied to the OutExpr arguments-(here BIG) which lack all internal occurrence info.--Is this inefficient?  Not really: we are about to walk over the result-of the rule firing to simplify it, so occurrence analysis is at most-a constant factor.--Possible improvement: occ-anal the rules when putting them in the-database; and in the simplifier just occ-anal the OutExpr arguments.-But that's more complicated and the rule RHS is usually tiny; so I'm-just doing the simple thing.--Historical note: previously we did occ-anal the rules in Rule.hs,-but failed to occ-anal the OutExpr arguments, which led to the-nasty performance problem described above.---Note [Optimising tagToEnum#]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have an enumeration data type:--  data Foo = A | B | C--Then we want to transform--   case tagToEnum# x of   ==>    case x of-     A -> e1                       DEFAULT -> e1-     B -> e2                       1#      -> e2-     C -> e3                       2#      -> e3--thereby getting rid of the tagToEnum# altogether.  If there was a DEFAULT-alternative we retain it (remember it comes first).  If not the case must-be exhaustive, and we reflect that in the transformed version by adding-a DEFAULT.  Otherwise Lint complains that the new case is not exhaustive.-See #8317.--Note [Rules for recursive functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-You might think that we shouldn't apply rules for a loop breaker:-doing so might give rise to an infinite loop, because a RULE is-rather like an extra equation for the function:-     RULE:           f (g x) y = x+y-     Eqn:            f a     y = a-y--But it's too drastic to disable rules for loop breakers.-Even the foldr/build rule would be disabled, because foldr-is recursive, and hence a loop breaker:-     foldr k z (build g) = g k z-So it's up to the programmer: rules can cause divergence---************************************************************************-*                                                                      *-                Rebuilding a case expression-*                                                                      *-************************************************************************--Note [Case elimination]-~~~~~~~~~~~~~~~~~~~~~~~-The case-elimination transformation discards redundant case expressions.-Start with a simple situation:--        case x# of      ===>   let y# = x# in e-          y# -> e--(when x#, y# are of primitive type, of course).  We can't (in general)-do this for algebraic cases, because we might turn bottom into-non-bottom!--The code in GHC.Core.Opt.Simplify.Utils.prepareAlts has the effect of generalise-this idea to look for a case where we're scrutinising a variable, and we know-that only the default case can match.  For example:--        case x of-          0#      -> ...-          DEFAULT -> ...(case x of-                         0#      -> ...-                         DEFAULT -> ...) ...--Here the inner case is first trimmed to have only one alternative, the-DEFAULT, after which it's an instance of the previous case.  This-really only shows up in eliminating error-checking code.--Note that GHC.Core.Opt.Simplify.Utils.mkCase combines identical RHSs.  So--        case e of       ===> case e of DEFAULT -> r-           True  -> r-           False -> r--Now again the case may be eliminated by the CaseElim transformation.-This includes things like (==# a# b#)::Bool so that we simplify-      case ==# a# b# of { True -> x; False -> x }-to just-      x-This particular example shows up in default methods for-comparison operations (e.g. in (>=) for Int.Int32)--Note [Case to let transformation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If a case over a lifted type has a single alternative, and is being-used as a strict 'let' (all isDeadBinder bndrs), we may want to do-this transformation:--    case e of r       ===>   let r = e in ...r...-      _ -> ...r...--We treat the unlifted and lifted cases separately:--* Unlifted case: 'e' satisfies exprOkForSpeculation-  (ok-for-spec is needed to satisfy the let/app invariant).-  This turns     case a +# b of r -> ...r...-  into           let r = a +# b in ...r...-  and thence     .....(a +# b)....--  However, if we have-      case indexArray# a i of r -> ...r...-  we might like to do the same, and inline the (indexArray# a i).-  But indexArray# is not okForSpeculation, so we don't build a let-  in rebuildCase (lest it get floated *out*), so the inlining doesn't-  happen either.  Annoying.--* Lifted case: we need to be sure that the expression is already-  evaluated (exprIsHNF).  If it's not already evaluated-      - we risk losing exceptions, divergence or-        user-specified thunk-forcing-      - even if 'e' is guaranteed to converge, we don't want to-        create a thunk (call by need) instead of evaluating it-        right away (call by value)--  However, we can turn the case into a /strict/ let if the 'r' is-  used strictly in the body.  Then we won't lose divergence; and-  we won't build a thunk because the let is strict.-  See also Note [Case-to-let for strictly-used binders]--  NB: absentError satisfies exprIsHNF: see Note [aBSENT_ERROR_ID] in GHC.Core.Make.-  We want to turn-     case (absentError "foo") of r -> ...MkT r...-  into-     let r = absentError "foo" in ...MkT r...---Note [Case-to-let for strictly-used binders]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have this:-   case <scrut> of r { _ -> ..r.. }--where 'r' is used strictly in (..r..), we can safely transform to-   let r = <scrut> in ...r...--This is a Good Thing, because 'r' might be dead (if the body just-calls error), or might be used just once (in which case it can be-inlined); or we might be able to float the let-binding up or down.-E.g. #15631 has an example.--Note that this can change the error behaviour.  For example, we might-transform-    case x of { _ -> error "bad" }-    --> error "bad"-which is might be puzzling if 'x' currently lambda-bound, but later gets-let-bound to (error "good").--Nevertheless, the paper "A semantics for imprecise exceptions" allows-this transformation. If you want to fix the evaluation order, use-'pseq'.  See #8900 for an example where the loss of this-transformation bit us in practice.--See also Note [Empty case alternatives] in GHC.Core.--Historical notes--There have been various earlier versions of this patch:--* By Sept 18 the code looked like this:-     || scrut_is_demanded_var scrut--    scrut_is_demanded_var :: CoreExpr -> Bool-    scrut_is_demanded_var (Cast s _) = scrut_is_demanded_var s-    scrut_is_demanded_var (Var _)    = isStrUsedDmd (idDemandInfo case_bndr)-    scrut_is_demanded_var _          = False--  This only fired if the scrutinee was a /variable/, which seems-  an unnecessary restriction. So in #15631 I relaxed it to allow-  arbitrary scrutinees.  Less code, less to explain -- but the change-  had 0.00% effect on nofib.--* Previously, in Jan 13 the code looked like this:-     || case_bndr_evald_next rhs--    case_bndr_evald_next :: CoreExpr -> Bool-      -- See Note [Case binder next]-    case_bndr_evald_next (Var v)         = v == case_bndr-    case_bndr_evald_next (Cast e _)      = case_bndr_evald_next e-    case_bndr_evald_next (App e _)       = case_bndr_evald_next e-    case_bndr_evald_next (Case e _ _ _)  = case_bndr_evald_next e-    case_bndr_evald_next _               = False--  This patch was part of fixing #7542. See also-  Note [Eta reduction of an eval'd function] in GHC.Core.Utils.)---Further notes about case elimination-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider:       test :: Integer -> IO ()-                test = print--Turns out that this compiles to:-    Print.test-      = \ eta :: Integer-          eta1 :: Void# ->-          case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT ->-          case hPutStr stdout-                 (PrelNum.jtos eta ($w[] @ Char))-                 eta1-          of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s  }}--Notice the strange '<' which has no effect at all. This is a funny one.-It started like this:--f x y = if x < 0 then jtos x-          else if y==0 then "" else jtos x--At a particular call site we have (f v 1).  So we inline to get--        if v < 0 then jtos x-        else if 1==0 then "" else jtos x--Now simplify the 1==0 conditional:--        if v<0 then jtos v else jtos v--Now common-up the two branches of the case:--        case (v<0) of DEFAULT -> jtos v--Why don't we drop the case?  Because it's strict in v.  It's technically-wrong to drop even unnecessary evaluations, and in practice they-may be a result of 'seq' so we *definitely* don't want to drop those.-I don't really know how to improve this situation.---Note [FloatBinds from constructor wrappers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have FloatBinds coming from the constructor wrapper-(as in Note [exprIsConApp_maybe on data constructors with wrappers]),-we cannot float past them. We'd need to float the FloatBind-together with the simplify floats, unfortunately the-simplifier doesn't have case-floats. The simplest thing we can-do is to wrap all the floats here. The next iteration of the-simplifier will take care of all these cases and lets.--Given data T = MkT !Bool, this allows us to simplify-case $WMkT b of { MkT x -> f x }-to-case b of { b' -> f b' }.--We could try and be more clever (like maybe wfloats only contain-let binders, so we could float them). But the need for the-extra complication is not clear.--}--------------------------------------------------------------      Eliminate the case if possible--rebuildCase, reallyRebuildCase-   :: SimplEnv-   -> OutExpr          -- Scrutinee-   -> InId             -- Case binder-   -> [InAlt]          -- Alternatives (increasing order)-   -> SimplCont-   -> SimplM (SimplFloats, OutExpr)-------------------------------------------------------      1. Eliminate the case if there's a known constructor-----------------------------------------------------rebuildCase env scrut case_bndr alts cont-  | Lit lit <- scrut    -- No need for same treatment as constructors-                        -- because literals are inlined more vigorously-  , not (litIsLifted lit)-  = do  { tick (KnownBranch case_bndr)-        ; case findAlt (LitAlt lit) alts of-            Nothing             -> missingAlt env case_bndr alts cont-            Just (Alt _ bs rhs) -> simple_rhs env [] scrut bs rhs }--  | Just (in_scope', wfloats, con, ty_args, other_args)-      <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut-        -- Works when the scrutinee is a variable with a known unfolding-        -- as well as when it's an explicit constructor application-  , let env0 = setInScopeSet env in_scope'-  = do  { tick (KnownBranch case_bndr)-        ; let scaled_wfloats = map scale_float wfloats-        ; case findAlt (DataAlt con) alts of-            Nothing  -> missingAlt env0 case_bndr alts cont-            Just (Alt DEFAULT bs rhs) -> let con_app = Var (dataConWorkId con)-                                                 `mkTyApps` ty_args-                                                 `mkApps`   other_args-                                         in simple_rhs env0 scaled_wfloats con_app bs rhs-            Just (Alt _ bs rhs)       -> knownCon env0 scrut scaled_wfloats con ty_args other_args-                                                  case_bndr bs rhs cont-        }-  where-    simple_rhs env wfloats scrut' bs rhs =-      ASSERT( null bs )-      do { (floats1, env') <- simplNonRecX env case_bndr scrut'-             -- scrut is a constructor application,-             -- hence satisfies let/app invariant-         ; (floats2, expr') <- simplExprF env' rhs cont-         ; case wfloats of-             [] -> return (floats1 `addFloats` floats2, expr')-             _ -> return-               -- See Note [FloatBinds from constructor wrappers]-                   ( emptyFloats env,-                     GHC.Core.Make.wrapFloats wfloats $-                     wrapFloats (floats1 `addFloats` floats2) expr' )}--    -- This scales case floats by the multiplicity of the continuation hole (see-    -- Note [Scaling in case-of-case]).  Let floats are _not_ scaled, because-    -- they are aliases anyway.-    scale_float (GHC.Core.Make.FloatCase scrut case_bndr con vars) =-      let-        scale_id id = scaleVarBy holeScaling id-      in-      GHC.Core.Make.FloatCase scrut (scale_id case_bndr) con (map scale_id vars)-    scale_float f = f--    holeScaling = contHoleScaling cont `mkMultMul` idMult case_bndr-     -- We are in the following situation-     --   case[p] case[q] u of { D x -> C v } of { C x -> w }-     -- And we are producing case[??] u of { D x -> w[x\v]}-     ---     -- What should the multiplicity `??` be? In order to preserve the usage of-     -- variables in `u`, it needs to be `pq`.-     ---     -- As an illustration, consider the following-     --   case[Many] case[1] of { C x -> C x } of { C x -> (x, x) }-     -- Where C :: A %1 -> T is linear-     -- If we were to produce a case[1], like the inner case, we would get-     --   case[1] of { C x -> (x, x) }-     -- Which is ill-typed with respect to linearity. So it needs to be a-     -- case[Many].-------------------------------------------------------      2. Eliminate the case if scrutinee is evaluated-----------------------------------------------------rebuildCase env scrut case_bndr alts@[Alt _ bndrs rhs] cont-  -- See if we can get rid of the case altogether-  -- See Note [Case elimination]-  -- mkCase made sure that if all the alternatives are equal,-  -- then there is now only one (DEFAULT) rhs--  -- 2a.  Dropping the case altogether, if-  --      a) it binds nothing (so it's really just a 'seq')-  --      b) evaluating the scrutinee has no side effects-  | is_plain_seq-  , exprOkForSideEffects scrut-          -- The entire case is dead, so we can drop it-          -- if the scrutinee converges without having imperative-          -- side effects or raising a Haskell exception-          -- See Note [PrimOp can_fail and has_side_effects] in GHC.Builtin.PrimOps-   = simplExprF env rhs cont--  -- 2b.  Turn the case into a let, if-  --      a) it binds only the case-binder-  --      b) unlifted case: the scrutinee is ok-for-speculation-  --           lifted case: the scrutinee is in HNF (or will later be demanded)-  -- See Note [Case to let transformation]-  | all_dead_bndrs-  , doCaseToLet scrut case_bndr-  = do { tick (CaseElim case_bndr)-       ; (floats1, env') <- simplNonRecX env case_bndr scrut-       ; (floats2, expr') <- simplExprF env' rhs cont-       ; return (floats1 `addFloats` floats2, expr') }--  -- 2c. Try the seq rules if-  --     a) it binds only the case binder-  --     b) a rule for seq applies-  -- See Note [User-defined RULES for seq] in GHC.Types.Id.Make-  | is_plain_seq-  = do { mb_rule <- trySeqRules env scrut rhs cont-       ; case mb_rule of-           Just (env', rule_rhs, cont') -> simplExprF env' rule_rhs cont'-           Nothing                      -> reallyRebuildCase env scrut case_bndr alts cont }-  where-    all_dead_bndrs = all isDeadBinder bndrs       -- bndrs are [InId]-    is_plain_seq   = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect--rebuildCase env scrut case_bndr alts cont-  = reallyRebuildCase env scrut case_bndr alts cont---doCaseToLet :: OutExpr          -- Scrutinee-            -> InId             -- Case binder-            -> Bool--- The situation is         case scrut of b { DEFAULT -> body }--- Can we transform thus?   let { b = scrut } in body-doCaseToLet scrut case_bndr-  | isTyCoVar case_bndr    -- Respect GHC.Core-  = isTyCoArg scrut        -- Note [Core type and coercion invariant]--  | isUnliftedType (idType case_bndr)-  = exprOkForSpeculation scrut--  | otherwise  -- Scrut has a lifted type-  = exprIsHNF scrut-    || isStrUsedDmd (idDemandInfo case_bndr)-    -- See Note [Case-to-let for strictly-used binders]-------------------------------------------------------      3. Catch-all case-----------------------------------------------------reallyRebuildCase env scrut case_bndr alts cont-  | not (sm_case_case (getMode env))-  = do { case_expr <- simplAlts env scrut case_bndr alts-                                (mkBoringStop (contHoleType cont))-       ; rebuild env case_expr cont }--  | otherwise-  = do { (floats, env', cont') <- mkDupableCaseCont env alts cont-       ; case_expr <- simplAlts env' scrut-                                (scaleIdBy holeScaling case_bndr)-                                (scaleAltsBy holeScaling alts)-                                cont'-       ; return (floats, case_expr) }-  where-    holeScaling = contHoleScaling cont-    -- Note [Scaling in case-of-case]--{--simplCaseBinder checks whether the scrutinee is a variable, v.  If so,-try to eliminate uses of v in the RHSs in favour of case_bndr; that-way, there's a chance that v will now only be used once, and hence-inlined.--Historical note: we use to do the "case binder swap" in the Simplifier-so there were additional complications if the scrutinee was a variable.-Now the binder-swap stuff is done in the occurrence analyser; see-"GHC.Core.Opt.OccurAnal" Note [Binder swap].--Note [knownCon occ info]-~~~~~~~~~~~~~~~~~~~~~~~~-If the case binder is not dead, then neither are the pattern bound-variables:-        case <any> of x { (a,b) ->-        case x of { (p,q) -> p } }-Here (a,b) both look dead, but come alive after the inner case is eliminated.-The point is that we bring into the envt a binding-        let x = (a,b)-after the outer case, and that makes (a,b) alive.  At least we do unless-the case binder is guaranteed dead.--Note [Case alternative occ info]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we are simply reconstructing a case (the common case), we always-zap the occurrence info on the binders in the alternatives.  Even-if the case binder is dead, the scrutinee is usually a variable, and *that*-can bring the case-alternative binders back to life.-See Note [Add unfolding for scrutinee]--Note [Improving seq]-~~~~~~~~~~~~~~~~~~~-Consider-        type family F :: * -> *-        type instance F Int = Int--We'd like to transform-        case e of (x :: F Int) { DEFAULT -> rhs }-===>-        case e `cast` co of (x'::Int)-           I# x# -> let x = x' `cast` sym co-                    in rhs--so that 'rhs' can take advantage of the form of x'.  Notice that Note-[Case of cast] (in OccurAnal) may then apply to the result.--We'd also like to eliminate empty types (#13468). So if--    data Void-    type instance F Bool = Void--then we'd like to transform-        case (x :: F Bool) of { _ -> error "urk" }-===>-        case (x |> co) of (x' :: Void) of {}--Nota Bene: we used to have a built-in rule for 'seq' that dropped-casts, so that-    case (x |> co) of { _ -> blah }-dropped the cast; in order to improve the chances of trySeqRules-firing.  But that works in the /opposite/ direction to Note [Improving-seq] so there's a danger of flip/flopping.  Better to make trySeqRules-insensitive to the cast, which is now is.--The need for [Improving seq] showed up in Roman's experiments.  Example:-  foo :: F Int -> Int -> Int-  foo t n = t `seq` bar n-     where-       bar 0 = 0-       bar n = bar (n - case t of TI i -> i)-Here we'd like to avoid repeated evaluating t inside the loop, by-taking advantage of the `seq`.--At one point I did transformation in LiberateCase, but it's more-robust here.  (Otherwise, there's a danger that we'll simply drop the-'seq' altogether, before LiberateCase gets to see it.)--Note [Scaling in case-of-case]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--When two cases commute, if done naively, the multiplicities will be wrong:--  case (case u of w[1] { (x[1], y[1]) } -> f x y) of w'[Many]-  { (z[Many], t[Many]) -> z-  }--The multiplicities here, are correct, but if I perform a case of case:--  case u of w[1]-  { (x[1], y[1]) -> case f x y of w'[Many] of { (z[Many], t[Many]) -> z }-  }--This is wrong! Using `f x y` inside a `case … of w'[Many]` means that `x` and-`y` must have multiplicities `Many` not `1`! The correct solution is to make-all the `1`-s be `Many`-s instead:--  case u of w[Many]-  { (x[Many], y[Many]) -> case f x y of w'[Many] of { (z[Many], t[Many]) -> z }-  }--In general, when commuting two cases, the rule has to be:--  case (case … of x[p] {…}) of y[q] { … }-  ===> case … of x[p*q] { … case … of y[q] { … } }--This is materialised, in the simplifier, by the fact that every time we simplify-case alternatives with a continuation (the surrounded case (or more!)), we must-scale the entire case we are simplifying, by a scaling factor which can be-computed in the continuation (with function `contHoleScaling`).--}--simplAlts :: SimplEnv-          -> OutExpr         -- Scrutinee-          -> InId            -- Case binder-          -> [InAlt]         -- Non-empty-          -> SimplCont-          -> SimplM OutExpr  -- Returns the complete simplified case expression--simplAlts env0 scrut case_bndr alts cont'-  = do  { traceSmpl "simplAlts" (vcat [ ppr case_bndr-                                      , text "cont':" <+> ppr cont'-                                      , text "in_scope" <+> ppr (seInScope env0) ])-        ; (env1, case_bndr1) <- simplBinder env0 case_bndr-        ; let case_bndr2 = case_bndr1 `setIdUnfolding` evaldUnfolding-              env2       = modifyInScope env1 case_bndr2-              -- See Note [Case binder evaluated-ness]--        ; fam_envs <- getFamEnvs-        ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env2 scrut-                                                       case_bndr case_bndr2 alts--        ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts-          -- NB: it's possible that the returned in_alts is empty: this is handled-          -- by the caller (rebuildCase) in the missingAlt function--        ; alts' <- mapM (simplAlt alt_env' (Just scrut') imposs_deflt_cons case_bndr' cont') in_alts-        ; -- pprTrace "simplAlts" (ppr case_bndr $$ ppr alts_ty $$ ppr alts_ty' $$ ppr alts $$ ppr cont') $--        ; let alts_ty' = contResultType cont'-        -- See Note [Avoiding space leaks in OutType]-        ; seqType alts_ty' `seq`-          mkCase (seDynFlags env0) scrut' case_bndr' alts_ty' alts' }----------------------------------------improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv-           -> OutExpr -> InId -> OutId -> [InAlt]-           -> SimplM (SimplEnv, OutExpr, OutId)--- Note [Improving seq]-improveSeq fam_envs env scrut case_bndr case_bndr1 [Alt DEFAULT _ _]-  | Just (co, ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1)-  = do { case_bndr2 <- newId (fsLit "nt") Many ty2-        ; let rhs  = DoneEx (Var case_bndr2 `Cast` mkSymCo co) Nothing-              env2 = extendIdSubst env case_bndr rhs-        ; return (env2, scrut `Cast` co, case_bndr2) }--improveSeq _ env scrut _ case_bndr1 _-  = return (env, scrut, case_bndr1)----------------------------------------simplAlt :: SimplEnv-         -> Maybe OutExpr  -- The scrutinee-         -> [AltCon]       -- These constructors can't be present when-                           -- matching the DEFAULT alternative-         -> OutId          -- The case binder-         -> SimplCont-         -> InAlt-         -> SimplM OutAlt--simplAlt env _ !imposs_deflt_cons case_bndr' cont' (Alt DEFAULT bndrs rhs)-  = ASSERT( null bndrs )-    do  { let env' = addBinderUnfolding env case_bndr'-                                        (mkOtherCon imposs_deflt_cons)-                -- Record the constructors that the case-binder *can't* be.-        ; rhs' <- simplExprC env' rhs cont'-        ; return (Alt DEFAULT [] rhs') }--simplAlt env scrut' _ case_bndr' cont' (Alt (LitAlt lit) bndrs rhs)-  = ASSERT( null bndrs )-    do  { env' <- addAltUnfoldings env scrut' case_bndr' (Lit lit)-        ; rhs' <- simplExprC env' rhs cont'-        ; return (Alt (LitAlt lit) [] rhs') }--simplAlt env scrut' _ case_bndr' cont' (Alt (DataAlt con) vs rhs)-  = do  { -- See Note [Adding evaluatedness info to pattern-bound variables]-          let vs_with_evals = addEvals scrut' con vs-        ; (env', vs') <- simplLamBndrs env vs_with_evals--                -- Bind the case-binder to (con args)-        ; let inst_tys' = tyConAppArgs (idType case_bndr')-              con_app :: OutExpr-              con_app   = mkConApp2 con inst_tys' vs'--        ; env'' <- addAltUnfoldings env' scrut' case_bndr' con_app-        -- Forced so that simplExprC forces wrapFloats which means we don't-        -- retain the InScopeSet in SimplFloats-        ; !rhs' <- simplExprC env'' rhs cont'-        ; return (Alt (DataAlt con) vs' rhs') }--{- Note [Adding evaluatedness info to pattern-bound variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-addEvals records the evaluated-ness of the bound variables of-a case pattern.  This is *important*.  Consider--     data T = T !Int !Int--     case x of { T a b -> T (a+1) b }--We really must record that b is already evaluated so that we don't-go and re-evaluate it when constructing the result.-See Note [Data-con worker strictness] in GHC.Core.DataCon--NB: simplLamBndrs preserves this eval info--In addition to handling data constructor fields with !s, addEvals-also records the fact that the result of seq# is always in WHNF.-See Note [seq# magic] in GHC.Core.Opt.ConstantFold.  Example (#15226):--  case seq# v s of-    (# s', v' #) -> E--we want the compiler to be aware that v' is in WHNF in E.--Open problem: we don't record that v itself is in WHNF (and we can't-do it here).  The right thing is to do some kind of binder-swap;-see #15226 for discussion.--}--addEvals :: Maybe OutExpr -> DataCon -> [Id] -> [Id]--- See Note [Adding evaluatedness info to pattern-bound variables]-addEvals scrut con vs-  -- Deal with seq# applications-  | Just scr <- scrut-  , isUnboxedTupleDataCon con-  , [s,x] <- vs-    -- Use stripNArgs rather than collectArgsTicks to avoid building-    -- a list of arguments only to throw it away immediately.-  , Just (Var f) <- stripNArgs 4 scr-  , Just SeqOp <- isPrimOpId_maybe f-  , let x' = zapIdOccInfoAndSetEvald MarkedStrict x-  = [s, x']--  -- Deal with banged datacon fields-addEvals _scrut con vs = go vs the_strs-    where-      the_strs = dataConRepStrictness con--      go [] [] = []-      go (v:vs') strs | isTyVar v = v : go vs' strs-      go (v:vs') (str:strs) = zapIdOccInfoAndSetEvald str v : go vs' strs-      go _ _ = pprPanic "Simplify.addEvals"-                (ppr con $$-                 ppr vs  $$-                 ppr_with_length (map strdisp the_strs) $$-                 ppr_with_length (dataConRepArgTys con) $$-                 ppr_with_length (dataConRepStrictness con))-        where-          ppr_with_length list-            = ppr list <+> parens (text "length =" <+> ppr (length list))-          strdisp MarkedStrict = text "MarkedStrict"-          strdisp NotMarkedStrict = text "NotMarkedStrict"--zapIdOccInfoAndSetEvald :: StrictnessMark -> Id -> Id-zapIdOccInfoAndSetEvald str v =-  setCaseBndrEvald str $ -- Add eval'dness info-  zapIdOccInfo v         -- And kill occ info;-                         -- see Note [Case alternative occ info]--addAltUnfoldings :: SimplEnv -> Maybe OutExpr -> OutId -> OutExpr -> SimplM SimplEnv-addAltUnfoldings env scrut case_bndr con_app-  = do { let con_app_unf = mk_simple_unf con_app-             env1 = addBinderUnfolding env case_bndr con_app_unf--             -- See Note [Add unfolding for scrutinee]-             env2 | Many <- idMult case_bndr = case scrut of-                      Just (Var v)           -> addBinderUnfolding env1 v con_app_unf-                      Just (Cast (Var v) co) -> addBinderUnfolding env1 v $-                                                mk_simple_unf (Cast con_app (mkSymCo co))-                      _                      -> env1-                  | otherwise = env1--       ; traceSmpl "addAltUnf" (vcat [ppr case_bndr <+> ppr scrut, ppr con_app])-       ; return env2 }-  where-    -- Force the opts, so that the whole SimplEnv isn't retained-    !opts = seUnfoldingOpts env-    mk_simple_unf = mkSimpleUnfolding opts--addBinderUnfolding :: SimplEnv -> Id -> Unfolding -> SimplEnv-addBinderUnfolding env bndr unf-  | debugIsOn, Just tmpl <- maybeUnfoldingTemplate unf-  = WARN( not (eqType (idType bndr) (exprType tmpl)),-          ppr bndr $$ ppr (idType bndr) $$ ppr tmpl $$ ppr (exprType tmpl) )-    modifyInScope env (bndr `setIdUnfolding` unf)--  | otherwise-  = modifyInScope env (bndr `setIdUnfolding` unf)--zapBndrOccInfo :: Bool -> Id -> Id--- Consider  case e of b { (a,b) -> ... }--- Then if we bind b to (a,b) in "...", and b is not dead,--- then we must zap the deadness info on a,b-zapBndrOccInfo keep_occ_info pat_id-  | keep_occ_info = pat_id-  | otherwise     = zapIdOccInfo pat_id--{- Note [Case binder evaluated-ness]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We pin on a (OtherCon []) unfolding to the case-binder of a Case,-even though it'll be over-ridden in every case alternative with a more-informative unfolding.  Why?  Because suppose a later, less clever, pass-simply replaces all occurrences of the case binder with the binder itself;-then Lint may complain about the let/app invariant.  Example-    case e of b { DEFAULT -> let v = reallyUnsafePtrEq# b y in ....-                ; K       -> blah }--The let/app invariant requires that y is evaluated in the call to-reallyUnsafePtrEq#, which it is.  But we still want that to be true if we-propagate binders to occurrences.--This showed up in #13027.--Note [Add unfolding for scrutinee]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In general it's unlikely that a variable scrutinee will appear-in the case alternatives   case x of { ...x unlikely to appear... }-because the binder-swap in OccurAnal has got rid of all such occurrences-See Note [Binder swap] in "GHC.Core.Opt.OccurAnal".--BUT it is still VERY IMPORTANT to add a suitable unfolding for a-variable scrutinee, in simplAlt.  Here's why-   case x of y-     (a,b) -> case b of c-                I# v -> ...(f y)...-There is no occurrence of 'b' in the (...(f y)...).  But y gets-the unfolding (a,b), and *that* mentions b.  If f has a RULE-    RULE f (p, I# q) = ...-we want that rule to match, so we must extend the in-scope env with a-suitable unfolding for 'y'.  It's *essential* for rule matching; but-it's also good for case-elimination -- suppose that 'f' was inlined-and did multi-level case analysis, then we'd solve it in one-simplifier sweep instead of two.--Exactly the same issue arises in GHC.Core.Opt.SpecConstr;-see Note [Add scrutinee to ValueEnv too] in GHC.Core.Opt.SpecConstr--HOWEVER, given-  case x of y { Just a -> r1; Nothing -> r2 }-we do not want to add the unfolding x -> y to 'x', which might seem cool,-since 'y' itself has different unfoldings in r1 and r2.  Reason: if we-did that, we'd have to zap y's deadness info and that is a very useful-piece of information.--So instead we add the unfolding x -> Just a, and x -> Nothing in the-respective RHSs.--Since this transformation is tantamount to a binder swap, the same caveat as in-Note [Suppressing binder-swaps on linear case] in OccurAnal apply.---************************************************************************-*                                                                      *-\subsection{Known constructor}-*                                                                      *-************************************************************************--We are a bit careful with occurrence info.  Here's an example--        (\x* -> case x of (a*, b) -> f a) (h v, e)--where the * means "occurs once".  This effectively becomes-        case (h v, e) of (a*, b) -> f a)-and then-        let a* = h v; b = e in f a-and then-        f (h v)--All this should happen in one sweep.--}--knownCon :: SimplEnv-         -> OutExpr                                           -- The scrutinee-         -> [FloatBind] -> DataCon -> [OutType] -> [OutExpr]  -- The scrutinee (in pieces)-         -> InId -> [InBndr] -> InExpr                        -- The alternative-         -> SimplCont-         -> SimplM (SimplFloats, OutExpr)--knownCon env scrut dc_floats dc dc_ty_args dc_args bndr bs rhs cont-  = do  { (floats1, env1)  <- bind_args env bs dc_args-        ; (floats2, env2)  <- bind_case_bndr env1-        ; (floats3, expr') <- simplExprF env2 rhs cont-        ; case dc_floats of-            [] ->-              return (floats1 `addFloats` floats2 `addFloats` floats3, expr')-            _ ->-              return ( emptyFloats env-               -- See Note [FloatBinds from constructor wrappers]-                     , GHC.Core.Make.wrapFloats dc_floats $-                       wrapFloats (floats1 `addFloats` floats2 `addFloats` floats3) expr') }-  where-    zap_occ = zapBndrOccInfo (isDeadBinder bndr)    -- bndr is an InId--                  -- Ugh!-    bind_args env' [] _  = return (emptyFloats env', env')--    bind_args env' (b:bs') (Type ty : args)-      = ASSERT( isTyVar b )-        bind_args (extendTvSubst env' b ty) bs' args--    bind_args env' (b:bs') (Coercion co : args)-      = ASSERT( isCoVar b )-        bind_args (extendCvSubst env' b co) bs' args--    bind_args env' (b:bs') (arg : args)-      = ASSERT( isId b )-        do { let b' = zap_occ b-             -- Note that the binder might be "dead", because it doesn't-             -- occur in the RHS; and simplNonRecX may therefore discard-             -- it via postInlineUnconditionally.-             -- Nevertheless we must keep it if the case-binder is alive,-             -- because it may be used in the con_app.  See Note [knownCon occ info]-           ; (floats1, env2) <- simplNonRecX env' b' arg  -- arg satisfies let/app invariant-           ; (floats2, env3)  <- bind_args env2 bs' args-           ; return (floats1 `addFloats` floats2, env3) }--    bind_args _ _ _ =-      pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$-                             text "scrut:" <+> ppr scrut--       -- It's useful to bind bndr to scrut, rather than to a fresh-       -- binding      x = Con arg1 .. argn-       -- because very often the scrut is a variable, so we avoid-       -- creating, and then subsequently eliminating, a let-binding-       -- BUT, if scrut is a not a variable, we must be careful-       -- about duplicating the arg redexes; in that case, make-       -- a new con-app from the args-    bind_case_bndr env-      | isDeadBinder bndr   = return (emptyFloats env, env)-      | exprIsTrivial scrut = return (emptyFloats env-                                     , extendIdSubst env bndr (DoneEx scrut Nothing))-      | otherwise           = do { dc_args <- mapM (simplVar env) bs-                                         -- dc_ty_args are already OutTypes,-                                         -- but bs are InBndrs-                                 ; let con_app = Var (dataConWorkId dc)-                                                 `mkTyApps` dc_ty_args-                                                 `mkApps`   dc_args-                                 ; simplNonRecX env bndr con_app }----------------------missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont-           -> SimplM (SimplFloats, OutExpr)-                -- This isn't strictly an error, although it is unusual.-                -- It's possible that the simplifier might "see" that-                -- an inner case has no accessible alternatives before-                -- it "sees" that the entire branch of an outer case is-                -- inaccessible.  So we simply put an error case here instead.-missingAlt env case_bndr _ cont-  = WARN( True, text "missingAlt" <+> ppr case_bndr )-    -- See Note [Avoiding space leaks in OutType]-    let cont_ty = contResultType cont-    in seqType cont_ty `seq`-       return (emptyFloats env, mkImpossibleExpr cont_ty)--{--************************************************************************-*                                                                      *-\subsection{Duplicating continuations}-*                                                                      *-************************************************************************--Consider-  let x* = case e of { True -> e1; False -> e2 }-  in b-where x* is a strict binding.  Then mkDupableCont will be given-the continuation-   case [] of { True -> e1; False -> e2 } ; let x* = [] in b ; stop-and will split it into-   dupable:      case [] of { True -> $j1; False -> $j2 } ; stop-   join floats:  $j1 = e1, $j2 = e2-   non_dupable:  let x* = [] in b; stop--Putting this back together would give-   let x* = let { $j1 = e1; $j2 = e2 } in-            case e of { True -> $j1; False -> $j2 }-   in b-(Of course we only do this if 'e' wants to duplicate that continuation.)-Note how important it is that the new join points wrap around the-inner expression, and not around the whole thing.--In contrast, any let-bindings introduced by mkDupableCont can wrap-around the entire thing.--Note [Bottom alternatives]-~~~~~~~~~~~~~~~~~~~~~~~~~~-When we have-     case (case x of { A -> error .. ; B -> e; C -> error ..)-       of alts-then we can just duplicate those alts because the A and C cases-will disappear immediately.  This is more direct than creating-join points and inlining them away.  See #4930.--}-----------------------mkDupableCaseCont :: SimplEnv -> [InAlt] -> SimplCont-                  -> SimplM ( SimplFloats  -- Join points (if any)-                            , SimplEnv     -- Use this for the alts-                            , SimplCont)-mkDupableCaseCont env alts cont-  | altsWouldDup alts = do { (floats, cont) <- mkDupableCont env cont-                           ; let env' = bumpCaseDepth $-                                        env `setInScopeFromF` floats-                           ; return (floats, env', cont) }-  | otherwise         = return (emptyFloats env, env, cont)--altsWouldDup :: [InAlt] -> Bool -- True iff strictly > 1 non-bottom alternative-altsWouldDup []  = False        -- See Note [Bottom alternatives]-altsWouldDup [_] = False-altsWouldDup (alt:alts)-  | is_bot_alt alt = altsWouldDup alts-  | otherwise      = not (all is_bot_alt alts)-    -- otherwise case: first alt is non-bot, so all the rest must be bot-  where-    is_bot_alt (Alt _ _ rhs) = exprIsDeadEnd rhs----------------------------mkDupableCont :: SimplEnv-              -> SimplCont-              -> SimplM ( SimplFloats  -- Incoming SimplEnv augmented with-                                       --   extra let/join-floats and in-scope variables-                        , SimplCont)   -- dup_cont: duplicable continuation-mkDupableCont env cont-  = mkDupableContWithDmds env (repeat topDmd) cont--mkDupableContWithDmds-   :: SimplEnv  -> [Demand]  -- Demands on arguments; always infinite-   -> SimplCont -> SimplM ( SimplFloats, SimplCont)--mkDupableContWithDmds env _ cont-  | contIsDupable cont-  = return (emptyFloats env, cont)--mkDupableContWithDmds _ _ (Stop {}) = panic "mkDupableCont"     -- Handled by previous eqn--mkDupableContWithDmds env dmds (CastIt ty cont)-  = do  { (floats, cont') <- mkDupableContWithDmds env dmds cont-        ; return (floats, CastIt ty cont') }---- Duplicating ticks for now, not sure if this is good or not-mkDupableContWithDmds env dmds (TickIt t cont)-  = do  { (floats, cont') <- mkDupableContWithDmds env dmds cont-        ; return (floats, TickIt t cont') }--mkDupableContWithDmds env _-     (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs-                 , sc_body = body, sc_env = se, sc_cont = cont})--- See Note [Duplicating StrictBind]--- K[ let x = <> in b ]  -->   join j x = K[ b ]---                             j <>-  = do { let sb_env = se `setInScopeFromE` env-       ; (sb_env1, bndr')      <- simplBinder sb_env bndr-       ; (floats1, join_inner) <- simplLam sb_env1 bndrs body cont-          -- No need to use mkDupableCont before simplLam; we-          -- use cont once here, and then share the result if necessary--       ; let join_body = wrapFloats floats1 join_inner-             res_ty    = contResultType cont--       ; mkDupableStrictBind env bndr' join_body res_ty }--mkDupableContWithDmds env _-    (StrictArg { sc_fun = fun, sc_cont = cont-               , sc_fun_ty = fun_ty })-  -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable-  | isNothing (isDataConId_maybe (ai_fun fun))-  , thumbsUpPlanA cont  -- See point (3) of Note [Duplicating join points]-  = -- Use Plan A of Note [Duplicating StrictArg]-    do { let (_ : dmds) = ai_dmds fun-       ; (floats1, cont')  <- mkDupableContWithDmds env dmds cont-                              -- Use the demands from the function to add the right-                              -- demand info on any bindings we make for further args-       ; (floats_s, args') <- mapAndUnzipM (makeTrivialArg (getMode env))-                                           (ai_args fun)-       ; return ( foldl' addLetFloats floats1 floats_s-                , StrictArg { sc_fun = fun { ai_args = args' }-                            , sc_cont = cont'-                            , sc_fun_ty = fun_ty-                            , sc_dup = OkToDup} ) }--  | otherwise-  = -- Use Plan B of Note [Duplicating StrictArg]-    --   K[ f a b <> ]   -->   join j x = K[ f a b x ]-    --                         j <>-    do { let rhs_ty       = contResultType cont-             (m,arg_ty,_) = splitFunTy fun_ty-       ; arg_bndr <- newId (fsLit "arg") m arg_ty-       ; let env' = env `addNewInScopeIds` [arg_bndr]-       ; (floats, join_rhs) <- rebuildCall env' (addValArgTo fun (Var arg_bndr) fun_ty) cont-       ; mkDupableStrictBind env' arg_bndr (wrapFloats floats join_rhs) rhs_ty }-  where-    thumbsUpPlanA (StrictArg {})               = False-    thumbsUpPlanA (CastIt _ k)                 = thumbsUpPlanA k-    thumbsUpPlanA (TickIt _ k)                 = thumbsUpPlanA k-    thumbsUpPlanA (ApplyToVal { sc_cont = k }) = thumbsUpPlanA k-    thumbsUpPlanA (ApplyToTy  { sc_cont = k }) = thumbsUpPlanA k-    thumbsUpPlanA (Select {})                  = True-    thumbsUpPlanA (StrictBind {})              = True-    thumbsUpPlanA (Stop {})                    = True--mkDupableContWithDmds env dmds-    (ApplyToTy { sc_cont = cont, sc_arg_ty = arg_ty, sc_hole_ty = hole_ty })-  = do  { (floats, cont') <- mkDupableContWithDmds env dmds cont-        ; return (floats, ApplyToTy { sc_cont = cont'-                                    , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) }--mkDupableContWithDmds env dmds-    (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_env = se-                , sc_cont = cont, sc_hole_ty = hole_ty })-  =     -- e.g.         [...hole...] (...arg...)-        --      ==>-        --              let a = ...arg...-        --              in [...hole...] a-        -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable-    do  { let (dmd:_) = dmds   -- Never fails-        ; (floats1, cont') <- mkDupableContWithDmds env dmds cont-        ; let env' = env `setInScopeFromF` floats1-        ; (_, se', arg') <- simplArg env' dup se arg-        ; (let_floats2, arg'') <- makeTrivial (getMode env) NotTopLevel dmd (fsLit "karg") arg'-        ; let all_floats = floats1 `addLetFloats` let_floats2-        ; return ( all_floats-                 , ApplyToVal { sc_arg = arg''-                              , sc_env = se' `setInScopeFromF` all_floats-                                         -- Ensure that sc_env includes the free vars of-                                         -- arg'' in its in-scope set, even if makeTrivial-                                         -- has turned arg'' into a fresh variable-                                         -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils-                              , sc_dup = OkToDup, sc_cont = cont'-                              , sc_hole_ty = hole_ty }) }--mkDupableContWithDmds env _-    (Select { sc_bndr = case_bndr, sc_alts = alts, sc_env = se, sc_cont = cont })-  =     -- e.g.         (case [...hole...] of { pi -> ei })-        --      ===>-        --              let ji = \xij -> ei-        --              in case [...hole...] of { pi -> ji xij }-        -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable-    do  { tick (CaseOfCase case_bndr)-        ; (floats, alt_env, alt_cont) <- mkDupableCaseCont (se `setInScopeFromE` env) alts cont-                -- NB: We call mkDupableCaseCont here to make cont duplicable-                --     (if necessary, depending on the number of alts)-                -- And this is important: see Note [Fusing case continuations]--        ; let cont_scaling = contHoleScaling cont-          -- See Note [Scaling in case-of-case]-        ; (alt_env', case_bndr') <- simplBinder alt_env (scaleIdBy cont_scaling case_bndr)-        ; alts' <- mapM (simplAlt alt_env' Nothing [] case_bndr' alt_cont) (scaleAltsBy cont_scaling alts)-        -- Safe to say that there are no handled-cons for the DEFAULT case-                -- NB: simplBinder does not zap deadness occ-info, so-                -- a dead case_bndr' will still advertise its deadness-                -- This is really important because in-                --      case e of b { (# p,q #) -> ... }-                -- b is always dead, and indeed we are not allowed to bind b to (# p,q #),-                -- which might happen if e was an explicit unboxed pair and b wasn't marked dead.-                -- In the new alts we build, we have the new case binder, so it must retain-                -- its deadness.-        -- NB: we don't use alt_env further; it has the substEnv for-        --     the alternatives, and we don't want that--        ; (join_floats, alts'') <- mapAccumLM (mkDupableAlt (targetPlatform (seDynFlags env)) case_bndr')-                                              emptyJoinFloats alts'--        ; let all_floats = floats `addJoinFloats` join_floats-                           -- Note [Duplicated env]-        ; return (all_floats-                 , Select { sc_dup  = OkToDup-                          , sc_bndr = case_bndr'-                          , sc_alts = alts''-                          , sc_env  = zapSubstEnv se `setInScopeFromF` all_floats-                                      -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils-                          , sc_cont = mkBoringStop (contResultType cont) } ) }--mkDupableStrictBind :: SimplEnv -> OutId -> OutExpr -> OutType-                    -> SimplM (SimplFloats, SimplCont)-mkDupableStrictBind env arg_bndr join_rhs res_ty-  | exprIsTrivial join_rhs   -- See point (2) of Note [Duplicating join points]-  = return (emptyFloats env-           , StrictBind { sc_bndr = arg_bndr, sc_bndrs = []-                        , sc_body = join_rhs-                        , sc_env  = zapSubstEnv env-                          -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils-                        , sc_dup  = OkToDup-                        , sc_cont = mkBoringStop res_ty } )-  | otherwise-  = do { join_bndr <- newJoinId [arg_bndr] res_ty-       ; let arg_info = ArgInfo { ai_fun   = join_bndr-                                , ai_rules = Nothing, ai_args  = []-                                , ai_encl  = False, ai_dmds  = repeat topDmd-                                , ai_discs = repeat 0 }-       ; return ( addJoinFloats (emptyFloats env) $-                  unitJoinFloat                   $-                  NonRec join_bndr                $-                  Lam (setOneShotLambda arg_bndr) join_rhs-                , StrictArg { sc_dup    = OkToDup-                            , sc_fun    = arg_info-                            , sc_fun_ty = idType join_bndr-                            , sc_cont   = mkBoringStop res_ty-                            } ) }--mkDupableAlt :: Platform -> OutId-             -> JoinFloats -> OutAlt-             -> SimplM (JoinFloats, OutAlt)-mkDupableAlt _platform case_bndr jfloats (Alt con bndrs' rhs')-  | exprIsTrivial rhs'   -- See point (2) of Note [Duplicating join points]-  = return (jfloats, Alt con bndrs' rhs')--  | otherwise-  = do  { simpl_opts <- initSimpleOpts <$> getDynFlags-        ; let rhs_ty'  = exprType rhs'-              scrut_ty = idType case_bndr-              case_bndr_w_unf-                = case con of-                      DEFAULT    -> case_bndr-                      DataAlt dc -> setIdUnfolding case_bndr unf-                          where-                                 -- See Note [Case binders and join points]-                             unf = mkInlineUnfolding simpl_opts rhs-                             rhs = mkConApp2 dc (tyConAppArgs scrut_ty) bndrs'--                      LitAlt {} -> WARN( True, text "mkDupableAlt"-                                                <+> ppr case_bndr <+> ppr con )-                                   case_bndr-                           -- The case binder is alive but trivial, so why has-                           -- it not been substituted away?--              final_bndrs'-                | isDeadBinder case_bndr = filter abstract_over bndrs'-                | otherwise              = bndrs' ++ [case_bndr_w_unf]--              abstract_over bndr-                  | isTyVar bndr = True -- Abstract over all type variables just in case-                  | otherwise    = not (isDeadBinder bndr)-                        -- The deadness info on the new Ids is preserved by simplBinders-              final_args = varsToCoreExprs final_bndrs'-                           -- Note [Join point abstraction]--                -- We make the lambdas into one-shot-lambdas.  The-                -- join point is sure to be applied at most once, and doing so-                -- prevents the body of the join point being floated out by-                -- the full laziness pass-              really_final_bndrs     = map one_shot final_bndrs'-              one_shot v | isId v    = setOneShotLambda v-                         | otherwise = v-              join_rhs   = mkLams really_final_bndrs rhs'--        ; join_bndr <- newJoinId final_bndrs' rhs_ty'--        ; let join_call = mkApps (Var join_bndr) final_args-              alt'      = Alt con bndrs' join_call--        ; return ( jfloats `addJoinFlts` unitJoinFloat (NonRec join_bndr join_rhs)-                 , alt') }-                -- See Note [Duplicated env]--{--Note [Fusing case continuations]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's important to fuse two successive case continuations when the-first has one alternative.  That's why we call prepareCaseCont here.-Consider this, which arises from thunk splitting (see Note [Thunk-splitting] in GHC.Core.Opt.WorkWrap):--      let-        x* = case (case v of {pn -> rn}) of-               I# a -> I# a-      in body--The simplifier will find-    (Var v) with continuation-            Select (pn -> rn) (-            Select [I# a -> I# a] (-            StrictBind body Stop--So we'll call mkDupableCont on-   Select [I# a -> I# a] (StrictBind body Stop)-There is just one alternative in the first Select, so we want to-simplify the rhs (I# a) with continuation (StrictBind body Stop)-Supposing that body is big, we end up with-          let $j a = <let x = I# a in body>-          in case v of { pn -> case rn of-                                 I# a -> $j a }-This is just what we want because the rn produces a box that-the case rn cancels with.--See #4957 a fuller example.--Note [Duplicating join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-IN #19996 we discovered that we want to be really careful about-inlining join points.   Consider-    case (join $j x = K f x )-         (in case v of      )-         (     p1 -> $j x1  ) of-         (     p2 -> $j x2  )-         (     p3 -> $j x3  )-      K g y -> blah[g,y]--Here the join-point RHS is very small, just a constructor-application (K x y).  So we might inline it to get-    case (case v of        )-         (     p1 -> K f x1  ) of-         (     p2 -> K f x2  )-         (     p3 -> K f x3  )-      K g y -> blah[g,y]--But now we have to make `blah` into a join point, /abstracted/-over `g` and `y`.   In contrast, if we /don't/ inline $j we-don't need a join point for `blah` and we'll get-    join $j x = let g=f, y=x in blah[g,y]-    in case v of-       p1 -> $j x1-       p2 -> $j x2-       p3 -> $j x3--This can make a /massive/ difference, because `blah` can see-what `f` is, instead of lambda-abstracting over it.--To achieve this:--1. Do not postInlineUnconditionally a join point, until the Final-   phase.  (The Final phase is still quite early, so we might consider-   delaying still more.)--2. In mkDupableAlt and mkDupableStrictBind, generate an alterative for-   all alternatives, except for exprIsTrival RHSs. Previously we used-   exprIsDupable.  This generates a lot more join points, but makes-   them much more case-of-case friendly.--   It is definitely worth checking for exprIsTrivial, otherwise we get-   an extra Simplifier iteration, because it is inlined in the next-   round.--3. By the same token we want to use Plan B in-   Note [Duplicating StrictArg] when the RHS of the new join point-   is a data constructor application.  That same Note explains why we-   want Plan A when the RHS of the new join point would be a-   non-data-constructor application--4. You might worry that $j will be inlined by the call-site inliner,-   but it won't because the call-site context for a join is usually-   extremely boring (the arguments come from the pattern match).-   And if not, then perhaps inlining it would be a good idea.--   You might also wonder if we get UnfWhen, because the RHS of the-   join point is no bigger than the call. But in the cases we care-   about it will be a little bigger, because of that free `f` in-       $j x = K f x-   So for now we don't do anything special in callSiteInline--There is a bit of tension between (2) and (3).  Do we want to retain-the join point only when the RHS is-* a constructor application? or-* just non-trivial?-Currently, a bit ad-hoc, but we definitely want to retain the join-point for data constructors in mkDupalbleALt (point 2); that is the-whole point of #19996 described above.--Note [Case binders and join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this-   case (case .. ) of c {-     I# c# -> ....c....--If we make a join point with c but not c# we get-  $j = \c -> ....c....--But if later inlining scrutinises the c, thus--  $j = \c -> ... case c of { I# y -> ... } ...--we won't see that 'c' has already been scrutinised.  This actually-happens in the 'tabulate' function in wave4main, and makes a significant-difference to allocation.--An alternative plan is this:--   $j = \c# -> let c = I# c# in ...c....--but that is bad if 'c' is *not* later scrutinised.--So instead we do both: we pass 'c' and 'c#' , and record in c's inlining-(a stable unfolding) that it's really I# c#, thus--   $j = \c# -> \c[=I# c#] -> ...c....--Absence analysis may later discard 'c'.--NB: take great care when doing strictness analysis;-    see Note [Lambda-bound unfoldings] in GHC.Core.Opt.DmdAnal.--Also note that we can still end up passing stuff that isn't used.  Before-strictness analysis we have-   let $j x y c{=(x,y)} = (h c, ...)-   in ...-After strictness analysis we see that h is strict, we end up with-   let $j x y c{=(x,y)} = ($wh x y, ...)-and c is unused.--Note [Duplicated env]-~~~~~~~~~~~~~~~~~~~~~-Some of the alternatives are simplified, but have not been turned into a join point-So they *must* have a zapped subst-env.  So we can't use completeNonRecX to-bind the join point, because it might to do PostInlineUnconditionally, and-we'd lose that when zapping the subst-env.  We could have a per-alt subst-env,-but zapping it (as we do in mkDupableCont, the Select case) is safe, and-at worst delays the join-point inlining.--Note [Funky mkLamTypes]-~~~~~~~~~~~~~~~~~~~~~~-Notice the funky mkLamTypes.  If the constructor has existentials-it's possible that the join point will be abstracted over-type variables as well as term variables.- Example:  Suppose we have-        data T = forall t.  C [t]- Then faced with-        case (case e of ...) of-            C t xs::[t] -> rhs- We get the join point-        let j :: forall t. [t] -> ...-            j = /\t \xs::[t] -> rhs-        in-        case (case e of ...) of-            C t xs::[t] -> j t xs--Note [Duplicating StrictArg]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Dealing with making a StrictArg continuation duplicable has turned out-to be one of the trickiest corners of the simplifier, giving rise-to several cases in which the simplier expanded the program's size-*exponentially*.  They include-  #13253 exponential inlining-  #10421 ditto-  #18140 strict constructors-  #18282 another nested-function call case--Suppose we have a call-  f e1 (case x of { True -> r1; False -> r2 }) e3-and f is strict in its second argument.  Then we end up in-mkDupableCont with a StrictArg continuation for (f e1 <> e3).-There are two ways to make it duplicable.--* Plan A: move the entire call inwards, being careful not-  to duplicate e1 or e3, thus:-     let a1 = e1-         a3 = e3-     in case x of { True  -> f a1 r1 a3-                  ; False -> f a1 r2 a3 }--* Plan B: make a join point:-     join $j x = f e1 x e3-     in case x of { True  -> jump $j r1-                  ; False -> jump $j r2 }--  Notice that Plan B is very like the way we handle strict bindings;-  see Note [Duplicating StrictBind].  And Plan B is exactly what we'd-  get if we turned use a case expression to evaluate the strict arg:--       case (case x of { True -> r1; False -> r2 }) of-         r -> f e1 r e3--  So, looking at Note [Duplicating join points], we also want Plan B-  when `f` is a data constructor.--Plan A is often good. Here's an example from #3116-     go (n+1) (case l of-                 1  -> bs'-                 _  -> Chunk p fpc (o+1) (l-1) bs')--If we pushed the entire call for 'go' inside the case, we get-call-pattern specialisation for 'go', which is *crucial* for-this particular program.--Here is another example.-        && E (case x of { T -> F; F -> T })--Pushing the call inward (being careful not to duplicate E)-        let a = E-        in case x of { T -> && a F; F -> && a T }--and now the (&& a F) etc can optimise.  Moreover there might-be a RULE for the function that can fire when it "sees" the-particular case alternative.--But Plan A can have terrible, terrible behaviour. Here is a classic-case:-  f (f (f (f (f True))))--Suppose f is strict, and has a body that is small enough to inline.-The innermost call inlines (seeing the True) to give-  f (f (f (f (case v of { True -> e1; False -> e2 }))))--Now, suppose we naively push the entire continuation into both-case branches (it doesn't look large, just f.f.f.f). We get-  case v of-    True  -> f (f (f (f e1)))-    False -> f (f (f (f e2)))--And now the process repeats, so we end up with an exponentially large-number of copies of f. No good!--CONCLUSION: we want Plan A in general, but do Plan B is there a-danger of this nested call behaviour. The function that decides-this is called thumbsUpPlanA.--Note [Keeping demand info in StrictArg Plan A]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Following on from Note [Duplicating StrictArg], another common code-pattern that can go bad is this:-   f (case x1 of { T -> F; F -> T })-     (case x2 of { T -> F; F -> T })-     ...etc...-when f is strict in all its arguments.  (It might, for example, be a-strict data constructor whose wrapper has not yet been inlined.)--We use Plan A (because there is no nesting) giving-  let a2 = case x2 of ...-      a3 = case x3 of ...-  in case x1 of { T -> f F a2 a3 ... ; F -> f T a2 a3 ... }--Now we must be careful!  a2 and a3 are small, and the OneOcc code in-postInlineUnconditionally may inline them both at both sites; see Note-Note [Inline small things to avoid creating a thunk] in-Simplify.Utils. But if we do inline them, the entire process will-repeat -- back to exponential behaviour.--So we are careful to keep the demand-info on a2 and a3.  Then they'll-be /strict/ let-bindings, which will be dealt with by StrictBind.-That's why contIsDupableWithDmds is careful to propagage demand-info to the auxiliary bindings it creates.  See the Demand argument-to makeTrivial.--Note [Duplicating StrictBind]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We make a StrictBind duplicable in a very similar way to-that for case expressions.  After all,-   let x* = e in b   is similar to    case e of x -> b--So we potentially make a join-point for the body, thus:-   let x = <> in b   ==>   join j x = b-                           in j <>--Just like StrictArg in fact -- and indeed they share code.--Note [Join point abstraction]  Historical note-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-NB: This note is now historical, describing how (in the past) we used-to add a void argument to nullary join points.  But now that "join-point" is not a fuzzy concept but a formal syntactic construct (as-distinguished by the JoinId constructor of IdDetails), each of these-concerns is handled separately, with no need for a vestigial extra-argument.--Join points always have at least one value argument,-for several reasons--* If we try to lift a primitive-typed something out-  for let-binding-purposes, we will *caseify* it (!),-  with potentially-disastrous strictness results.  So-  instead we turn it into a function: \v -> e-  where v::Void#.  The value passed to this function is void,-  which generates (almost) no code.--* CPR.  We used to say "&& isUnliftedType rhs_ty'" here, but now-  we make the join point into a function whenever used_bndrs'-  is empty.  This makes the join-point more CPR friendly.-  Consider:       let j = if .. then I# 3 else I# 4-                  in case .. of { A -> j; B -> j; C -> ... }--  Now CPR doesn't w/w j because it's a thunk, so-  that means that the enclosing function can't w/w either,-  which is a lose.  Here's the example that happened in practice:-          kgmod :: Int -> Int -> Int-          kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0-                      then 78-                      else 5--* Let-no-escape.  We want a join point to turn into a let-no-escape-  so that it is implemented as a jump, and one of the conditions-  for LNE is that it's not updatable.  In CoreToStg, see-  Note [What is a non-escaping let]--* Floating.  Since a join point will be entered once, no sharing is-  gained by floating out, but something might be lost by doing-  so because it might be allocated.--I have seen a case alternative like this:-        True -> \v -> ...-It's a bit silly to add the realWorld dummy arg in this case, making-        $j = \s v -> ...-           True -> $j s-(the \v alone is enough to make CPR happy) but I think it's rare--There's a slight infelicity here: we pass the overall-case_bndr to all the join points if it's used in *any* RHS,-because we don't know its usage in each RHS separately----************************************************************************-*                                                                      *-                    Unfoldings-*                                                                      *-************************************************************************--}--simplLetUnfolding :: SimplEnv-> TopLevelFlag-                  -> MaybeJoinCont-                  -> InId-                  -> OutExpr -> OutType -> ArityType-                  -> Unfolding -> SimplM Unfolding-simplLetUnfolding env top_lvl cont_mb id new_rhs rhs_ty arity unf-  | isStableUnfolding unf-  = simplStableUnfolding env top_lvl cont_mb id rhs_ty arity unf-  | isExitJoinId id-  = return noUnfolding -- See Note [Do not inline exit join points] in GHC.Core.Opt.Exitify-  | otherwise-  = -- Otherwise, we end up retaining all the SimpleEnv-    let !opts = seUnfoldingOpts env-    in mkLetUnfolding opts top_lvl InlineRhs id new_rhs----------------------mkLetUnfolding :: UnfoldingOpts -> TopLevelFlag -> UnfoldingSource-               -> InId -> OutExpr -> SimplM Unfolding-mkLetUnfolding !uf_opts top_lvl src id new_rhs-  = return (mkUnfolding uf_opts src is_top_lvl is_bottoming new_rhs)-            -- We make an  unfolding *even for loop-breakers*.-            -- Reason: (a) It might be useful to know that they are WHNF-            --         (b) In GHC.Iface.Tidy we currently assume that, if we want to-            --             expose the unfolding then indeed we *have* an unfolding-            --             to expose.  (We could instead use the RHS, but currently-            --             we don't.)  The simple thing is always to have one.-  where-    -- Might as well force this, profiles indicate up to 0.5MB of thunks-    -- just from this site.-    !is_top_lvl   = isTopLevel top_lvl-    -- See Note [Force bottoming field]-    !is_bottoming = isDeadEndId id----------------------simplStableUnfolding :: SimplEnv -> TopLevelFlag-                     -> MaybeJoinCont  -- Just k => a join point with continuation k-                     -> InId-                     -> OutType-                     -> ArityType      -- Used to eta expand, but only for non-join-points-                     -> Unfolding-                     ->SimplM Unfolding--- Note [Setting the new unfolding]-simplStableUnfolding env top_lvl mb_cont id rhs_ty id_arity unf-  = case unf of-      NoUnfolding   -> return unf-      BootUnfolding -> return unf-      OtherCon {}   -> return unf--      DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }-        -> do { (env', bndrs') <- simplBinders unf_env bndrs-              ; args' <- mapM (simplExpr env') args-              ; return (mkDFunUnfolding bndrs' con args') }--      CoreUnfolding { uf_tmpl = expr, uf_src = src, uf_guidance = guide }-        | isStableSource src-        -> do { expr' <- case mb_cont of-                           Just cont -> -- Binder is a join point-                                        -- See Note [Rules and unfolding for join points]-                                        simplJoinRhs unf_env id expr cont-                           Nothing   -> -- Binder is not a join point-                                        do { expr' <- simplExprC unf_env expr (mkBoringStop rhs_ty)-                                           ; return (eta_expand expr') }-              ; case guide of-                  UnfWhen { ug_arity = arity-                          , ug_unsat_ok = sat_ok-                          , ug_boring_ok = boring_ok-                          }-                          -- Happens for INLINE things-                        -- Really important to force new_boring_ok as otherwise-                        -- `ug_boring_ok` is a thunk chain of-                        -- inlineBoringExprOk expr0-                        --  || inlineBoringExprOk expr1 || ...-                        --  See #20134-                     -> let !new_boring_ok = boring_ok || inlineBoringOk expr'-                            guide' =-                              UnfWhen { ug_arity = arity-                                      , ug_unsat_ok = sat_ok-                                      , ug_boring_ok = new_boring_ok--                                      }-                        -- Refresh the boring-ok flag, in case expr'-                        -- has got small. This happens, notably in the inlinings-                        -- for dfuns for single-method classes; see-                        -- Note [Single-method classes] in GHC.Tc.TyCl.Instance.-                        -- A test case is #4138-                        -- But retain a previous boring_ok of True; e.g. see-                        -- the way it is set in calcUnfoldingGuidanceWithArity-                        in return (mkCoreUnfolding src is_top_lvl expr' guide')-                            -- See Note [Top-level flag on inline rules] in GHC.Core.Unfold--                  _other              -- Happens for INLINABLE things-                     -> mkLetUnfolding uf_opts top_lvl src id expr' }-                -- If the guidance is UnfIfGoodArgs, this is an INLINABLE-                -- unfolding, and we need to make sure the guidance is kept up-                -- to date with respect to any changes in the unfolding.--        | otherwise -> return noUnfolding   -- Discard unstable unfoldings-  where-    uf_opts    = seUnfoldingOpts env-    -- Forcing this can save about 0.5MB of max residency and the result-    -- is small and easy to compute so might as well force it.-    !is_top_lvl = isTopLevel top_lvl-    act        = idInlineActivation id-    unf_env    = updMode (updModeForStableUnfoldings act) env-         -- See Note [Simplifying inside stable unfoldings] in GHC.Core.Opt.Simplify.Utils--    -- See Note [Eta-expand stable unfoldings]-    eta_expand expr-      | not eta_on         = expr-      | exprIsTrivial expr = expr-      | otherwise          = etaExpandAT id_arity expr-    eta_on = sm_eta_expand (getMode env)--{- Note [Eta-expand stable unfoldings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For INLINE/INLINABLE things (which get stable unfoldings) there's a danger-of getting-   f :: Int -> Int -> Int -> Blah-   [ Arity = 3                 -- Good arity-   , Unf=Stable (\xy. blah)    -- Less good arity, only 2-   f = \pqr. e--This can happen because f's RHS is optimised more vigorously than-its stable unfolding.  Now suppose we have a call-   g = f x-Because f has arity=3, g will have arity=2.  But if we inline f (using-its stable unfolding) g's arity will reduce to 1, because <blah>-hasn't been optimised yet.  This happened in the 'parsec' library,-for Text.Pasec.Char.string.--Generally, if we know that 'f' has arity N, it seems sensible to-eta-expand the stable unfolding to arity N too. Simple and consistent.--Wrinkles--* See Note [Eta-expansion in stable unfoldings] in-  GHC.Core.Opt.Simplify.Utils--* Don't eta-expand a trivial expr, else each pass will eta-reduce it,-  and then eta-expand again. See Note [Do not eta-expand trivial expressions]-  in GHC.Core.Opt.Simplify.Utils.--* Don't eta-expand join points; see Note [Do not eta-expand join points]-  in GHC.Core.Opt.Simplify.Utils.  We uphold this because the join-point-  case (mb_cont = Just _) doesn't use eta_expand.--Note [Force bottoming field]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We need to force bottoming, or the new unfolding holds-on to the old unfolding (which is part of the id).--Note [Setting the new unfolding]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-* If there's an INLINE pragma, we simplify the RHS gently.  Maybe we-  should do nothing at all, but simplifying gently might get rid of-  more crap.--* If not, we make an unfolding from the new RHS.  But *only* for-  non-loop-breakers. Making loop breakers not have an unfolding at all-  means that we can avoid tests in exprIsConApp, for example.  This is-  important: if exprIsConApp says 'yes' for a recursive thing, then we-  can get into an infinite loop--If there's a stable unfolding on a loop breaker (which happens for-INLINABLE), we hang on to the inlining.  It's pretty dodgy, but the-user did say 'INLINE'.  May need to revisit this choice.--************************************************************************-*                                                                      *-                    Rules-*                                                                      *-************************************************************************--Note [Rules in a letrec]-~~~~~~~~~~~~~~~~~~~~~~~~-After creating fresh binders for the binders of a letrec, we-substitute the RULES and add them back onto the binders; this is done-*before* processing any of the RHSs.  This is important.  Manuel found-cases where he really, really wanted a RULE for a recursive function-to apply in that function's own right-hand side.--See Note [Forming Rec groups] in "GHC.Core.Opt.OccurAnal"--}--addBndrRules :: SimplEnv -> InBndr -> OutBndr-             -> MaybeJoinCont   -- Just k for a join point binder-                                -- Nothing otherwise-             -> SimplM (SimplEnv, OutBndr)--- Rules are added back into the bin-addBndrRules env in_id out_id mb_cont-  | null old_rules-  = return (env, out_id)-  | otherwise-  = do { new_rules <- simplRules env (Just out_id) old_rules mb_cont-       ; let final_id  = out_id `setIdSpecialisation` mkRuleInfo new_rules-       ; return (modifyInScope env final_id, final_id) }-  where-    old_rules = ruleInfoRules (idSpecialisation in_id)--simplRules :: SimplEnv -> Maybe OutId -> [CoreRule]-           -> MaybeJoinCont -> SimplM [CoreRule]-simplRules env mb_new_id rules mb_cont-  = mapM simpl_rule rules-  where-    simpl_rule rule@(BuiltinRule {})-      = return rule--    simpl_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args-                          , ru_fn = fn_name, ru_rhs = rhs-                          , ru_act = act })-      = do { (env', bndrs') <- simplBinders env bndrs-           ; let rhs_ty = substTy env' (exprType rhs)-                 rhs_cont = case mb_cont of  -- See Note [Rules and unfolding for join points]-                                Nothing   -> mkBoringStop rhs_ty-                                Just cont -> ASSERT2( join_ok, bad_join_msg )-                                             cont-                 lhs_env = updMode updModeForRules env'-                 rhs_env = updMode (updModeForStableUnfoldings act) env'-                           -- See Note [Simplifying the RHS of a RULE]-                 fn_name' = case mb_new_id of-                              Just id -> idName id-                              Nothing -> fn_name--                 -- join_ok is an assertion check that the join-arity of the-                 -- binder matches that of the rule, so that pushing the-                 -- continuation into the RHS makes sense-                 join_ok = case mb_new_id of-                             Just id | Just join_arity <- isJoinId_maybe id-                                     -> length args == join_arity-                             _ -> False-                 bad_join_msg = vcat [ ppr mb_new_id, ppr rule-                                     , ppr (fmap isJoinId_maybe mb_new_id) ]--           ; args' <- mapM (simplExpr lhs_env) args-           ; rhs'  <- simplExprC rhs_env rhs rhs_cont-           ; return (rule { ru_bndrs = bndrs'-                          , ru_fn    = fn_name'-                          , ru_args  = args'-                          , ru_rhs   = rhs' }) }--{- Note [Simplifying the RHS of a RULE]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We can simplify the RHS of a RULE much as we do the RHS of a stable-unfolding.  We used to use the much more conservative updModeForRules-for the RHS as well as the LHS, but that seems more conservative-than necesary.  Allowing some inlining might, for example, eliminate-a binding.--}++{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates -Wno-incomplete-uni-patterns #-}+module GHC.Core.Opt.Simplify ( simplTopBinds, simplExpr, simplImpRules ) where++import GHC.Prelude++import GHC.Platform++import GHC.Driver.Session++import GHC.Core+import GHC.Core.Opt.Simplify.Monad+import GHC.Core.Type hiding ( substTy, substTyVar, extendTvSubst, extendCvSubst )+import GHC.Core.Opt.Simplify.Env+import GHC.Core.Opt.Simplify.Utils+import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr, zapLambdaBndrs )+import GHC.Core.Make       ( FloatBind, mkImpossibleExpr, castBottomExpr )+import qualified GHC.Core.Make+import GHC.Core.Coercion hiding ( substCo, substCoVar )+import GHC.Core.Reduction+import GHC.Core.Coercion.Opt    ( optCoercion )+import GHC.Core.FamInstEnv      ( FamInstEnv, topNormaliseType_maybe )+import GHC.Core.DataCon+   ( DataCon, dataConWorkId, dataConRepStrictness+   , dataConRepArgTys, isUnboxedTupleDataCon+   , StrictnessMark (..) )+import GHC.Core.Opt.Monad ( Tick(..), SimplMode(..) )+import GHC.Core.Ppr     ( pprCoreExpr )+import GHC.Core.Unfold+import GHC.Core.Unfold.Make+import GHC.Core.Utils+import GHC.Core.Opt.Arity ( ArityType(..)+                          , pushCoTyArg, pushCoValArg+                          , etaExpandAT )+import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe )+import GHC.Core.FVs     ( mkRuleInfo )+import GHC.Core.Rules   ( lookupRule, getRules, initRuleOpts )+import GHC.Core.Multiplicity++import GHC.Types.Literal   ( litIsLifted ) --, mkLitInt ) -- temporarily commented out. See #8326+import GHC.Types.SourceText+import GHC.Types.Id+import GHC.Types.Id.Make   ( seqId )+import GHC.Types.Id.Info+import GHC.Types.Name   ( mkSystemVarName, isExternalName, getOccFS )+import GHC.Types.Demand+import GHC.Types.Cpr    ( mkCprSig, botCpr )+import GHC.Types.Unique ( hasKey )+import GHC.Types.Basic+import GHC.Types.Tickish+import GHC.Types.Var    ( isTyCoVar )+import GHC.Builtin.PrimOps ( PrimOp (SeqOp) )+import GHC.Builtin.Types.Prim( realWorldStatePrimTy )+import GHC.Builtin.Names( runRWKey )++import GHC.Data.Maybe   ( isNothing, orElse )+import GHC.Data.FastString+import GHC.Unit.Module ( moduleName, pprModuleName )+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.Trace+import GHC.Utils.Monad  ( mapAccumLM, liftIO )+import GHC.Utils.Logger++import Control.Monad++{-+The guts of the simplifier is in this module, but the driver loop for+the simplifier is in GHC.Core.Opt.Pipeline++Note [The big picture]+~~~~~~~~~~~~~~~~~~~~~~+The general shape of the simplifier is this:++  simplExpr :: SimplEnv -> InExpr -> SimplCont -> SimplM (SimplFloats, OutExpr)+  simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv)++ * SimplEnv contains+     - Simplifier mode (which includes DynFlags for convenience)+     - Ambient substitution+     - InScopeSet++ * SimplFloats contains+     - Let-floats (which includes ok-for-spec case-floats)+     - Join floats+     - InScopeSet (including all the floats)++ * Expressions+      simplExpr :: SimplEnv -> InExpr -> SimplCont+                -> SimplM (SimplFloats, OutExpr)+   The result of simplifying an /expression/ is (floats, expr)+      - A bunch of floats (let bindings, join bindings)+      - A simplified expression.+   The overall result is effectively (let floats in expr)++ * Bindings+      simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv)+   The result of simplifying a binding is+     - A bunch of floats, the last of which is the simplified binding+       There may be auxiliary bindings too; see prepareRhs+     - An environment suitable for simplifying the scope of the binding++   The floats may also be empty, if the binding is inlined unconditionally;+   in that case the returned SimplEnv will have an augmented substitution.++   The returned floats and env both have an in-scope set, and they are+   guaranteed to be the same.+++Note [Shadowing]+~~~~~~~~~~~~~~~~+The simplifier used to guarantee that the output had no shadowing, but+it does not do so any more.   (Actually, it never did!)  The reason is+documented with simplifyArgs.+++Eta expansion+~~~~~~~~~~~~~~+For eta expansion, we want to catch things like++        case e of (a,b) -> \x -> case a of (p,q) -> \y -> r++If the \x was on the RHS of a let, we'd eta expand to bring the two+lambdas together.  And in general that's a good thing to do.  Perhaps+we should eta expand wherever we find a (value) lambda?  Then the eta+expansion at a let RHS can concentrate solely on the PAP case.++Note [In-scope set as a substitution]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As per Note [Lookups in in-scope set], an in-scope set can act as+a substitution. Specifically, it acts as a substitution from variable to+variables /with the same unique/.++Why do we need this? Well, during the course of the simplifier, we may want to+adjust inessential properties of a variable. For instance, when performing a+beta-reduction, we change++    (\x. e) u ==> let x = u in e++We typically want to add an unfolding to `x` so that it inlines to (the+simplification of) `u`.++We do that by adding the unfolding to the binder `x`, which is added to the+in-scope set. When simplifying occurrences of `x` (every occurrence!), they are+replaced by their “updated” version from the in-scope set, hence inherit the+unfolding. This happens in `SimplEnv.substId`.++Another example. Consider++   case x of y { Node a b -> ...y...+               ; Leaf v   -> ...y... }++In the Node branch want y's unfolding to be (Node a b); in the Leaf branch we+want y's unfolding to be (Leaf v). We achieve this by adding the appropriate+unfolding to y, and re-adding it to the in-scope set. See the calls to+`addBinderUnfolding` in `Simplify.addAltUnfoldings` and elsewhere.++It's quite convenient. This way we don't need to manipulate the substitution all+the time: every update to a binder is automatically reflected to its bound+occurrences.++Note [Bangs in the Simplifier]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Both SimplFloats and SimplEnv do *not* generally benefit from making+their fields strict. I don't know if this is because of good use of+laziness or unintended side effects like closures capturing more variables+after WW has run.++But the end result is that we keep these lazy, but force them in some places+where we know it's beneficial to the compiler.++Similarly environments returned from functions aren't *always* beneficial to+force. In some places they would never be demanded so forcing them early+increases allocation. In other places they almost always get demanded so+it's worthwhile to force them early.++Would it be better to through every allocation of e.g. SimplEnv and decide+wether or not to make this one strict? Absolutely! Would be a good use of+someones time? Absolutely not! I made these strict that showed up during+a profiled build or which I noticed while looking at core for one reason+or another.++The result sadly is that we end up with "random" bangs in the simplifier+where we sometimes force e.g. the returned environment from a function and+sometimes we don't for the same function. Depending on the context around+the call. The treatment is also not very consistent. I only added bangs+where I saw it making a difference either in the core or benchmarks. Some+patterns where it would be beneficial aren't convered as a consequence as+I neither have the time to go through all of the core and some cases are+too small to show up in benchmarks.++++************************************************************************+*                                                                      *+\subsection{Bindings}+*                                                                      *+************************************************************************+-}++simplTopBinds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv)+-- See Note [The big picture]+simplTopBinds env0 binds0+  = do  {       -- Put all the top-level binders into scope at the start+                -- so that if a rewrite rule has unexpectedly brought+                -- anything into scope, then we don't get a complaint about that.+                -- It's rather as if the top-level binders were imported.+                -- See Note [Glomming] in "GHC.Core.Opt.OccurAnal".+        -- See Note [Bangs in the Simplifier]+        ; !env1 <- {-#SCC "simplTopBinds-simplRecBndrs" #-} simplRecBndrs env0 (bindersOfBinds binds0)+        ; (floats, env2) <- {-#SCC "simplTopBinds-simpl_binds" #-} simpl_binds env1 binds0+        ; freeTick SimplifierDone+        ; return (floats, env2) }+  where+        -- We need to track the zapped top-level binders, because+        -- they should have their fragile IdInfo zapped (notably occurrence info)+        -- That's why we run down binds and bndrs' simultaneously.+        --+    simpl_binds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv)+    simpl_binds env []           = return (emptyFloats env, env)+    simpl_binds env (bind:binds) = do { (float,  env1) <- simpl_bind env bind+                                      ; (floats, env2) <- simpl_binds env1 binds+                                      -- See Note [Bangs in the Simplifier]+                                      ; let !floats1 = float `addFloats` floats+                                      ; return (floats1, env2) }++    simpl_bind env (Rec pairs)+      = simplRecBind env (BC_Let TopLevel Recursive) pairs+    simpl_bind env (NonRec b r)+      = do { let bind_cxt = BC_Let TopLevel NonRecursive+           ; (env', b') <- addBndrRules env b (lookupRecBndr env b) bind_cxt+           ; simplRecOrTopPair env' bind_cxt b b' r }++{-+************************************************************************+*                                                                      *+        Lazy bindings+*                                                                      *+************************************************************************++simplRecBind is used for+        * recursive bindings only+-}++simplRecBind :: SimplEnv -> BindContext+             -> [(InId, InExpr)]+             -> SimplM (SimplFloats, SimplEnv)+simplRecBind env0 bind_cxt pairs0+  = do  { (env_with_info, triples) <- mapAccumLM add_rules env0 pairs0+        ; (rec_floats, env1) <- go env_with_info triples+        ; return (mkRecFloats rec_floats, env1) }+  where+    add_rules :: SimplEnv -> (InBndr,InExpr) -> SimplM (SimplEnv, (InBndr, OutBndr, InExpr))+        -- Add the (substituted) rules to the binder+    add_rules env (bndr, rhs)+        = do { (env', bndr') <- addBndrRules env bndr (lookupRecBndr env bndr) bind_cxt+             ; return (env', (bndr, bndr', rhs)) }++    go env [] = return (emptyFloats env, env)++    go env ((old_bndr, new_bndr, rhs) : pairs)+        = do { (float, env1) <- simplRecOrTopPair env bind_cxt+                                                  old_bndr new_bndr rhs+             ; (floats, env2) <- go env1 pairs+             ; return (float `addFloats` floats, env2) }++{-+simplOrTopPair is used for+        * recursive bindings (whether top level or not)+        * top-level non-recursive bindings++It assumes the binder has already been simplified, but not its IdInfo.+-}++simplRecOrTopPair :: SimplEnv+                  -> BindContext+                  -> InId -> OutBndr -> InExpr  -- Binder and rhs+                  -> SimplM (SimplFloats, SimplEnv)++simplRecOrTopPair env bind_cxt old_bndr new_bndr rhs+  | Just env' <- preInlineUnconditionally env (bindContextLevel bind_cxt)+                                          old_bndr rhs env+  = {-#SCC "simplRecOrTopPair-pre-inline-uncond" #-}+    simplTrace env "SimplBindr:inline-uncond" (ppr old_bndr) $+    do { tick (PreInlineUnconditionally old_bndr)+       ; return ( emptyFloats env, env' ) }++  | otherwise+  = case bind_cxt of+      BC_Join cont  -> simplTrace env "SimplBind:join" (ppr old_bndr) $+                       simplJoinBind env cont old_bndr new_bndr rhs env++      BC_Let top_lvl is_rec -> simplTrace env "SimplBind:normal" (ppr old_bndr) $+                               simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env++simplTrace :: SimplEnv -> String -> SDoc -> a -> a+simplTrace env herald doc thing_inside+  | not (logHasDumpFlag logger Opt_D_verbose_core2core)+  = thing_inside+  | otherwise+  = logTraceMsg logger herald doc thing_inside+  where+    logger = seLogger env++--------------------------+simplLazyBind :: SimplEnv+              -> TopLevelFlag -> RecFlag+              -> InId -> OutId          -- Binder, both pre-and post simpl+                                        -- Not a JoinId+                                        -- The OutId has IdInfo, except arity, unfolding+                                        -- Ids only, no TyVars+              -> InExpr -> SimplEnv     -- The RHS and its environment+              -> SimplM (SimplFloats, SimplEnv)+-- Precondition: the OutId is already in the InScopeSet of the incoming 'env'+-- Precondition: not a JoinId+-- Precondition: rhs obeys the let/app invariant+-- NOT used for JoinIds+simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se+  = assert (isId bndr )+    assertPpr (not (isJoinId bndr)) (ppr bndr) $+    -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $+    do  { let   !rhs_env     = rhs_se `setInScopeFromE` env -- See Note [Bangs in the Simplifier]+                (tvs, body) = case collectTyAndValBinders rhs of+                                (tvs, [], body)+                                  | surely_not_lam body -> (tvs, body)+                                _                       -> ([], rhs)++                surely_not_lam (Lam {})     = False+                surely_not_lam (Tick t e)+                  | not (tickishFloatable t) = surely_not_lam e+                   -- eta-reduction could float+                surely_not_lam _            = True+                        -- Do not do the "abstract tyvar" thing if there's+                        -- a lambda inside, because it defeats eta-reduction+                        --    f = /\a. \x. g a x+                        -- should eta-reduce.++        ; (body_env, tvs') <- {-#SCC "simplBinders" #-} simplBinders rhs_env tvs+                -- See Note [Floating and type abstraction] in GHC.Core.Opt.Simplify.Utils++        -- Simplify the RHS+        ; let rhs_cont = mkRhsStop (substTy body_env (exprType body))+        ; (body_floats0, body0) <- {-#SCC "simplExprF" #-} simplExprF body_env body rhs_cont++        -- ANF-ise a constructor or PAP rhs+        ; (body_floats2, body2) <- {-#SCC "prepareBinding" #-}+                                   prepareBinding env top_lvl is_rec+                                                  False  -- Not strict; this is simplLazyBind+                                                  bndr1 body_floats0 body0+          -- Subtle point: we do not need or want tvs' in the InScope set+          -- of body_floats2, so we pass in 'env' not 'body_env'.+          -- Don't want: if tvs' are in-scope in the scope of this let-binding, we may do+          -- more renaming than necessary => extra work (see !7777 and test T16577).+          -- Don't need: we wrap tvs' around the RHS anyway.++        ; (rhs_floats, body3)+            <-  if isEmptyFloats body_floats2 || null tvs then   -- Simple floating+                     {-#SCC "simplLazyBind-simple-floating" #-}+                     return (body_floats2, body2)++                else -- Non-empty floats, and non-empty tyvars: do type-abstraction first+                     {-#SCC "simplLazyBind-type-abstraction-first" #-}+                     do { (poly_binds, body3) <- abstractFloats (seUnfoldingOpts env) top_lvl+                                                                tvs' body_floats2 body2+                        ; let floats = foldl' extendFloats (emptyFloats env) poly_binds+                        ; return (floats, body3) }++        ; let env' = env `setInScopeFromF` rhs_floats+        ; rhs' <- mkLam env' tvs' body3 rhs_cont+        ; (bind_float, env2) <- completeBind env' (BC_Let top_lvl is_rec) bndr bndr1 rhs'+        ; return (rhs_floats `addFloats` bind_float, env2) }++--------------------------+simplJoinBind :: SimplEnv+              -> SimplCont+              -> InId -> OutId          -- Binder, both pre-and post simpl+                                        -- The OutId has IdInfo, except arity,+                                        --   unfolding+              -> InExpr -> SimplEnv     -- The right hand side and its env+              -> SimplM (SimplFloats, SimplEnv)+simplJoinBind env cont old_bndr new_bndr rhs rhs_se+  = do  { let rhs_env = rhs_se `setInScopeFromE` env+        ; rhs' <- simplJoinRhs rhs_env old_bndr rhs cont+        ; completeBind env (BC_Join cont) old_bndr new_bndr rhs' }++--------------------------+simplNonRecX :: SimplEnv+             -> InId            -- Old binder; not a JoinId+             -> OutExpr         -- Simplified RHS+             -> SimplM (SimplFloats, SimplEnv)+-- A specialised variant of simplNonRec used when the RHS is already+-- simplified, notably in knownCon.  It uses case-binding where necessary.+--+-- Precondition: rhs satisfies the let/app invariant++simplNonRecX env bndr new_rhs+  | assertPpr (not (isJoinId bndr)) (ppr bndr) $+    isDeadBinder bndr   -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p }+  = return (emptyFloats env, env)    --  Here c is dead, and we avoid+                                         --  creating the binding c = (a,b)++  | Coercion co <- new_rhs+  = return (emptyFloats env, extendCvSubst env bndr co)++  | exprIsTrivial new_rhs  -- Short-cut for let x = y in ...+    -- This case would ultimately land in postInlineUnconditionally+    -- but it seems not uncommon, and avoids a lot of faff to do it here+  = return (emptyFloats env+           , extendIdSubst env bndr (DoneEx new_rhs Nothing))++  | otherwise+  = do  { (env1, new_bndr)   <- simplBinder env bndr+        ; let is_strict = isStrictId new_bndr+              -- isStrictId: use new_bndr because the InId bndr might not have+              -- a fixed runtime representation, which isStrictId doesn't expect+              -- c.f. Note [Dark corner with representation polymorphism]++        ; (rhs_floats, rhs1) <- prepareBinding env NotTopLevel NonRecursive is_strict+                                               new_bndr (emptyFloats env) new_rhs+              -- NB: it makes a surprisingly big difference (5% in compiler allocation+              -- in T9630) to pass 'env' rather than 'env1'.  It's fine to pass 'env',+              -- because this is simplNonRecX, so bndr is not in scope in the RHS.++        ; (bind_float, env2) <- completeBind (env1 `setInScopeFromF` rhs_floats)+                                             (BC_Let NotTopLevel NonRecursive)+                                             bndr new_bndr rhs1+              -- Must pass env1 to completeBind in case simplBinder had to clone,+              -- and extended the substitution with [bndr :-> new_bndr]++        ; return (rhs_floats `addFloats` bind_float, env2) }+++{- *********************************************************************+*                                                                      *+           Cast worker/wrapper+*                                                                      *+************************************************************************++Note [Cast worker/wrapper]+~~~~~~~~~~~~~~~~~~~~~~~~~~+When we have a binding+   x = e |> co+we want to do something very similar to worker/wrapper:+   $wx = e+   x = $wx |> co++We call this making a cast worker/wrapper in tryCastWorkerWrapper.++The main motivaiton is that x can be inlined freely.  There's a chance+that e will be a constructor application or function, or something+like that, so moving the coercion to the usage site may well cancel+the coercions and lead to further optimisation.  Example:++     data family T a :: *+     data instance T Int = T Int++     foo :: Int -> Int -> Int+     foo m n = ...+        where+          t = T m+          go 0 = 0+          go n = case t of { T m -> go (n-m) }+                -- This case should optimise++A second reason for doing cast worker/wrapper is that the worker/wrapper+pass after strictness analysis can't deal with RHSs like+     f = (\ a b c. blah) |> co+Instead, it relies on cast worker/wrapper to get rid of the cast,+leaving a simpler job for demand-analysis worker/wrapper.  See #19874.++Wrinkles++1. We must /not/ do cast w/w on+     f = g |> co+   otherwise it'll just keep repeating forever! You might think this+   is avoided because the call to tryCastWorkerWrapper is guarded by+   preInlineUnconditinally, but I'm worried that a loop-breaker or an+   exported Id might say False to preInlineUnonditionally.++2. We need to be careful with inline/noinline pragmas:+       rec { {-# NOINLINE f #-}+             f = (...g...) |> co+           ; g = ...f... }+   This is legitimate -- it tells GHC to use f as the loop breaker+   rather than g.  Now we do the cast thing, to get something like+       rec { $wf = ...g...+           ; f = $wf |> co+           ; g = ...f... }+   Where should the NOINLINE pragma go?  If we leave it on f we'll get+     rec { $wf = ...g...+         ; {-# NOINLINE f #-}+           f = $wf |> co+         ; g = ...f... }+   and that is bad: the whole point is that we want to inline that+   cast!  We want to transfer the pagma to $wf:+      rec { {-# NOINLINE $wf #-}+            $wf = ...g...+          ; f = $wf |> co+          ; g = ...f... }+   c.f. Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap.++3. We should still do cast w/w even if `f` is INLINEABLE.  E.g.+      {- f: Stable unfolding = <stable-big> -}+      f = (\xy. <big-body>) |> co+   Then we want to w/w to+      {- $wf: Stable unfolding = <stable-big> |> sym co -}+      $wf = \xy. <big-body>+      f = $wf |> co+   Notice that the stable unfolding moves to the worker!  Now demand analysis+   will work fine on $wf, whereas it has trouble with the original f.+   c.f. Note [Worker/wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap.+   This point also applies to strong loopbreakers with INLINE pragmas, see+   wrinkle (4).++4. We should /not/ do cast w/w for non-loop-breaker INLINE functions (hence+   hasInlineUnfolding in tryCastWorkerWrapper, which responds False to+   loop-breakers) because they'll definitely be inlined anyway, cast and+   all. And if we do cast w/w for an INLINE function with arity zero, we get+   something really silly: we inline that "worker" right back into the wrapper!+   Worse than a no-op, because we have then lost the stable unfolding.++All these wrinkles are exactly like worker/wrapper for strictness analysis:+  f is the wrapper and must inline like crazy+  $wf is the worker and must carry f's original pragma+See Note [Worker/wrapper for INLINABLE functions]+and Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap.++See #17673, #18093, #18078, #19890.++Note [Preserve strictness in cast w/w]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the Note [Cast worker/wrapper] transformation, keep the strictness info.+Eg+        f = e `cast` co    -- f has strictness SSL+When we transform to+        f' = e             -- f' also has strictness SSL+        f = f' `cast` co   -- f still has strictness SSL++Its not wrong to drop it on the floor, but better to keep it.++Note [Preserve RuntimeRep info in cast w/w]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We must not do cast w/w when the presence of the coercion is needed in order+to determine the runtime representation.++Example:++  Suppose we have a type family:++    type F :: RuntimeRep+    type family F where+      F = LiftedRep++  together with a type `ty :: TYPE F` and a top-level binding++    a :: ty |> TYPE F[0]++  The kind of `ty |> TYPE F[0]` is `LiftedRep`, so `a` is a top-level lazy binding.+  However, were we to apply cast w/w, we would get:++    b :: ty+    b = ...++    a :: ty |> TYPE F[0]+    a = b `cast` GRefl (TYPE F[0])++  Now we are in trouble because `ty :: TYPE F` does not have a known runtime+  representation, because we need to be able to reduce the nullary type family+  application `F` to find that out.++Conclusion: only do cast w/w when doing so would not lose the RuntimeRep+information. That is, when handling `Cast rhs co`, don't attempt cast w/w+unless the kind of the type of rhs is concrete, in the sense of+Note [Concrete types] in GHC.Tc.Utils.Concrete.+-}++tryCastWorkerWrapper :: SimplEnv -> BindContext+                     -> InId -> OccInfo+                     -> OutId -> OutExpr+                     -> SimplM (SimplFloats, SimplEnv)+-- See Note [Cast worker/wrapper]+tryCastWorkerWrapper env bind_cxt old_bndr occ_info bndr (Cast rhs co)+  | BC_Let top_lvl is_rec <- bind_cxt  -- Not join points+  , not (isDFunId bndr) -- nor DFuns; cast w/w is no help, and we can't transform+                        --            a DFunUnfolding in mk_worker_unfolding+  , not (exprIsTrivial rhs)        -- Not x = y |> co; Wrinkle 1+  , not (hasInlineUnfolding info)  -- Not INLINE things: Wrinkle 4+  , isConcrete (typeKind rhs_ty)   -- Don't peel off a cast if doing so would+                                   -- lose the underlying runtime representation.+                                   -- See Note [Preserve RuntimeRep info in cast w/w]+  , not (isOpaquePragma (idInlinePragma old_bndr)) -- Not for OPAQUE bindings+                                                   -- See Note [OPAQUE pragma]+  = do  { uniq <- getUniqueM+        ; let work_name = mkSystemVarName uniq occ_fs+              work_id   = mkLocalIdWithInfo work_name Many rhs_ty worker_info+              is_strict = isStrictId bndr++        ; (rhs_floats, work_rhs) <- prepareBinding env top_lvl is_rec is_strict+                                                   work_id (emptyFloats env) rhs++        ; work_unf <- mk_worker_unfolding top_lvl work_id work_rhs+        ; let  work_id_w_unf = work_id `setIdUnfolding` work_unf+               floats   = rhs_floats `addLetFloats`+                          unitLetFloat (NonRec work_id_w_unf work_rhs)++               triv_rhs = Cast (Var work_id_w_unf) co++        ; if postInlineUnconditionally env bind_cxt bndr occ_info triv_rhs+             -- Almost always True, because the RHS is trivial+             -- In that case we want to eliminate the binding fast+             -- We conservatively use postInlineUnconditionally so that we+             -- check all the right things+          then do { tick (PostInlineUnconditionally bndr)+                  ; return ( floats+                           , extendIdSubst (setInScopeFromF env floats) old_bndr $+                             DoneEx triv_rhs Nothing ) }++          else do { wrap_unf <- mkLetUnfolding (sm_uf_opts mode) top_lvl InlineRhs bndr triv_rhs+                  ; let bndr' = bndr `setInlinePragma` mkCastWrapperInlinePrag (idInlinePragma bndr)+                                `setIdUnfolding`  wrap_unf+                        floats' = floats `extendFloats` NonRec bndr' triv_rhs+                  ; return ( floats', setInScopeFromF env floats' ) } }+  where+    mode   = getMode env+    occ_fs = getOccFS bndr+    rhs_ty = coercionLKind co+    info   = idInfo bndr++    worker_info = vanillaIdInfo `setDmdSigInfo`     dmdSigInfo info+                                `setCprSigInfo`     cprSigInfo info+                                `setDemandInfo`     demandInfo info+                                `setInlinePragInfo` inlinePragInfo info+                                `setArityInfo`      arityInfo info+           -- We do /not/ want to transfer OccInfo, Rules+           -- Note [Preserve strictness in cast w/w]+           -- and Wrinkle 2 of Note [Cast worker/wrapper]++    ----------- Worker unfolding -----------+    -- Stable case: if there is a stable unfolding we have to compose with (Sym co);+    --   the next round of simplification will do the job+    -- Non-stable case: use work_rhs+    -- Wrinkle 3 of Note [Cast worker/wrapper]+    mk_worker_unfolding top_lvl work_id work_rhs+      = case realUnfoldingInfo info of -- NB: the real one, even for loop-breakers+           unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src })+             | isStableSource src -> return (unf { uf_tmpl = mkCast unf_rhs (mkSymCo co) })+           _ -> mkLetUnfolding (sm_uf_opts mode) top_lvl InlineRhs work_id work_rhs++tryCastWorkerWrapper env _ _ _ bndr rhs  -- All other bindings+  = return (mkFloatBind env (NonRec bndr rhs))++mkCastWrapperInlinePrag :: InlinePragma -> InlinePragma+-- See Note [Cast worker/wrapper]+mkCastWrapperInlinePrag (InlinePragma { inl_act = act, inl_rule = rule_info })+  = InlinePragma { inl_src    = SourceText "{-# INLINE"+                 , inl_inline = NoUserInlinePrag -- See Note [Wrapper NoUserInlinePrag]+                 , inl_sat    = Nothing      --     in GHC.Core.Opt.WorkWrap+                 , inl_act    = wrap_act     -- See Note [Wrapper activation]+                 , inl_rule   = rule_info }  --     in GHC.Core.Opt.WorkWrap+                                -- RuleMatchInfo is (and must be) unaffected+  where+    -- See Note [Wrapper activation] in GHC.Core.Opt.WorkWrap+    -- But simpler, because we don't need to disable during InitialPhase+    wrap_act | isNeverActive act = activateDuringFinal+             | otherwise         = act+++{- *********************************************************************+*                                                                      *+           prepareBinding, prepareRhs, makeTrivial+*                                                                      *+********************************************************************* -}++prepareBinding :: SimplEnv -> TopLevelFlag -> RecFlag -> Bool+               -> Id   -- Used only for its OccName; can be InId or OutId+               -> SimplFloats -> OutExpr+               -> SimplM (SimplFloats, OutExpr)+-- In (prepareBinding ... bndr floats rhs), the binding is really just+--    bndr = let floats in rhs+-- Maybe we can ANF-ise this binding and float out; e.g.+--    bndr = let a = f x in K a a (g x)+-- we could float out to give+--    a    = f x+--    tmp  = g x+--    bndr = K a a tmp+-- That's what prepareBinding does+-- Precondition: binder is not a JoinId+prepareBinding env top_lvl is_rec strict_bind bndr rhs_floats rhs+  = do { -- Never float join-floats out of a non-join let-binding (which this is)+         -- So wrap the body in the join-floats right now+         -- Hence: rhs_floats1 consists only of let-floats+         let (rhs_floats1, rhs1) = wrapJoinFloatsX rhs_floats rhs++         -- rhs_env: add to in-scope set the binders from rhs_floats+         -- so that prepareRhs knows what is in scope in rhs+       ; let rhs_env = env `setInScopeFromF` rhs_floats1++       -- Now ANF-ise the remaining rhs+       ; (anf_floats, rhs2) <- prepareRhs rhs_env top_lvl (getOccFS bndr) rhs1++       -- Finally, decide whether or not to float+       ; let all_floats = rhs_floats1 `addLetFloats` anf_floats+       ; if doFloatFromRhs top_lvl is_rec strict_bind all_floats rhs2+         then -- Float!+              do { tick LetFloatFromLet+                 ; return (all_floats, rhs2) }++         else -- Abandon floating altogether; revert to original rhs+              -- Since we have already built rhs1, we just need to add+              -- rhs_floats1 to it+              return (emptyFloats env, wrapFloats rhs_floats1 rhs1) }++{- Note [prepareRhs]+~~~~~~~~~~~~~~~~~~~~+prepareRhs takes a putative RHS, checks whether it's a PAP or+constructor application and, if so, converts it to ANF, so that the+resulting thing can be inlined more easily.  Thus+        x = (f a, g b)+becomes+        t1 = f a+        t2 = g b+        x = (t1,t2)++We also want to deal well cases like this+        v = (f e1 `cast` co) e2+Here we want to make e1,e2 trivial and get+        x1 = e1; x2 = e2; v = (f x1 `cast` co) v2+That's what the 'go' loop in prepareRhs does+-}++prepareRhs :: SimplEnv -> TopLevelFlag+           -> FastString    -- Base for any new variables+           -> OutExpr+           -> SimplM (LetFloats, OutExpr)+-- Transforms a RHS into a better RHS by ANF'ing args+-- for expandable RHSs: constructors and PAPs+-- e.g        x = Just e+-- becomes    a = e               -- 'a' is fresh+--            x = Just a+-- See Note [prepareRhs]+prepareRhs env top_lvl occ rhs0+  = do  { (_is_exp, floats, rhs1) <- go 0 rhs0+        ; return (floats, rhs1) }+  where+    go :: Int -> OutExpr -> SimplM (Bool, LetFloats, OutExpr)+    go n_val_args (Cast rhs co)+        = do { (is_exp, floats, rhs') <- go n_val_args rhs+             ; return (is_exp, floats, Cast rhs' co) }+    go n_val_args (App fun (Type ty))+        = do { (is_exp, floats, rhs') <- go n_val_args fun+             ; return (is_exp, floats, App rhs' (Type ty)) }+    go n_val_args (App fun arg)+        = do { (is_exp, floats1, fun') <- go (n_val_args+1) fun+             ; case is_exp of+                False -> return (False, emptyLetFloats, App fun arg)+                True  -> do { (floats2, arg') <- makeTrivial env top_lvl topDmd occ arg+                            ; return (True, floats1 `addLetFlts` floats2, App fun' arg') } }+    go n_val_args (Var fun)+        = return (is_exp, emptyLetFloats, Var fun)+        where+          is_exp = isExpandableApp fun n_val_args   -- The fun a constructor or PAP+                        -- See Note [CONLIKE pragma] in GHC.Types.Basic+                        -- The definition of is_exp should match that in+                        -- 'GHC.Core.Opt.OccurAnal.occAnalApp'++    go n_val_args (Tick t rhs)+        -- We want to be able to float bindings past this+        -- tick. Non-scoping ticks don't care.+        | tickishScoped t == NoScope+        = do { (is_exp, floats, rhs') <- go n_val_args rhs+             ; return (is_exp, floats, Tick t rhs') }++        -- On the other hand, for scoping ticks we need to be able to+        -- copy them on the floats, which in turn is only allowed if+        -- we can obtain non-counting ticks.+        | (not (tickishCounts t) || tickishCanSplit t)+        = do { (is_exp, floats, rhs') <- go n_val_args rhs+             ; let tickIt (id, expr) = (id, mkTick (mkNoCount t) expr)+                   floats' = mapLetFloats floats tickIt+             ; return (is_exp, floats', Tick t rhs') }++    go _ other+        = return (False, emptyLetFloats, other)++makeTrivialArg :: SimplEnv -> ArgSpec -> SimplM (LetFloats, ArgSpec)+makeTrivialArg env arg@(ValArg { as_arg = e, as_dmd = dmd })+  = do { (floats, e') <- makeTrivial env NotTopLevel dmd (fsLit "arg") e+       ; return (floats, arg { as_arg = e' }) }+makeTrivialArg _ arg+  = return (emptyLetFloats, arg)  -- CastBy, TyArg++makeTrivial :: SimplEnv -> TopLevelFlag -> Demand+            -> FastString  -- ^ A "friendly name" to build the new binder from+            -> OutExpr     -- ^ This expression satisfies the let/app invariant+            -> SimplM (LetFloats, OutExpr)+-- Binds the expression to a variable, if it's not trivial, returning the variable+-- For the Demand argument, see Note [Keeping demand info in StrictArg Plan A]+makeTrivial env top_lvl dmd occ_fs expr+  | exprIsTrivial expr                          -- Already trivial+  || not (bindingOk top_lvl expr expr_ty)       -- Cannot trivialise+                                                --   See Note [Cannot trivialise]+  = return (emptyLetFloats, expr)++  | Cast expr' co <- expr+  = do { (floats, triv_expr) <- makeTrivial env top_lvl dmd occ_fs expr'+       ; return (floats, Cast triv_expr co) }++  | otherwise+  = do { (floats, new_id) <- makeTrivialBinding env top_lvl occ_fs+                                                id_info expr expr_ty+       ; return (floats, Var new_id) }+  where+    id_info = vanillaIdInfo `setDemandInfo` dmd+    expr_ty = exprType expr++makeTrivialBinding :: SimplEnv -> TopLevelFlag+                   -> FastString  -- ^ a "friendly name" to build the new binder from+                   -> IdInfo+                   -> OutExpr     -- ^ This expression satisfies the let/app invariant+                   -> OutType     -- Type of the expression+                   -> SimplM (LetFloats, OutId)+makeTrivialBinding env top_lvl occ_fs info expr expr_ty+  = do  { (floats, expr1) <- prepareRhs env top_lvl occ_fs expr+        ; uniq <- getUniqueM+        ; let name = mkSystemVarName uniq occ_fs+              var  = mkLocalIdWithInfo name Many expr_ty info++        -- Now something very like completeBind,+        -- but without the postInlineUnconditionally part+        ; (arity_type, expr2) <- tryEtaExpandRhs env var expr1+          -- Technically we should extend the in-scope set in 'env' with+          -- the 'floats' from prepareRHS; but they are all fresh, so there is+          -- no danger of introducing name shadowig in eta expansion++        ; unf <- mkLetUnfolding (sm_uf_opts mode) top_lvl InlineRhs var expr2++        ; let final_id = addLetBndrInfo var arity_type unf+              bind     = NonRec final_id expr2++        ; return ( floats `addLetFlts` unitLetFloat bind, final_id ) }+  where+    mode = getMode env++bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool+-- True iff we can have a binding of this expression at this level+-- Precondition: the type is the type of the expression+bindingOk top_lvl expr expr_ty+  | isTopLevel top_lvl = exprIsTopLevelBindable expr expr_ty+  | otherwise          = True++{- Note [Cannot trivialise]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider:+   f :: Int -> Addr#++   foo :: Bar+   foo = Bar (f 3)++Then we can't ANF-ise foo, even though we'd like to, because+we can't make a top-level binding for the Addr# (f 3). And if+so we don't want to turn it into+   foo = let x = f 3 in Bar x+because we'll just end up inlining x back, and that makes the+simplifier loop.  Better not to ANF-ise it at all.++Literal strings are an exception.++   foo = Ptr "blob"#++We want to turn this into:++   foo1 = "blob"#+   foo = Ptr foo1++See Note [Core top-level string literals] in GHC.Core.++************************************************************************+*                                                                      *+          Completing a lazy binding+*                                                                      *+************************************************************************++completeBind+  * deals only with Ids, not TyVars+  * takes an already-simplified binder and RHS+  * is used for both recursive and non-recursive bindings+  * is used for both top-level and non-top-level bindings++It does the following:+  - tries discarding a dead binding+  - tries PostInlineUnconditionally+  - add unfolding [this is the only place we add an unfolding]+  - add arity+  - extend the InScopeSet of the SimplEnv++It does *not* attempt to do let-to-case.  Why?  Because it is used for+  - top-level bindings (when let-to-case is impossible)+  - many situations where the "rhs" is known to be a WHNF+                (so let-to-case is inappropriate).++Nor does it do the atomic-argument thing+-}++completeBind :: SimplEnv+             -> BindContext+             -> InId           -- Old binder+             -> OutId          -- New binder; can be a JoinId+             -> OutExpr        -- New RHS+             -> SimplM (SimplFloats, SimplEnv)+-- completeBind may choose to do its work+--      * by extending the substitution (e.g. let x = y in ...)+--      * or by adding to the floats in the envt+--+-- Binder /can/ be a JoinId+-- Precondition: rhs obeys the let/app invariant+completeBind env bind_cxt old_bndr new_bndr new_rhs+ | isCoVar old_bndr+ = case new_rhs of+     Coercion co -> return (emptyFloats env, extendCvSubst env old_bndr co)+     _           -> return (mkFloatBind env (NonRec new_bndr new_rhs))++ | otherwise+ = assert (isId new_bndr) $+   do { let old_info = idInfo old_bndr+            old_unf  = realUnfoldingInfo old_info+            occ_info = occInfo old_info++         -- Do eta-expansion on the RHS of the binding+         -- See Note [Eta-expanding at let bindings] in GHC.Core.Opt.Simplify.Utils+      ; (new_arity, eta_rhs) <- tryEtaExpandRhs env new_bndr new_rhs++        -- Simplify the unfolding+      ; new_unfolding <- simplLetUnfolding env bind_cxt old_bndr+                         eta_rhs (idType new_bndr) new_arity old_unf++      ; let new_bndr_w_info = addLetBndrInfo new_bndr new_arity new_unfolding+        -- See Note [In-scope set as a substitution]++      ; if postInlineUnconditionally env bind_cxt new_bndr_w_info occ_info eta_rhs++        then -- Inline and discard the binding+             do  { tick (PostInlineUnconditionally old_bndr)+                 ; let unf_rhs = maybeUnfoldingTemplate new_unfolding `orElse` eta_rhs+                          -- See Note [Use occ-anald RHS in postInlineUnconditionally]+                 ; simplTrace env "PostInlineUnconditionally" (ppr new_bndr <+> ppr unf_rhs) $+                   return ( emptyFloats env+                          , extendIdSubst env old_bndr $+                            DoneEx unf_rhs (isJoinId_maybe new_bndr)) }+                -- Use the substitution to make quite, quite sure that the+                -- substitution will happen, since we are going to discard the binding++        else -- Keep the binding; do cast worker/wrapper+             -- pprTrace "Binding" (ppr new_bndr <+> ppr new_unfolding) $+             tryCastWorkerWrapper env bind_cxt old_bndr occ_info new_bndr_w_info eta_rhs }++addLetBndrInfo :: OutId -> ArityType -> Unfolding -> OutId+addLetBndrInfo new_bndr new_arity_type new_unf+  = new_bndr `setIdInfo` info5+  where+    AT oss div = new_arity_type+    new_arity  = length oss++    info1 = idInfo new_bndr `setArityInfo` new_arity++    -- Unfolding info: Note [Setting the new unfolding]+    info2 = info1 `setUnfoldingInfo` new_unf++    -- Demand info: Note [Setting the demand info]+    info3 | isEvaldUnfolding new_unf+          = zapDemandInfo info2 `orElse` info2+          | otherwise+          = info2++    -- Bottoming bindings: see Note [Bottoming bindings]+    info4 | isDeadEndDiv div = info3 `setDmdSigInfo` bot_sig+                                     `setCprSigInfo`        bot_cpr+          | otherwise        = info3++    bot_sig = mkClosedDmdSig (replicate new_arity topDmd) div+    bot_cpr = mkCprSig new_arity botCpr++     -- Zap call arity info. We have used it by now (via+     -- `tryEtaExpandRhs`), and the simplifier can invalidate this+     -- information, leading to broken code later (e.g. #13479)+    info5 = zapCallArityInfo info4+++{- Note [Bottoming bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have+   let x = error "urk"+   in ...(case x of <alts>)...+or+   let f = \x. error (x ++ "urk")+   in ...(case f "foo" of <alts>)...++Then we'd like to drop the dead <alts> immediately.  So it's good to+propagate the info that x's RHS is bottom to x's IdInfo as rapidly as+possible.++We use tryEtaExpandRhs on every binding, and it turns out that the+arity computation it performs (via GHC.Core.Opt.Arity.findRhsArity) already+does a simple bottoming-expression analysis.  So all we need to do+is propagate that info to the binder's IdInfo.++This showed up in #12150; see comment:16.++Note [Setting the demand info]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If the unfolding is a value, the demand info may+go pear-shaped, so we nuke it.  Example:+     let x = (a,b) in+     case x of (p,q) -> h p q x+Here x is certainly demanded. But after we've nuked+the case, we'll get just+     let x = (a,b) in h a b x+and now x is not demanded (I'm assuming h is lazy)+This really happens.  Similarly+     let f = \x -> e in ...f..f...+After inlining f at some of its call sites the original binding may+(for example) be no longer strictly demanded.+The solution here is a bit ad hoc...++Note [Use occ-anald RHS in postInlineUnconditionally]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we postInlineUnconditionally 'f in+  let f = \x -> x True in ...(f blah)...+then we'd like to inline the /occ-anald/ RHS for 'f'.  If we+use the non-occ-anald version, we'll end up with a+    ...(let x = blah in x True)...+and hence an extra Simplifier iteration.++We already /have/ the occ-anald version in the Unfolding for+the Id.  Well, maybe not /quite/ always.  If the binder is Dead,+postInlineUnconditionally will return True, but we may not have an+unfolding because it's too big. Hence the belt-and-braces `orElse`+in the defn of unf_rhs.  The Nothing case probably never happens.+++************************************************************************+*                                                                      *+\subsection[Simplify-simplExpr]{The main function: simplExpr}+*                                                                      *+************************************************************************++The reason for this OutExprStuff stuff is that we want to float *after*+simplifying a RHS, not before.  If we do so naively we get quadratic+behaviour as things float out.++To see why it's important to do it after, consider this (real) example:++        let t = f x+        in fst t+==>+        let t = let a = e1+                    b = e2+                in (a,b)+        in fst t+==>+        let a = e1+            b = e2+            t = (a,b)+        in+        a       -- Can't inline a this round, cos it appears twice+==>+        e1++Each of the ==> steps is a round of simplification.  We'd save a+whole round if we float first.  This can cascade.  Consider++        let f = g d+        in \x -> ...f...+==>+        let f = let d1 = ..d.. in \y -> e+        in \x -> ...f...+==>+        let d1 = ..d..+        in \x -> ...(\y ->e)...++Only in this second round can the \y be applied, and it+might do the same again.+-}++simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr+simplExpr !env (Type ty) -- See Note [Bangs in the Simplifier]+  = do { ty' <- simplType env ty  -- See Note [Avoiding space leaks in OutType]+       ; return (Type ty') }++simplExpr env expr+  = simplExprC env expr (mkBoringStop expr_out_ty)+  where+    expr_out_ty :: OutType+    expr_out_ty = substTy env (exprType expr)+    -- NB: Since 'expr' is term-valued, not (Type ty), this call+    --     to exprType will succeed.  exprType fails on (Type ty).++simplExprC :: SimplEnv+           -> InExpr     -- A term-valued expression, never (Type ty)+           -> SimplCont+           -> SimplM OutExpr+        -- Simplify an expression, given a continuation+simplExprC env expr cont+  = -- pprTrace "simplExprC" (ppr expr $$ ppr cont) $+    do  { (floats, expr') <- simplExprF env expr cont+        ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $+          -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $+          -- pprTrace "simplExprC ret4" (ppr (seLetFloats env')) $+          return (wrapFloats floats expr') }++--------------------------------------------------+simplExprF :: SimplEnv+           -> InExpr     -- A term-valued expression, never (Type ty)+           -> SimplCont+           -> SimplM (SimplFloats, OutExpr)++simplExprF !env e !cont -- See Note [Bangs in the Simplifier]+  = {- pprTrace "simplExprF" (vcat+      [ ppr e+      , text "cont =" <+> ppr cont+      , text "inscope =" <+> ppr (seInScope env)+      , text "tvsubst =" <+> ppr (seTvSubst env)+      , text "idsubst =" <+> ppr (seIdSubst env)+      , text "cvsubst =" <+> ppr (seCvSubst env)+      ]) $ -}+    simplExprF1 env e cont++simplExprF1 :: SimplEnv -> InExpr -> SimplCont+            -> SimplM (SimplFloats, OutExpr)++simplExprF1 _ (Type ty) cont+  = pprPanic "simplExprF: type" (ppr ty <+> text"cont: " <+> ppr cont)+    -- simplExprF does only with term-valued expressions+    -- The (Type ty) case is handled separately by simplExpr+    -- and by the other callers of simplExprF++simplExprF1 env (Var v)        cont = {-#SCC "simplIdF" #-} simplIdF env v cont+simplExprF1 env (Lit lit)      cont = {-#SCC "rebuild" #-} rebuild env (Lit lit) cont+simplExprF1 env (Tick t expr)  cont = {-#SCC "simplTick" #-} simplTick env t expr cont+simplExprF1 env (Cast body co) cont = {-#SCC "simplCast" #-} simplCast env body co cont+simplExprF1 env (Coercion co)  cont = {-#SCC "simplCoercionF" #-} simplCoercionF env co cont++simplExprF1 env (App fun arg) cont+  = {-#SCC "simplExprF1-App" #-} case arg of+      Type ty -> do { -- The argument type will (almost) certainly be used+                      -- in the output program, so just force it now.+                      -- See Note [Avoiding space leaks in OutType]+                      arg' <- simplType env ty++                      -- But use substTy, not simplType, to avoid forcing+                      -- the hole type; it will likely not be needed.+                      -- See Note [The hole type in ApplyToTy]+                    ; let hole' = substTy env (exprType fun)++                    ; simplExprF env fun $+                      ApplyToTy { sc_arg_ty  = arg'+                                , sc_hole_ty = hole'+                                , sc_cont    = cont } }+      _       ->+          -- Crucially, sc_hole_ty is a /lazy/ binding.  It will+          -- be forced only if we need to run contHoleType.+          -- When these are forced, we might get quadratic behavior;+          -- this quadratic blowup could be avoided by drilling down+          -- to the function and getting its multiplicities all at once+          -- (instead of one-at-a-time). But in practice, we have not+          -- observed the quadratic behavior, so this extra entanglement+          -- seems not worthwhile.+        simplExprF env fun $+        ApplyToVal { sc_arg = arg, sc_env = env+                   , sc_hole_ty = substTy env (exprType fun)+                   , sc_dup = NoDup, sc_cont = cont }++simplExprF1 env expr@(Lam {}) cont+  = {-#SCC "simplExprF1-Lam" #-}+    simplLam env (zapLambdaBndrs expr n_args) cont+        -- zapLambdaBndrs: the issue here is under-saturated lambdas+        --   (\x1. \x2. e) arg1+        -- Here x1 might have "occurs-once" occ-info, because occ-info+        -- is computed assuming that a group of lambdas is applied+        -- all at once.  If there are too few args, we must zap the+        -- occ-info, UNLESS the remaining binders are one-shot+  where+    n_args = countArgs cont+        -- NB: countArgs counts all the args (incl type args)+        -- and likewise drop counts all binders (incl type lambdas)++simplExprF1 env (Case scrut bndr _ alts) cont+  = {-#SCC "simplExprF1-Case" #-}+    simplExprF env scrut (Select { sc_dup = NoDup, sc_bndr = bndr+                                 , sc_alts = alts+                                 , sc_env = env, sc_cont = cont })++simplExprF1 env (Let (Rec pairs) body) cont+  | Just pairs' <- joinPointBindings_maybe pairs+  = {-#SCC "simplRecJoinPoin" #-} simplRecJoinPoint env pairs' body cont++  | otherwise+  = {-#SCC "simplRecE" #-} simplRecE env pairs body cont++simplExprF1 env (Let (NonRec bndr rhs) body) cont+  | Type ty <- rhs    -- First deal with type lets (let a = Type ty in e)+  = {-#SCC "simplExprF1-NonRecLet-Type" #-}+    assert (isTyVar bndr) $+    do { ty' <- simplType env ty+       ; simplExprF (extendTvSubst env bndr ty') body cont }++  | Just (bndr', rhs') <- joinPointBinding_maybe bndr rhs+  = {-#SCC "simplNonRecJoinPoint" #-} simplNonRecJoinPoint env bndr' rhs' body cont++  | otherwise+  = {-#SCC "simplNonRecE" #-} simplNonRecE env bndr (rhs, env) body cont++{- Note [Avoiding space leaks in OutType]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Since the simplifier is run for multiple iterations, we need to ensure+that any thunks in the output of one simplifier iteration are forced+by the evaluation of the next simplifier iteration. Otherwise we may+retain multiple copies of the Core program and leak a terrible amount+of memory (as in #13426).++The simplifier is naturally strict in the entire "Expr part" of the+input Core program, because any expression may contain binders, which+we must find in order to extend the SimplEnv accordingly. But types+do not contain binders and so it is tempting to write things like++    simplExpr env (Type ty) = return (Type (substTy env ty))   -- Bad!++This is Bad because the result includes a thunk (substTy env ty) which+retains a reference to the whole simplifier environment; and the next+simplifier iteration will not force this thunk either, because the+line above is not strict in ty.++So instead our strategy is for the simplifier to fully evaluate+OutTypes when it emits them into the output Core program, for example++    simplExpr env (Type ty) = do { ty' <- simplType env ty     -- Good+                                 ; return (Type ty') }++where the only difference from above is that simplType calls seqType+on the result of substTy.++However, SimplCont can also contain OutTypes and it's not necessarily+a good idea to force types on the way in to SimplCont, because they+may end up not being used and forcing them could be a lot of wasted+work. T5631 is a good example of this.++- For ApplyToTy's sc_arg_ty, we force the type on the way in because+  the type will almost certainly appear as a type argument in the+  output program.++- For the hole types in Stop and ApplyToTy, we force the type when we+  emit it into the output program, after obtaining it from+  contResultType. (The hole type in ApplyToTy is only directly used+  to form the result type in a new Stop continuation.)+-}++---------------------------------+-- Simplify a join point, adding the context.+-- Context goes *inside* the lambdas. IOW, if the join point has arity n, we do:+--   \x1 .. xn -> e => \x1 .. xn -> E[e]+-- Note that we need the arity of the join point, since e may be a lambda+-- (though this is unlikely). See Note [Join points and case-of-case].+simplJoinRhs :: SimplEnv -> InId -> InExpr -> SimplCont+             -> SimplM OutExpr+simplJoinRhs env bndr expr cont+  | Just arity <- isJoinId_maybe bndr+  =  do { let (join_bndrs, join_body) = collectNBinders arity expr+              mult = contHoleScaling cont+        ; (env', join_bndrs') <- simplLamBndrs env (map (scaleVarBy mult) join_bndrs)+        ; join_body' <- simplExprC env' join_body cont+        ; return $ mkLams join_bndrs' join_body' }++  | otherwise+  = pprPanic "simplJoinRhs" (ppr bndr)++---------------------------------+simplType :: SimplEnv -> InType -> SimplM OutType+        -- Kept monadic just so we can do the seqType+        -- See Note [Avoiding space leaks in OutType]+simplType env ty+  = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $+    seqType new_ty `seq` return new_ty+  where+    new_ty = substTy env ty++---------------------------------+simplCoercionF :: SimplEnv -> InCoercion -> SimplCont+               -> SimplM (SimplFloats, OutExpr)+simplCoercionF env co cont+  = do { co' <- simplCoercion env co+       ; rebuild env (Coercion co') cont }++simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion+simplCoercion env co+  = do { opts <- getOptCoercionOpts+       ; let opt_co = optCoercion opts (getTCvSubst env) co+       ; seqCo opt_co `seq` return opt_co }++-----------------------------------+-- | Push a TickIt context outwards past applications and cases, as+-- long as this is a non-scoping tick, to let case and application+-- optimisations apply.++simplTick :: SimplEnv -> CoreTickish -> InExpr -> SimplCont+          -> SimplM (SimplFloats, OutExpr)+simplTick env tickish expr cont+  -- A scoped tick turns into a continuation, so that we can spot+  -- (scc t (\x . e)) in simplLam and eliminate the scc.  If we didn't do+  -- it this way, then it would take two passes of the simplifier to+  -- reduce ((scc t (\x . e)) e').+  -- NB, don't do this with counting ticks, because if the expr is+  -- bottom, then rebuildCall will discard the continuation.++-- XXX: we cannot do this, because the simplifier assumes that+-- the context can be pushed into a case with a single branch. e.g.+--    scc<f>  case expensive of p -> e+-- becomes+--    case expensive of p -> scc<f> e+--+-- So I'm disabling this for now.  It just means we will do more+-- simplifier iterations that necessary in some cases.++--  | tickishScoped tickish && not (tickishCounts tickish)+--  = simplExprF env expr (TickIt tickish cont)++  -- For unscoped or soft-scoped ticks, we are allowed to float in new+  -- cost, so we simply push the continuation inside the tick.  This+  -- has the effect of moving the tick to the outside of a case or+  -- application context, allowing the normal case and application+  -- optimisations to fire.+  | tickish `tickishScopesLike` SoftScope+  = do { (floats, expr') <- simplExprF env expr cont+       ; return (floats, mkTick tickish expr')+       }++  -- Push tick inside if the context looks like this will allow us to+  -- do a case-of-case - see Note [case-of-scc-of-case]+  | Select {} <- cont, Just expr' <- push_tick_inside+  = simplExprF env expr' cont++  -- We don't want to move the tick, but we might still want to allow+  -- floats to pass through with appropriate wrapping (or not, see+  -- wrap_floats below)+  --- | not (tickishCounts tickish) || tickishCanSplit tickish+  -- = wrap_floats++  | otherwise+  = no_floating_past_tick++ where++  -- Try to push tick inside a case, see Note [case-of-scc-of-case].+  push_tick_inside =+    case expr0 of+      Case scrut bndr ty alts+             -> Just $ Case (tickScrut scrut) bndr ty (map tickAlt alts)+      _other -> Nothing+   where (ticks, expr0) = stripTicksTop movable (Tick tickish expr)+         movable t      = not (tickishCounts t) ||+                          t `tickishScopesLike` NoScope ||+                          tickishCanSplit t+         tickScrut e    = foldr mkTick e ticks+         -- Alternatives get annotated with all ticks that scope in some way,+         -- but we don't want to count entries.+         tickAlt (Alt c bs e) = Alt c bs (foldr mkTick e ts_scope)+         ts_scope         = map mkNoCount $+                            filter (not . (`tickishScopesLike` NoScope)) ticks++  no_floating_past_tick =+    do { let (inc,outc) = splitCont cont+       ; (floats, expr1) <- simplExprF env expr inc+       ; let expr2    = wrapFloats floats expr1+             tickish' = simplTickish env tickish+       ; rebuild env (mkTick tickish' expr2) outc+       }++-- Alternative version that wraps outgoing floats with the tick.  This+-- results in ticks being duplicated, as we don't make any attempt to+-- eliminate the tick if we re-inline the binding (because the tick+-- semantics allows unrestricted inlining of HNFs), so I'm not doing+-- this any more.  FloatOut will catch any real opportunities for+-- floating.+--+--  wrap_floats =+--    do { let (inc,outc) = splitCont cont+--       ; (env', expr') <- simplExprF (zapFloats env) expr inc+--       ; let tickish' = simplTickish env tickish+--       ; let wrap_float (b,rhs) = (zapIdDmdSig (setIdArity b 0),+--                                   mkTick (mkNoCount tickish') rhs)+--              -- when wrapping a float with mkTick, we better zap the Id's+--              -- strictness info and arity, because it might be wrong now.+--       ; let env'' = addFloats env (mapFloats env' wrap_float)+--       ; rebuild env'' expr' (TickIt tickish' outc)+--       }+++  simplTickish env tickish+    | Breakpoint ext n ids <- tickish+          = Breakpoint ext n (map (getDoneId . substId env) ids)+    | otherwise = tickish++  -- Push type application and coercion inside a tick+  splitCont :: SimplCont -> (SimplCont, SimplCont)+  splitCont cont@(ApplyToTy { sc_cont = tail }) = (cont { sc_cont = inc }, outc)+    where (inc,outc) = splitCont tail+  splitCont (CastIt co c) = (CastIt co inc, outc)+    where (inc,outc) = splitCont c+  splitCont other = (mkBoringStop (contHoleType other), other)++  getDoneId (DoneId id)  = id+  getDoneId (DoneEx e _) = getIdFromTrivialExpr e -- Note [substTickish] in GHC.Core.Subst+  getDoneId other = pprPanic "getDoneId" (ppr other)++-- Note [case-of-scc-of-case]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~+-- It's pretty important to be able to transform case-of-case when+-- there's an SCC in the way.  For example, the following comes up+-- in nofib/real/compress/Encode.hs:+--+--        case scctick<code_string.r1>+--             case $wcode_string_r13s wild_XC w1_s137 w2_s138 l_aje+--             of _ { (# ww1_s13f, ww2_s13g, ww3_s13h #) ->+--             (ww1_s13f, ww2_s13g, ww3_s13h)+--             }+--        of _ { (ww_s12Y, ww1_s12Z, ww2_s130) ->+--        tick<code_string.f1>+--        (ww_s12Y,+--         ww1_s12Z,+--         PTTrees.PT+--           @ GHC.Types.Char @ GHC.Types.Int wild2_Xj ww2_s130 r_ajf)+--        }+--+-- We really want this case-of-case to fire, because then the 3-tuple+-- will go away (indeed, the CPR optimisation is relying on this+-- happening).  But the scctick is in the way - we need to push it+-- inside to expose the case-of-case.  So we perform this+-- transformation on the inner case:+--+--   scctick c (case e of { p1 -> e1; ...; pn -> en })+--    ==>+--   case (scctick c e) of { p1 -> scc c e1; ...; pn -> scc c en }+--+-- So we've moved a constant amount of work out of the scc to expose+-- the case.  We only do this when the continuation is interesting: in+-- for now, it has to be another Case (maybe generalise this later).++{-+************************************************************************+*                                                                      *+\subsection{The main rebuilder}+*                                                                      *+************************************************************************+-}++rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplFloats, OutExpr)+-- At this point the substitution in the SimplEnv should be irrelevant;+-- only the in-scope set matters+rebuild env expr cont+  = case cont of+      Stop {}          -> return (emptyFloats env, expr)+      TickIt t cont    -> rebuild env (mkTick t expr) cont+      CastIt co cont   -> rebuild env (mkCast expr co) cont+                       -- NB: mkCast implements the (Coercion co |> g) optimisation++      Select { sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont }+        -> rebuildCase (se `setInScopeFromE` env) expr bndr alts cont++      StrictArg { sc_fun = fun, sc_cont = cont, sc_fun_ty = fun_ty }+        -> rebuildCall env (addValArgTo fun expr fun_ty ) cont+      StrictBind { sc_bndr = b, sc_body = body+                 , sc_env = se, sc_cont = cont }+        -> do { (floats1, env') <- simplNonRecX (se `setInScopeFromE` env) b expr+                                  -- expr satisfies let/app since it started life+                                  -- in a call to simplNonRecE+              ; (floats2, expr') <- simplLam env' body cont+              ; return (floats1 `addFloats` floats2, expr') }++      ApplyToTy  { sc_arg_ty = ty, sc_cont = cont}+        -> rebuild env (App expr (Type ty)) cont++      ApplyToVal { sc_arg = arg, sc_env = se, sc_dup = dup_flag, sc_cont = cont}+        -- See Note [Avoid redundant simplification]+        -> do { (_, _, arg') <- simplArg env dup_flag se arg+              ; rebuild env (App expr arg') cont }++{-+************************************************************************+*                                                                      *+\subsection{Lambdas}+*                                                                      *+************************************************************************+-}++{- Note [Optimising reflexivity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's important (for compiler performance) to get rid of reflexivity as soon+as it appears.  See #11735, #14737, and #15019.++In particular, we want to behave well on++ *  e |> co1 |> co2+    where the two happen to cancel out entirely. That is quite common;+    e.g. a newtype wrapping and unwrapping cancel.+++ * (f |> co) @t1 @t2 ... @tn x1 .. xm+   Here we will use pushCoTyArg and pushCoValArg successively, which+   build up NthCo stacks.  Silly to do that if co is reflexive.++However, we don't want to call isReflexiveCo too much, because it uses+type equality which is expensive on big types (#14737 comment:7).++A good compromise (determined experimentally) seems to be to call+isReflexiveCo+ * when composing casts, and+ * at the end++In investigating this I saw missed opportunities for on-the-fly+coercion shrinkage. See #15090.+-}+++simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont+          -> SimplM (SimplFloats, OutExpr)+simplCast env body co0 cont0+  = do  { co1   <- {-#SCC "simplCast-simplCoercion" #-} simplCoercion env co0+        ; cont1 <- {-#SCC "simplCast-addCoerce" #-}+                   if isReflCo co1+                   then return cont0  -- See Note [Optimising reflexivity]+                   else addCoerce co1 cont0+        ; {-#SCC "simplCast-simplExprF" #-} simplExprF env body cont1 }+  where+        -- If the first parameter is MRefl, then simplifying revealed a+        -- reflexive coercion. Omit.+        addCoerceM :: MOutCoercion -> SimplCont -> SimplM SimplCont+        addCoerceM MRefl   cont = return cont+        addCoerceM (MCo co) cont = addCoerce co cont++        addCoerce :: OutCoercion -> SimplCont -> SimplM SimplCont+        addCoerce co1 (CastIt co2 cont)  -- See Note [Optimising reflexivity]+          | isReflexiveCo co' = return cont+          | otherwise         = addCoerce co' cont+          where+            co' = mkTransCo co1 co2++        addCoerce co (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail })+          | Just (arg_ty', m_co') <- pushCoTyArg co arg_ty+          = {-#SCC "addCoerce-pushCoTyArg" #-}+            do { tail' <- addCoerceM m_co' tail+               ; return (ApplyToTy { sc_arg_ty  = arg_ty'+                                   , sc_cont    = tail'+                                   , sc_hole_ty = coercionLKind co }) }+                                        -- NB!  As the cast goes past, the+                                        -- type of the hole changes (#16312)++        -- (f |> co) e   ===>   (f (e |> co1)) |> co2+        -- where   co :: (s1->s2) ~ (t1->t2)+        --         co1 :: t1 ~ s1+        --         co2 :: s2 ~ t2+        addCoerce co cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se+                                      , sc_dup = dup, sc_cont = tail })+          | Just (m_co1, m_co2) <- pushCoValArg co+          , fixed_rep m_co1+          = {-#SCC "addCoerce-pushCoValArg" #-}+            do { tail' <- addCoerceM m_co2 tail+               ; case m_co1 of {+                   MRefl -> return (cont { sc_cont = tail'+                                         , sc_hole_ty = coercionLKind co }) ;+                      -- Avoid simplifying if possible;+                      -- See Note [Avoiding exponential behaviour]++                   MCo co1 ->+            do { (dup', arg_se', arg') <- simplArg env dup arg_se arg+                    -- When we build the ApplyTo we can't mix the OutCoercion+                    -- 'co' with the InExpr 'arg', so we simplify+                    -- to make it all consistent.  It's a bit messy.+                    -- But it isn't a common case.+                    -- Example of use: #995+               ; return (ApplyToVal { sc_arg  = mkCast arg' co1+                                    , sc_env  = arg_se'+                                    , sc_dup  = dup'+                                    , sc_cont = tail'+                                    , sc_hole_ty = coercionLKind co }) } } }++        addCoerce co cont+          | isReflexiveCo co = return cont  -- Having this at the end makes a huge+                                            -- difference in T12227, for some reason+                                            -- See Note [Optimising reflexivity]+          | otherwise        = return (CastIt co cont)++        fixed_rep :: MCoercionR -> Bool+        fixed_rep MRefl    = True+        fixed_rep (MCo co) = typeHasFixedRuntimeRep $ coercionRKind co+          -- Without this check, we can get an argument which does not+          -- have a fixed runtime representation.+          -- See Note [Representation polymorphism invariants] in GHC.Core+          -- test: typecheck/should_run/EtaExpandLevPoly++simplArg :: SimplEnv -> DupFlag -> StaticEnv -> CoreExpr+         -> SimplM (DupFlag, StaticEnv, OutExpr)+simplArg env dup_flag arg_env arg+  | isSimplified dup_flag+  = return (dup_flag, arg_env, arg)+  | otherwise+  = do { let arg_env' = arg_env `setInScopeFromE` env+       ; arg' <- simplExpr arg_env'  arg+       ; return (Simplified, zapSubstEnv arg_env', arg') }+         -- Return a StaticEnv that includes the in-scope set from 'env',+         -- because arg' may well mention those variables (#20639)++{-+************************************************************************+*                                                                      *+\subsection{Lambdas}+*                                                                      *+************************************************************************+-}++simplLam :: SimplEnv -> InExpr -> SimplCont+         -> SimplM (SimplFloats, OutExpr)++simplLam env (Lam bndr body) cont = simpl_lam env bndr body cont+simplLam env expr            cont = simplExprF env expr cont++simpl_lam :: SimplEnv -> InBndr -> InExpr -> SimplCont+          -> SimplM (SimplFloats, OutExpr)++-- Type beta-reduction+simpl_lam env bndr body (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont })+  = do { tick (BetaReduction bndr)+       ; simplLam (extendTvSubst env bndr arg_ty) body cont }++-- Value beta-reduction+simpl_lam env bndr body (ApplyToVal { sc_arg = arg, sc_env = arg_se+                                    , sc_cont = cont, sc_dup = dup })+  | isSimplified dup  -- Don't re-simplify if we've simplified it once+                      -- See Note [Avoiding exponential behaviour]+  = do  { tick (BetaReduction bndr)+        ; (floats1, env') <- simplNonRecX env bndr arg+        ; (floats2, expr') <- simplLam env' body cont+        ; return (floats1 `addFloats` floats2, expr') }++  | otherwise+  = do  { tick (BetaReduction bndr)+        ; simplNonRecE env bndr (arg, arg_se) body cont }++-- Discard a non-counting tick on a lambda.  This may change the+-- cost attribution slightly (moving the allocation of the+-- lambda elsewhere), but we don't care: optimisation changes+-- cost attribution all the time.+simpl_lam env bndr body (TickIt tickish cont)+  | not (tickishCounts tickish)+  = simpl_lam env bndr body cont++-- Not enough args, so there are real lambdas left to put in the result+simpl_lam env bndr body cont+  = do  { let (inner_bndrs, inner_body) = collectBinders body+        ; (env', bndrs') <- simplLamBndrs env (bndr:inner_bndrs)+        ; body'   <- simplExpr env' inner_body+        ; new_lam <- mkLam env' bndrs' body' cont+        ; rebuild env' new_lam cont }++-------------+simplLamBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)+-- Historically this had a special case for when a lambda-binder+-- could have a stable unfolding;+-- see Historical Note [Case binders and join points]+-- But now it is much simpler! We now only remove unfoldings.+-- See Note [Never put `OtherCon` unfoldings on lambda binders]+simplLamBndr env bndr = simplBinder env (zapIdUnfolding bndr)++simplLamBndrs :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])+simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs++------------------+simplNonRecE :: SimplEnv+             -> InId                    -- The binder, always an Id+                                        -- Never a join point+             -> (InExpr, SimplEnv)      -- Rhs of binding (or arg of lambda)+             -> InExpr                  -- Body of the let/lambda+             -> SimplCont+             -> SimplM (SimplFloats, OutExpr)++-- simplNonRecE is used for+--  * non-top-level non-recursive non-join-point lets in expressions+--  * beta reduction+--+-- simplNonRec env b (rhs, rhs_se) body k+--   = let env in+--     cont< let b = rhs_se(rhs) in body >+--+-- It deals with strict bindings, via the StrictBind continuation,+-- which may abort the whole process+--+-- Precondition: rhs satisfies the let/app invariant+--               Note [Core let/app invariant] in GHC.Core++simplNonRecE env bndr (rhs, rhs_se) body cont+  | assert (isId bndr && not (isJoinId bndr) ) True+  , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs rhs_se+  = do { tick (PreInlineUnconditionally bndr)+       ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $+         simplLam env' body cont }++  | otherwise+  = do { (env1, bndr1) <- simplNonRecBndr env bndr++       -- Deal with strict bindings+       -- See Note [Dark corner with representation polymorphism]+       ; if isStrictId bndr1 && sm_case_case (getMode env)+         then simplExprF (rhs_se `setInScopeFromE` env) rhs+                   (StrictBind { sc_bndr = bndr, sc_body = body+                               , sc_env = env, sc_cont = cont, sc_dup = NoDup })++       -- Deal with lazy bindings+         else do+       { (env2, bndr2)    <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive)+       ; (floats1, env3)  <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se+       ; (floats2, expr') <- simplLam env3 body cont+       ; return (floats1 `addFloats` floats2, expr') } }++------------------+simplRecE :: SimplEnv+          -> [(InId, InExpr)]+          -> InExpr+          -> SimplCont+          -> SimplM (SimplFloats, OutExpr)++-- simplRecE is used for+--  * non-top-level recursive lets in expressions+-- Precondition: not a join-point binding+simplRecE env pairs body cont+  = do  { let bndrs = map fst pairs+        ; massert (all (not . isJoinId) bndrs)+        ; env1 <- simplRecBndrs env bndrs+                -- NB: bndrs' don't have unfoldings or rules+                -- We add them as we go down+        ; (floats1, env2)  <- simplRecBind env1 (BC_Let NotTopLevel Recursive) pairs+        ; (floats2, expr') <- simplExprF env2 body cont+        ; return (floats1 `addFloats` floats2, expr') }++{- Note [Dark corner with representation polymorphism]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In `simplNonRecE`, the call to `isStrictId` will fail if the binder+does not have a fixed runtime representation, e.g. if it is of kind (TYPE r).+So we are careful to call `isStrictId` on the OutId, not the InId, in case we have+     ((\(r::RuntimeRep) \(x::TYPE r). blah) Lifted arg)+That will lead to `simplNonRecE env (x::TYPE r) arg`, and we can't tell+if x is lifted or unlifted from that.++We only get such redexes from the compulsory inlining of a wired-in,+representation-polymorphic function like `rightSection` (see+GHC.Types.Id.Make).  Mind you, SimpleOpt should probably have inlined+such compulsory inlinings already, but belt and braces does no harm.++Plus, it turns out that GHC.Driver.Main.hscCompileCoreExpr calls the+Simplifier without first calling SimpleOpt, so anything involving+GHCi or TH and operator sections will fall over if we don't take+care here.++Note [Avoiding exponential behaviour]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+One way in which we can get exponential behaviour is if we simplify a+big expression, and the re-simplify it -- and then this happens in a+deeply-nested way.  So we must be jolly careful about re-simplifying+an expression.  That is why simplNonRecX does not try+preInlineUnconditionally (unlike simplNonRecE).++Example:+  f BIG, where f has a RULE+Then+ * We simplify BIG before trying the rule; but the rule does not fire+ * We inline f = \x. x True+ * So if we did preInlineUnconditionally we'd re-simplify (BIG True)++However, if BIG has /not/ already been simplified, we'd /like/ to+simplify BIG True; maybe good things happen.  That is why++* simplLam has+    - a case for (isSimplified dup), which goes via simplNonRecX, and+    - a case for the un-simplified case, which goes via simplNonRecE++* We go to some efforts to avoid unnecessarily simplifying ApplyToVal,+  in at least two places+    - In simplCast/addCoerce, where we check for isReflCo+    - In rebuildCall we avoid simplifying arguments before we have to+      (see Note [Trying rewrite rules])+++************************************************************************+*                                                                      *+                     Join points+*                                                                      *+********************************************************************* -}++{- Note [Rules and unfolding for join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have++   simplExpr (join j x = rhs                         ) cont+             (      {- RULE j (p:ps) = blah -}       )+             (      {- StableUnfolding j = blah -}   )+             (in blah                                )++Then we will push 'cont' into the rhs of 'j'.  But we should *also* push+'cont' into the RHS of+  * Any RULEs for j, e.g. generated by SpecConstr+  * Any stable unfolding for j, e.g. the result of an INLINE pragma++Simplifying rules and stable-unfoldings happens a bit after+simplifying the right-hand side, so we remember whether or not it+is a join point, and what 'cont' is, in a value of type MaybeJoinCont++#13900 was caused by forgetting to push 'cont' into the RHS+of a SpecConstr-generated RULE for a join point.+-}++simplNonRecJoinPoint :: SimplEnv -> InId -> InExpr+                     -> InExpr -> SimplCont+                     -> SimplM (SimplFloats, OutExpr)+simplNonRecJoinPoint env bndr rhs body cont+  | assert (isJoinId bndr ) True+  , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs env+  = do { tick (PreInlineUnconditionally bndr)+       ; simplExprF env' body cont }++   | otherwise+   = wrapJoinCont env cont $ \ env cont ->+     do { -- We push join_cont into the join RHS and the body;+          -- and wrap wrap_cont around the whole thing+        ; let mult   = contHoleScaling cont+              res_ty = contResultType cont+        ; (env1, bndr1)    <- simplNonRecJoinBndr env bndr mult res_ty+        ; (env2, bndr2)    <- addBndrRules env1 bndr bndr1 (BC_Join cont)+        ; (floats1, env3)  <- simplJoinBind env2 cont bndr bndr2 rhs env+        ; (floats2, body') <- simplExprF env3 body cont+        ; return (floats1 `addFloats` floats2, body') }+++------------------+simplRecJoinPoint :: SimplEnv -> [(InId, InExpr)]+                  -> InExpr -> SimplCont+                  -> SimplM (SimplFloats, OutExpr)+simplRecJoinPoint env pairs body cont+  = wrapJoinCont env cont $ \ env cont ->+    do { let bndrs  = map fst pairs+             mult   = contHoleScaling cont+             res_ty = contResultType cont+       ; env1 <- simplRecJoinBndrs env bndrs mult res_ty+               -- NB: bndrs' don't have unfoldings or rules+               -- We add them as we go down+       ; (floats1, env2)  <- simplRecBind env1 (BC_Join cont) pairs+       ; (floats2, body') <- simplExprF env2 body cont+       ; return (floats1 `addFloats` floats2, body') }++--------------------+wrapJoinCont :: SimplEnv -> SimplCont+             -> (SimplEnv -> SimplCont -> SimplM (SimplFloats, OutExpr))+             -> SimplM (SimplFloats, OutExpr)+-- Deal with making the continuation duplicable if necessary,+-- and with the no-case-of-case situation.+wrapJoinCont env cont thing_inside+  | contIsStop cont        -- Common case; no need for fancy footwork+  = thing_inside env cont++  | not (sm_case_case (getMode env))+    -- See Note [Join points with -fno-case-of-case]+  = do { (floats1, expr1) <- thing_inside env (mkBoringStop (contHoleType cont))+       ; let (floats2, expr2) = wrapJoinFloatsX floats1 expr1+       ; (floats3, expr3) <- rebuild (env `setInScopeFromF` floats2) expr2 cont+       ; return (floats2 `addFloats` floats3, expr3) }++  | otherwise+    -- Normal case; see Note [Join points and case-of-case]+  = do { (floats1, cont')  <- mkDupableCont env cont+       ; (floats2, result) <- thing_inside (env `setInScopeFromF` floats1) cont'+       ; return (floats1 `addFloats` floats2, result) }+++--------------------+trimJoinCont :: Id -> Maybe JoinArity -> SimplCont -> SimplCont+-- Drop outer context from join point invocation (jump)+-- See Note [Join points and case-of-case]++trimJoinCont _ Nothing cont+  = cont -- Not a jump+trimJoinCont var (Just arity) cont+  = trim arity cont+  where+    trim 0 cont@(Stop {})+      = cont+    trim 0 cont+      = mkBoringStop (contResultType cont)+    trim n cont@(ApplyToVal { sc_cont = k })+      = cont { sc_cont = trim (n-1) k }+    trim n cont@(ApplyToTy { sc_cont = k })+      = cont { sc_cont = trim (n-1) k } -- join arity counts types!+    trim _ cont+      = pprPanic "completeCall" $ ppr var $$ ppr cont+++{- Note [Join points and case-of-case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we perform the case-of-case transform (or otherwise push continuations+inward), we want to treat join points specially. Since they're always+tail-called and we want to maintain this invariant, we can do this (for any+evaluation context E):++  E[join j = e+    in case ... of+         A -> jump j 1+         B -> jump j 2+         C -> f 3]++    -->++  join j = E[e]+  in case ... of+       A -> jump j 1+       B -> jump j 2+       C -> E[f 3]++As is evident from the example, there are two components to this behavior:++  1. When entering the RHS of a join point, copy the context inside.+  2. When a join point is invoked, discard the outer context.++We need to be very careful here to remain consistent---neither part is+optional!++We need do make the continuation E duplicable (since we are duplicating it)+with mkDupableCont.+++Note [Join points with -fno-case-of-case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Supose case-of-case is switched off, and we are simplifying++    case (join j x = <j-rhs> in+          case y of+             A -> j 1+             B -> j 2+             C -> e) of <outer-alts>++Usually, we'd push the outer continuation (case . of <outer-alts>) into+both the RHS and the body of the join point j.  But since we aren't doing+case-of-case we may then end up with this totally bogus result++    join x = case <j-rhs> of <outer-alts> in+    case (case y of+             A -> j 1+             B -> j 2+             C -> e) of <outer-alts>++This would be OK in the language of the paper, but not in GHC: j is no longer+a join point.  We can only do the "push continuation into the RHS of the+join point j" if we also push the continuation right down to the /jumps/ to+j, so that it can evaporate there.  If we are doing case-of-case, we'll get to++    join x = case <j-rhs> of <outer-alts> in+    case y of+      A -> j 1+      B -> j 2+      C -> case e of <outer-alts>++which is great.++Bottom line: if case-of-case is off, we must stop pushing the continuation+inwards altogether at any join point.  Instead simplify the (join ... in ...)+with a Stop continuation, and wrap the original continuation around the+outside.  Surprisingly tricky!+++************************************************************************+*                                                                      *+                     Variables+*                                                                      *+************************************************************************+-}++simplVar :: SimplEnv -> InVar -> SimplM OutExpr+-- Look up an InVar in the environment+simplVar env var+  -- Why $! ? See Note [Bangs in the Simplifier]+  | isTyVar var = return $! Type $! (substTyVar env var)+  | isCoVar var = return $! Coercion $! (substCoVar env var)+  | otherwise+  = case substId env var of+        ContEx tvs cvs ids e -> let env' = setSubstEnv env tvs cvs ids+                                in simplExpr env' e+        DoneId var1          -> return (Var var1)+        DoneEx e _           -> return e++simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr)+simplIdF env var cont+  = case substId env var of+      ContEx tvs cvs ids e ->+          let env' = setSubstEnv env tvs cvs ids+          in simplExprF env' e cont+          -- Don't trim; haven't already simplified e,+          -- so the cont is not embodied in e++      DoneId var1 ->+          let cont' = trimJoinCont var (isJoinId_maybe var1) cont+          in completeCall env var1 cont'++      DoneEx e mb_join ->+          let env' = zapSubstEnv env+              cont' = trimJoinCont var mb_join cont+          in simplExprF env' e cont'+              -- Note [zapSubstEnv]+              -- ~~~~~~~~~~~~~~~~~~+              -- The template is already simplified, so don't re-substitute.+              -- This is VITAL.  Consider+              --      let x = e in+              --      let y = \z -> ...x... in+              --      \ x -> ...y...+              -- We'll clone the inner \x, adding x->x' in the id_subst+              -- Then when we inline y, we must *not* replace x by x' in+              -- the inlined copy!!++---------------------------------------------------------+--      Dealing with a call site++completeCall :: SimplEnv -> OutId -> SimplCont -> SimplM (SimplFloats, OutExpr)+completeCall env var cont+  | Just expr <- callSiteInline logger uf_opts case_depth var active_unf+                                lone_variable arg_infos interesting_cont+  -- Inline the variable's RHS+  = do { checkedTick (UnfoldingDone var)+       ; dump_inline expr cont+       ; let env1 = zapSubstEnv env+       ; simplExprF env1 expr cont }++  | otherwise+  -- Don't inline; instead rebuild the call+  = do { rule_base <- getSimplRules+       ; let rules = getRules rule_base var+             info = mkArgInfo env var rules+                              n_val_args call_cont+       ; rebuildCall env info cont }++  where+    uf_opts    = seUnfoldingOpts env+    case_depth = seCaseDepth env+    logger     = seLogger env+    (lone_variable, arg_infos, call_cont) = contArgs cont+    n_val_args       = length arg_infos+    interesting_cont = interestingCallContext env call_cont+    active_unf       = activeUnfolding (getMode env) var++    log_inlining doc+      = liftIO $ logDumpFile logger (mkDumpStyle alwaysQualify)+           Opt_D_dump_inlinings+           "" FormatText doc++    dump_inline unfolding cont+      | not (logHasDumpFlag logger Opt_D_dump_inlinings) = return ()+      | not (logHasDumpFlag logger Opt_D_verbose_core2core)+      = when (isExternalName (idName var)) $+            log_inlining $+                sep [text "Inlining done:", nest 4 (ppr var)]+      | otherwise+      = log_inlining $+           sep [text "Inlining done: " <> ppr var,+                nest 4 (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding),+                              text "Cont:  " <+> ppr cont])]++rebuildCall :: SimplEnv+            -> ArgInfo+            -> SimplCont+            -> SimplM (SimplFloats, OutExpr)+-- We decided not to inline, so+--    - simplify the arguments+--    - try rewrite rules+--    - and rebuild++---------- Bottoming applications --------------+rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_dmds = [] }) cont+  -- When we run out of strictness args, it means+  -- that the call is definitely bottom; see GHC.Core.Opt.Simplify.Utils.mkArgInfo+  -- Then we want to discard the entire strict continuation.  E.g.+  --    * case (error "hello") of { ... }+  --    * (error "Hello") arg+  --    * f (error "Hello") where f is strict+  --    etc+  -- Then, especially in the first of these cases, we'd like to discard+  -- the continuation, leaving just the bottoming expression.  But the+  -- type might not be right, so we may have to add a coerce.+  | not (contIsTrivial cont)     -- Only do this if there is a non-trivial+                                 -- continuation to discard, else we do it+                                 -- again and again!+  = seqType cont_ty `seq`        -- See Note [Avoiding space leaks in OutType]+    return (emptyFloats env, castBottomExpr res cont_ty)+  where+    res     = argInfoExpr fun rev_args+    cont_ty = contResultType cont++---------- Try rewrite RULES --------------+-- See Note [Trying rewrite rules]+rebuildCall env info@(ArgInfo { ai_fun = fun, ai_args = rev_args+                              , ai_rules = Just (nr_wanted, rules) }) cont+  | nr_wanted == 0 || no_more_args+  , let info' = info { ai_rules = Nothing }+  = -- We've accumulated a simplified call in <fun,rev_args>+    -- so try rewrite rules; see Note [RULES apply to simplified arguments]+    -- See also Note [Rules for recursive functions]+    do { mb_match <- tryRules env rules fun (reverse rev_args) cont+       ; case mb_match of+             Just (env', rhs, cont') -> simplExprF env' rhs cont'+             Nothing                 -> rebuildCall env info' cont }+  where+    no_more_args = case cont of+                      ApplyToTy  {} -> False+                      ApplyToVal {} -> False+                      _             -> True+++---------- Simplify applications and casts --------------+rebuildCall env info (CastIt co cont)+  = rebuildCall env (addCastTo info co) cont++rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = cont })+  = rebuildCall env (addTyArgTo info arg_ty hole_ty) cont++---------- The runRW# rule. Do this after absorbing all arguments ------+-- See Note [Simplification of runRW#] in GHC.CoreToSTG.Prep.+--+-- runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). (State# RealWorld -> o) -> o+-- K[ runRW# rr ty body ]   -->   runRW rr' ty' (\s. K[ body s ])+rebuildCall env (ArgInfo { ai_fun = fun_id, ai_args = rev_args })+            (ApplyToVal { sc_arg = arg, sc_env = arg_se+                        , sc_cont = cont, sc_hole_ty = fun_ty })+  | fun_id `hasKey` runRWKey+  , not (contIsStop cont)  -- Don't fiddle around if the continuation is boring+  , [ TyArg {}, TyArg {} ] <- rev_args+  = do { s <- newId (fsLit "s") Many realWorldStatePrimTy+       ; let (m,_,_) = splitFunTy fun_ty+             env'  = (arg_se `setInScopeFromE` env) `addNewInScopeIds` [s]+             ty'   = contResultType cont+             cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s+                                , sc_env = env', sc_cont = cont+                                , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy ty' }+                     -- cont' applies to s, then K+       ; body' <- simplExprC env' arg cont'+       ; let arg'  = Lam s body'+             rr'   = getRuntimeRep ty'+             call' = mkApps (Var fun_id) [mkTyArg rr', mkTyArg ty', arg']+       ; return (emptyFloats env, call') }++rebuildCall env fun_info+            (ApplyToVal { sc_arg = arg, sc_env = arg_se+                        , sc_dup = dup_flag, sc_hole_ty = fun_ty+                        , sc_cont = cont })+  -- Argument is already simplified+  | isSimplified dup_flag     -- See Note [Avoid redundant simplification]+  = rebuildCall env (addValArgTo fun_info arg fun_ty) cont++  -- Strict arguments+  | isStrictArgInfo fun_info+  , sm_case_case (getMode env)+  = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $+    simplExprF (arg_se `setInScopeFromE` env) arg+               (StrictArg { sc_fun = fun_info, sc_fun_ty = fun_ty+                          , sc_dup = Simplified+                          , sc_cont = cont })+                -- Note [Shadowing]++  -- Lazy arguments+  | otherwise+        -- DO NOT float anything outside, hence simplExprC+        -- There is no benefit (unlike in a let-binding), and we'd+        -- have to be very careful about bogus strictness through+        -- floating a demanded let.+  = do  { arg' <- simplExprC (arg_se `setInScopeFromE` env) arg+                             (mkLazyArgStop arg_ty (lazyArgContext fun_info))+        ; rebuildCall env (addValArgTo fun_info  arg' fun_ty) cont }+  where+    arg_ty = funArgTy fun_ty+++---------- No further useful info, revert to generic rebuild ------------+rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args }) cont+  = rebuild env (argInfoExpr fun rev_args) cont++{- Note [Trying rewrite rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider an application (f e1 e2 e3) where the e1,e2,e3 are not yet+simplified.  We want to simplify enough arguments to allow the rules+to apply, but it's more efficient to avoid simplifying e2,e3 if e1 alone+is sufficient.  Example: class ops+   (+) dNumInt e2 e3+If we rewrite ((+) dNumInt) to plusInt, we can take advantage of the+latter's strictness when simplifying e2, e3.  Moreover, suppose we have+  RULE  f Int = \x. x True++Then given (f Int e1) we rewrite to+   (\x. x True) e1+without simplifying e1.  Now we can inline x into its unique call site,+and absorb the True into it all in the same pass.  If we simplified+e1 first, we couldn't do that; see Note [Avoiding exponential behaviour].++So we try to apply rules if either+  (a) no_more_args: we've run out of argument that the rules can "see"+  (b) nr_wanted: none of the rules wants any more arguments+++Note [RULES apply to simplified arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's very desirable to try RULES once the arguments have been simplified, because+doing so ensures that rule cascades work in one pass.  Consider+   {-# RULES g (h x) = k x+             f (k x) = x #-}+   ...f (g (h x))...+Then we want to rewrite (g (h x)) to (k x) and only then try f's rules. If+we match f's rules against the un-simplified RHS, it won't match.  This+makes a particularly big difference when superclass selectors are involved:+        op ($p1 ($p2 (df d)))+We want all this to unravel in one sweep.++Note [Avoid redundant simplification]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Because RULES apply to simplified arguments, there's a danger of repeatedly+simplifying already-simplified arguments.  An important example is that of+        (>>=) d e1 e2+Here e1, e2 are simplified before the rule is applied, but don't really+participate in the rule firing. So we mark them as Simplified to avoid+re-simplifying them.++Note [Shadowing]+~~~~~~~~~~~~~~~~+This part of the simplifier may break the no-shadowing invariant+Consider+        f (...(\a -> e)...) (case y of (a,b) -> e')+where f is strict in its second arg+If we simplify the innermost one first we get (...(\a -> e)...)+Simplifying the second arg makes us float the case out, so we end up with+        case y of (a,b) -> f (...(\a -> e)...) e'+So the output does not have the no-shadowing invariant.  However, there is+no danger of getting name-capture, because when the first arg was simplified+we used an in-scope set that at least mentioned all the variables free in its+static environment, and that is enough.++We can't just do innermost first, or we'd end up with a dual problem:+        case x of (a,b) -> f e (...(\a -> e')...)++I spent hours trying to recover the no-shadowing invariant, but I just could+not think of an elegant way to do it.  The simplifier is already knee-deep in+continuations.  We have to keep the right in-scope set around; AND we have+to get the effect that finding (error "foo") in a strict arg position will+discard the entire application and replace it with (error "foo").  Getting+all this at once is TOO HARD!+++************************************************************************+*                                                                      *+                Rewrite rules+*                                                                      *+************************************************************************+-}++tryRules :: SimplEnv -> [CoreRule]+         -> Id -> [ArgSpec]+         -> SimplCont+         -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont))++tryRules env rules fn args call_cont+  | null rules+  = return Nothing++{- Disabled until we fix #8326+  | fn `hasKey` tagToEnumKey   -- See Note [Optimising tagToEnum#]+  , [_type_arg, val_arg] <- args+  , Select dup bndr ((_,[],rhs1) : rest_alts) se cont <- call_cont+  , isDeadBinder bndr+  = do { let enum_to_tag :: CoreAlt -> CoreAlt+                -- Takes   K -> e  into   tagK# -> e+                -- where tagK# is the tag of constructor K+             enum_to_tag (DataAlt con, [], rhs)+               = assert (isEnumerationTyCon (dataConTyCon con) )+                (LitAlt tag, [], rhs)+              where+                tag = mkLitInt dflags (toInteger (dataConTag con - fIRST_TAG))+             enum_to_tag alt = pprPanic "tryRules: tagToEnum" (ppr alt)++             new_alts = (DEFAULT, [], rhs1) : map enum_to_tag rest_alts+             new_bndr = setIdType bndr intPrimTy+                 -- The binder is dead, but should have the right type+      ; return (Just (val_arg, Select dup new_bndr new_alts se cont)) }+-}++  | Just (rule, rule_rhs) <- lookupRule ropts (getUnfoldingInRuleMatch env)+                                        (activeRule (getMode env)) fn+                                        (argInfoAppArgs args) rules+  -- Fire a rule for the function+  = do { checkedTick (RuleFired (ruleName rule))+       ; let cont' = pushSimplifiedArgs zapped_env+                                        (drop (ruleArity rule) args)+                                        call_cont+                     -- (ruleArity rule) says how+                     -- many args the rule consumed++             occ_anald_rhs = occurAnalyseExpr rule_rhs+                 -- See Note [Occurrence-analyse after rule firing]+       ; dump rule rule_rhs+       ; return (Just (zapped_env, occ_anald_rhs, cont')) }+            -- The occ_anald_rhs and cont' are all Out things+            -- hence zapping the environment++  | otherwise  -- No rule fires+  = do { nodump  -- This ensures that an empty file is written+       ; return Nothing }++  where+    ropts      = initRuleOpts dflags+    dflags     = seDynFlags env+    logger     = seLogger env+    zapped_env = zapSubstEnv env  -- See Note [zapSubstEnv]++    printRuleModule rule+      = parens (maybe (text "BUILTIN")+                      (pprModuleName . moduleName)+                      (ruleModule rule))++    dump rule rule_rhs+      | logHasDumpFlag logger Opt_D_dump_rule_rewrites+      = log_rule Opt_D_dump_rule_rewrites "Rule fired" $ vcat+          [ text "Rule:" <+> ftext (ruleName rule)+          , text "Module:" <+>  printRuleModule rule+          , text "Before:" <+> hang (ppr fn) 2 (sep (map ppr args))+          , text "After: " <+> hang (pprCoreExpr rule_rhs) 2+                               (sep $ map ppr $ drop (ruleArity rule) args)+          , text "Cont:  " <+> ppr call_cont ]++      | logHasDumpFlag logger Opt_D_dump_rule_firings+      = log_rule Opt_D_dump_rule_firings "Rule fired:" $+          ftext (ruleName rule)+            <+> printRuleModule rule++      | otherwise+      = return ()++    nodump+      | logHasDumpFlag logger Opt_D_dump_rule_rewrites+      = liftIO $+          touchDumpFile logger Opt_D_dump_rule_rewrites++      | logHasDumpFlag logger Opt_D_dump_rule_firings+      = liftIO $+          touchDumpFile logger Opt_D_dump_rule_firings++      | otherwise+      = return ()++    log_rule flag hdr details+      = liftIO $ logDumpFile logger (mkDumpStyle alwaysQualify) flag "" FormatText+               $ sep [text hdr, nest 4 details]++trySeqRules :: SimplEnv+            -> OutExpr -> InExpr   -- Scrutinee and RHS+            -> SimplCont+            -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont))+-- See Note [User-defined RULES for seq]+trySeqRules in_env scrut rhs cont+  = do { rule_base <- getSimplRules+       ; tryRules in_env (getRules rule_base seqId) seqId out_args rule_cont }+  where+    no_cast_scrut = drop_casts scrut+    scrut_ty  = exprType no_cast_scrut+    seq_id_ty = idType seqId                    -- forall r a (b::TYPE r). a -> b -> b+    res1_ty   = piResultTy seq_id_ty rhs_rep    -- forall a (b::TYPE rhs_rep). a -> b -> b+    res2_ty   = piResultTy res1_ty   scrut_ty   -- forall (b::TYPE rhs_rep). scrut_ty -> b -> b+    res3_ty   = piResultTy res2_ty   rhs_ty     -- scrut_ty -> rhs_ty -> rhs_ty+    res4_ty   = funResultTy res3_ty             -- rhs_ty -> rhs_ty+    rhs_ty    = substTy in_env (exprType rhs)+    rhs_rep   = getRuntimeRep rhs_ty+    out_args  = [ TyArg { as_arg_ty  = rhs_rep+                        , as_hole_ty = seq_id_ty }+                , TyArg { as_arg_ty  = scrut_ty+                        , as_hole_ty = res1_ty }+                , TyArg { as_arg_ty  = rhs_ty+                        , as_hole_ty = res2_ty }+                , ValArg { as_arg = no_cast_scrut+                         , as_dmd = seqDmd+                         , as_hole_ty = res3_ty } ]+    rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs+                           , sc_env = in_env, sc_cont = cont+                           , sc_hole_ty = res4_ty }++    -- Lazily evaluated, so we don't do most of this++    drop_casts (Cast e _) = drop_casts e+    drop_casts e          = e++{- Note [User-defined RULES for seq]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Given+   case (scrut |> co) of _ -> rhs+look for rules that match the expression+   seq @t1 @t2 scrut+where scrut :: t1+      rhs   :: t2++If you find a match, rewrite it, and apply to 'rhs'.++Notice that we can simply drop casts on the fly here, which+makes it more likely that a rule will match.++See Note [User-defined RULES for seq] in GHC.Types.Id.Make.++Note [Occurrence-analyse after rule firing]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+After firing a rule, we occurrence-analyse the instantiated RHS before+simplifying it.  Usually this doesn't make much difference, but it can+be huge.  Here's an example (simplCore/should_compile/T7785)++  map f (map f (map f xs)++= -- Use build/fold form of map, twice+  map f (build (\cn. foldr (mapFB c f) n+                           (build (\cn. foldr (mapFB c f) n xs))))++= -- Apply fold/build rule+  map f (build (\cn. (\cn. foldr (mapFB c f) n xs) (mapFB c f) n))++= -- Beta-reduce+  -- Alas we have no occurrence-analysed, so we don't know+  -- that c is used exactly once+  map f (build (\cn. let c1 = mapFB c f in+                     foldr (mapFB c1 f) n xs))++= -- Use mapFB rule:   mapFB (mapFB c f) g = mapFB c (f.g)+  -- We can do this because (mapFB c n) is a PAP and hence expandable+  map f (build (\cn. let c1 = mapFB c n in+                     foldr (mapFB c (f.f)) n x))++This is not too bad.  But now do the same with the outer map, and+we get another use of mapFB, and t can interact with /both/ remaining+mapFB calls in the above expression.  This is stupid because actually+that 'c1' binding is dead.  The outer map introduces another c2. If+there is a deep stack of maps we get lots of dead bindings, and lots+of redundant work as we repeatedly simplify the result of firing rules.++The easy thing to do is simply to occurrence analyse the result of+the rule firing.  Note that this occ-anals not only the RHS of the+rule, but also the function arguments, which by now are OutExprs.+E.g.+      RULE f (g x) = x+1++Call   f (g BIG)  -->   (\x. x+1) BIG++The rule binders are lambda-bound and applied to the OutExpr arguments+(here BIG) which lack all internal occurrence info.++Is this inefficient?  Not really: we are about to walk over the result+of the rule firing to simplify it, so occurrence analysis is at most+a constant factor.++Possible improvement: occ-anal the rules when putting them in the+database; and in the simplifier just occ-anal the OutExpr arguments.+But that's more complicated and the rule RHS is usually tiny; so I'm+just doing the simple thing.++Historical note: previously we did occ-anal the rules in Rule.hs,+but failed to occ-anal the OutExpr arguments, which led to the+nasty performance problem described above.+++Note [Optimising tagToEnum#]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have an enumeration data type:++  data Foo = A | B | C++Then we want to transform++   case tagToEnum# x of   ==>    case x of+     A -> e1                       DEFAULT -> e1+     B -> e2                       1#      -> e2+     C -> e3                       2#      -> e3++thereby getting rid of the tagToEnum# altogether.  If there was a DEFAULT+alternative we retain it (remember it comes first).  If not the case must+be exhaustive, and we reflect that in the transformed version by adding+a DEFAULT.  Otherwise Lint complains that the new case is not exhaustive.+See #8317.++Note [Rules for recursive functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+You might think that we shouldn't apply rules for a loop breaker:+doing so might give rise to an infinite loop, because a RULE is+rather like an extra equation for the function:+     RULE:           f (g x) y = x+y+     Eqn:            f a     y = a-y++But it's too drastic to disable rules for loop breakers.+Even the foldr/build rule would be disabled, because foldr+is recursive, and hence a loop breaker:+     foldr k z (build g) = g k z+So it's up to the programmer: rules can cause divergence+++************************************************************************+*                                                                      *+                Rebuilding a case expression+*                                                                      *+************************************************************************++Note [Case elimination]+~~~~~~~~~~~~~~~~~~~~~~~+The case-elimination transformation discards redundant case expressions.+Start with a simple situation:++        case x# of      ===>   let y# = x# in e+          y# -> e++(when x#, y# are of primitive type, of course).  We can't (in general)+do this for algebraic cases, because we might turn bottom into+non-bottom!++The code in GHC.Core.Opt.Simplify.Utils.prepareAlts has the effect of generalise+this idea to look for a case where we're scrutinising a variable, and we know+that only the default case can match.  For example:++        case x of+          0#      -> ...+          DEFAULT -> ...(case x of+                         0#      -> ...+                         DEFAULT -> ...) ...++Here the inner case is first trimmed to have only one alternative, the+DEFAULT, after which it's an instance of the previous case.  This+really only shows up in eliminating error-checking code.++Note that GHC.Core.Opt.Simplify.Utils.mkCase combines identical RHSs.  So++        case e of       ===> case e of DEFAULT -> r+           True  -> r+           False -> r++Now again the case may be eliminated by the CaseElim transformation.+This includes things like (==# a# b#)::Bool so that we simplify+      case ==# a# b# of { True -> x; False -> x }+to just+      x+This particular example shows up in default methods for+comparison operations (e.g. in (>=) for Int.Int32)++Note [Case to let transformation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If a case over a lifted type has a single alternative, and is being+used as a strict 'let' (all isDeadBinder bndrs), we may want to do+this transformation:++    case e of r       ===>   let r = e in ...r...+      _ -> ...r...++We treat the unlifted and lifted cases separately:++* Unlifted case: 'e' satisfies exprOkForSpeculation+  (ok-for-spec is needed to satisfy the let/app invariant).+  This turns     case a +# b of r -> ...r...+  into           let r = a +# b in ...r...+  and thence     .....(a +# b)....++  However, if we have+      case indexArray# a i of r -> ...r...+  we might like to do the same, and inline the (indexArray# a i).+  But indexArray# is not okForSpeculation, so we don't build a let+  in rebuildCase (lest it get floated *out*), so the inlining doesn't+  happen either.  Annoying.++* Lifted case: we need to be sure that the expression is already+  evaluated (exprIsHNF).  If it's not already evaluated+      - we risk losing exceptions, divergence or+        user-specified thunk-forcing+      - even if 'e' is guaranteed to converge, we don't want to+        create a thunk (call by need) instead of evaluating it+        right away (call by value)++  However, we can turn the case into a /strict/ let if the 'r' is+  used strictly in the body.  Then we won't lose divergence; and+  we won't build a thunk because the let is strict.+  See also Note [Case-to-let for strictly-used binders]++Note [Case-to-let for strictly-used binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have this:+   case <scrut> of r { _ -> ..r.. }++where 'r' is used strictly in (..r..), we can safely transform to+   let r = <scrut> in ...r...++This is a Good Thing, because 'r' might be dead (if the body just+calls error), or might be used just once (in which case it can be+inlined); or we might be able to float the let-binding up or down.+E.g. #15631 has an example.++Note that this can change the error behaviour.  For example, we might+transform+    case x of { _ -> error "bad" }+    --> error "bad"+which is might be puzzling if 'x' currently lambda-bound, but later gets+let-bound to (error "good").++Nevertheless, the paper "A semantics for imprecise exceptions" allows+this transformation. If you want to fix the evaluation order, use+'pseq'.  See #8900 for an example where the loss of this+transformation bit us in practice.++See also Note [Empty case alternatives] in GHC.Core.++Historical notes++There have been various earlier versions of this patch:++* By Sept 18 the code looked like this:+     || scrut_is_demanded_var scrut++    scrut_is_demanded_var :: CoreExpr -> Bool+    scrut_is_demanded_var (Cast s _) = scrut_is_demanded_var s+    scrut_is_demanded_var (Var _)    = isStrUsedDmd (idDemandInfo case_bndr)+    scrut_is_demanded_var _          = False++  This only fired if the scrutinee was a /variable/, which seems+  an unnecessary restriction. So in #15631 I relaxed it to allow+  arbitrary scrutinees.  Less code, less to explain -- but the change+  had 0.00% effect on nofib.++* Previously, in Jan 13 the code looked like this:+     || case_bndr_evald_next rhs++    case_bndr_evald_next :: CoreExpr -> Bool+      -- See Note [Case binder next]+    case_bndr_evald_next (Var v)         = v == case_bndr+    case_bndr_evald_next (Cast e _)      = case_bndr_evald_next e+    case_bndr_evald_next (App e _)       = case_bndr_evald_next e+    case_bndr_evald_next (Case e _ _ _)  = case_bndr_evald_next e+    case_bndr_evald_next _               = False++  This patch was part of fixing #7542. See also+  Note [Eta reduction of an eval'd function] in GHC.Core.Utils.)+++Further notes about case elimination+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider:       test :: Integer -> IO ()+                test = print++Turns out that this compiles to:+    Print.test+      = \ eta :: Integer+          eta1 :: Void# ->+          case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT ->+          case hPutStr stdout+                 (PrelNum.jtos eta ($w[] @ Char))+                 eta1+          of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s  }}++Notice the strange '<' which has no effect at all. This is a funny one.+It started like this:++f x y = if x < 0 then jtos x+          else if y==0 then "" else jtos x++At a particular call site we have (f v 1).  So we inline to get++        if v < 0 then jtos x+        else if 1==0 then "" else jtos x++Now simplify the 1==0 conditional:++        if v<0 then jtos v else jtos v++Now common-up the two branches of the case:++        case (v<0) of DEFAULT -> jtos v++Why don't we drop the case?  Because it's strict in v.  It's technically+wrong to drop even unnecessary evaluations, and in practice they+may be a result of 'seq' so we *definitely* don't want to drop those.+I don't really know how to improve this situation.+++Note [FloatBinds from constructor wrappers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have FloatBinds coming from the constructor wrapper+(as in Note [exprIsConApp_maybe on data constructors with wrappers]),+we cannot float past them. We'd need to float the FloatBind+together with the simplify floats, unfortunately the+simplifier doesn't have case-floats. The simplest thing we can+do is to wrap all the floats here. The next iteration of the+simplifier will take care of all these cases and lets.++Given data T = MkT !Bool, this allows us to simplify+case $WMkT b of { MkT x -> f x }+to+case b of { b' -> f b' }.++We could try and be more clever (like maybe wfloats only contain+let binders, so we could float them). But the need for the+extra complication is not clear.++Note [Do not duplicate constructor applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this (#20125)+   let x = (a,b)+   in ...(case x of x' -> blah)...x...x...++We want that `case` to vanish (since `x` is bound to a data con) leaving+   let x = (a,b)+   in ...(let x'=x in blah)...x..x...++In rebuildCase, `exprIsConApp_maybe` will succeed on the scrutinee `x`,+since is bound to (a,b).  But in eliminating the case, if the scrutinee+is trivial, we want to bind the case-binder to the scrutinee, /not/ to+the constructor application.  Hence the case_bndr_rhs in rebuildCase.++This applies equally to a non-DEFAULT case alternative, say+   let x = (a,b) in ...(case x of x' { (p,q) -> blah })...+This variant is handled by bind_case_bndr in knownCon.++We want to bind x' to x, and not to a duplicated (a,b)).+-}++---------------------------------------------------------+--      Eliminate the case if possible++rebuildCase, reallyRebuildCase+   :: SimplEnv+   -> OutExpr          -- Scrutinee+   -> InId             -- Case binder+   -> [InAlt]          -- Alternatives (increasing order)+   -> SimplCont+   -> SimplM (SimplFloats, OutExpr)++--------------------------------------------------+--      1. Eliminate the case if there's a known constructor+--------------------------------------------------++rebuildCase env scrut case_bndr alts cont+  | Lit lit <- scrut    -- No need for same treatment as constructors+                        -- because literals are inlined more vigorously+  , not (litIsLifted lit)+  = do  { tick (KnownBranch case_bndr)+        ; case findAlt (LitAlt lit) alts of+            Nothing             -> missingAlt env case_bndr alts cont+            Just (Alt _ bs rhs) -> simple_rhs env [] scrut bs rhs }++  | Just (in_scope', wfloats, con, ty_args, other_args)+      <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut+        -- Works when the scrutinee is a variable with a known unfolding+        -- as well as when it's an explicit constructor application+  , let env0 = setInScopeSet env in_scope'+  = do  { tick (KnownBranch case_bndr)+        ; let scaled_wfloats = map scale_float wfloats+              -- case_bndr_unf: see Note [Do not duplicate constructor applications]+              case_bndr_rhs | exprIsTrivial scrut = scrut+                            | otherwise           = con_app+              con_app = Var (dataConWorkId con) `mkTyApps` ty_args+                                                `mkApps`   other_args+        ; case findAlt (DataAlt con) alts of+            Nothing                   -> missingAlt env0 case_bndr alts cont+            Just (Alt DEFAULT bs rhs) -> simple_rhs env0 scaled_wfloats case_bndr_rhs bs rhs+            Just (Alt _       bs rhs) -> knownCon env0 scrut scaled_wfloats con ty_args+                                                  other_args case_bndr bs rhs cont+        }+  where+    simple_rhs env wfloats case_bndr_rhs bs rhs =+      assert (null bs) $+      do { (floats1, env') <- simplNonRecX env case_bndr case_bndr_rhs+             -- scrut is a constructor application,+             -- hence satisfies let/app invariant+         ; (floats2, expr') <- simplExprF env' rhs cont+         ; case wfloats of+             [] -> return (floats1 `addFloats` floats2, expr')+             _ -> return+               -- See Note [FloatBinds from constructor wrappers]+                   ( emptyFloats env,+                     GHC.Core.Make.wrapFloats wfloats $+                     wrapFloats (floats1 `addFloats` floats2) expr' )}++    -- This scales case floats by the multiplicity of the continuation hole (see+    -- Note [Scaling in case-of-case]).  Let floats are _not_ scaled, because+    -- they are aliases anyway.+    scale_float (GHC.Core.Make.FloatCase scrut case_bndr con vars) =+      let+        scale_id id = scaleVarBy holeScaling id+      in+      GHC.Core.Make.FloatCase scrut (scale_id case_bndr) con (map scale_id vars)+    scale_float f = f++    holeScaling = contHoleScaling cont `mkMultMul` idMult case_bndr+     -- We are in the following situation+     --   case[p] case[q] u of { D x -> C v } of { C x -> w }+     -- And we are producing case[??] u of { D x -> w[x\v]}+     --+     -- What should the multiplicity `??` be? In order to preserve the usage of+     -- variables in `u`, it needs to be `pq`.+     --+     -- As an illustration, consider the following+     --   case[Many] case[1] of { C x -> C x } of { C x -> (x, x) }+     -- Where C :: A %1 -> T is linear+     -- If we were to produce a case[1], like the inner case, we would get+     --   case[1] of { C x -> (x, x) }+     -- Which is ill-typed with respect to linearity. So it needs to be a+     -- case[Many].++--------------------------------------------------+--      2. Eliminate the case if scrutinee is evaluated+--------------------------------------------------++rebuildCase env scrut case_bndr alts@[Alt _ bndrs rhs] cont+  -- See if we can get rid of the case altogether+  -- See Note [Case elimination]+  -- mkCase made sure that if all the alternatives are equal,+  -- then there is now only one (DEFAULT) rhs++  -- 2a.  Dropping the case altogether, if+  --      a) it binds nothing (so it's really just a 'seq')+  --      b) evaluating the scrutinee has no side effects+  | is_plain_seq+  , exprOkForSideEffects scrut+          -- The entire case is dead, so we can drop it+          -- if the scrutinee converges without having imperative+          -- side effects or raising a Haskell exception+          -- See Note [PrimOp can_fail and has_side_effects] in GHC.Builtin.PrimOps+   = simplExprF env rhs cont++  -- 2b.  Turn the case into a let, if+  --      a) it binds only the case-binder+  --      b) unlifted case: the scrutinee is ok-for-speculation+  --           lifted case: the scrutinee is in HNF (or will later be demanded)+  -- See Note [Case to let transformation]+  | all_dead_bndrs+  , doCaseToLet scrut case_bndr+  = do { tick (CaseElim case_bndr)+       ; (floats1, env') <- simplNonRecX env case_bndr scrut+       ; (floats2, expr') <- simplExprF env' rhs cont+       ; return (floats1 `addFloats` floats2, expr') }++  -- 2c. Try the seq rules if+  --     a) it binds only the case binder+  --     b) a rule for seq applies+  -- See Note [User-defined RULES for seq] in GHC.Types.Id.Make+  | is_plain_seq+  = do { mb_rule <- trySeqRules env scrut rhs cont+       ; case mb_rule of+           Just (env', rule_rhs, cont') -> simplExprF env' rule_rhs cont'+           Nothing                      -> reallyRebuildCase env scrut case_bndr alts cont }+  where+    all_dead_bndrs = all isDeadBinder bndrs       -- bndrs are [InId]+    is_plain_seq   = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect++rebuildCase env scrut case_bndr alts cont+  = reallyRebuildCase env scrut case_bndr alts cont+++doCaseToLet :: OutExpr          -- Scrutinee+            -> InId             -- Case binder+            -> Bool+-- The situation is         case scrut of b { DEFAULT -> body }+-- Can we transform thus?   let { b = scrut } in body+doCaseToLet scrut case_bndr+  | isTyCoVar case_bndr    -- Respect GHC.Core+  = isTyCoArg scrut        -- Note [Core type and coercion invariant]++  | isUnliftedType (idType case_bndr)+    -- OK to call isUnliftedType: scrutinees always have a fixed RuntimeRep (see FRRCase)+  = exprOkForSpeculation scrut++  | otherwise  -- Scrut has a lifted type+  = exprIsHNF scrut+    || isStrUsedDmd (idDemandInfo case_bndr)+    -- See Note [Case-to-let for strictly-used binders]++--------------------------------------------------+--      3. Catch-all case+--------------------------------------------------++reallyRebuildCase env scrut case_bndr alts cont+  | not (sm_case_case (getMode env))+  = do { case_expr <- simplAlts env scrut case_bndr alts+                                (mkBoringStop (contHoleType cont))+       ; rebuild env case_expr cont }++  | otherwise+  = do { (floats, env', cont') <- mkDupableCaseCont env alts cont+       ; case_expr <- simplAlts env' scrut+                                (scaleIdBy holeScaling case_bndr)+                                (scaleAltsBy holeScaling alts)+                                cont'+       ; return (floats, case_expr) }+  where+    holeScaling = contHoleScaling cont+    -- Note [Scaling in case-of-case]++{-+simplCaseBinder checks whether the scrutinee is a variable, v.  If so,+try to eliminate uses of v in the RHSs in favour of case_bndr; that+way, there's a chance that v will now only be used once, and hence+inlined.++Historical note: we use to do the "case binder swap" in the Simplifier+so there were additional complications if the scrutinee was a variable.+Now the binder-swap stuff is done in the occurrence analyser; see+"GHC.Core.Opt.OccurAnal" Note [Binder swap].++Note [knownCon occ info]+~~~~~~~~~~~~~~~~~~~~~~~~+If the case binder is not dead, then neither are the pattern bound+variables:+        case <any> of x { (a,b) ->+        case x of { (p,q) -> p } }+Here (a,b) both look dead, but come alive after the inner case is eliminated.+The point is that we bring into the envt a binding+        let x = (a,b)+after the outer case, and that makes (a,b) alive.  At least we do unless+the case binder is guaranteed dead.++Note [Case alternative occ info]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we are simply reconstructing a case (the common case), we always+zap the occurrence info on the binders in the alternatives.  Even+if the case binder is dead, the scrutinee is usually a variable, and *that*+can bring the case-alternative binders back to life.+See Note [Add unfolding for scrutinee]++Note [Improving seq]+~~~~~~~~~~~~~~~~~~~+Consider+        type family F :: * -> *+        type instance F Int = Int++We'd like to transform+        case e of (x :: F Int) { DEFAULT -> rhs }+===>+        case e `cast` co of (x'::Int)+           I# x# -> let x = x' `cast` sym co+                    in rhs++so that 'rhs' can take advantage of the form of x'.  Notice that Note+[Case of cast] (in OccurAnal) may then apply to the result.++We'd also like to eliminate empty types (#13468). So if++    data Void+    type instance F Bool = Void++then we'd like to transform+        case (x :: F Bool) of { _ -> error "urk" }+===>+        case (x |> co) of (x' :: Void) of {}++Nota Bene: we used to have a built-in rule for 'seq' that dropped+casts, so that+    case (x |> co) of { _ -> blah }+dropped the cast; in order to improve the chances of trySeqRules+firing.  But that works in the /opposite/ direction to Note [Improving+seq] so there's a danger of flip/flopping.  Better to make trySeqRules+insensitive to the cast, which is now is.++The need for [Improving seq] showed up in Roman's experiments.  Example:+  foo :: F Int -> Int -> Int+  foo t n = t `seq` bar n+     where+       bar 0 = 0+       bar n = bar (n - case t of TI i -> i)+Here we'd like to avoid repeated evaluating t inside the loop, by+taking advantage of the `seq`.++At one point I did transformation in LiberateCase, but it's more+robust here.  (Otherwise, there's a danger that we'll simply drop the+'seq' altogether, before LiberateCase gets to see it.)++Note [Scaling in case-of-case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++When two cases commute, if done naively, the multiplicities will be wrong:++  case (case u of w[1] { (x[1], y[1]) } -> f x y) of w'[Many]+  { (z[Many], t[Many]) -> z+  }++The multiplicities here, are correct, but if I perform a case of case:++  case u of w[1]+  { (x[1], y[1]) -> case f x y of w'[Many] of { (z[Many], t[Many]) -> z }+  }++This is wrong! Using `f x y` inside a `case … of w'[Many]` means that `x` and+`y` must have multiplicities `Many` not `1`! The correct solution is to make+all the `1`-s be `Many`-s instead:++  case u of w[Many]+  { (x[Many], y[Many]) -> case f x y of w'[Many] of { (z[Many], t[Many]) -> z }+  }++In general, when commuting two cases, the rule has to be:++  case (case … of x[p] {…}) of y[q] { … }+  ===> case … of x[p*q] { … case … of y[q] { … } }++This is materialised, in the simplifier, by the fact that every time we simplify+case alternatives with a continuation (the surrounded case (or more!)), we must+scale the entire case we are simplifying, by a scaling factor which can be+computed in the continuation (with function `contHoleScaling`).+-}++simplAlts :: SimplEnv+          -> OutExpr         -- Scrutinee+          -> InId            -- Case binder+          -> [InAlt]         -- Non-empty+          -> SimplCont+          -> SimplM OutExpr  -- Returns the complete simplified case expression++simplAlts env0 scrut case_bndr alts cont'+  = do  { traceSmpl "simplAlts" (vcat [ ppr case_bndr+                                      , text "cont':" <+> ppr cont'+                                      , text "in_scope" <+> ppr (seInScope env0) ])+        ; (env1, case_bndr1) <- simplBinder env0 case_bndr+        ; let case_bndr2 = case_bndr1 `setIdUnfolding` evaldUnfolding+              env2       = modifyInScope env1 case_bndr2+              -- See Note [Case binder evaluated-ness]++        ; fam_envs <- getFamEnvs+        ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env2 scrut+                                                       case_bndr case_bndr2 alts++        ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts+          -- NB: it's possible that the returned in_alts is empty: this is handled+          -- by the caller (rebuildCase) in the missingAlt function++        ; alts' <- mapM (simplAlt alt_env' (Just scrut') imposs_deflt_cons case_bndr' cont') in_alts+--      ; pprTrace "simplAlts" (ppr case_bndr $$ ppr alts $$ ppr cont') $ return ()++        ; let alts_ty' = contResultType cont'+        -- See Note [Avoiding space leaks in OutType]+        ; seqType alts_ty' `seq`+          mkCase (seDynFlags env0) scrut' case_bndr' alts_ty' alts' }+++------------------------------------+improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv+           -> OutExpr -> InId -> OutId -> [InAlt]+           -> SimplM (SimplEnv, OutExpr, OutId)+-- Note [Improving seq]+improveSeq fam_envs env scrut case_bndr case_bndr1 [Alt DEFAULT _ _]+  | Just (Reduction co ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1)+  = do { case_bndr2 <- newId (fsLit "nt") Many ty2+        ; let rhs  = DoneEx (Var case_bndr2 `Cast` mkSymCo co) Nothing+              env2 = extendIdSubst env case_bndr rhs+        ; return (env2, scrut `Cast` co, case_bndr2) }++improveSeq _ env scrut _ case_bndr1 _+  = return (env, scrut, case_bndr1)+++------------------------------------+simplAlt :: SimplEnv+         -> Maybe OutExpr  -- The scrutinee+         -> [AltCon]       -- These constructors can't be present when+                           -- matching the DEFAULT alternative+         -> OutId          -- The case binder+         -> SimplCont+         -> InAlt+         -> SimplM OutAlt++simplAlt env _ imposs_deflt_cons case_bndr' cont' (Alt DEFAULT bndrs rhs)+  = assert (null bndrs) $+    do  { let env' = addBinderUnfolding env case_bndr'+                                        (mkOtherCon imposs_deflt_cons)+                -- Record the constructors that the case-binder *can't* be.+        ; rhs' <- simplExprC env' rhs cont'+        ; return (Alt DEFAULT [] rhs') }++simplAlt env scrut' _ case_bndr' cont' (Alt (LitAlt lit) bndrs rhs)+  = assert (null bndrs) $+    do  { env' <- addAltUnfoldings env scrut' case_bndr' (Lit lit)+        ; rhs' <- simplExprC env' rhs cont'+        ; return (Alt (LitAlt lit) [] rhs') }++simplAlt env scrut' _ case_bndr' cont' (Alt (DataAlt con) vs rhs)+  = do  { -- See Note [Adding evaluatedness info to pattern-bound variables]+          let vs_with_evals = addEvals scrut' con vs+        ; (env', vs') <- simplBinders env vs_with_evals++                -- Bind the case-binder to (con args)+        ; let inst_tys' = tyConAppArgs (idType case_bndr')+              con_app :: OutExpr+              con_app   = mkConApp2 con inst_tys' vs'++        ; env'' <- addAltUnfoldings env' scrut' case_bndr' con_app+        ; rhs' <- simplExprC env'' rhs cont'+        ; return (Alt (DataAlt con) vs' rhs') }++{- Note [Adding evaluatedness info to pattern-bound variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+addEvals records the evaluated-ness of the bound variables of+a case pattern.  This is *important*.  Consider++     data T = T !Int !Int++     case x of { T a b -> T (a+1) b }++We really must record that b is already evaluated so that we don't+go and re-evaluate it when constructing the result.+See Note [Data-con worker strictness] in GHC.Core.DataCon++NB: simplLamBndrs preserves this eval info++In addition to handling data constructor fields with !s, addEvals+also records the fact that the result of seq# is always in WHNF.+See Note [seq# magic] in GHC.Core.Opt.ConstantFold.  Example (#15226):++  case seq# v s of+    (# s', v' #) -> E++we want the compiler to be aware that v' is in WHNF in E.++Open problem: we don't record that v itself is in WHNF (and we can't+do it here).  The right thing is to do some kind of binder-swap;+see #15226 for discussion.+-}++addEvals :: Maybe OutExpr -> DataCon -> [Id] -> [Id]+-- See Note [Adding evaluatedness info to pattern-bound variables]+addEvals scrut con vs+  -- Deal with seq# applications+  | Just scr <- scrut+  , isUnboxedTupleDataCon con+  , [s,x] <- vs+    -- Use stripNArgs rather than collectArgsTicks to avoid building+    -- a list of arguments only to throw it away immediately.+  , Just (Var f) <- stripNArgs 4 scr+  , Just SeqOp <- isPrimOpId_maybe f+  , let x' = zapIdOccInfoAndSetEvald MarkedStrict x+  = [s, x']++  -- Deal with banged datacon fields+addEvals _scrut con vs = go vs the_strs+    where+      the_strs = dataConRepStrictness con++      go [] [] = []+      go (v:vs') strs | isTyVar v = v : go vs' strs+      go (v:vs') (str:strs) = zapIdOccInfoAndSetEvald str v : go vs' strs+      go _ _ = pprPanic "Simplify.addEvals"+                (ppr con $$+                 ppr vs  $$+                 ppr_with_length (map strdisp the_strs) $$+                 ppr_with_length (dataConRepArgTys con) $$+                 ppr_with_length (dataConRepStrictness con))+        where+          ppr_with_length list+            = ppr list <+> parens (text "length =" <+> ppr (length list))+          strdisp MarkedStrict = text "MarkedStrict"+          strdisp NotMarkedStrict = text "NotMarkedStrict"++zapIdOccInfoAndSetEvald :: StrictnessMark -> Id -> Id+zapIdOccInfoAndSetEvald str v =+  setCaseBndrEvald str $ -- Add eval'dness info+  zapIdOccInfo v         -- And kill occ info;+                         -- see Note [Case alternative occ info]++addAltUnfoldings :: SimplEnv -> Maybe OutExpr -> OutId -> OutExpr -> SimplM SimplEnv+addAltUnfoldings env scrut case_bndr con_app+  = do { let con_app_unf = mk_simple_unf con_app+             env1 = addBinderUnfolding env case_bndr con_app_unf++             -- See Note [Add unfolding for scrutinee]+             env2 | Many <- idMult case_bndr = case scrut of+                      Just (Var v)           -> addBinderUnfolding env1 v con_app_unf+                      Just (Cast (Var v) co) -> addBinderUnfolding env1 v $+                                                mk_simple_unf (Cast con_app (mkSymCo co))+                      _                      -> env1+                  | otherwise = env1++       ; traceSmpl "addAltUnf" (vcat [ppr case_bndr <+> ppr scrut, ppr con_app])+       ; return env2 }+  where+    -- Force the opts, so that the whole SimplEnv isn't retained+    !opts = seUnfoldingOpts env+    mk_simple_unf = mkSimpleUnfolding opts++addBinderUnfolding :: SimplEnv -> Id -> Unfolding -> SimplEnv+addBinderUnfolding env bndr unf+  | debugIsOn, Just tmpl <- maybeUnfoldingTemplate unf+  = warnPprTrace (not (eqType (idType bndr) (exprType tmpl)))+          "unfolding type mismatch"+          (ppr bndr $$ ppr (idType bndr) $$ ppr tmpl $$ ppr (exprType tmpl)) $+          modifyInScope env (bndr `setIdUnfolding` unf)++  | otherwise+  = modifyInScope env (bndr `setIdUnfolding` unf)++zapBndrOccInfo :: Bool -> Id -> Id+-- Consider  case e of b { (a,b) -> ... }+-- Then if we bind b to (a,b) in "...", and b is not dead,+-- then we must zap the deadness info on a,b+zapBndrOccInfo keep_occ_info pat_id+  | keep_occ_info = pat_id+  | otherwise     = zapIdOccInfo pat_id++{- Note [Case binder evaluated-ness]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We pin on a (OtherCon []) unfolding to the case-binder of a Case,+even though it'll be over-ridden in every case alternative with a more+informative unfolding.  Why?  Because suppose a later, less clever, pass+simply replaces all occurrences of the case binder with the binder itself;+then Lint may complain about the let/app invariant.  Example+    case e of b { DEFAULT -> let v = reallyUnsafePtrEquality# b y in ....+                ; K       -> blah }++The let/app invariant requires that y is evaluated in the call to+reallyUnsafePtrEquality#, which it is.  But we still want that to be true if we+propagate binders to occurrences.++This showed up in #13027.++Note [Add unfolding for scrutinee]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In general it's unlikely that a variable scrutinee will appear+in the case alternatives   case x of { ...x unlikely to appear... }+because the binder-swap in OccurAnal has got rid of all such occurrences+See Note [Binder swap] in "GHC.Core.Opt.OccurAnal".++BUT it is still VERY IMPORTANT to add a suitable unfolding for a+variable scrutinee, in simplAlt.  Here's why+   case x of y+     (a,b) -> case b of c+                I# v -> ...(f y)...+There is no occurrence of 'b' in the (...(f y)...).  But y gets+the unfolding (a,b), and *that* mentions b.  If f has a RULE+    RULE f (p, I# q) = ...+we want that rule to match, so we must extend the in-scope env with a+suitable unfolding for 'y'.  It's *essential* for rule matching; but+it's also good for case-elimination -- suppose that 'f' was inlined+and did multi-level case analysis, then we'd solve it in one+simplifier sweep instead of two.++Exactly the same issue arises in GHC.Core.Opt.SpecConstr;+see Note [Add scrutinee to ValueEnv too] in GHC.Core.Opt.SpecConstr++HOWEVER, given+  case x of y { Just a -> r1; Nothing -> r2 }+we do not want to add the unfolding x -> y to 'x', which might seem cool,+since 'y' itself has different unfoldings in r1 and r2.  Reason: if we+did that, we'd have to zap y's deadness info and that is a very useful+piece of information.++So instead we add the unfolding x -> Just a, and x -> Nothing in the+respective RHSs.++Since this transformation is tantamount to a binder swap, the same caveat as in+Note [Suppressing binder-swaps on linear case] in OccurAnal apply.+++************************************************************************+*                                                                      *+\subsection{Known constructor}+*                                                                      *+************************************************************************++We are a bit careful with occurrence info.  Here's an example++        (\x* -> case x of (a*, b) -> f a) (h v, e)++where the * means "occurs once".  This effectively becomes+        case (h v, e) of (a*, b) -> f a)+and then+        let a* = h v; b = e in f a+and then+        f (h v)++All this should happen in one sweep.+-}++knownCon :: SimplEnv+         -> OutExpr                                           -- The scrutinee+         -> [FloatBind] -> DataCon -> [OutType] -> [OutExpr]  -- The scrutinee (in pieces)+         -> InId -> [InBndr] -> InExpr                        -- The alternative+         -> SimplCont+         -> SimplM (SimplFloats, OutExpr)++knownCon env scrut dc_floats dc dc_ty_args dc_args bndr bs rhs cont+  = do  { (floats1, env1)  <- bind_args env bs dc_args+        ; (floats2, env2)  <- bind_case_bndr env1+        ; (floats3, expr') <- simplExprF env2 rhs cont+        ; case dc_floats of+            [] ->+              return (floats1 `addFloats` floats2 `addFloats` floats3, expr')+            _ ->+              return ( emptyFloats env+               -- See Note [FloatBinds from constructor wrappers]+                     , GHC.Core.Make.wrapFloats dc_floats $+                       wrapFloats (floats1 `addFloats` floats2 `addFloats` floats3) expr') }+  where+    zap_occ = zapBndrOccInfo (isDeadBinder bndr)    -- bndr is an InId++                  -- Ugh!+    bind_args env' [] _  = return (emptyFloats env', env')++    bind_args env' (b:bs') (Type ty : args)+      = assert (isTyVar b )+        bind_args (extendTvSubst env' b ty) bs' args++    bind_args env' (b:bs') (Coercion co : args)+      = assert (isCoVar b )+        bind_args (extendCvSubst env' b co) bs' args++    bind_args env' (b:bs') (arg : args)+      = assert (isId b) $+        do { let b' = zap_occ b+             -- Note that the binder might be "dead", because it doesn't+             -- occur in the RHS; and simplNonRecX may therefore discard+             -- it via postInlineUnconditionally.+             -- Nevertheless we must keep it if the case-binder is alive,+             -- because it may be used in the con_app.  See Note [knownCon occ info]+           ; (floats1, env2) <- simplNonRecX env' b' arg  -- arg satisfies let/app invariant+           ; (floats2, env3)  <- bind_args env2 bs' args+           ; return (floats1 `addFloats` floats2, env3) }++    bind_args _ _ _ =+      pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$+                             text "scrut:" <+> ppr scrut++       -- It's useful to bind bndr to scrut, rather than to a fresh+       -- binding      x = Con arg1 .. argn+       -- because very often the scrut is a variable, so we avoid+       -- creating, and then subsequently eliminating, a let-binding+       -- BUT, if scrut is a not a variable, we must be careful+       -- about duplicating the arg redexes; in that case, make+       -- a new con-app from the args+    bind_case_bndr env+      | isDeadBinder bndr   = return (emptyFloats env, env)+      | exprIsTrivial scrut = return (emptyFloats env+                                     , extendIdSubst env bndr (DoneEx scrut Nothing))+                              -- See Note [Do not duplicate constructor applications]+      | otherwise           = do { dc_args <- mapM (simplVar env) bs+                                         -- dc_ty_args are already OutTypes,+                                         -- but bs are InBndrs+                                 ; let con_app = Var (dataConWorkId dc)+                                                 `mkTyApps` dc_ty_args+                                                 `mkApps`   dc_args+                                 ; simplNonRecX env bndr con_app }++-------------------+missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont+           -> SimplM (SimplFloats, OutExpr)+                -- This isn't strictly an error, although it is unusual.+                -- It's possible that the simplifier might "see" that+                -- an inner case has no accessible alternatives before+                -- it "sees" that the entire branch of an outer case is+                -- inaccessible.  So we simply put an error case here instead.+missingAlt env case_bndr _ cont+  = warnPprTrace True "missingAlt" (ppr case_bndr) $+    -- See Note [Avoiding space leaks in OutType]+    let cont_ty = contResultType cont+    in seqType cont_ty `seq`+       return (emptyFloats env, mkImpossibleExpr cont_ty)++{-+************************************************************************+*                                                                      *+\subsection{Duplicating continuations}+*                                                                      *+************************************************************************++Consider+  let x* = case e of { True -> e1; False -> e2 }+  in b+where x* is a strict binding.  Then mkDupableCont will be given+the continuation+   case [] of { True -> e1; False -> e2 } ; let x* = [] in b ; stop+and will split it into+   dupable:      case [] of { True -> $j1; False -> $j2 } ; stop+   join floats:  $j1 = e1, $j2 = e2+   non_dupable:  let x* = [] in b; stop++Putting this back together would give+   let x* = let { $j1 = e1; $j2 = e2 } in+            case e of { True -> $j1; False -> $j2 }+   in b+(Of course we only do this if 'e' wants to duplicate that continuation.)+Note how important it is that the new join points wrap around the+inner expression, and not around the whole thing.++In contrast, any let-bindings introduced by mkDupableCont can wrap+around the entire thing.++Note [Bottom alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~+When we have+     case (case x of { A -> error .. ; B -> e; C -> error ..)+       of alts+then we can just duplicate those alts because the A and C cases+will disappear immediately.  This is more direct than creating+join points and inlining them away.  See #4930.+-}++--------------------+mkDupableCaseCont :: SimplEnv -> [InAlt] -> SimplCont+                  -> SimplM ( SimplFloats  -- Join points (if any)+                            , SimplEnv     -- Use this for the alts+                            , SimplCont)+mkDupableCaseCont env alts cont+  | altsWouldDup alts = do { (floats, cont) <- mkDupableCont env cont+                           ; let env' = bumpCaseDepth $+                                        env `setInScopeFromF` floats+                           ; return (floats, env', cont) }+  | otherwise         = return (emptyFloats env, env, cont)++altsWouldDup :: [InAlt] -> Bool -- True iff strictly > 1 non-bottom alternative+altsWouldDup []  = False        -- See Note [Bottom alternatives]+altsWouldDup [_] = False+altsWouldDup (alt:alts)+  | is_bot_alt alt = altsWouldDup alts+  | otherwise      = not (all is_bot_alt alts)+    -- otherwise case: first alt is non-bot, so all the rest must be bot+  where+    is_bot_alt (Alt _ _ rhs) = exprIsDeadEnd rhs++-------------------------+mkDupableCont :: SimplEnv+              -> SimplCont+              -> SimplM ( SimplFloats  -- Incoming SimplEnv augmented with+                                       --   extra let/join-floats and in-scope variables+                        , SimplCont)   -- dup_cont: duplicable continuation+mkDupableCont env cont+  = mkDupableContWithDmds env (repeat topDmd) cont++mkDupableContWithDmds+   :: SimplEnv  -> [Demand]  -- Demands on arguments; always infinite+   -> SimplCont -> SimplM ( SimplFloats, SimplCont)++mkDupableContWithDmds env _ cont+  | contIsDupable cont+  = return (emptyFloats env, cont)++mkDupableContWithDmds _ _ (Stop {}) = panic "mkDupableCont"     -- Handled by previous eqn++mkDupableContWithDmds env dmds (CastIt ty cont)+  = do  { (floats, cont') <- mkDupableContWithDmds env dmds cont+        ; return (floats, CastIt ty cont') }++-- Duplicating ticks for now, not sure if this is good or not+mkDupableContWithDmds env dmds (TickIt t cont)+  = do  { (floats, cont') <- mkDupableContWithDmds env dmds cont+        ; return (floats, TickIt t cont') }++mkDupableContWithDmds env _+     (StrictBind { sc_bndr = bndr, sc_body = body+                 , sc_env = se, sc_cont = cont})+-- See Note [Duplicating StrictBind]+-- K[ let x = <> in b ]  -->   join j x = K[ b ]+--                             j <>+  = do { let sb_env = se `setInScopeFromE` env+       ; (sb_env1, bndr')      <- simplBinder sb_env bndr+       ; (floats1, join_inner) <- simplLam sb_env1 body cont+          -- No need to use mkDupableCont before simplLam; we+          -- use cont once here, and then share the result if necessary++       ; let join_body = wrapFloats floats1 join_inner+             res_ty    = contResultType cont++       ; mkDupableStrictBind env bndr' join_body res_ty }++mkDupableContWithDmds env _+    (StrictArg { sc_fun = fun, sc_cont = cont+               , sc_fun_ty = fun_ty })+  -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable+  | isNothing (isDataConId_maybe (ai_fun fun))+  , thumbsUpPlanA cont  -- See point (3) of Note [Duplicating join points]+  = -- Use Plan A of Note [Duplicating StrictArg]+    do { let (_ : dmds) = ai_dmds fun+       ; (floats1, cont')  <- mkDupableContWithDmds env dmds cont+                              -- Use the demands from the function to add the right+                              -- demand info on any bindings we make for further args+       ; (floats_s, args') <- mapAndUnzipM (makeTrivialArg env)+                                           (ai_args fun)+       ; return ( foldl' addLetFloats floats1 floats_s+                , StrictArg { sc_fun = fun { ai_args = args' }+                            , sc_cont = cont'+                            , sc_fun_ty = fun_ty+                            , sc_dup = OkToDup} ) }++  | otherwise+  = -- Use Plan B of Note [Duplicating StrictArg]+    --   K[ f a b <> ]   -->   join j x = K[ f a b x ]+    --                         j <>+    do { let rhs_ty       = contResultType cont+             (m,arg_ty,_) = splitFunTy fun_ty+       ; arg_bndr <- newId (fsLit "arg") m arg_ty+       ; let env' = env `addNewInScopeIds` [arg_bndr]+       ; (floats, join_rhs) <- rebuildCall env' (addValArgTo fun (Var arg_bndr) fun_ty) cont+       ; mkDupableStrictBind env' arg_bndr (wrapFloats floats join_rhs) rhs_ty }+  where+    thumbsUpPlanA (StrictArg {})               = False+    thumbsUpPlanA (CastIt _ k)                 = thumbsUpPlanA k+    thumbsUpPlanA (TickIt _ k)                 = thumbsUpPlanA k+    thumbsUpPlanA (ApplyToVal { sc_cont = k }) = thumbsUpPlanA k+    thumbsUpPlanA (ApplyToTy  { sc_cont = k }) = thumbsUpPlanA k+    thumbsUpPlanA (Select {})                  = True+    thumbsUpPlanA (StrictBind {})              = True+    thumbsUpPlanA (Stop {})                    = True++mkDupableContWithDmds env dmds+    (ApplyToTy { sc_cont = cont, sc_arg_ty = arg_ty, sc_hole_ty = hole_ty })+  = do  { (floats, cont') <- mkDupableContWithDmds env dmds cont+        ; return (floats, ApplyToTy { sc_cont = cont'+                                    , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) }++mkDupableContWithDmds env dmds+    (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_env = se+                , sc_cont = cont, sc_hole_ty = hole_ty })+  =     -- e.g.         [...hole...] (...arg...)+        --      ==>+        --              let a = ...arg...+        --              in [...hole...] a+        -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable+    do  { let (dmd:_) = dmds   -- Never fails+        ; (floats1, cont') <- mkDupableContWithDmds env dmds cont+        ; let env' = env `setInScopeFromF` floats1+        ; (_, se', arg') <- simplArg env' dup se arg+        ; (let_floats2, arg'') <- makeTrivial env NotTopLevel dmd (fsLit "karg") arg'+        ; let all_floats = floats1 `addLetFloats` let_floats2+        ; return ( all_floats+                 , ApplyToVal { sc_arg = arg''+                              , sc_env = se' `setInScopeFromF` all_floats+                                         -- Ensure that sc_env includes the free vars of+                                         -- arg'' in its in-scope set, even if makeTrivial+                                         -- has turned arg'' into a fresh variable+                                         -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils+                              , sc_dup = OkToDup, sc_cont = cont'+                              , sc_hole_ty = hole_ty }) }++mkDupableContWithDmds env _+    (Select { sc_bndr = case_bndr, sc_alts = alts, sc_env = se, sc_cont = cont })+  =     -- e.g.         (case [...hole...] of { pi -> ei })+        --      ===>+        --              let ji = \xij -> ei+        --              in case [...hole...] of { pi -> ji xij }+        -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable+    do  { tick (CaseOfCase case_bndr)+        ; (floats, alt_env, alt_cont) <- mkDupableCaseCont (se `setInScopeFromE` env) alts cont+                -- NB: We call mkDupableCaseCont here to make cont duplicable+                --     (if necessary, depending on the number of alts)+                -- And this is important: see Note [Fusing case continuations]++        ; let cont_scaling = contHoleScaling cont+          -- See Note [Scaling in case-of-case]+        ; (alt_env', case_bndr') <- simplBinder alt_env (scaleIdBy cont_scaling case_bndr)+        ; alts' <- mapM (simplAlt alt_env' Nothing [] case_bndr' alt_cont) (scaleAltsBy cont_scaling alts)+        -- Safe to say that there are no handled-cons for the DEFAULT case+                -- NB: simplBinder does not zap deadness occ-info, so+                -- a dead case_bndr' will still advertise its deadness+                -- This is really important because in+                --      case e of b { (# p,q #) -> ... }+                -- b is always dead, and indeed we are not allowed to bind b to (# p,q #),+                -- which might happen if e was an explicit unboxed pair and b wasn't marked dead.+                -- In the new alts we build, we have the new case binder, so it must retain+                -- its deadness.+        -- NB: we don't use alt_env further; it has the substEnv for+        --     the alternatives, and we don't want that++        ; (join_floats, alts'') <- mapAccumLM (mkDupableAlt (targetPlatform (seDynFlags env)) case_bndr')+                                              emptyJoinFloats alts'++        ; let all_floats = floats `addJoinFloats` join_floats+                           -- Note [Duplicated env]+        ; return (all_floats+                 , Select { sc_dup  = OkToDup+                          , sc_bndr = case_bndr'+                          , sc_alts = alts''+                          , sc_env  = zapSubstEnv se `setInScopeFromF` all_floats+                                      -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils+                          , sc_cont = mkBoringStop (contResultType cont) } ) }++mkDupableStrictBind :: SimplEnv -> OutId -> OutExpr -> OutType+                    -> SimplM (SimplFloats, SimplCont)+mkDupableStrictBind env arg_bndr join_rhs res_ty+  | exprIsTrivial join_rhs   -- See point (2) of Note [Duplicating join points]+  = return (emptyFloats env+           , StrictBind { sc_bndr = arg_bndr+                        , sc_body = join_rhs+                        , sc_env  = zapSubstEnv env+                          -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils+                        , sc_dup  = OkToDup+                        , sc_cont = mkBoringStop res_ty } )+  | otherwise+  = do { join_bndr <- newJoinId [arg_bndr] res_ty+       ; let arg_info = ArgInfo { ai_fun   = join_bndr+                                , ai_rules = Nothing, ai_args  = []+                                , ai_encl  = False, ai_dmds  = repeat topDmd+                                , ai_discs = repeat 0 }+       ; return ( addJoinFloats (emptyFloats env) $+                  unitJoinFloat                   $+                  NonRec join_bndr                $+                  Lam (setOneShotLambda arg_bndr) join_rhs+                , StrictArg { sc_dup    = OkToDup+                            , sc_fun    = arg_info+                            , sc_fun_ty = idType join_bndr+                            , sc_cont   = mkBoringStop res_ty+                            } ) }++mkDupableAlt :: Platform -> OutId+             -> JoinFloats -> OutAlt+             -> SimplM (JoinFloats, OutAlt)+mkDupableAlt _platform case_bndr jfloats (Alt con alt_bndrs alt_rhs_in)+  | exprIsTrivial alt_rhs_in   -- See point (2) of Note [Duplicating join points]+  = return (jfloats, Alt con alt_bndrs alt_rhs_in)++  | otherwise+  = do  { let rhs_ty'  = exprType alt_rhs_in++              bangs+                | DataAlt c <- con+                = dataConRepStrictness c+                | otherwise = []++              abstracted_binders = abstract_binders alt_bndrs bangs++              abstract_binders :: [Var] -> [StrictnessMark] -> [(Id,StrictnessMark)]+              abstract_binders [] []+                -- Abstract over the case binder too if it's used.+                | isDeadBinder case_bndr  = []+                | otherwise               = [(case_bndr,MarkedStrict)]+              abstract_binders (alt_bndr:alt_bndrs) marks+                -- Abstract over all type variables just in case+                | isTyVar alt_bndr        = (alt_bndr,NotMarkedStrict) : abstract_binders alt_bndrs marks+              abstract_binders (alt_bndr:alt_bndrs) (mark:marks)+                -- The deadness info on the new Ids is preserved by simplBinders+                -- We don't abstract over dead ids here.+                | isDeadBinder alt_bndr   = abstract_binders alt_bndrs marks+                | otherwise               = (alt_bndr,mark) : abstract_binders alt_bndrs marks+              abstract_binders _ _ = pprPanic "abstrict_binders - failed to abstract" (ppr $ Alt con alt_bndrs alt_rhs_in)++              filtered_binders = map fst abstracted_binders+              -- We want to make any binder with an evaldUnfolding strict in the rhs.+              -- See Note [Call-by-value for worker args] (which also applies to join points)+              (rhs_with_seqs) = mkStrictFieldSeqs abstracted_binders alt_rhs_in++              final_args = varsToCoreExprs filtered_binders+                           -- Note [Join point abstraction]++                -- We make the lambdas into one-shot-lambdas.  The+                -- join point is sure to be applied at most once, and doing so+                -- prevents the body of the join point being floated out by+                -- the full laziness pass+              final_bndrs     = map one_shot filtered_binders+              one_shot v | isId v    = setOneShotLambda v+                         | otherwise = v++              -- No lambda binder has an unfolding, but (currently) case binders can,+              -- so we must zap them here.+              join_rhs   = mkLams (map zapIdUnfolding final_bndrs) rhs_with_seqs++        ; join_bndr <- newJoinId filtered_binders rhs_ty'++        ; let join_call = mkApps (Var join_bndr) final_args+              alt'      = Alt con alt_bndrs join_call++        ; return ( jfloats `addJoinFlts` unitJoinFloat (NonRec join_bndr join_rhs)+                 , alt') }+                -- See Note [Duplicated env]++{-+Note [Fusing case continuations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's important to fuse two successive case continuations when the+first has one alternative.  That's why we call prepareCaseCont here.+Consider this, which arises from thunk splitting (see Note [Thunk+splitting] in GHC.Core.Opt.WorkWrap):++      let+        x* = case (case v of {pn -> rn}) of+               I# a -> I# a+      in body++The simplifier will find+    (Var v) with continuation+            Select (pn -> rn) (+            Select [I# a -> I# a] (+            StrictBind body Stop++So we'll call mkDupableCont on+   Select [I# a -> I# a] (StrictBind body Stop)+There is just one alternative in the first Select, so we want to+simplify the rhs (I# a) with continuation (StrictBind body Stop)+Supposing that body is big, we end up with+          let $j a = <let x = I# a in body>+          in case v of { pn -> case rn of+                                 I# a -> $j a }+This is just what we want because the rn produces a box that+the case rn cancels with.++See #4957 a fuller example.++Note [Duplicating join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+IN #19996 we discovered that we want to be really careful about+inlining join points.   Consider+    case (join $j x = K f x )+         (in case v of      )+         (     p1 -> $j x1  ) of+         (     p2 -> $j x2  )+         (     p3 -> $j x3  )+      K g y -> blah[g,y]++Here the join-point RHS is very small, just a constructor+application (K x y).  So we might inline it to get+    case (case v of        )+         (     p1 -> K f x1  ) of+         (     p2 -> K f x2  )+         (     p3 -> K f x3  )+      K g y -> blah[g,y]++But now we have to make `blah` into a join point, /abstracted/+over `g` and `y`.   In contrast, if we /don't/ inline $j we+don't need a join point for `blah` and we'll get+    join $j x = let g=f, y=x in blah[g,y]+    in case v of+       p1 -> $j x1+       p2 -> $j x2+       p3 -> $j x3++This can make a /massive/ difference, because `blah` can see+what `f` is, instead of lambda-abstracting over it.++To achieve this:++1. Do not postInlineUnconditionally a join point, until the Final+   phase.  (The Final phase is still quite early, so we might consider+   delaying still more.)++2. In mkDupableAlt and mkDupableStrictBind, generate an alterative for+   all alternatives, except for exprIsTrival RHSs. Previously we used+   exprIsDupable.  This generates a lot more join points, but makes+   them much more case-of-case friendly.++   It is definitely worth checking for exprIsTrivial, otherwise we get+   an extra Simplifier iteration, because it is inlined in the next+   round.++3. By the same token we want to use Plan B in+   Note [Duplicating StrictArg] when the RHS of the new join point+   is a data constructor application.  That same Note explains why we+   want Plan A when the RHS of the new join point would be a+   non-data-constructor application++4. You might worry that $j will be inlined by the call-site inliner,+   but it won't because the call-site context for a join is usually+   extremely boring (the arguments come from the pattern match).+   And if not, then perhaps inlining it would be a good idea.++   You might also wonder if we get UnfWhen, because the RHS of the+   join point is no bigger than the call. But in the cases we care+   about it will be a little bigger, because of that free `f` in+       $j x = K f x+   So for now we don't do anything special in callSiteInline++There is a bit of tension between (2) and (3).  Do we want to retain+the join point only when the RHS is+* a constructor application? or+* just non-trivial?+Currently, a bit ad-hoc, but we definitely want to retain the join+point for data constructors in mkDupalbleALt (point 2); that is the+whole point of #19996 described above.++Historical Note [Case binders and join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+NB: this entire Note is now irrelevant.  In Jun 21 we stopped+adding unfoldings to lambda binders (#17530).  It was always a+hack and bit us in multiple small and not-so-small ways++Consider this+   case (case .. ) of c {+     I# c# -> ....c....++If we make a join point with c but not c# we get+  $j = \c -> ....c....++But if later inlining scrutinises the c, thus++  $j = \c -> ... case c of { I# y -> ... } ...++we won't see that 'c' has already been scrutinised.  This actually+happens in the 'tabulate' function in wave4main, and makes a significant+difference to allocation.++An alternative plan is this:++   $j = \c# -> let c = I# c# in ...c....++but that is bad if 'c' is *not* later scrutinised.++So instead we do both: we pass 'c' and 'c#' , and record in c's inlining+(a stable unfolding) that it's really I# c#, thus++   $j = \c# -> \c[=I# c#] -> ...c....++Absence analysis may later discard 'c'.++NB: take great care when doing strictness analysis;+    see Note [Lambda-bound unfoldings] in GHC.Core.Opt.DmdAnal.++Also note that we can still end up passing stuff that isn't used.  Before+strictness analysis we have+   let $j x y c{=(x,y)} = (h c, ...)+   in ...+After strictness analysis we see that h is strict, we end up with+   let $j x y c{=(x,y)} = ($wh x y, ...)+and c is unused.++Note [Duplicated env]+~~~~~~~~~~~~~~~~~~~~~+Some of the alternatives are simplified, but have not been turned into a join point+So they *must* have a zapped subst-env.  So we can't use completeNonRecX to+bind the join point, because it might to do PostInlineUnconditionally, and+we'd lose that when zapping the subst-env.  We could have a per-alt subst-env,+but zapping it (as we do in mkDupableCont, the Select case) is safe, and+at worst delays the join-point inlining.++Note [Funky mkLamTypes]+~~~~~~~~~~~~~~~~~~~~~~+Notice the funky mkLamTypes.  If the constructor has existentials+it's possible that the join point will be abstracted over+type variables as well as term variables.+ Example:  Suppose we have+        data T = forall t.  C [t]+ Then faced with+        case (case e of ...) of+            C t xs::[t] -> rhs+ We get the join point+        let j :: forall t. [t] -> ...+            j = /\t \xs::[t] -> rhs+        in+        case (case e of ...) of+            C t xs::[t] -> j t xs++Note [Duplicating StrictArg]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Dealing with making a StrictArg continuation duplicable has turned out+to be one of the trickiest corners of the simplifier, giving rise+to several cases in which the simplier expanded the program's size+*exponentially*.  They include+  #13253 exponential inlining+  #10421 ditto+  #18140 strict constructors+  #18282 another nested-function call case++Suppose we have a call+  f e1 (case x of { True -> r1; False -> r2 }) e3+and f is strict in its second argument.  Then we end up in+mkDupableCont with a StrictArg continuation for (f e1 <> e3).+There are two ways to make it duplicable.++* Plan A: move the entire call inwards, being careful not+  to duplicate e1 or e3, thus:+     let a1 = e1+         a3 = e3+     in case x of { True  -> f a1 r1 a3+                  ; False -> f a1 r2 a3 }++* Plan B: make a join point:+     join $j x = f e1 x e3+     in case x of { True  -> jump $j r1+                  ; False -> jump $j r2 }++  Notice that Plan B is very like the way we handle strict bindings;+  see Note [Duplicating StrictBind].  And Plan B is exactly what we'd+  get if we turned use a case expression to evaluate the strict arg:++       case (case x of { True -> r1; False -> r2 }) of+         r -> f e1 r e3++  So, looking at Note [Duplicating join points], we also want Plan B+  when `f` is a data constructor.++Plan A is often good. Here's an example from #3116+     go (n+1) (case l of+                 1  -> bs'+                 _  -> Chunk p fpc (o+1) (l-1) bs')++If we pushed the entire call for 'go' inside the case, we get+call-pattern specialisation for 'go', which is *crucial* for+this particular program.++Here is another example.+        && E (case x of { T -> F; F -> T })++Pushing the call inward (being careful not to duplicate E)+        let a = E+        in case x of { T -> && a F; F -> && a T }++and now the (&& a F) etc can optimise.  Moreover there might+be a RULE for the function that can fire when it "sees" the+particular case alternative.++But Plan A can have terrible, terrible behaviour. Here is a classic+case:+  f (f (f (f (f True))))++Suppose f is strict, and has a body that is small enough to inline.+The innermost call inlines (seeing the True) to give+  f (f (f (f (case v of { True -> e1; False -> e2 }))))++Now, suppose we naively push the entire continuation into both+case branches (it doesn't look large, just f.f.f.f). We get+  case v of+    True  -> f (f (f (f e1)))+    False -> f (f (f (f e2)))++And now the process repeats, so we end up with an exponentially large+number of copies of f. No good!++CONCLUSION: we want Plan A in general, but do Plan B is there a+danger of this nested call behaviour. The function that decides+this is called thumbsUpPlanA.++Note [Keeping demand info in StrictArg Plan A]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Following on from Note [Duplicating StrictArg], another common code+pattern that can go bad is this:+   f (case x1 of { T -> F; F -> T })+     (case x2 of { T -> F; F -> T })+     ...etc...+when f is strict in all its arguments.  (It might, for example, be a+strict data constructor whose wrapper has not yet been inlined.)++We use Plan A (because there is no nesting) giving+  let a2 = case x2 of ...+      a3 = case x3 of ...+  in case x1 of { T -> f F a2 a3 ... ; F -> f T a2 a3 ... }++Now we must be careful!  a2 and a3 are small, and the OneOcc code in+postInlineUnconditionally may inline them both at both sites; see Note+Note [Inline small things to avoid creating a thunk] in+Simplify.Utils. But if we do inline them, the entire process will+repeat -- back to exponential behaviour.++So we are careful to keep the demand-info on a2 and a3.  Then they'll+be /strict/ let-bindings, which will be dealt with by StrictBind.+That's why contIsDupableWithDmds is careful to propagage demand+info to the auxiliary bindings it creates.  See the Demand argument+to makeTrivial.++Note [Duplicating StrictBind]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We make a StrictBind duplicable in a very similar way to+that for case expressions.  After all,+   let x* = e in b   is similar to    case e of x -> b++So we potentially make a join-point for the body, thus:+   let x = <> in b   ==>   join j x = b+                           in j <>++Just like StrictArg in fact -- and indeed they share code.++Note [Join point abstraction]  Historical note+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+NB: This note is now historical, describing how (in the past) we used+to add a void argument to nullary join points.  But now that "join+point" is not a fuzzy concept but a formal syntactic construct (as+distinguished by the JoinId constructor of IdDetails), each of these+concerns is handled separately, with no need for a vestigial extra+argument.++Join points always have at least one value argument,+for several reasons++* If we try to lift a primitive-typed something out+  for let-binding-purposes, we will *caseify* it (!),+  with potentially-disastrous strictness results.  So+  instead we turn it into a function: \v -> e+  where v::Void#.  The value passed to this function is void,+  which generates (almost) no code.++* CPR.  We used to say "&& isUnliftedType rhs_ty'" here, but now+  we make the join point into a function whenever used_bndrs'+  is empty.  This makes the join-point more CPR friendly.+  Consider:       let j = if .. then I# 3 else I# 4+                  in case .. of { A -> j; B -> j; C -> ... }++  Now CPR doesn't w/w j because it's a thunk, so+  that means that the enclosing function can't w/w either,+  which is a lose.  Here's the example that happened in practice:+          kgmod :: Int -> Int -> Int+          kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0+                      then 78+                      else 5++* Let-no-escape.  We want a join point to turn into a let-no-escape+  so that it is implemented as a jump, and one of the conditions+  for LNE is that it's not updatable.  In CoreToStg, see+  Note [What is a non-escaping let]++* Floating.  Since a join point will be entered once, no sharing is+  gained by floating out, but something might be lost by doing+  so because it might be allocated.++I have seen a case alternative like this:+        True -> \v -> ...+It's a bit silly to add the realWorld dummy arg in this case, making+        $j = \s v -> ...+           True -> $j s+(the \v alone is enough to make CPR happy) but I think it's rare++There's a slight infelicity here: we pass the overall+case_bndr to all the join points if it's used in *any* RHS,+because we don't know its usage in each RHS separately++++************************************************************************+*                                                                      *+                    Unfoldings+*                                                                      *+************************************************************************+-}++simplLetUnfolding :: SimplEnv+                  -> BindContext+                  -> InId+                  -> OutExpr -> OutType -> ArityType+                  -> Unfolding -> SimplM Unfolding+simplLetUnfolding env bind_cxt id new_rhs rhs_ty arity unf+  | isStableUnfolding unf+  = simplStableUnfolding env bind_cxt id rhs_ty arity unf+  | isExitJoinId id+  = return noUnfolding -- See Note [Do not inline exit join points] in GHC.Core.Opt.Exitify+  | otherwise+  = -- Otherwise, we end up retaining all the SimpleEnv+    let !opts = seUnfoldingOpts env+    in mkLetUnfolding opts (bindContextLevel bind_cxt) InlineRhs id new_rhs++-------------------+mkLetUnfolding :: UnfoldingOpts -> TopLevelFlag -> UnfoldingSource+               -> InId -> OutExpr -> SimplM Unfolding+mkLetUnfolding !uf_opts top_lvl src id new_rhs+  = return (mkUnfolding uf_opts src is_top_lvl is_bottoming new_rhs)+            -- We make an  unfolding *even for loop-breakers*.+            -- Reason: (a) It might be useful to know that they are WHNF+            --         (b) In GHC.Iface.Tidy we currently assume that, if we want to+            --             expose the unfolding then indeed we *have* an unfolding+            --             to expose.  (We could instead use the RHS, but currently+            --             we don't.)  The simple thing is always to have one.+  where+    -- Might as well force this, profiles indicate up to 0.5MB of thunks+    -- just from this site.+    !is_top_lvl   = isTopLevel top_lvl+    -- See Note [Force bottoming field]+    !is_bottoming = isDeadEndId id++-------------------+simplStableUnfolding :: SimplEnv -> BindContext+                     -> InId+                     -> OutType+                     -> ArityType      -- Used to eta expand, but only for non-join-points+                     -> Unfolding+                     ->SimplM Unfolding+-- Note [Setting the new unfolding]+simplStableUnfolding env bind_cxt id rhs_ty id_arity unf+  = case unf of+      NoUnfolding   -> return unf+      BootUnfolding -> return unf+      OtherCon {}   -> return unf++      DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }+        -> do { (env', bndrs') <- simplBinders unf_env bndrs+              ; args' <- mapM (simplExpr env') args+              ; return (mkDFunUnfolding bndrs' con args') }++      CoreUnfolding { uf_tmpl = expr, uf_src = src, uf_guidance = guide }+        | isStableSource src+        -> do { expr' <- case bind_cxt of+                           BC_Join cont -> -- Binder is a join point+                                           -- See Note [Rules and unfolding for join points]+                                           simplJoinRhs unf_env id expr cont+                           BC_Let {} -> -- Binder is not a join point+                                        do { expr' <- simplExprC unf_env expr (mkBoringStop rhs_ty)+                                           ; return (eta_expand expr') }+              ; case guide of+                  UnfWhen { ug_arity = arity+                          , ug_unsat_ok = sat_ok+                          , ug_boring_ok = boring_ok+                          }+                          -- Happens for INLINE things+                        -- Really important to force new_boring_ok as otherwise+                        -- `ug_boring_ok` is a thunk chain of+                        -- inlineBoringExprOk expr0+                        --  || inlineBoringExprOk expr1 || ...+                        --  See #20134+                     -> let !new_boring_ok = boring_ok || inlineBoringOk expr'+                            guide' =+                              UnfWhen { ug_arity = arity+                                      , ug_unsat_ok = sat_ok+                                      , ug_boring_ok = new_boring_ok++                                      }+                        -- Refresh the boring-ok flag, in case expr'+                        -- has got small. This happens, notably in the inlinings+                        -- for dfuns for single-method classes; see+                        -- Note [Single-method classes] in GHC.Tc.TyCl.Instance.+                        -- A test case is #4138+                        -- But retain a previous boring_ok of True; e.g. see+                        -- the way it is set in calcUnfoldingGuidanceWithArity+                        in return (mkCoreUnfolding src is_top_lvl expr' guide')+                            -- See Note [Top-level flag on inline rules] in GHC.Core.Unfold++                  _other              -- Happens for INLINABLE things+                     -> mkLetUnfolding uf_opts top_lvl src id expr' }+                -- If the guidance is UnfIfGoodArgs, this is an INLINABLE+                -- unfolding, and we need to make sure the guidance is kept up+                -- to date with respect to any changes in the unfolding.++        | otherwise -> return noUnfolding   -- Discard unstable unfoldings+  where+    uf_opts    = seUnfoldingOpts env+    -- Forcing this can save about 0.5MB of max residency and the result+    -- is small and easy to compute so might as well force it.+    top_lvl     = bindContextLevel bind_cxt+    !is_top_lvl = isTopLevel top_lvl+    act        = idInlineActivation id+    unf_env    = updMode (updModeForStableUnfoldings act) env+         -- See Note [Simplifying inside stable unfoldings] in GHC.Core.Opt.Simplify.Utils++    -- See Note [Eta-expand stable unfoldings]+    eta_expand expr+      | not eta_on         = expr+      | exprIsTrivial expr = expr+      | otherwise          = etaExpandAT (getInScope env) id_arity expr+    eta_on = sm_eta_expand (getMode env)++{- Note [Eta-expand stable unfoldings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For INLINE/INLINABLE things (which get stable unfoldings) there's a danger+of getting+   f :: Int -> Int -> Int -> Blah+   [ Arity = 3                 -- Good arity+   , Unf=Stable (\xy. blah)    -- Less good arity, only 2+   f = \pqr. e++This can happen because f's RHS is optimised more vigorously than+its stable unfolding.  Now suppose we have a call+   g = f x+Because f has arity=3, g will have arity=2.  But if we inline f (using+its stable unfolding) g's arity will reduce to 1, because <blah>+hasn't been optimised yet.  This happened in the 'parsec' library,+for Text.Pasec.Char.string.++Generally, if we know that 'f' has arity N, it seems sensible to+eta-expand the stable unfolding to arity N too. Simple and consistent.++Wrinkles++* See Note [Eta-expansion in stable unfoldings] in+  GHC.Core.Opt.Simplify.Utils++* Don't eta-expand a trivial expr, else each pass will eta-reduce it,+  and then eta-expand again. See Note [Do not eta-expand trivial expressions]+  in GHC.Core.Opt.Simplify.Utils.++* Don't eta-expand join points; see Note [Do not eta-expand join points]+  in GHC.Core.Opt.Simplify.Utils.  We uphold this because the join-point+  case (bind_cxt = BC_Join _) doesn't use eta_expand.++Note [Force bottoming field]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We need to force bottoming, or the new unfolding holds+on to the old unfolding (which is part of the id).++Note [Setting the new unfolding]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* If there's an INLINE pragma, we simplify the RHS gently.  Maybe we+  should do nothing at all, but simplifying gently might get rid of+  more crap.++* If not, we make an unfolding from the new RHS.  But *only* for+  non-loop-breakers. Making loop breakers not have an unfolding at all+  means that we can avoid tests in exprIsConApp, for example.  This is+  important: if exprIsConApp says 'yes' for a recursive thing, then we+  can get into an infinite loop++If there's a stable unfolding on a loop breaker (which happens for+INLINABLE), we hang on to the inlining.  It's pretty dodgy, but the+user did say 'INLINE'.  May need to revisit this choice.++************************************************************************+*                                                                      *+                    Rules+*                                                                      *+************************************************************************++Note [Rules in a letrec]+~~~~~~~~~~~~~~~~~~~~~~~~+After creating fresh binders for the binders of a letrec, we+substitute the RULES and add them back onto the binders; this is done+*before* processing any of the RHSs.  This is important.  Manuel found+cases where he really, really wanted a RULE for a recursive function+to apply in that function's own right-hand side.++See Note [Forming Rec groups] in "GHC.Core.Opt.OccurAnal"+-}++addBndrRules :: SimplEnv -> InBndr -> OutBndr+             -> BindContext+             -> SimplM (SimplEnv, OutBndr)+-- Rules are added back into the bin+addBndrRules env in_id out_id bind_cxt+  | null old_rules+  = return (env, out_id)+  | otherwise+  = do { new_rules <- simplRules env (Just out_id) old_rules bind_cxt+       ; let final_id  = out_id `setIdSpecialisation` mkRuleInfo new_rules+       ; return (modifyInScope env final_id, final_id) }+  where+    old_rules = ruleInfoRules (idSpecialisation in_id)++simplImpRules :: SimplEnv -> [CoreRule] -> SimplM [CoreRule]+-- Simplify local rules for imported Ids+simplImpRules env rules+  = simplRules env Nothing rules (BC_Let TopLevel NonRecursive)++simplRules :: SimplEnv -> Maybe OutId -> [CoreRule]+           -> BindContext -> SimplM [CoreRule]+simplRules env mb_new_id rules bind_cxt+  = mapM simpl_rule rules+  where+    simpl_rule rule@(BuiltinRule {})+      = return rule++    simpl_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args+                          , ru_fn = fn_name, ru_rhs = rhs+                          , ru_act = act })+      = do { (env', bndrs') <- simplBinders env bndrs+           ; let rhs_ty = substTy env' (exprType rhs)+                 rhs_cont = case bind_cxt of  -- See Note [Rules and unfolding for join points]+                                BC_Let {}    -> mkBoringStop rhs_ty+                                BC_Join cont -> assertPpr join_ok bad_join_msg cont+                 lhs_env = updMode updModeForRules env'+                 rhs_env = updMode (updModeForStableUnfoldings act) env'+                           -- See Note [Simplifying the RHS of a RULE]+                 fn_name' = case mb_new_id of+                              Just id -> idName id+                              Nothing -> fn_name++                 -- join_ok is an assertion check that the join-arity of the+                 -- binder matches that of the rule, so that pushing the+                 -- continuation into the RHS makes sense+                 join_ok = case mb_new_id of+                             Just id | Just join_arity <- isJoinId_maybe id+                                     -> length args == join_arity+                             _ -> False+                 bad_join_msg = vcat [ ppr mb_new_id, ppr rule+                                     , ppr (fmap isJoinId_maybe mb_new_id) ]++           ; args' <- mapM (simplExpr lhs_env) args+           ; rhs'  <- simplExprC rhs_env rhs rhs_cont+           ; return (rule { ru_bndrs = bndrs'+                          , ru_fn    = fn_name'+                          , ru_args  = args'+                          , ru_rhs   = rhs' }) }++{- Note [Simplifying the RHS of a RULE]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We can simplify the RHS of a RULE much as we do the RHS of a stable+unfolding.  We used to use the much more conservative updModeForRules+for the RHS as well as the LHS, but that seems more conservative+than necesary.  Allowing some inlining might, for example, eliminate+a binding.+-}+
compiler/GHC/Core/Opt/Simplify/Env.hs view
@@ -4,8 +4,8 @@ \section[GHC.Core.Opt.Simplify.Monad]{The simplifier Monad} -} -{-# LANGUAGE CPP #-} + module GHC.Core.Opt.Simplify.Env (         -- * The simplifier mode         setMode, getMode, updMode, seDynFlags, seUnfoldingOpts, seLogger,@@ -29,7 +29,7 @@         substCo, substCoVar,          -- * Floats-        SimplFloats(..), emptyFloats, mkRecFloats,+        SimplFloats(..), emptyFloats, isEmptyFloats, mkRecFloats,         mkFloatBind, addLetFloats, addJoinFloats, addFloats,         extendFloats, wrapFloats,         doFloatFromRhs, getTopFloatBinds,@@ -43,8 +43,6 @@         wrapJoinFloats, wrapJoinFloatsX, unitJoinFloat, addJoinFlts     ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Core.Opt.Simplify.Monad@@ -70,6 +68,7 @@ import GHC.Utils.Monad import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Misc import GHC.Utils.Logger import GHC.Types.Unique.FM      ( pprUniqFM )@@ -140,6 +139,13 @@                 , sfJoinFloats = emptyJoinFloats                 , sfInScope    = seInScope env } +isEmptyFloats :: SimplFloats -> Bool+-- Precondition: used only when sfJoinFloats is empty+isEmptyFloats (SimplFloats { sfLetFloats  = LetFloats fs _+                           , sfJoinFloats = js })+  = assertPpr (isNilOL js) (ppr js ) $+    isNilOL fs+ pprSimplEnv :: SimplEnv -> SDoc -- Used for debugging; selective pprSimplEnv env@@ -336,17 +342,17 @@ --------------------- extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res-  = ASSERT2( isId var && not (isCoVar var), ppr var )+  = assertPpr (isId var && not (isCoVar var)) (ppr var) $     env { seIdSubst = extendVarEnv subst var res }  extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv extendTvSubst env@(SimplEnv {seTvSubst = tsubst}) var res-  = ASSERT2( isTyVar var, ppr var $$ ppr res )+  = assertPpr (isTyVar var) (ppr var $$ ppr res) $     env {seTvSubst = extendVarEnv tsubst var res}  extendCvSubst :: SimplEnv -> CoVar -> Coercion -> SimplEnv extendCvSubst env@(SimplEnv {seCvSubst = csubst}) var co-  = ASSERT( isCoVar var )+  = assert (isCoVar var) $     env {seCvSubst = extendVarEnv csubst var co}  ---------------------@@ -486,7 +492,7 @@  doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> SimplFloats -> OutExpr -> Bool -- If you change this function look also at FloatIn.noFloatFromRhs-doFloatFromRhs lvl rec str (SimplFloats { sfLetFloats = LetFloats fs ff }) rhs+doFloatFromRhs lvl rec strict_bind (SimplFloats { sfLetFloats = LetFloats fs ff }) rhs   =  not (isNilOL fs) && want_to_float && can_float   where      want_to_float = isTopLevel lvl || exprIsCheap rhs || exprIsExpandable rhs@@ -494,7 +500,7 @@      can_float = case ff of                    FltLifted  -> True                    FltOkSpec  -> isNotTopLevel lvl && isNonRec rec-                   FltCareful -> isNotTopLevel lvl && isNonRec rec && str+                   FltCareful -> isNotTopLevel lvl && isNonRec rec && strict_bind  {- Note [Float when cheap or expandable]@@ -516,7 +522,7 @@  unitLetFloat :: OutBind -> LetFloats -- This key function constructs a singleton float with the right form-unitLetFloat bind = ASSERT(all (not . isJoinId) (bindersOf bind))+unitLetFloat bind = assert (all (not . isJoinId) (bindersOf bind)) $                     LetFloats (unitOL bind) (flag bind)   where     flag (Rec {})                = FltLifted@@ -526,12 +532,14 @@           -- String literals can be floated freely.           -- See Note [Core top-level string literals] in GHC.Core.       | exprOkForSpeculation rhs = FltOkSpec  -- Unlifted, and lifted but ok-for-spec (eg HNF)-      | otherwise                = ASSERT2( not (isUnliftedType (idType bndr)), ppr bndr )+      | otherwise                = assertPpr (not (isUnliftedType (idType bndr))) (ppr bndr)+                                   -- NB: binders always have a fixed RuntimeRep, so calling+                                   -- isUnliftedType is OK here                                    FltCareful       -- Unlifted binders can only be let-bound if exprOkForSpeculation holds  unitJoinFloat :: OutBind -> JoinFloats-unitJoinFloat bind = ASSERT(all isJoinId (bindersOf bind))+unitJoinFloat bind = assert (all isJoinId (bindersOf bind)) $                      unitOL bind  mkFloatBind :: SimplEnv -> OutBind -> (SimplFloats, SimplEnv)@@ -577,11 +585,14 @@ -- Add the let-floats for env2 to env1; -- *plus* the in-scope set for env2, which is bigger -- than that for env1-addLetFloats floats let_floats@(LetFloats binds _)+addLetFloats floats let_floats   = floats { sfLetFloats = sfLetFloats floats `addLetFlts` let_floats-           , sfInScope   = foldlOL extendInScopeSetBind-                                   (sfInScope floats) binds }+           , sfInScope   = sfInScope floats `extendInScopeFromLF` let_floats } +extendInScopeFromLF :: InScopeSet -> LetFloats -> InScopeSet+extendInScopeFromLF in_scope (LetFloats binds _)+  = foldlOL extendInScopeSetBind in_scope binds+ addJoinFloats :: SimplFloats -> JoinFloats -> SimplFloats addJoinFloats floats join_floats   = floats { sfJoinFloats = sfJoinFloats floats `addJoinFlts` join_floats@@ -618,7 +629,7 @@ mkRecFloats floats@(SimplFloats { sfLetFloats  = LetFloats bs _ff                                 , sfJoinFloats = jbs                                 , sfInScope    = in_scope })-  = ASSERT2( isNilOL bs || isNilOL jbs, ppr floats )+  = assertPpr (isNilOL bs || isNilOL jbs) (ppr floats) $     SimplFloats { sfLetFloats  = floats'                 , sfJoinFloats = jfloats'                 , sfInScope    = in_scope }@@ -654,7 +665,7 @@ getTopFloatBinds :: SimplFloats -> [CoreBind] getTopFloatBinds (SimplFloats { sfLetFloats  = lbs                               , sfJoinFloats = jbs})-  = ASSERT( isNilOL jbs )  -- Can't be any top-level join bindings+  = assert (isNilOL jbs) $  -- Can't be any top-level join bindings     letFloatBinds lbs  {-# INLINE mapLetFloats #-}@@ -786,7 +797,7 @@ -- Recursive let binders simplRecBndrs env@(SimplEnv {}) ids   -- See Note [Bangs in the Simplifier]-  = ASSERT(all (not . isJoinId) ids)+  = assert (all (not . isJoinId) ids) $     do  { let (!env1, ids1) = mapAccumL substIdBndr env ids         ; seqIds ids1 `seq` return env1 } @@ -832,7 +843,7 @@               -> (SimplEnv, OutBndr) subst_id_bndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst })               old_id adjust_type-  = ASSERT2( not (isCoVar old_id), ppr old_id )+  = assertPpr (not (isCoVar old_id)) (ppr old_id)     (env { seInScope = new_in_scope,            seIdSubst = new_subst }, new_id)     -- It's important that both seInScope and seIdSubst are updated with@@ -933,7 +944,7 @@ -- context being pushed inward may change types -- See Note [Return type for join points] simplRecJoinBndrs env@(SimplEnv {}) ids mult res_ty-  = ASSERT(all isJoinId ids)+  = assert (all isJoinId ids) $     do  { let (env1, ids1) = mapAccumL (simplJoinBndr mult res_ty) env ids         ; seqIds ids1 `seq` return env1 } @@ -960,7 +971,7 @@ -- INVARIANT: If any of the first n binders are foralls, those tyvars -- cannot appear in the original result type. See isValidJoinPointType. adjustJoinPointType mult new_res_ty join_id-  = ASSERT( isJoinId join_id )+  = assert (isJoinId join_id) $     setIdType join_id new_join_ty   where     orig_ar = idJoinArity join_id
compiler/GHC/Core/Opt/Simplify/Monad.hs view
@@ -28,7 +28,8 @@ import GHC.Types.Id.Info   ( IdDetails(..), vanillaIdInfo, setArityInfo ) import GHC.Core.Type       ( Type, Mult ) import GHC.Core.FamInstEnv ( FamInstEnv )-import GHC.Core            ( RuleEnv(..) )+import GHC.Core            ( RuleEnv(..), RuleBase)+import GHC.Core.Rules import GHC.Core.Utils      ( mkLamTypes ) import GHC.Core.Coercion.Opt import GHC.Types.Unique.Supply@@ -79,20 +80,23 @@   = STE { st_flags     :: DynFlags         , st_logger    :: !Logger         , st_max_ticks :: IntWithInf  -- ^ Max #ticks in this simplifier run-        , st_rules     :: RuleEnv+        , st_query_rulebase :: IO RuleBase+          -- ^ The action to retrieve an up-to-date EPS RuleBase+          -- See Note [Overall plumbing for rules]+        , st_mod_rules :: RuleEnv         , st_fams      :: (FamInstEnv, FamInstEnv)          , st_co_opt_opts :: !OptCoercionOpts             -- ^ Coercion optimiser options         } -initSmpl :: Logger -> DynFlags -> RuleEnv -> (FamInstEnv, FamInstEnv)+initSmpl :: Logger -> DynFlags -> IO RuleBase -> RuleEnv -> (FamInstEnv, FamInstEnv)          -> Int                 -- Size of the bindings, used to limit                                 -- the number of ticks we allow          -> SimplM a          -> IO (a, SimplCount) -initSmpl logger dflags rules fam_envs size m+initSmpl logger dflags qrb rules fam_envs size m   = do -- No init count; set to 0        let simplCount = zeroSimplCount dflags        (result, count) <- unSM m env simplCount@@ -100,7 +104,8 @@   where     env = STE { st_flags = dflags               , st_logger = logger-              , st_rules = rules+              , st_query_rulebase = qrb+              , st_mod_rules = rules               , st_max_ticks = computeMaxTicks dflags size               , st_fams = fam_envs               , st_co_opt_opts = initOptCoercionOpts dflags@@ -169,9 +174,8 @@  traceSmpl :: String -> SDoc -> SimplM () traceSmpl herald doc-  = do dflags <- getDynFlags-       logger <- getLogger-       liftIO $ Logger.dumpIfSet_dyn logger dflags Opt_D_dump_simpl_trace "Simpl Trace"+  = do logger <- getLogger+       liftIO $ Logger.putDumpFileMaybe logger Opt_D_dump_simpl_trace "Simpl Trace"          FormatText          (hang (text herald) 2 doc) {-# INLINE traceSmpl #-}  -- see Note [INLINE conditional tracing utilities]@@ -204,7 +208,9 @@       return (x, sc)  getSimplRules :: SimplM RuleEnv-getSimplRules = SM (\st_env sc -> return (st_rules st_env, sc))+getSimplRules = SM (\st_env sc -> do+    eps_rules <- st_query_rulebase st_env+    return (extendRuleEnv (st_mod_rules st_env) eps_rules, sc))  getFamEnvs :: SimplM (FamInstEnv, FamInstEnv) getFamEnvs = SM (\st_env sc -> return (st_fams st_env, sc))@@ -216,6 +222,7 @@ newId fs w ty = do uniq <- getUniqueM                    return (mkSysLocalOrCoVar fs uniq w ty) +-- | Make a join id with given type and arity but without call-by-value annotations. newJoinId :: [Var] -> Type -> SimplM Id newJoinId bndrs body_ty   = do { uniq <- getUniqueM@@ -224,7 +231,7 @@              arity      = count isId bndrs              -- arity: See Note [Invariants on join points] invariant 2b, in GHC.Core              join_arity = length bndrs-             details    = JoinId join_arity+             details    = JoinId join_arity Nothing              id_info    = vanillaIdInfo `setArityInfo` arity --                                        `setOccInfo` strongLoopBreaker
compiler/GHC/Core/Opt/Simplify/Utils.hs view
@@ -4,8 +4,8 @@ The simplifier utilities -} -{-# LANGUAGE CPP #-} + module GHC.Core.Opt.Simplify.Utils (         -- Rebuilding         mkLam, mkCase, prepareAlts, tryEtaExpandRhs,@@ -16,6 +16,9 @@         getUnfoldingInRuleMatch,         simplEnvForGHCi, updModeForStableUnfoldings, updModeForRules, +        -- The BindContext type+        BindContext(..), bindContextLevel,+         -- The continuation type         SimplCont(..), DupFlag(..), StaticEnv,         isSimplified, contIsStop,@@ -37,15 +40,14 @@         isExitJoinId     ) where -#include "GhclibHsVersions.h"- import GHC.Prelude -import GHC.Core.Opt.Simplify.Env-import GHC.Core.Opt.Monad        ( SimplMode(..), Tick(..) ) import GHC.Driver.Session-import GHC.Driver.Ppr+ import GHC.Core+import GHC.Types.Literal ( isLitRubbish )+import GHC.Core.Opt.Simplify.Env+import GHC.Core.Opt.Monad        ( SimplMode(..), Tick(..) ) import qualified GHC.Core.Subst import GHC.Core.Ppr import GHC.Core.TyCo.Ppr ( pprParendType )@@ -54,34 +56,57 @@ import GHC.Core.Opt.Arity import GHC.Core.Unfold import GHC.Core.Unfold.Make+import GHC.Core.Opt.Simplify.Monad+import GHC.Core.Type     hiding( substTy )+import GHC.Core.Coercion hiding( substCo )+import GHC.Core.DataCon ( dataConWorkId, isNullaryRepDataCon )+import GHC.Core.Multiplicity+import GHC.Core.Opt.ConstantFold+ import GHC.Types.Name import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Tickish-import GHC.Types.Var import GHC.Types.Demand import GHC.Types.Var.Set import GHC.Types.Basic-import GHC.Core.Opt.Simplify.Monad-import GHC.Core.Type     hiding( substTy )-import GHC.Core.Coercion hiding( substCo )-import GHC.Core.DataCon ( dataConWorkId, isNullaryRepDataCon )-import GHC.Core.Multiplicity-import GHC.Utils.Misc+ import GHC.Data.OrdList ( isNilOL )+import GHC.Data.FastString ( fsLit )++import GHC.Utils.Misc import GHC.Utils.Monad import GHC.Utils.Outputable import GHC.Utils.Logger import GHC.Utils.Panic-import GHC.Core.Opt.ConstantFold-import GHC.Data.FastString ( fsLit )+import GHC.Utils.Panic.Plain+import GHC.Utils.Trace  import Control.Monad    ( when ) import Data.List        ( sortBy ) -{--************************************************************************+{- ********************************************************************* *                                                                      *+                The BindContext type+*                                                                      *+********************************************************************* -}++-- What sort of binding is this? A let-binding or a join-binding?+data BindContext+  = BC_Let                 -- A regular let-binding+      TopLevelFlag RecFlag++  | BC_Join                -- A join point with continuation k+      SimplCont            -- See Note [Rules and unfolding for join points]+                           -- in GHC.Core.Opt.Simplify++bindContextLevel :: BindContext -> TopLevelFlag+bindContextLevel (BC_Let top_lvl _) = top_lvl+bindContextLevel (BC_Join {})       = NotTopLevel+++{- *********************************************************************+*                                                                      *                 The SimplCont and DupFlag types *                                                                      * ************************************************************************@@ -127,7 +152,7 @@   | ApplyToVal         -- (ApplyToVal arg K)[e] = K[ e arg ]       { sc_dup     :: DupFlag   -- See Note [DupFlag invariants]       , sc_hole_ty :: OutType   -- Type of the function, presumably (forall a. blah)-                                -- See Note [The hole type in ApplyToTy/Val]+                                -- See Note [The hole type in ApplyToTy]       , sc_arg  :: InExpr       -- The argument,       , sc_env  :: StaticEnv    -- see Note [StaticEnv invariant]       , sc_cont :: SimplCont }@@ -135,7 +160,7 @@   | ApplyToTy          -- (ApplyToTy ty K)[e] = K[ e ty ]       { sc_arg_ty  :: OutType     -- Argument type       , sc_hole_ty :: OutType     -- Type of the function, presumably (forall a. blah)-                                  -- See Note [The hole type in ApplyToTy/Val]+                                  -- See Note [The hole type in ApplyToTy]       , sc_cont    :: SimplCont }    | Select             -- (Select alts K)[e] = K[ case e of alts ]@@ -146,11 +171,10 @@       , sc_cont :: SimplCont }    -- The two strict forms have no DupFlag, because we never duplicate them-  | StrictBind          -- (StrictBind x xs b K)[e] = let x = e in K[\xs.b]-                        --       or, equivalently,  = K[ (\x xs.b) e ]+  | StrictBind          -- (StrictBind x b K)[e] = let x = e in K[b]+                        --       or, equivalently,  = K[ (\x.b) e ]       { sc_dup   :: DupFlag        -- See Note [DupFlag invariants]       , sc_bndr  :: InId-      , sc_bndrs :: [InBndr]       , sc_body  :: InExpr       , sc_env   :: StaticEnv      -- See Note [StaticEnv invariant]       , sc_cont  :: SimplCont }@@ -406,6 +430,7 @@  contIsRhs :: SimplCont -> Bool contIsRhs (Stop _ RhsCtxt) = True+contIsRhs (CastIt _ k)     = contIsRhs k   -- For f = e |> co, treat e as Rhs context contIsRhs _                = False  -------------------@@ -426,7 +451,8 @@ contIsTrivial :: SimplCont -> Bool contIsTrivial (Stop {})                                         = True contIsTrivial (ApplyToTy { sc_cont = k })                       = contIsTrivial k-contIsTrivial (ApplyToVal { sc_arg = Coercion _, sc_cont = k }) = contIsTrivial k+-- This one doesn't look right.  A value application is not trivial+-- contIsTrivial (ApplyToVal { sc_arg = Coercion _, sc_cont = k }) = contIsTrivial k contIsTrivial (CastIt _ k)                                      = contIsTrivial k contIsTrivial _                                                 = False @@ -449,7 +475,7 @@   = perhapsSubstTy dup se (idType b) contHoleType (StrictArg  { sc_fun_ty = ty })  = funArgTy ty contHoleType (ApplyToTy  { sc_hole_ty = ty }) = ty  -- See Note [The hole type in ApplyToTy]-contHoleType (ApplyToVal { sc_hole_ty = ty }) = ty  -- See Note [The hole type in ApplyToTy/Val]+contHoleType (ApplyToVal { sc_hole_ty = ty }) = ty  -- See Note [The hole type in ApplyToTy] contHoleType (Select { sc_dup = d, sc_bndr =  b, sc_env = se })   = perhapsSubstTy d se (idType b) @@ -478,9 +504,11 @@ contHoleScaling (TickIt _ k) = contHoleScaling k ------------------- countArgs :: SimplCont -> Int--- Count all arguments, including types, coercions, and other values+-- Count all arguments, including types, coercions,+-- and other values; skipping over casts. countArgs (ApplyToTy  { sc_cont = cont }) = 1 + countArgs cont countArgs (ApplyToVal { sc_cont = cont }) = 1 + countArgs cont+countArgs (CastIt _ cont)                 = countArgs cont countArgs _                               = 0  contArgs :: SimplCont -> (Bool, [ArgSummary], SimplCont)@@ -547,7 +575,7 @@       = vanilla_dmds -- See Note [Do not expose strictness if sm_inline=False]       | otherwise       = -- add_type_str fun_ty $-        case splitStrictSig (idStrictness fun) of+        case splitDmdSig (idDmdSig fun) of           (demands, result_info)                 | not (demands `lengthExceeds` n_val_args)                 ->      -- Enough args, use the strictness given.@@ -563,8 +591,8 @@                    else                         demands ++ vanilla_dmds                | otherwise-               -> WARN( True, text "More demands than arity" <+> ppr fun <+> ppr (idArity fun)-                                <+> ppr n_val_args <+> ppr demands )+               -> warnPprTrace True "More demands than arity" (ppr fun <+> ppr (idArity fun)+                                <+> ppr n_val_args <+> ppr demands) $                   vanilla_dmds      -- Not enough args, or no strictness      add_type_strictness :: Type -> [Demand] -> [Demand]@@ -583,13 +611,15 @@        | Just (_, arg_ty, fun_ty') <- splitFunTy_maybe fun_ty        -- Add strict-type info       , dmd : rest_dmds <- dmds-      , let dmd' = case isLiftedType_maybe arg_ty of-                       Just False -> strictifyDmd dmd-                       _          -> dmd+      , let dmd'+             | Just Unlifted <- typeLevity_maybe arg_ty+             = strictifyDmd dmd+             | otherwise+             -- Something that's not definitely unlifted.+             -- If the type is representation-polymorphic, we can't know whether+             -- it's strict.+             = dmd       = dmd' : add_type_strictness fun_ty' rest_dmds-          -- If the type is levity-polymorphic, we can't know whether it's-          -- strict. isLiftedType_maybe will return Just False only when-          -- we're sure the type is unlifted.        | otherwise       = dmds@@ -816,7 +846,9 @@            DoneEx e _           -> go (zapSubstEnv env)             n e            ContEx tvs cvs ids e -> go (setSubstEnv env tvs cvs ids) n e -    go _   _ (Lit {})          = ValueArg+    go _   _ (Lit l)+       | isLitRubbish l        = TrivArg -- Leads to unproductive inlining in WWRec, #20035+       | otherwise             = ValueArg     go _   _ (Type _)          = TrivArg     go _   _ (Coercion _)      = TrivArg     go env n (App fn (Type _)) = go env n fn@@ -1113,13 +1145,9 @@     mode = getMode env     id_unf id | unf_is_active id = idUnfolding id               | otherwise        = NoUnfolding-    unf_is_active id-     | not (sm_rules mode) = -- active_unfolding_minimal id-                             isStableUnfolding (realIdUnfolding id)-        -- Do we even need to test this?  I think this InScopeEnv-        -- is only consulted if activeRule returns True, which-        -- never happens if sm_rules is False-     | otherwise           = isActive (sm_phase mode) (idInlineActivation id)+    unf_is_active id = isActive (sm_phase mode) (idInlineActivation id)+       -- When sm_rules was off we used to test for a /stable/ unfolding,+       -- but that seems wrong (#20941)  ---------------------- activeRule :: SimplMode -> Activation -> Bool@@ -1276,7 +1304,7 @@   | not (one_occ (idOccInfo bndr))           = Nothing   | not (isStableUnfolding unf)              = Just $! (extend_subst_with rhs) -  -- Note [Stable unfoldings and preInlineUnconditionally]+  -- See Note [Stable unfoldings and preInlineUnconditionally]   | not (isInlinePragma inline_prag)   , Just inl <- maybeUnfoldingTemplate unf   = Just $! (extend_subst_with inl)   | otherwise                                = Nothing@@ -1378,12 +1406,12 @@ story for now.  NB: unconditional inlining of this sort can introduce ticks in places that-may seem surprising; for instance, the LHS of rules. See Note [Simplfying+may seem surprising; for instance, the LHS of rules. See Note [Simplifying rules] for details. -}  postInlineUnconditionally-    :: SimplEnv -> TopLevelFlag+    :: SimplEnv -> BindContext     -> OutId            -- The binder (*not* a CoVar), including its unfolding     -> OccInfo          -- From the InId     -> OutExpr@@ -1392,14 +1420,15 @@ -- See Note [Core let/app invariant] in GHC.Core -- Reason: we don't want to inline single uses, or discard dead bindings, --         for unlifted, side-effect-ful bindings-postInlineUnconditionally env top_lvl bndr occ_info rhs+postInlineUnconditionally env bind_cxt bndr occ_info rhs   | not active                  = False   | isWeakLoopBreaker occ_info  = False -- If it's a loop-breaker of any kind, don't inline                                         -- because it might be referred to "earlier"   | isStableUnfolding unfolding = False -- Note [Stable unfoldings and postInlineUnconditionally]-  | isTopLevel top_lvl          = False -- Note [Top level and postInlineUnconditionally]+  | isTopLevel (bindContextLevel bind_cxt)+                                = False -- Note [Top level and postInlineUnconditionally]   | exprIsTrivial rhs           = True-  | isJoinId bndr                       -- See point (1) of Note [Duplicating join points]+  | BC_Join {} <- bind_cxt              -- See point (1) of Note [Duplicating join points]   , not (phase == FinalPhase)   = False -- in Simplify.hs   | otherwise   = case occ_info of@@ -1570,11 +1599,14 @@ -- mkLam tries three things --      a) eta reduction, if that gives a trivial expression --      b) eta expansion [only if there are some value lambdas]-+--+-- NB: the SimplEnv already includes the [OutBndr] in its in-scope set mkLam _env [] body _cont   = return body mkLam env bndrs body cont-  = do { dflags <- getDynFlags+  = {-#SCC "mkLam" #-}+--    pprTrace "mkLam" (ppr bndrs $$ ppr body $$ ppr cont) $+    do { dflags <- getDynFlags        ; mkLam' dflags bndrs body }   where     mode = getMode env@@ -1605,7 +1637,7 @@       = do { tick (EtaReduction (head bndrs))            ; return etad_lam } -      | not (contIsRhs cont)   -- See Note [Eta-expanding lambdas]+      | not (contIsRhs cont)   -- See Note [Eta expanding lambdas]       , sm_eta_expand mode       , any isRuntimeVar bndrs       , let body_arity = {-# SCC "eta" #-} exprEtaExpandArity dflags body@@ -1613,13 +1645,15 @@       = do { tick (EtaExpansion (head bndrs))            ; let res = {-# SCC "eta3" #-}                        mkLams bndrs $-                       etaExpandAT body_arity body+                       etaExpandAT in_scope body_arity body            ; traceSmpl "eta expand" (vcat [text "before" <+> ppr (mkLams bndrs body)                                           , text "after" <+> ppr res])            ; return res }        | otherwise       = return (mkLams bndrs body)+      where+        in_scope = getInScope env  -- Includes 'bndrs'  {- Note [Eta expanding lambdas]@@ -1688,16 +1722,18 @@ ************************************************************************ -} -tryEtaExpandRhs :: SimplMode -> OutId -> OutExpr+tryEtaExpandRhs :: SimplEnv -> OutId -> OutExpr                 -> SimplM (ArityType, OutExpr) -- See Note [Eta-expanding at let bindings] -- If tryEtaExpandRhs rhs = (n, is_bot, rhs') then --   (a) rhs' has manifest arity n --   (b) if is_bot is True then rhs' applied to n args is guaranteed bottom-tryEtaExpandRhs mode bndr rhs+tryEtaExpandRhs env bndr rhs   | Just join_arity <- isJoinId_maybe bndr   = do { let (join_bndrs, join_body) = collectNBinders join_arity rhs-             arity_type = mkManifestArityType join_bndrs join_body+             oss   = [idOneShotInfo id | id <- join_bndrs, isId id]+             arity_type | exprIsDeadEnd join_body = mkBotArityType oss+                        | otherwise               = mkTopArityType oss        ; return (arity_type, rhs) }          -- Note [Do not eta-expand join points]          -- But do return the correct arity and bottom-ness, because@@ -1708,12 +1744,14 @@   , new_arity > old_arity   -- And the current manifest arity isn't enough   , want_eta rhs   = do { tick (EtaExpansion bndr)-       ; return (arity_type, etaExpandAT arity_type rhs) }+       ; return (arity_type, etaExpandAT in_scope arity_type rhs) }    | otherwise   = return (arity_type, rhs)    where+    mode      = getMode env+    in_scope  = getInScope env     dflags    = sm_dflags mode     old_arity = exprArity rhs @@ -1788,7 +1826,7 @@ Suppose we have a PAP     foo :: IO ()     foo = returnIO ()-Then we can eta-expand do+Then we can eta-expand to     foo = (\eta. (returnIO () |> sym g) eta) |> g where     g :: IO () ~ State# RealWorld -> (# State# RealWorld, () #)@@ -1954,18 +1992,25 @@     otherwise we get        t = /\ (f:k->*) (a:k). AccFailure @ (f a)     which is obviously bogus.++  * We get the variables to abstract over by filtering down the+    the main_tvs for the original function, picking only ones+    mentioned in the abstracted body. This means:+    - they are automatically in dependency order, because main_tvs is+    - there is no issue about non-determinism+    - we don't gratuitiously change order, which may help (in a tiny+      way) with CSE and/or the compiler-debugging experience -}  abstractFloats :: UnfoldingOpts -> TopLevelFlag -> [OutTyVar] -> SimplFloats               -> OutExpr -> SimplM ([OutBind], OutExpr) abstractFloats uf_opts top_lvl main_tvs floats body-  = ASSERT( notNull body_floats )-    ASSERT( isNilOL (sfJoinFloats floats) )+  = assert (notNull body_floats) $+    assert (isNilOL (sfJoinFloats floats)) $     do  { (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats         ; return (float_binds, GHC.Core.Subst.substExpr subst body) }   where     is_top_lvl  = isTopLevel top_lvl-    main_tv_set = mkVarSet main_tvs     body_floats = letFloatBinds (sfLetFloats floats)     empty_subst = GHC.Core.Subst.mkEmptySubst (sfInScope floats) @@ -1979,10 +2024,9 @@         rhs' = GHC.Core.Subst.substExpr subst rhs          -- tvs_here: see Note [Which type variables to abstract over]-        tvs_here = scopedSort $-                   filter (`elemVarSet` main_tv_set) $-                   closeOverKindsList $-                   exprSomeFreeVarsList isTyVar rhs'+        tvs_here = filter (`elemVarSet` free_tvs) main_tvs+        free_tvs = closeOverKinds $+                   exprSomeFreeVars isTyVar rhs'      abstract subst (Rec prs)        = do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly1 tvs_here) ids@@ -2164,9 +2208,9 @@  mkCase tries these things -* Note [Nerge nested cases]-* Note [Eliminate identity case]-* Note [Scrutinee constant folding]+* Note [Merge Nested Cases]+* Note [Eliminate Identity Case]+* Note [Scrutinee Constant Folding]  Note [Merge Nested Cases] ~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2283,7 +2327,7 @@   , inner_scrut_var == outer_bndr   = do  { tick (CaseMerge outer_bndr) -        ; let wrap_alt (Alt con args rhs) = ASSERT( outer_bndr `notElem` args )+        ; let wrap_alt (Alt con args rhs) = assert (outer_bndr `notElem` args)                                             (Alt con args (wrap_rhs rhs))                 -- Simplifier's no-shadowing invariant should ensure                 -- that outer_bndr is not shadowed by the inner patterns
compiler/GHC/Core/Opt/SpecConstr.hs view
@@ -10,8 +10,8 @@ \section[SpecConstr]{Specialise over constructors} -} -{-# LANGUAGE CPP #-} + {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  module GHC.Core.Opt.SpecConstr(@@ -19,53 +19,61 @@         SpecConstrAnnotation(..)     ) where -#include "GhclibHsVersions.h"- import GHC.Prelude +import GHC.Driver.Session ( DynFlags(..), GeneralFlag( Opt_SpecConstrKeen )+                          , gopt, hasPprDebug )+ import GHC.Core import GHC.Core.Subst import GHC.Core.Utils import GHC.Core.Unfold import GHC.Core.FVs     ( exprsFreeVarsList ) import GHC.Core.Opt.Monad-import GHC.Types.Literal ( litIsLifted )-import GHC.Unit.Module.ModGuts-import GHC.Core.Opt.WorkWrap.Utils ( isWorkerSmallEnough, mkWorkerArgs )+import GHC.Core.Opt.WorkWrap.Utils import GHC.Core.DataCon import GHC.Core.Coercion hiding( substCo ) import GHC.Core.Rules import GHC.Core.Type     hiding ( substTy ) import GHC.Core.TyCon   (TyCon, tyConUnique, tyConName ) import GHC.Core.Multiplicity-import GHC.Types.Id import GHC.Core.Ppr     ( pprParendExpr ) import GHC.Core.Make    ( mkImpossibleExpr )++import GHC.Unit.Module+import GHC.Unit.Module.ModGuts++import GHC.Types.Literal ( litIsLifted )+import GHC.Types.Id import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Name import GHC.Types.Tickish import GHC.Types.Basic-import GHC.Driver.Session ( DynFlags(..), GeneralFlag( Opt_SpecConstrKeen )-                          , gopt, hasPprDebug )-import GHC.Driver.Ppr-import GHC.Data.Maybe     ( orElse, catMaybes, isJust, isNothing ) import GHC.Types.Demand import GHC.Types.Cpr-import GHC.Serialized   ( deserializeWithData )-import GHC.Utils.Misc-import GHC.Data.Pair import GHC.Types.Unique.Supply+import GHC.Types.Unique.FM++import GHC.Data.Maybe     ( orElse, catMaybes, isJust, isNothing )+import GHC.Data.Pair+import GHC.Data.FastString++import GHC.Utils.Misc import GHC.Utils.Outputable+import GHC.Utils.Panic.Plain import GHC.Utils.Panic-import GHC.Data.FastString-import GHC.Types.Unique.FM+import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Monad-import Control.Monad    ( zipWithM )-import Data.List (nubBy, sortBy, partition)+import GHC.Utils.Trace+ import GHC.Builtin.Names ( specTyConKey )-import GHC.Unit.Module+ import GHC.Exts( SpecConstrAnnotation(..) )+import GHC.Serialized   ( deserializeWithData )++import Control.Monad    ( zipWithM )+import Data.List (nubBy, sortBy, partition, dropWhileEnd, mapAccumL ) import Data.Ord( comparing )  {-@@ -618,6 +626,13 @@ that we have ForceSpecConstr, this NoSpecConstr is probably redundant. (Used only for PArray, TODO: remove?) +Note [SpecConstr and strict fields]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We treat strict fields in SpecConstr the same way we do in W/W.+That is we make the specialized function strict in arguments+representing strict fields. See Note [Call-by-value for worker args]+for why we do this.+ -----------------------------------------------------                 Stuff not yet handled -----------------------------------------------------@@ -707,6 +722,7 @@       us     <- getUniqueSupplyM       (_, annos) <- getFirstAnnotations deserializeWithData guts       this_mod <- getModule+      -- pprTraceM "specConstrInput" (ppr $ mg_binds guts)       let binds' = reverse $ fst $ initUs us $ do                     -- Note [Top-level recursive groups]                     (env, binds) <- goEnv (initScEnv dflags this_mod annos)@@ -946,10 +962,13 @@                       where                         (subst', bndrs') = substRecBndrs (sc_subst env) bndrs +extendBndrs :: ScEnv -> [Var] -> (ScEnv, [Var])+extendBndrs env bndrs = mapAccumL extendBndr env bndrs+ extendBndr :: ScEnv -> Var -> (ScEnv, Var)-extendBndr  env bndr  = (env { sc_subst = subst' }, bndr')-                      where-                        (subst', bndr') = substBndr (sc_subst env) bndr+extendBndr env bndr  = (env { sc_subst = subst' }, bndr')+                     where+                       (subst', bndr') = substBndr (sc_subst env) bndr  extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv extendValEnv env _  Nothing   = env@@ -1102,11 +1121,14 @@         -- The arguments of the call, together with the         -- env giving the constructor bindings at the call site         -- We keep the function mainly for debug output+        --+        -- The call is not necessarily saturated; we just put+        -- in however many args are visible at the call site  instance Outputable ScUsage where   ppr (SCU { scu_calls = calls, scu_occs = occs })-    = text "SCU" <+> braces (sep [ ptext (sLit "calls =") <+> ppr calls-                                         , text "occs =" <+> ppr occs ])+    = text "SCU" <+> braces (sep [ text "calls =" <+> ppr calls+                                 , text "occs =" <+> ppr occs ])  instance Outputable Call where   ppr (Call fn args _) = ppr fn <+> fsep (map pprParendExpr args)@@ -1136,10 +1158,8 @@             | ScrutOcc  -- See Note [ScrutOcc]                  (DataConEnv [ArgOcc])   -- How the sub-components are used -type DataConEnv a = UniqFM DataCon a     -- Keyed by DataCon--{- Note  [ScrutOcc]-~~~~~~~~~~~~~~~~~~~+{- Note [ScrutOcc]+~~~~~~~~~~~~~~~~~~ An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing, is *only* taken apart or applied. @@ -1273,7 +1293,7 @@         ; rhs_info  <- scRecRhs env (bndr',rhs)          ; let body_env2 = extendHowBound body_env [bndr'] RecFun-                           -- Note [Local let bindings]+                           -- See Note [Local let bindings]               rhs'      = ri_new_rhs rhs_info               body_env3 = extendValEnv body_env2 bndr' (isValue (sc_vals env) rhs') @@ -1283,9 +1303,14 @@           -- the parent function (see Note [Forcing specialisation])         ; (spec_usg, specs) <- specNonRec env body_usg rhs_info +        -- Specialized + original binding+        ; let spec_bnds = mkLets [NonRec b r | (b,r) <- ruleInfoBinds rhs_info specs] body'+        -- ; pprTraceM "spec_bnds" $ (ppr spec_bnds)+         ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' }                     `combineUsage` spec_usg,  -- Note [spec_usg includes rhs_usg]-                  mkLets [NonRec b r | (b,r) <- ruleInfoBinds rhs_info specs] body')+                  spec_bnds+                  )         }  @@ -1336,7 +1361,7 @@ scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr)  scApp env (Var fn, args)        -- Function is a variable-  = ASSERT( not (null args) )+  = assert (not (null args)) $     do  { args_w_usgs <- mapM (scExpr env) args         ; let (arg_usgs, args') = unzip args_w_usgs               arg_usg = combineUsages arg_usgs@@ -1399,12 +1424,6 @@ ---------------------- scTopBind :: ScEnv -> ScUsage -> CoreBind -> UniqSM (ScUsage, CoreBind) -{--scTopBind _ usage _-  | pprTrace "scTopBind_usage" (ppr (scu_calls usage)) False-  = error "false"--}- scTopBind env body_usage (Rec prs)   | Just threshold <- sc_size env   , not force_spec@@ -1603,15 +1622,16 @@   = -- pprTrace "specialise bot" (ppr fn) $     return (nullUsage, spec_info) -  | isNeverActive (idInlineActivation fn) -- See Note [Transfer activation]-    || null arg_bndrs                     -- Only specialise functions-  = -- pprTrace "specialise inactive" (ppr fn) $-    case mb_unspec of    -- Behave as if there was a single, boring call-      Just rhs_usg -> return (rhs_usg, spec_info { si_mb_unspec = Nothing })-                         -- See Note [spec_usg includes rhs_usg]-      Nothing      -> return (nullUsage, spec_info)--  | Just all_calls <- lookupVarEnv bind_calls fn+  | not (isNeverActive (idInlineActivation fn))+      -- See Note [Transfer activation]+      --+      --+      -- Don't specialise OPAQUE things, see Note [OPAQUE pragma].+      -- Since OPAQUE things are always never-active (see+      -- GHC.Parser.PostProcess.mkOpaquePragma) this guard never fires for+      -- OPAQUE things.+  , not (null arg_bndrs)                         -- Only specialise functions+  , Just all_calls <- lookupVarEnv bind_calls fn -- Some calls to it   = -- pprTrace "specialise entry {" (ppr fn <+> ppr all_calls) $     do  { (boring_call, new_pats) <- callsToNewPats env fn spec_info arg_occs all_calls @@ -1650,10 +1670,13 @@                                 , si_n_specs = spec_count + n_pats                                 , si_mb_unspec = mb_unspec' }) } -  | otherwise  -- No new seeds, so return nullUsage-  = return (nullUsage, spec_info)--+  | otherwise  -- No calls, inactive, or not a function+               -- Behave as if there was a single, boring call+  = -- pprTrace "specialise inactive" (ppr fn $$ ppr mb_unspec) $+    case mb_unspec of    -- Behave as if there was a single, boring call+      Just rhs_usg -> return (rhs_usg, spec_info { si_mb_unspec = Nothing })+                         -- See Note [spec_usg includes rhs_usg]+      Nothing      -> return (nullUsage, spec_info)   ---------------------@@ -1686,58 +1709,78 @@             f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw -} -spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number)+spec_one env fn arg_bndrs body (call_pat, rule_number)+  | CP { cp_qvars = qvars, cp_args = pats, cp_strict_args = cbv_args } <- call_pat   = do  { spec_uniq <- getUniqueM-        ; let spec_env   = extendScSubstList (extendScInScope env qvars)-                                             (arg_bndrs `zip` pats)-              fn_name    = idName fn-              fn_loc     = nameSrcSpan fn_name-              fn_occ     = nameOccName fn_name-              spec_occ   = mkSpecOcc fn_occ+        ; let env1 = extendScSubstList (extendScInScope env qvars)+                                       (arg_bndrs `zip` pats)+              (body_env, extra_bndrs) = extendBndrs env1 (dropList pats arg_bndrs)+              -- Remember, there may be fewer pats than arg_bndrs+              -- See Note [SpecConstr call patterns]+              -- extra_bndrs will then be arguments in the specialized version+              -- which are *not* applied to arguments immediately at the call sites.+              -- e.g. let f x y = ... in map (f True) xs+              -- will result in y becoming an extra_bndr++              fn_name  = idName fn+              fn_loc   = nameSrcSpan fn_name+              fn_occ   = nameOccName fn_name+              spec_occ = mkSpecOcc fn_occ               -- We use fn_occ rather than fn in the rule_name string               -- as we don't want the uniq to end up in the rule, and               -- hence in the ABI, as that can cause spurious ABI               -- changes (#4012).               rule_name  = mkFastString ("SC:" ++ occNameString fn_occ ++ show rule_number)               spec_name  = mkInternalName spec_uniq spec_occ fn_loc---      ; pprTrace "{spec_one" (ppr (sc_count env) <+> ppr fn---                              <+> ppr pats <+> text "-->" <+> ppr spec_name) $+--      ; pprTrace "spec_one {" (vcat [ text "function:" <+> ppr fn <+> ppr (idUnique fn)+--                                    , text "sc_count:" <+> ppr (sc_count env)+--                                    , text "pats:" <+> ppr pats+--                                    , text "-->" <+> ppr spec_name+--                                    , text "bndrs" <+> ppr arg_bndrs+--                                    , text "body" <+> ppr body+--                                    , text "how_bound" <+> ppr (sc_how_bound env) ]) $ --        return ()          -- Specialise the body-        ; (spec_usg, spec_body) <- scExpr spec_env body+        -- ; pprTraceM "body_subst_for" $ ppr (spec_occ) $$ ppr (sc_subst body_env)+        ; (spec_usg, spec_body) <- scExpr body_env body ---      ; pprTrace "done spec_one}" (ppr fn) $+--      ; pprTrace "done spec_one }" (ppr fn $$ ppr (scu_calls spec_usg)) $ --        return ()                  -- And build the results-        ; let (spec_lam_args, spec_call_args) = mkWorkerArgs (sc_dflags env)-                                                             qvars body_ty-                -- Usual w/w hack to avoid generating-                -- a spec_rhs of unlifted type and no args+        ; let spec_body_ty   = exprType spec_body+              (spec_lam_args1, spec_sig, spec_arity1, spec_join_arity1)+                  = calcSpecInfo fn call_pat extra_bndrs+                  -- Annotate the variables with the strictness information from+                  -- the function (see Note [Strictness information in worker binders]) -              spec_lam_args_str = handOutStrictnessInformation (fst (splitStrictSig spec_str)) spec_lam_args-                -- Annotate the variables with the strictness information from-                -- the function (see Note [Strictness information in worker binders])+              (spec_lam_args, spec_call_args, spec_arity, spec_join_arity)+                  | needsVoidWorkerArg fn arg_bndrs spec_lam_args1+                  , (spec_lam_args, spec_call_args, _) <- addVoidWorkerArg spec_lam_args1 []+                      -- needsVoidWorkerArg: usual w/w hack to avoid generating+                      -- a spec_rhs of unlifted type and no args.+                  , !spec_arity      <- spec_arity1 + 1+                  , !spec_join_arity <- fmap (+ 1) spec_join_arity1+                  = (spec_lam_args,  spec_call_args, spec_arity,  spec_join_arity)+                  | otherwise+                  = (spec_lam_args1, spec_lam_args1, spec_arity1, spec_join_arity1) -              spec_join_arity | isJoinId fn = Just (length spec_lam_args)-                              | otherwise   = Nothing-              spec_id    = mkLocalId spec_name Many-                                     (mkLamTypes spec_lam_args body_ty)+              spec_id    = asWorkerLikeId $+                           mkLocalId spec_name Many+                                     (mkLamTypes spec_lam_args spec_body_ty)                              -- See Note [Transfer strictness]-                             `setIdStrictness` spec_str-                             `setIdCprInfo` topCprSig-                             `setIdArity` count isId spec_lam_args+                             `setIdDmdSig`    spec_sig+                             `setIdCprSig`    topCprSig+                             `setIdArity`     spec_arity                              `asJoinId_maybe` spec_join_arity-              spec_str   = calcSpecStrictness fn spec_lam_args pats -                 -- Conditionally use result of new worker-wrapper transform-              spec_rhs   = mkLams spec_lam_args_str spec_body-              body_ty    = exprType spec_body-              rule_rhs   = mkVarApps (Var spec_id) spec_call_args+              spec_rhs   = mkLams spec_lam_args (mkSeqs cbv_args spec_body_ty spec_body)+              rule_rhs   = mkVarApps (Var spec_id) $+                           dropTail (length extra_bndrs) spec_call_args               inline_act = idInlineActivation fn-              this_mod   = sc_module spec_env+              this_mod   = sc_module env               rule       = mkRule this_mod True {- Auto -} True {- Local -}                                   rule_name inline_act fn_name qvars pats rule_rhs                            -- See Note [Transfer activation]@@ -1745,31 +1788,89 @@                                , os_id = spec_id                                , os_rhs = spec_rhs }) } +-- See Note [SpecConstr and strict fields]+mkSeqs :: [Var] -> Type -> CoreExpr -> CoreExpr+mkSeqs seqees res_ty rhs =+  foldr addEval rhs seqees+    where+      addEval :: Var -> CoreExpr -> CoreExpr+      addEval arg_id rhs+        -- Argument representing strict field and it's worth passing via cbv+        | shouldStrictifyIdForCbv arg_id+        = Case (Var arg_id) arg_id res_ty ([Alt DEFAULT [] rhs])+        | otherwise+        = rhs --- See Note [Strictness information in worker binders]-handOutStrictnessInformation :: [Demand] -> [Var] -> [Var]-handOutStrictnessInformation = go-  where-    go _ [] = []-    go [] vs = vs-    go (d:dmds) (v:vs) | isId v = setIdDemandInfo v d : go dmds vs-    go dmds (v:vs) = v : go dmds vs -calcSpecStrictness :: Id                     -- The original function-                   -> [Var] -> [CoreExpr]    -- Call pattern-                   -> StrictSig              -- Strictness of specialised thing+{- Note [SpecConst needs to add void args first]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider a function+    f start @t = e+We want to specialize for a partially applied call `f True`.+See also Note [SpecConstr call patterns], second Wrinkle.+Naively we would expect to get+    $sf @t = $se+    RULE: f True = $sf+The specialized function only takes a single type argument+so we add a void argument to prevent it from turning into+a thunk. See Note [Protecting the last value argument] for details+why. Normally we would add the void argument after the+type argument giving us:+    $sf :: forall t. Void# -> bla+    $sf @t void = $se+    RULE: f True = $sf void# (wrong)+But if you look closely this wouldn't typecheck!+If we substitute `f True` with `$sf void#` we expect the type argument to be applied first+but we apply void# first.+The easist fix seems to be just to add the void argument to the front of the arguments.+Now we get:+    $sf :: Void# -> forall t. bla+    $sf void @t = $se+    RULE: f True = $sf void#+And now we can substitute `f True` with `$sf void#` with everything working out nicely!+-}++calcSpecInfo :: Id                     -- The original function+             -> CallPat                -- Call pattern+             -> [Var]                  -- Extra bndrs+             -> ( [Var]                     -- Demand-decorated binders+                , DmdSig                    -- Strictness of specialised thing+                , Arity, Maybe JoinArity )  -- Arities of specialised thing+-- Calcuate bits of IdInfo for the specialised function -- See Note [Transfer strictness]-calcSpecStrictness fn qvars pats-  = mkClosedStrictSig spec_dmds div+-- See Note [Strictness information in worker binders]+calcSpecInfo fn (CP { cp_qvars = qvars, cp_args = pats }) extra_bndrs+  | isJoinId fn    -- Join points have strictness and arity for LHS only+  = ( bndrs_w_dmds+    , mkClosedDmdSig qvar_dmds div+    , count isId qvars+    , Just (length qvars) )+  | otherwise+  = ( bndrs_w_dmds+    , mkClosedDmdSig (qvar_dmds ++ extra_dmds) div+    , count isId qvars + count isId extra_bndrs+    , Nothing )   where-    spec_dmds = [ lookupVarEnv dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ]-    StrictSig (DmdType _ dmds div) = idStrictness fn+    DmdSig (DmdType _ fn_dmds div) = idDmdSig fn -    dmd_env = go emptyVarEnv dmds pats+    val_pats   = filterOut isTypeArg pats -- value args at call sites, used to determine how many demands to drop+                                          -- from the original functions demand and for setting up dmd_env.+    qvar_dmds  = [ lookupVarEnv dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ]+    extra_dmds = dropList val_pats fn_dmds +    bndrs_w_dmds =  set_dmds qvars       qvar_dmds+                 ++ set_dmds extra_bndrs extra_dmds++    set_dmds :: [Var] -> [Demand] -> [Var]+    set_dmds [] _   = []+    set_dmds vs  [] = vs  -- Run out of demands+    set_dmds (v:vs) ds@(d:ds') | isTyVar v = v                   : set_dmds vs ds+                               | otherwise = setIdDemandInfo v d : set_dmds vs ds'++    dmd_env = go emptyVarEnv fn_dmds val_pats+     go :: DmdEnv -> [Demand] -> [CoreExpr] -> DmdEnv-    go env ds (Type {} : pats)     = go env ds pats-    go env ds (Coercion {} : pats) = go env ds pats+    -- We've filtered out all the type patterns already     go env (d:ds) (pat : pats)     = go (go_one env d pat) ds pats     go env _      _                = env @@ -1777,10 +1878,11 @@     go_one env d          (Var v) = extendVarEnv_C plusDmd env v d     go_one env (_n :* cd) e -- NB: _n does not have to be strict       | (Var _, args) <- collectArgs e-      , Just ds <- viewProd (length args) cd+      , Just (_b, ds) <- viewProd (length args) cd -- TODO: We may want to look at boxity _b, though...       = go env ds args-    go_one env _               _       = env+    go_one env _  _ = env + {- Note [spec_usg includes rhs_usg] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1837,13 +1939,13 @@  Note [Strictness information in worker binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- After having calculated the strictness annotation for the worker (see Note [Transfer strictness] above), we also want to have this information attached to the worker’s arguments, for the benefit of later passes. The function handOutStrictnessInformation decomposes the strictness annotation calculated by calcSpecStrictness and attaches them to the variables. + ************************************************************************ *                                                                      * \subsection{Argument analysis}@@ -1871,19 +1973,39 @@ Note [SpecConstr call patterns] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A "call patterns" that we collect is going to become the LHS of a RULE.-It's important that it doesn't have++Wrinkles:++* The list of argument patterns, cp_args, is no longer than the+  visible lambdas of the binding, ri_arg_occs.  This is done via+  the zipWithM in callToPats.++* The list of argument patterns can certainly be shorter than the+  lambdas in the function definition (under-saturated).  For example+      f x y = case x of { True -> e1; False -> e2 }+      ....map (f True) e...+  We want to specialise `f` for `f True`.++* In fact we deliberately shrink the list of argument patterns,+  cp_args, by trimming off all the boring ones at the end (see+  `dropWhileEnd is_boring` in callToPats).  Since the RULE only+  applies when it is saturated, this shrinking makes the RULE more+  applicable.  But it does mean that the argument patterns do not+  necessarily saturate the lambdas of the function.++* It's important that the pattern arguments do not look like      e |> Refl-or+  or     e |> g1 |> g2-because both of these will be optimised by Simplify.simplRule. In the-former case such optimisation benign, because the rule will match more-terms; but in the latter we may lose a binding of 'g1' or 'g2', and-end up with a rule LHS that doesn't bind the template variables-(#10602).+  because both of these will be optimised by Simplify.simplRule. In the+  former case such optimisation benign, because the rule will match more+  terms; but in the latter we may lose a binding of 'g1' or 'g2', and+  end up with a rule LHS that doesn't bind the template variables+  (#10602). -The simplifier eliminates such things, but SpecConstr itself constructs-new terms by substituting.  So the 'mkCast' in the Cast case of scExpr-is very important!+  The simplifier eliminates such things, but SpecConstr itself constructs+  new terms by substituting.  So the 'mkCast' in the Cast case of scExpr+  is very important!  Note [Choosing patterns] ~~~~~~~~~~~~~~~~~~~~~~~~@@ -1912,7 +2034,7 @@     in ... f (K @(a |> co)) ...  where 'co' is a coercion variable not in scope at f's definition site.-If we aren't caereful we'll get+If we aren't careful we'll get      let $sf a co = e (K @(a |> co))         RULE "SC:f" forall a co.  f (K @(a |> co)) = $sf a co@@ -1968,9 +2090,17 @@ only in kind-casts, but I'm doing the simple thing for now. -} -type CallPat = ([Var], [CoreExpr])      -- Quantified variables and arguments-                                        -- See Note [SpecConstr call patterns]+data CallPat = CP { cp_qvars :: [Var]           -- Quantified variables+                  , cp_args  :: [CoreExpr]      -- Arguments+                  , cp_strict_args :: [Var] }   -- Arguments we want to pass unlifted even if they are boxed+     -- See Note [SpecConstr call patterns] +instance Outputable CallPat where+  ppr (CP { cp_qvars = qvars, cp_args = args, cp_strict_args =  strict })+    = text "CP" <> braces (sep [ text "cp_qvars =" <+> ppr qvars <> comma+                               , text "cp_args =" <+> ppr args+                               , text "cp_strict_args = " <> ppr strict ])+ callsToNewPats :: ScEnv -> Id                -> SpecInfo                -> [ArgOcc] -> [Call]@@ -1995,34 +2125,40 @@                -- Remove ones that have too many worker variables               small_pats = filterOut too_big non_dups-              too_big (vars,args) = not (isWorkerSmallEnough (sc_dflags env) (valArgCount args) vars)+              max_args = maxWorkerArgs (sc_dflags env)+              too_big (CP { cp_qvars = vars, cp_args = args })+                = not (isWorkerSmallEnough max_args (valArgCount args) vars)                   -- We are about to construct w/w pair in 'spec_one'.                   -- Omit specialisation leading to high arity workers.                   -- See Note [Limit w/w arity] in GHC.Core.Opt.WorkWrap.Utils                  -- Discard specialisations if there are too many of them-              trimmed_pats = trim_pats env fn spec_info small_pats+              (pats_were_discarded, trimmed_pats) = trim_pats env fn spec_info small_pats  --        ; pprTrace "callsToPats" (vcat [ text "calls to" <+> ppr fn <> colon <+> ppr calls --                                       , text "done_specs:" <+> ppr (map os_pat done_specs) --                                       , text "good_pats:" <+> ppr good_pats ]) $ --          return () -        ; return (have_boring_call, trimmed_pats) }+        ; return (have_boring_call || pats_were_discarded, trimmed_pats) }+          -- If any of the calls does not give rise to a specialisation, either+          -- because it is boring, or because there are too many specialisations,+          -- return a flag to say so, so that we know to keep the original function.  -trim_pats :: ScEnv -> Id -> SpecInfo -> [CallPat] -> [CallPat]+trim_pats :: ScEnv -> Id -> SpecInfo -> [CallPat] -> (Bool, [CallPat])+-- True <=> some patterns were discarded -- See Note [Choosing patterns] trim_pats env fn (SI { si_n_specs = done_spec_count }) pats   | sc_force env     || isNothing mb_scc     || n_remaining >= n_pats   = -- pprTrace "trim_pats: no-trim" (ppr (sc_force env) $$ ppr mb_scc $$ ppr n_remaining $$ ppr n_pats)-    pats          -- No need to trim+    (False, pats)          -- No need to trim    | otherwise   = emit_trace $  -- Need to trim, so keep the best ones-    take n_remaining sorted_pats+    (True, take n_remaining sorted_pats)    where     n_pats         = length pats@@ -2041,7 +2177,8 @@     pat_cons :: CallPat -> Int     -- How many data constructors of literals are in     -- the pattern.  More data-cons => less general-    pat_cons (qs, ps) = foldr ((+) . n_cons) 0 ps+    pat_cons (CP { cp_qvars = qs, cp_args = ps })+       = foldr ((+) . n_cons) 0 ps        where           q_set = mkVarSet qs           n_cons (Var v) | v `elemVarSet` q_set = 0@@ -2072,12 +2209,21 @@         --      Type variables come first, since they may scope         --      over the following term variables         -- The [CoreExpr] are the argument patterns for the rule-callToPats env bndr_occs call@(Call _ args con_env)-  | args `ltLength` bndr_occs      -- Check saturated-  = return Nothing-  | otherwise+callToPats env bndr_occs call@(Call fn args con_env)   = do  { let in_scope = substInScope (sc_subst env)-        ; (interesting, pats) <- argsToPats env in_scope con_env args bndr_occs++        ; arg_tripples <- zipWith3M (argToPat env in_scope con_env) args bndr_occs (map (const NotMarkedStrict) args)+                   -- This zip trims the args to be no longer than+                   -- the lambdas in the function definition (bndr_occs)++          -- Drop boring patterns from the end+          -- See Note [SpecConstr call patterns]+        ; let arg_tripples' | isJoinId fn = arg_tripples+                            | otherwise   = dropWhileEnd is_boring arg_tripples+              is_boring (interesting, _,_) = not interesting+              (interesting_s, pats, cbv_ids) = unzip3 arg_tripples'+              interesting           = or interesting_s+         ; let pat_fvs = exprsFreeVarsList pats                 -- To get determinism we need the list of free variables in                 -- deterministic order. Otherwise we end up creating@@ -2107,18 +2253,20 @@               bad_covars :: CoVarSet               bad_covars = mapUnionVarSet get_bad_covars pats               get_bad_covars :: CoreArg -> CoVarSet-              get_bad_covars (Type ty)-                = filterVarSet (\v -> isId v && not (is_in_scope v)) $-                  tyCoVarsOfType ty-              get_bad_covars _-                = emptyVarSet+              get_bad_covars (Type ty) = filterVarSet bad_covar (tyCoVarsOfType ty)+              get_bad_covars _         = emptyVarSet+              bad_covar v = isId v && not (is_in_scope v)          ; -- pprTrace "callToPats"  (ppr args $$ ppr bndr_occs) $-          WARN( not (isEmptyVarSet bad_covars)-              , text "SpecConstr: bad covars:" <+> ppr bad_covars-                $$ ppr call )+          warnPprTrace (not (isEmptyVarSet bad_covars))+              "SpecConstr: bad covars"+              (ppr bad_covars $$ ppr call) $           if interesting && isEmptyVarSet bad_covars-          then return (Just (qvars', pats))+          then+              -- pprTraceM "callToPatsOut" (+              --   text "fun" <> ppr fn $$+              --   ppr (CP { cp_qvars = qvars', cp_args = pats })) >>+              return (Just (CP { cp_qvars = qvars', cp_args = pats, cp_strict_args = concat cbv_ids }))           else return Nothing }      -- argToPat takes an actual argument, and returns an abstracted@@ -2132,7 +2280,9 @@          -> ValueEnv                    -- ValueEnv at the call site          -> CoreArg                     -- A call arg (or component thereof)          -> ArgOcc-         -> UniqSM (Bool, CoreArg)+         -> StrictnessMark              -- Tells us if this argument is a strict field of a data constructor+                                        -- See Note [SpecConstr and strict fields]+         -> UniqSM (Bool, CoreArg, [Id])  -- Returns (interesting, pat), -- where pat is the pattern derived from the argument@@ -2144,11 +2294,25 @@ --              lvl7         --> (True, lvl7)      if lvl7 is bound --                                                 somewhere further out -argToPat _env _in_scope _val_env arg@(Type {}) _arg_occ-  = return (False, arg)+argToPat env in_scope val_env arg arg_occ arg_str+  = do+    -- pprTraceM "argToPatIn" (ppr arg)+    !res <- argToPat1 env in_scope val_env arg arg_occ arg_str+    -- pprTraceM "argToPatOut" (ppr res)+    return res -argToPat env in_scope val_env (Tick _ arg) arg_occ-  = argToPat env in_scope val_env arg arg_occ+argToPat1 :: ScEnv+  -> InScopeSet+  -> ValueEnv+  -> Expr CoreBndr+  -> ArgOcc+  -> StrictnessMark+  -> UniqSM (Bool, Expr CoreBndr, [Id])+argToPat1 _env _in_scope _val_env arg@(Type {}) _arg_occ _arg_str+  = return (False, arg, [])++argToPat1 env in_scope val_env (Tick _ arg) arg_occ arg_str+  = argToPat env in_scope val_env arg arg_occ arg_str         -- Note [Tick annotations in call patterns]         -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~         -- Ignore Notes.  In particular, we want to ignore any InlineMe notes@@ -2156,8 +2320,8 @@         -- ride roughshod over them all for now.         --- See Note [Tick annotations in RULE matching] in GHC.Core.Rules -argToPat env in_scope val_env (Let _ arg) arg_occ-  = argToPat env in_scope val_env arg arg_occ+argToPat1 env in_scope val_env (Let _ arg) arg_occ arg_str+  = argToPat env in_scope val_env arg arg_occ arg_str         -- See Note [Matching lets] in "GHC.Core.Rules"         -- Look through let expressions         -- e.g.         f (let v = rhs in (v,w))@@ -2170,17 +2334,17 @@   = argToPat env in_scope val_env rhs arg_occ -} -argToPat env in_scope val_env (Cast arg co) arg_occ+argToPat1 env in_scope val_env (Cast arg co) arg_occ arg_str   | not (ignoreType env ty2)-  = do  { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ+  = do  { (interesting, arg', strict_args) <- argToPat env in_scope val_env arg arg_occ arg_str         ; if not interesting then-                wildCardPat ty2+                wildCardPat ty2 arg_str           else do         { -- Make a wild-card pattern for the coercion           uniq <- getUniqueM         ; let co_name = mkSysTvName uniq (fsLit "sg")               co_var  = mkCoVar co_name (mkCoercionType Representational ty1 ty2)-        ; return (interesting, Cast arg' (mkCoVarCo co_var)) } }+        ; return (interesting, Cast arg' (mkCoVarCo co_var), strict_args) } }   where     Pair ty1 ty2 = coercionKind co @@ -2200,35 +2364,66 @@    -- Check for a constructor application   -- NB: this *precedes* the Var case, so that we catch nullary constrs-argToPat env in_scope val_env arg arg_occ+argToPat1 env in_scope val_env arg arg_occ _arg_str   | Just (ConVal (DataAlt dc) args) <- isValue val_env arg   , not (ignoreDataCon env dc)        -- See Note [NoSpecConstr]   , Just arg_occs <- mb_scrut dc-  = do  { let (ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) args-        ; (_, args') <- argsToPats env in_scope val_env rest_args arg_occs-        ; return (True,-                  mkConApp dc (ty_args ++ args')) }+  = do { let (ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) args+             con_str, matched_str :: [StrictnessMark]+             -- con_str corrresponds 1-1 with the /value/ arguments+             -- matched_str corresponds 1-1 with /all/ arguments+             con_str = dataConRepStrictness dc+             matched_str = match_vals con_str rest_args+      --  ; pprTraceM "bangs" (ppr (length rest_args == length con_str) $$+      --       ppr dc $$+      --       ppr con_str $$+      --       ppr rest_args $$+      --       ppr (map isTypeArg rest_args))+       ; prs <- zipWith3M (argToPat env in_scope val_env) rest_args arg_occs matched_str+       ; let args' = map sndOf3 prs :: [CoreArg]+       ; assertPpr (length con_str == length (filter isRuntimeArg rest_args))+            ( ppr con_str $$ ppr rest_args $$+              ppr (length con_str) $$ ppr (length rest_args)+            ) $ return ()+       ; return (True, mkConApp dc (ty_args ++ args'), concat (map thdOf3 prs)) }   where     mb_scrut dc = case arg_occ of-                    ScrutOcc bs | Just occs <- lookupUFM bs dc-                                -> Just (occs)  -- See Note [Reboxing]-                    _other      | sc_force env || sc_keen env-                                -> Just (repeat UnkOcc)-                                | otherwise-                                -> Nothing+                ScrutOcc bs | Just occs <- lookupUFM bs dc+                            -> Just (occs)  -- See Note [Reboxing]+                _other      | sc_force env || sc_keen env+                            -> Just (repeat UnkOcc)+                            | otherwise+                            -> Nothing+    match_vals bangs (arg:args)+      | isTypeArg arg+      = NotMarkedStrict : match_vals bangs args+      | (b:bs) <- bangs+      = b : match_vals bs args+    match_vals [] [] = []+    match_vals as bs =+        pprPanic "spec-constr:argToPat - Bangs don't match value arguments"+            (text "arg:" <> ppr arg $$+             text "remaining args:" <> ppr as $$+             text "remaining bangs:" <> ppr bs)    -- Check if the argument is a variable that   --    (a) is used in an interesting way in the function body+  ---       i.e. ScrutOcc. UnkOcc and NoOcc are not interesting+  --        (NoOcc means we could drop the argument, but that's the+  --         business of absence analysis, not SpecConstr.)   --    (b) we know what its value is   -- In that case it counts as "interesting"-argToPat env in_scope val_env (Var v) arg_occ-  | sc_force env || case arg_occ of { UnkOcc -> False; _other -> True }, -- (a)-    is_value,                                                            -- (b)+argToPat1 env in_scope val_env (Var v) arg_occ arg_str+  | sc_force env || case arg_occ of { ScrutOcc {} -> True+                                    ; UnkOcc      -> False+                                    ; NoOcc       -> False } -- (a)+  , is_value                                                 -- (b)        -- Ignoring sc_keen here to avoid gratuitously incurring Note [Reboxing]        -- So sc_keen focused just on f (I# x), where we have freshly-allocated        -- box that we can eliminate in the caller-    not (ignoreType env (varType v))-  = return (True, Var v)+  , not (ignoreType env (varType v))+  -- See Note [SpecConstr and strict fields]+  = return (True, Var v, if isMarkedStrict arg_str then [v] else mempty)   where     is_value         | isLocalId v = v `elemInScopeSet` in_scope@@ -2257,22 +2452,15 @@    -- The default case: make a wild-card   -- We use this for coercions too-argToPat _env _in_scope _val_env arg _arg_occ-  = wildCardPat (exprType arg)--wildCardPat :: Type -> UniqSM (Bool, CoreArg)-wildCardPat ty-  = do { uniq <- getUniqueM-       ; let id = mkSysLocalOrCoVar (fsLit "sc") uniq Many ty-       ; return (False, varToCoreExpr id) }+argToPat1 _env _in_scope _val_env arg _arg_occ arg_str+  = wildCardPat (exprType arg) arg_str -argsToPats :: ScEnv -> InScopeSet -> ValueEnv-           -> [CoreArg] -> [ArgOcc]  -- Should be same length-           -> UniqSM (Bool, [CoreArg])-argsToPats env in_scope val_env args occs-  = do { stuff <- zipWithM (argToPat env in_scope val_env) args occs-       ; let (interesting_s, args') = unzip stuff-       ; return (or interesting_s, args') }+-- | wildCardPats are always boring+wildCardPat :: Type -> StrictnessMark -> UniqSM (Bool, CoreArg, [Id])+wildCardPat ty str+  = do { id <- mkSysLocalOrCoVarM (fsLit "sc") Many ty+       -- ; pprTraceM "wildCardPat" (ppr id' <+> ppr (idUnfolding id'))+       ; return (False, varToCoreExpr id, if isMarkedStrict str then [id] else []) }  isValue :: ValueEnv -> CoreExpr -> Maybe Value isValue _env (Lit lit)@@ -2324,9 +2512,11 @@ valueIsWorkFree (ConVal _ args) = all exprIsWorkFree args  samePat :: CallPat -> CallPat -> Bool-samePat (vs1, as1) (vs2, as2)+samePat (CP { cp_qvars = vs1, cp_args = as1 })+        (CP { cp_qvars = vs2, cp_args = as2 })   = all2 same as1 as2   where+    -- If the args are the same, their strictness marks will be too so we don't compare those.     same (Var v1) (Var v2)         | v1 `elem` vs1 = v2 `elem` vs2         | v2 `elem` vs2 = False@@ -2342,7 +2532,7 @@     same e1 (Tick _ e2) = same e1 e2     same e1 (Cast e2 _) = same e1 e2 -    same e1 e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2)+    same e1 e2 = warnPprTrace (bad e1 || bad e2) "samePat" (ppr e1 $$ ppr e2) $                  False  -- Let, lambda, case should not occur     bad (Case {}) = True     bad (Let {})  = True
compiler/GHC/Core/Opt/Specialise.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  {-@@ -10,13 +10,12 @@  module GHC.Core.Opt.Specialise ( specProgram, specUnfolding ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Driver.Session import GHC.Driver.Ppr import GHC.Driver.Config+import GHC.Driver.Config.Diagnostic import GHC.Driver.Env  import GHC.Tc.Utils.TcType hiding( substTy )@@ -29,7 +28,6 @@ import qualified GHC.Core.Subst as Core import GHC.Core.Unfold.Make import GHC.Core-import GHC.Core.Make      ( mkLitRubbish ) import GHC.Core.Rules import GHC.Core.Utils     ( exprIsTrivial, getIdFromTrivialExpr_maybe                           , mkCast, exprType )@@ -43,6 +41,7 @@ import GHC.Data.Maybe     ( mapMaybe, maybeToList, isJust ) import GHC.Data.Bag import GHC.Data.FastString+import GHC.Data.List.SetOps  import GHC.Types.Basic import GHC.Types.Unique.Supply@@ -54,11 +53,14 @@ import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Id+import GHC.Types.Error +import GHC.Utils.Error ( mkMCDiagnostic ) import GHC.Utils.Monad    ( foldlM ) import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Trace  import GHC.Unit.Module( Module ) import GHC.Unit.Module.ModGuts@@ -735,8 +737,7 @@        ; hsc_env <- getHscEnv        ; eps <- liftIO $ hscEPS hsc_env        ; vis_orphs <- getVisibleOrphanMods-       ; let full_rb = unionRuleBase rb (eps_rule_base eps)-             rules_for_fn = getRules (RuleEnv full_rb vis_orphs) fn+       ; let rules_for_fn = getRules (RuleEnv [rb, eps_rule_base eps] vis_orphs) fn         ; (rules1, spec_pairs, MkUD { ud_binds = dict_binds1, ud_calls = new_calls })             <- -- debugTraceMsg (text "specImport1" <+> vcat [ppr fn, ppr good_calls, ppr rhs]) >>@@ -801,16 +802,17 @@ tryWarnMissingSpecs :: DynFlags -> [Id] -> Id -> [CallInfo] -> CoreM () -- See Note [Warning about missed specialisations] tryWarnMissingSpecs dflags callers fn calls_for_fn-  | isClassOpId fn = return () -- See Note [Missed specialization for ClassOps]+  | isClassOpId fn = return () -- See Note [Missed specialisation for ClassOps]   | wopt Opt_WarnMissedSpecs dflags     && not (null callers)-    && allCallersInlined                  = doWarn $ Reason Opt_WarnMissedSpecs-  | wopt Opt_WarnAllMissedSpecs dflags    = doWarn $ Reason Opt_WarnAllMissedSpecs+    && allCallersInlined                  = doWarn $ WarningWithFlag Opt_WarnMissedSpecs+  | wopt Opt_WarnAllMissedSpecs dflags    = doWarn $ WarningWithFlag Opt_WarnAllMissedSpecs   | otherwise                             = return ()   where     allCallersInlined = all (isAnyInlinePragma . idInlinePragma) callers+    diag_opts = initDiagOpts dflags     doWarn reason =-      warnMsg reason+      msg (mkMCDiagnostic diag_opts reason)         (vcat [ hang (text ("Could not specialise imported function") <+> quotes (ppr fn))                 2 (vcat [ text "when specialising" <+> quotes (ppr caller)                         | caller <- callers])@@ -892,14 +894,14 @@ Note [Avoiding loops in specImports] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We must take great care when specialising instance declarations-(functions like $fOrdList) lest we accidentally build a recursive-dictionary. See Note [Avoiding loops].+(DFuns like $fOrdList) lest we accidentally build a recursive+dictionary. See Note [Avoiding loops (DFuns)]. -The basic strategy of Note [Avoiding loops] is to use filterCalls+The basic strategy of Note [Avoiding loops (DFuns)] is to use filterCalls to discard loopy specialisations.  But to do that we must ensure that the in-scope dict-binds (passed to filterCalls) contains all the needed dictionary bindings.  In particular, in the recursive-call to spec_imorpts in spec_import, we must include the dict-binds+call to spec_imports in spec_import, we must include the dict-binds from the parent.  Lacking this caused #17151, a really nasty bug.  Here is what happened.@@ -991,7 +993,7 @@ and similarly specialising 'g' might expose a new call to 'h'.  We track the stack of enclosing functions. So when specialising 'h' we-haev a specImport call stack of [g,f]. We do this for two reasons:+have a specImport call stack of [g,f]. We do this for two reasons: * Note [Warning about missed specialisations] * Note [Avoiding recursive specialisation] @@ -1423,18 +1425,22 @@   && not (isNeverActive (idInlineActivation fn))         -- Don't specialise NOINLINE things         -- See Note [Auto-specialisation and RULES]+        --+        -- Don't specialise OPAQUE things, see Note [OPAQUE pragma].+        -- Since OPAQUE things are always never-active (see+        -- GHC.Parser.PostProcess.mkOpaquePragma) this guard never fires for+        -- OPAQUE things.  --   && not (certainlyWillInline (idUnfolding fn))      -- And it's not small---      See Note [Inline specialisation] for why we do not+--      See Note [Inline specialisations] for why we do not --      switch off specialisation for inline functions    = -- pprTrace "specDefn: some" (ppr fn $$ ppr calls_for_me $$ ppr existing_rules) $     foldlM spec_call ([], [], emptyUDs) calls_for_me    | otherwise   -- No calls or RHS doesn't fit our preconceptions-  = WARN( not (exprIsTrivial rhs) && notNull calls_for_me,-          text "Missed specialisation opportunity for"-                                 <+> ppr fn $$ _trace_doc )+  = warnPprTrace (not (exprIsTrivial rhs) && notNull calls_for_me)+          "Missed specialisation opportunity" (ppr fn $$ _trace_doc) $           -- Note [Specialisation shape]     -- pprTrace "specDefn: none" (ppr fn <+> ppr calls_for_me) $     return ([], [], emptyUDs)@@ -1504,7 +1510,7 @@                  -- Maybe add a void arg to the specialised function,                  -- to avoid unlifted bindings                  -- See Note [Specialisations Must Be Lifted]-                 -- C.f. GHC.Core.Opt.WorkWrap.Utils.mkWorkerArgs+                 -- C.f. GHC.Core.Opt.WorkWrap.Utils.needsVoidWorkerArg                  add_void_arg = isUnliftedType spec_fn_ty1 && not (isJoinId fn)                  (spec_bndrs, spec_rhs, spec_fn_ty)                    | add_void_arg = ( voidPrimId : spec_bndrs1@@ -1566,7 +1572,7 @@                   = (neverInlinePragma, noUnfolding)                         -- See Note [Specialising imported functions] in "GHC.Core.Opt.OccurAnal" -                  | InlinePragma { inl_inline = Inlinable } <- inl_prag+                  | isInlinablePragma inl_prag                   = (inl_prag { inl_inline = NoUserInlinePrag }, noUnfolding)                    | otherwise@@ -1737,11 +1743,8 @@   1. We don’t specialise on them.   2. They come before an argument we do specialise on. -Doing the latter would require eta-expanding the RULE, which could-make it match less often, so it’s not worth it. Doing the former could-be more useful --- it would stop us from generating pointless-specialisations --- but it’s more involved to implement and unclear if-it actually provides much benefit in practice.+  The right thing to do is to produce a LitRubbish; it should rapidly+  disappear.  Rather like GHC.Core.Opt.WorkWrap.Utils.mk_absent_let.  Note [Zap occ info in rule binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1853,8 +1856,8 @@   - there are some specialisations (spec_binds non-empty)   - there are some dict_binds that depend on f (dump_dbs non-empty) -Note [Avoiding loops]-~~~~~~~~~~~~~~~~~~~~~+Note [Avoiding loops (DFuns)]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When specialising /dictionary functions/ we must be very careful to avoid building loops. Here is an example that bit us badly, on several distinct occasions.@@ -1895,8 +1898,10 @@   (directly or indirectly) on the dfun we are specialising.   This is done by 'filterCalls' ----------------Here's yet another example+Note [Avoiding loops (non-DFuns)]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The whole Note [Avoiding loops (DFuns)] things applies only to DFuns.+It's important /not/ to apply filterCalls to non-DFuns. For example:    class C a where { foo,bar :: [a] -> [a] } @@ -1917,8 +1922,8 @@ The call (r_bar $fCInt) mentions $fCInt,                         which mentions foo_help,                         which mentions r_bar-But we DO want to specialise r_bar at Int: +But we DO want to specialise r_bar at Int:     Rec { $fCInt :: C Int = MkC foo_help reverse           foo_help (xs::[Int]) = r_bar Int $fCInt xs @@ -1930,8 +1935,24 @@  Note that, because of its RULE, r_bar joins the recursive group.  (In this case it'll unravel a short moment later.)+See test simplCore/should_compile/T19599a. +Another example is #19599, which looked like this: +   class (Show a, Enum a) => MyShow a where+      myShow :: a -> String++   myShow_impl :: MyShow a => a -> String++   foo :: Int -> String+   foo = myShow_impl @Int $fMyShowInt++   Rec { $fMyShowInt = MkMyShowD $fEnumInt $fShowInt $cmyShow+       ; $cmyShow = myShow_impl @Int $fMyShowInt }++Here, we really do want to specialise `myShow_impl @Int $fMyShowInt`.++ Note [Specialising a recursive group] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider@@ -2296,28 +2317,16 @@          let (env', bndr') = substBndr env (zapIdOccInfo bndr)        ; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)              <- specHeader env' bndrs args--       ; let bndr_ty = idType bndr'--             -- See Note [Drop dead args from specialisations]-             -- C.f. GHC.Core.Opt.WorkWrap.Utils.mk_absent_let-             (mb_spec_bndr, spec_arg)-                | isDeadBinder bndr-                , Just lit_expr <- mkLitRubbish bndr_ty-                = (Nothing, lit_expr)-                | otherwise-                = (Just bndr', varToCoreExpr bndr')-        ; pure ( useful               , env''               , leftover_bndrs               , bndr' : rule_bs               , varToCoreExpr bndr' : rule_es-              , case mb_spec_bndr of-                  Nothing -> bs' -- see Note [Drop dead args from specialisations]-                  Just b' -> b' : bs'+              , if isDeadBinder bndr+                  then bs' -- see Note [Drop dead args from specialisations]+                  else bndr' : bs'               , dx-              , spec_arg : spec_args+              , varToCoreExpr bndr' : spec_args               )        } @@ -2494,9 +2503,9 @@  data CallInfo   = CI { ci_key  :: [SpecArg]   -- All arguments-       , ci_fvs  :: VarSet      -- Free vars of the ci_key-                                -- call (including tyvars)-                                -- [*not* include the main id itself, of course]+       , ci_fvs  :: IdSet       -- Free Ids of the ci_key call+                                -- _not_ including the main id itself, of course+                                -- NB: excluding tyvars:     }  type DictExpr = CoreExpr@@ -2724,11 +2733,10 @@     interesting :: InterestingVarFun     interesting v = isLocalVar v || (isId v && isDFunId v)         -- Very important: include DFunIds /even/ if it is imported-        -- Reason: See Note [Avoiding loops], the second example-        --         involving an imported dfun.  We must know whether-        --         a dictionary binding depends on an imported dfun,-        --         in case we try to specialise that imported dfun-        --         #13429 illustrates+        -- Reason: See Note [Avoiding loops in specImports], the #13429+        --         example involving an imported dfun.  We must know+        --         whether a dictionary binding depends on an imported+        --         DFun in case we try to specialise that imported DFun  -- | Flatten a set of "dumped" 'DictBind's, and some other binding -- pairs, into a single recursive binding.@@ -2818,14 +2826,20 @@                         Nothing -> []                         Just cis -> filterCalls cis orig_dbs          -- filterCalls: drop calls that (directly or indirectly)-         -- refer to fn.  See Note [Avoiding loops]+         -- refer to fn.  See Note [Avoiding loops (DFuns)]  ---------------------- filterCalls :: CallInfoSet -> Bag DictBind -> [CallInfo]--- See Note [Avoiding loops]+-- Remove dominated calls+-- and loopy DFuns (Note [Avoiding loops (DFuns)]) filterCalls (CIS fn call_bag) dbs-  = filter ok_call (bagToList call_bag)+  | isDFunId fn  -- Note [Avoiding loops (DFuns)] applies only to DFuns+  = filter ok_call unfiltered_calls+  | otherwise         -- Do not apply it to non-DFuns+  = unfiltered_calls  -- See Note [Avoiding loops (non-DFuns)]   where+    unfiltered_calls = bagToList call_bag+     dump_set = foldl' go (unitVarSet fn) dbs       -- This dump-set could also be computed by splitDictBinds       --   (_,_,dump_set) = splitDictBinds dbs {fn}
compiler/GHC/Core/Opt/StaticArgs.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -73,8 +73,6 @@  import Data.List (mapAccumL) import GHC.Data.FastString--#include "GhclibHsVersions.h"  doStaticArgs :: UniqSupply -> CoreProgram -> CoreProgram doStaticArgs us binds = snd $ mapAccumL sat_bind_threaded_us us binds
compiler/GHC/Core/Opt/WorkWrap.hs view
@@ -4,38 +4,39 @@ \section[WorkWrap]{Worker/wrapper-generating back-end of strictness analyser} -} -{-# LANGUAGE CPP #-}+ module GHC.Core.Opt.WorkWrap ( wwTopBinds ) where  import GHC.Prelude -import GHC.Core.Opt.Arity  ( manifestArity )+import GHC.Driver.Session+ import GHC.Core-import GHC.Core.Unfold import GHC.Core.Unfold.Make import GHC.Core.Utils  ( exprType, exprIsHNF )-import GHC.Core.FVs    ( exprFreeVars )+import GHC.Core.Type+import GHC.Core.Opt.WorkWrap.Utils+import GHC.Core.FamInstEnv+import GHC.Core.SimpleOpt+ import GHC.Types.Var import GHC.Types.Id import GHC.Types.Id.Info-import GHC.Core.Type import GHC.Types.Unique.Supply import GHC.Types.Basic-import GHC.Driver.Session-import GHC.Driver.Ppr-import GHC.Driver.Config import GHC.Types.Demand import GHC.Types.Cpr import GHC.Types.SourceText-import GHC.Core.Opt.WorkWrap.Utils+import GHC.Types.Unique+ import GHC.Utils.Misc import GHC.Utils.Outputable-import GHC.Types.Unique import GHC.Utils.Panic-import GHC.Core.FamInstEnv+import GHC.Utils.Panic.Plain import GHC.Utils.Monad--#include "GhclibHsVersions.h"+import GHC.Utils.Trace+import GHC.Unit.Types+import GHC.Core.DataCon  {- We take Core bindings whose binders have:@@ -65,12 +66,14 @@ \end{enumerate} -} -wwTopBinds :: DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram+wwTopBinds :: Module -> DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram -wwTopBinds dflags fam_envs us top_binds+wwTopBinds this_mod dflags fam_envs us top_binds   = initUs_ us $ do-    top_binds' <- mapM (wwBind dflags fam_envs) top_binds+    top_binds' <- mapM (wwBind ww_opts) top_binds     return (concat top_binds')+  where+    ww_opts = initWwOpts this_mod dflags fam_envs  {- ************************************************************************@@ -83,25 +86,24 @@ turn.  Non-recursive case first, then recursive... -} -wwBind  :: DynFlags-        -> FamInstEnvs+wwBind  :: WwOpts         -> CoreBind         -> UniqSM [CoreBind]    -- returns a WwBinding intermediate form;                                 -- the caller will convert to Expr/Binding,                                 -- as appropriate. -wwBind dflags fam_envs (NonRec binder rhs) = do-    new_rhs <- wwExpr dflags fam_envs rhs-    new_pairs <- tryWW dflags fam_envs NonRecursive binder new_rhs+wwBind ww_opts (NonRec binder rhs) = do+    new_rhs   <- wwExpr ww_opts rhs+    new_pairs <- tryWW ww_opts NonRecursive binder new_rhs     return [NonRec b e | (b,e) <- new_pairs]       -- Generated bindings must be non-recursive       -- because the original binding was. -wwBind dflags fam_envs (Rec pairs)+wwBind ww_opts (Rec pairs)   = return . Rec <$> concatMapM do_one pairs   where-    do_one (binder, rhs) = do new_rhs <- wwExpr dflags fam_envs rhs-                              tryWW dflags fam_envs Recursive binder new_rhs+    do_one (binder, rhs) = do new_rhs <- wwExpr ww_opts rhs+                              tryWW ww_opts Recursive binder new_rhs  {- @wwExpr@ basically just walks the tree, looking for appropriate@@ -110,41 +112,41 @@ @wwExpr@ is a version that just returns the ``Plain'' Tree. -} -wwExpr :: DynFlags -> FamInstEnvs -> CoreExpr -> UniqSM CoreExpr+wwExpr :: WwOpts -> CoreExpr -> UniqSM CoreExpr -wwExpr _      _ e@(Type {}) = return e-wwExpr _      _ e@(Coercion {}) = return e-wwExpr _      _ e@(Lit  {}) = return e-wwExpr _      _ e@(Var  {}) = return e+wwExpr _ e@(Type {}) = return e+wwExpr _ e@(Coercion {}) = return e+wwExpr _ e@(Lit  {}) = return e+wwExpr _ e@(Var  {}) = return e -wwExpr dflags fam_envs (Lam binder expr)-  = Lam new_binder <$> wwExpr dflags fam_envs expr+wwExpr ww_opts (Lam binder expr)+  = Lam new_binder <$> wwExpr ww_opts expr   where new_binder | isId binder = zapIdUsedOnceInfo binder                    | otherwise   = binder   -- See Note [Zapping Used Once info in WorkWrap] -wwExpr dflags fam_envs (App f a)-  = App <$> wwExpr dflags fam_envs f <*> wwExpr dflags fam_envs a+wwExpr ww_opts (App f a)+  = App <$> wwExpr ww_opts f <*> wwExpr ww_opts a -wwExpr dflags fam_envs (Tick note expr)-  = Tick note <$> wwExpr dflags fam_envs expr+wwExpr ww_opts (Tick note expr)+  = Tick note <$> wwExpr ww_opts expr -wwExpr dflags fam_envs (Cast expr co) = do-    new_expr <- wwExpr dflags fam_envs expr+wwExpr ww_opts (Cast expr co) = do+    new_expr <- wwExpr ww_opts expr     return (Cast new_expr co) -wwExpr dflags fam_envs (Let bind expr)-  = mkLets <$> wwBind dflags fam_envs bind <*> wwExpr dflags fam_envs expr+wwExpr ww_opts (Let bind expr)+  = mkLets <$> wwBind ww_opts bind <*> wwExpr ww_opts expr -wwExpr dflags fam_envs (Case expr binder ty alts) = do-    new_expr <- wwExpr dflags fam_envs expr+wwExpr ww_opts (Case expr binder ty alts) = do+    new_expr <- wwExpr ww_opts expr     new_alts <- mapM ww_alt alts     let new_binder = zapIdUsedOnceInfo binder       -- See Note [Zapping Used Once info in WorkWrap]     return (Case new_expr new_binder ty new_alts)   where     ww_alt (Alt con binders rhs) = do-        new_rhs <- wwExpr dflags fam_envs rhs+        new_rhs <- wwExpr ww_opts rhs         let new_binders = [ if isId b then zapIdUsedOnceInfo b else b                           | b <- binders ]            -- See Note [Zapping Used Once info in WorkWrap]@@ -181,7 +183,7 @@ in a recursive group.  It might not be the loop breaker.  (We could test for loop-breaker-hood, but I'm not sure that ever matters.) -Note [Worker-wrapper for INLINABLE functions]+Note [Worker/wrapper for INLINABLE functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we have   {-# INLINABLE f #-}@@ -190,26 +192,26 @@  where f is strict in y, we might get a more efficient loop by w/w'ing f.  But that would make a new unfolding which would overwrite the old-one! So the function would no longer be INLNABLE, and in particular+one! So the function would no longer be INLINABLE, and in particular will not be specialised at call sites in other modules. -This comes in practice (#6056).+This comes up in practice (#6056).  Solution: do the w/w for strictness analysis, but transfer the Stable unfolding to the *worker*.  So we will get something like this: -  {-# INLINE[0] f #-}+  {-# INLINE[2] f #-}   f :: Ord a => [a] -> Int -> a   f d x y = case y of I# y' -> fw d x y' -  {-# INLINABLE[0] fw #-}+  {-# INLINABLE[2] fw #-}   fw :: Ord a => [a] -> Int# -> a   fw d x y' = let y = I# y' in ...f...  How do we "transfer the unfolding"? Easy: by using the old one, wrapped-in work_fn! See GHC.Core.Unfold.mkWorkerUnfolding.+in work_fn! See GHC.Core.Unfold.Make.mkWorkerUnfolding. -Note [No worker-wrapper for record selectors]+Note [No worker/wrapper for record selectors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We sometimes generate a lot of record selectors, and generally the don't benefit from worker/wrapper.  Yes, mkWwBodies would find a w/w split,@@ -225,8 +227,10 @@ in advance...the logic in mkWwBodies is complex. So I've left the super-simple test, with this Note to explain. +NB: record selectors are ordinary functions, inlined iff GHC wants to,+so won't be caught by the preceding isInlineUnfolding test in tryWW. -Note [Worker-wrapper for NOINLINE functions]+Note [Worker/wrapper for NOINLINE functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We used to disable worker/wrapper for NOINLINE things, but it turns out this can cause unnecessary reboxing of values. Consider@@ -300,7 +304,7 @@  Note [Worker activation] ~~~~~~~~~~~~~~~~~~~~~~~~-Follows on from Note [Worker-wrapper for INLINABLE functions]+Follows on from Note [Worker/wrapper for INLINABLE functions]  It is *vital* that if the worker gets an INLINABLE pragma (from the original function), then the worker has the same phase activation as@@ -308,7 +312,7 @@ inline into the worker's unfolding: see GHC.Core.Opt.Simplify.Utils Note [Simplifying inside stable unfoldings]. -If the original is NOINLINE, it's important that the work inherit the+If the original is NOINLINE, it's important that the worker inherits the original activation. Consider    {-# NOINLINE expensive #-}@@ -320,9 +324,9 @@ we'll get this (because of the compromise in point (2) of Note [Wrapper activation]) -  {-# NOINLINE[0] $wexpensive #-}+  {-# NOINLINE[Final] $wexpensive #-}   $wexpensive x = x + 1-  {-# INLINE[0] expensive #-}+  {-# INLINE[Final] expensive #-}   expensive x = $wexpensive x    f y = let z = expensive y in ...@@ -421,17 +425,20 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~ When should the wrapper inlining be active? -1. It must not be active earlier than the current Activation of the-   Id+1. It must not be active earlier than the current Activation of the Id,+   because we must give rewrite rules mentioning the wrapper and+   specialisation a chance to fire.+   See Note [Worker/wrapper for INLINABLE functions]+   and Note [Worker activation]  2. It should be active at some point, despite (1) because of-   Note [Worker-wrapper for NOINLINE functions]+   Note [Worker/wrapper for NOINLINE functions]  3. For ordinary functions with no pragmas we want to inline the    wrapper as early as possible (#15056).  Suppose another module-   defines    f x = g x x-   and suppose there is some RULE for (g True True).  Then if we have-   a call (f True), we'd expect to inline 'f' and the RULE will fire.+   defines    f !x xs = ... foldr k z xs ...+   and suppose we have the usual foldr/build RULE.  Then if we have+   a call `f x [1..x]`, we'd expect to inline f and the RULE will fire.    But if f is w/w'd (which it might be), we want the inlining to    occur just as if it hadn't been. @@ -456,32 +463,46 @@    In module Bar we want to give specialisations a chance to fire    before inlining f's wrapper. -   Historical note: At one stage I tried making the wrapper inlining+   (Historical note: At one stage I tried making the wrapper inlining    always-active, and that had a very bad effect on nofib/imaginary/x2n1;-   a wrapper was inlined before the specialisation fired.+   a wrapper was inlined before the specialisation fired.) +4a. If we have+      {-# SPECIALISE foo :: (Int,Int) -> Bool -> Int #-}+      {-# NOINLINE [n] foo #-}+    then specialisation will generate a SPEC rule active from Phase n.+    See Note [Auto-specialisation and RULES] in GHC.Core.Opt.Specialise+    This SPEC specialisation rule will compete with inlining, but we don't+    mind that, because if inlining succeeds, it should be better.++    Now, if we w/w foo, we must ensure that the wrapper (which is very+    keen to inline) has a phase /after/ 'n', else it'll always "win" over+    the SPEC rule -- disaster (#20709).++Conclusion: the activation for the wrapper should be the /later/ of+  (a) the current activation of the function, or FinalPhase if it is NOINLINE+  (b) one phase /after/ the activation of any rules+This is implemented by mkStrWrapperInlinePrag.+ Reminder: Note [Don't w/w INLINE things], so we don't need to worry           about INLINE things here. -Conclusion:-  - If the user said NOINLINE[n], respect that -  - If the user said NOINLINE, inline the wrapper only after-    phase 0, the last user-visible phase.  That means that all-    rules will have had a chance to fire.--    What phase is after phase 0?  Answer: FinalPhase, that's the reason it-    exists. NB: Similar to InitialPhase, users can't write INLINE[Final] f;-    it's syntactically illegal.+What if `foo` has no specialiations, is worker/wrappered (with the+wrapper inlining very early), and exported; and then in an importing+module we have {-# SPECIALISE foo : ... #-}? -  - Otherwise inline wrapper in phase 2.  That allows the-    'gentle' simplification pass to apply specialisation rules+Well then, we'll specialise foo's wrapper, which will expose a+specialisation for foo's worker, which we will do too.  That seems+fine.  (To work reliably, `foo` would need an INLINABLE pragma,+in which case we don't unpack dictionaries for the worker; see+see Note [Do not unbox class dictionaries].)  Note [Wrapper NoUserInlinePrag]-~~~~~~~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We use NoUserInlinePrag on the wrapper, to say that there is no user-specified inline pragma. (The worker inherits that; see Note-[Worker-wrapper for INLINABLE functions].)  The wrapper has no pragma+[Worker/wrapper for INLINABLE functions].)  The wrapper has no pragma given by the user.  (Historical note: we used to give the wrapper an INLINE pragma, but@@ -490,10 +511,20 @@ everything we needs is expressed by (a) the stable unfolding and (b) the inl_act activation.) +Note [Drop absent bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (#19824):+   let t = ...big...+   in ...(f t x)...++were `f` ignores its first argument.  With luck f's wrapper will inline+thereby dropping `t`, but maybe not: the arguments to f all look boring.++So we pre-empt the problem by replacing t's RHS with an absent filler.+Simple and effective. -} -tryWW   :: DynFlags-        -> FamInstEnvs+tryWW   :: WwOpts         -> RecFlag         -> Id                           -- The fn binder         -> CoreExpr                     -- The bound rhs; its innards@@ -503,49 +534,75 @@                                         -- the orig "wrapper" lives on);                                         -- if two, then a worker and a                                         -- wrapper.-tryWW dflags fam_envs is_rec fn_id rhs-  -- See Note [Worker-wrapper for NOINLINE functions]+tryWW ww_opts is_rec fn_id rhs+  -- See Note [Drop absent bindings]+  | isAbsDmd (demandInfo fn_info)+  , not (isJoinId fn_id)+  , Just filler <- mkAbsentFiller ww_opts fn_id NotMarkedStrict+  = return [(new_fn_id, filler)] -  | Just stable_unf <- certainlyWillInline uf_opts fn_info-  = return [ (fn_id `setIdUnfolding` stable_unf, rhs) ]-        -- See Note [Don't w/w INLINE things]-        -- See Note [Don't w/w inline small non-loop-breaker things]+  -- See Note [Don't w/w INLINE things]+  | hasInlineUnfolding fn_info+  = return [(new_fn_id, rhs)] -  | is_fun && is_eta_exp-  = splitFun dflags fam_envs new_fn_id fn_info wrap_dmds div cpr rhs+  -- See Note [No worker/wrapper for record selectors]+  | isRecordSelector fn_id+  = return [ (new_fn_id, rhs ) ] -  | isNonRec is_rec, is_thunk                        -- See Note [Thunk splitting]-  = splitThunk dflags fam_envs is_rec new_fn_id rhs+  -- Don't w/w OPAQUE things+  -- See Note [OPAQUE pragma]+  --+  -- Whilst this check might seem superfluous, since we strip boxity+  -- information in GHC.Core.Opt.DmdAnal.finaliseArgBoxities and+  -- CPR information in GHC.Core.Opt.CprAnal.cprAnalBind, it actually+  -- isn't. That is because we would still perform w/w when:+  --+  -- - An argument is used strictly, and -fworker-wrapper-cbv is+  --   enabled, or,+  -- - When demand analysis marks an argument as absent.+  --+  -- In a debug build we do assert that boxity and CPR information+  -- are actually stripped, since we want to prevent callers of OPAQUE+  -- things to do reboxing. See:+  -- - Note [The OPAQUE pragma and avoiding the reboxing of arguments]+  -- - Note [The OPAQUE pragma and avoiding the reboxing of results]+  | isOpaquePragma (inlinePragInfo fn_info)+  = assertPpr (onlyBoxedArguments (dmdSigInfo fn_info) &&+               isTopCprSig (cprSigInfo fn_info))+              (text "OPAQUE fun with boxity" $$+               ppr new_fn_id $$+               ppr (dmdSigInfo fn_info) $$+               ppr (cprSigInfo fn_info) $$+               ppr rhs) $+    return [ (new_fn_id, rhs) ] +  -- Do this even if there is a NOINLINE pragma+  -- See Note [Worker/wrapper for NOINLINE functions]+  | is_fun+  = splitFun ww_opts new_fn_id rhs++  -- See Note [Thunk splitting]+  | isNonRec is_rec, is_thunk+  = splitThunk ww_opts is_rec new_fn_id rhs+   | otherwise   = return [ (new_fn_id, rhs) ]    where-    uf_opts      = unfoldingOpts dflags-    fn_info      = idInfo new_fn_id-    (wrap_dmds, div) = splitStrictSig (strictnessInfo fn_info)--    cpr_ty       = getCprSig (cprInfo fn_info)-    -- Arity of the CPR sig should match idArity when it's not a join point.-    -- See Note [Arity trimming for CPR signatures] in GHC.Core.Opt.CprAnal-    cpr          = ASSERT2( isJoinId fn_id || cpr_ty == topCprType || ct_arty cpr_ty == arityInfo fn_info-                          , ppr fn_id <> colon <+> text "ct_arty:" <+> int (ct_arty cpr_ty) <+> text "arityInfo:" <+> ppr (arityInfo fn_info))-                   ct_cpr cpr_ty-+    fn_info        = idInfo fn_id+    (wrap_dmds, _) = splitDmdSig (dmdSigInfo fn_info)     new_fn_id      = zap_join_cpr $ zap_usage fn_id      zap_usage = zapIdUsedOnceInfo . zapIdUsageEnvInfo         -- See Note [Zapping DmdEnv after Demand Analyzer] and-        -- See Note [Zapping Used Once info WorkWrap]+        -- See Note [Zapping Used Once info in WorkWrap]      zap_join_cpr id-      | isJoinId id = id `setIdCprInfo` topCprSig+      | isJoinId id = id `setIdCprSig` topCprSig       | otherwise   = id         -- See Note [Don't w/w join points for CPR]      is_fun     = notNull wrap_dmds || isJoinId fn_id-    -- See Note [Don't eta expand in w/w]-    is_eta_exp = length wrap_dmds == manifestArity rhs     is_thunk   = not is_fun && not (exprIsHNF rhs) && not (isJoinId fn_id)                             && not (isUnliftedType (idType fn_id)) @@ -572,22 +629,57 @@  Note [Zapping Used Once info in WorkWrap] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In the worker-wrapper pass we zap the used once info in demands and in-strictness signatures.+During the work/wrap pass, using zapIdUsedOnceInfo, we zap the "used once" info+* on every binder (let binders, case binders, lambda binders)+* in both demands and in strictness signatures+* recursively  Why?  * The simplifier may happen to transform code in a way that invalidates the    data (see #11731 for an example).  * It is not used in later passes, up to code generation. -So as the data is useless and possibly wrong, we want to remove it. The most-convenient place to do that is the worker wrapper phase, as it runs after every-run of the demand analyser besides the very last one (which is the one where we-want to _keep_ the info for the code generator).+At first it's hard to see how the simplifier might invalidate it (and+indeed for a while I thought it couldn't: #19482), but it's not quite+as simple as I thought.  Consider this:+  {-# STRICTNESS SIG <SP(M,A)> #-}+  f p = let v = case p of (a,b) -> a+        in p `seq` (v,v) -We do not do it in the demand analyser for the same reasons outlined in-Note [Zapping DmdEnv after Demand Analyzer] above.+I think we'll give `f` the strictness signature `<SP(M,A)>`, where the+`M` sayd that we'll evaluate the first component of the pair at most+once.  Why?  Because the RHS of the thunk `v` is evaluated at most+once. +But now let's worker/wrapper f:+  {-# STRICTNESS SIG <M> #-}+  $wf p1 = let p2 = absentError "urk" in+           let p = (p1,p2) in+           let v = case p of (a,b) -> a+           in p `seq` (v,v)++where I've gotten the demand on `p1` by decomposing the P(M,A) argument demand.+This rapidly simplifies to+  {-# STRICTNESS SIG <M> #-}+  $wf p1 = let v = p1 in+           (v,v)++and thence to `(p1,p1)` by inlining the trivial let. Now the demand on `p1` should+not be at most once!!++Conclusion: used-once info is fragile to simplification, because of+the non-monotonic behaviour of let's, which turn used-many into+used-once.  So indeed we should zap this info in worker/wrapper.++Conclusion: kill it during worker/wrapper, using `zapUsedOnceInfo`.+Both the *demand signature* of the binder, and the *demand-info* of+the binder.  Moreover, do so recursively.++You might wonder: why do we generate used-once info if we then throw+it away.  The main reason is that we do a final run of the demand analyser,+immediately before CoreTidy, which is /not/ followed by worker/wrapper; it+is there only to generate used-once info for single-entry thunks.+ Note [Don't eta expand in w/w] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A binding where the manifestArity of the RHS is less than idArity of the binder@@ -595,7 +687,13 @@ for a reason (see Note [exprArity invariant] in GHC.Core.Opt.Arity) and we probably have a PAP, cast or trivial expression as RHS. -Performing the worker/wrapper split will implicitly eta-expand the binding to+Below is a historical account of what happened when w/w still did eta expansion.+Nowadays, it doesn't do that, but will simply w/w for the wrong arity, unleashing+a demand signature meant for e.g. 2 args to be unleashed for e.g. 1 arg+(manifest arity). That's at least as terrible as doing eta expansion, so don't+do it.+---+When worker/wrapper did eta expansion, it implictly eta expanded the binding to idArity, overriding GHC.Core.Opt.Arity's decision. Other than playing fast and loose with divergence, it's also broken for newtypes: @@ -603,7 +701,7 @@     where       co :: (Int -> Int -> Char) ~ T -Then idArity is 2 (despite the type T), and it can have a StrictSig based on a+Then idArity is 2 (despite the type T), and it can have a DmdSig based on a threshold of 2. But we can't w/w it without a type error.  The situation is less grave for PAPs, but the implicit eta expansion caused a@@ -617,67 +715,106 @@ that we W/W'd for idArity and will propagate analysis information under that assumption. So far, this doesn't seem to matter in practice. See https://gitlab.haskell.org/ghc/ghc/merge_requests/312#note_192064.++Note [Inline pragma for certainlyWillInline]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this (#19824 comment on 15 May 21):+  f _ (x,y) = ...big...+  v = ...big...+  g x = f v x + 1++So `f` will generate a worker/wrapper split; and `g` (since it is small)+will trigger the certainlyWillInline case of splitFun.  The danger is that+we end up with+  g {- StableUnfolding = \x -> f v x + 1 -}+    = ...blah...++Since (a) that unfolding for g is AlwaysActive+      (b) the unfolding for f's wrapper is ActiveAfterInitial+the call of f will never inline in g's stable unfolding, thereby+keeping `v` alive.++I thought of changing g's unfolding to be ActiveAfterInitial, but that+too is bad: it delays g's inlining into other modules, which makes fewer+specialisations happen. Example in perf/should_run/DeriveNull.++So I decided to live with the problem.  In fact v's RHS will be replaced+by LitRubbish (see Note [Drop absent bindings]) so there is no great harm. -}   ----------------------splitFun :: DynFlags -> FamInstEnvs -> Id -> IdInfo -> [Demand] -> Divergence -> Cpr -> CoreExpr-         -> UniqSM [(Id, CoreExpr)]-splitFun dflags fam_envs fn_id fn_info wrap_dmds div cpr rhs-  | isRecordSelector fn_id  -- See Note [No worker/wrapper for record selectors]-  = return [ (fn_id, rhs ) ]+splitFun :: WwOpts -> Id -> CoreExpr -> UniqSM [(Id, CoreExpr)]+splitFun ww_opts fn_id rhs+  | not (wrap_dmds `lengthIs` count isId arg_vars)+    -- See Note [Don't eta expand in w/w]+  = return [(fn_id, rhs)]    | otherwise-  = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr cpr) )-          -- The arity should match the signature-    do { mb_stuff <- mkWwBodies dflags fam_envs rhs_fvs fn_id wrap_dmds use_cpr_info+  = warnPprTrace (not (wrap_dmds `lengthIs` (arityInfo fn_info)))+                 "splitFun"+                 (ppr fn_id <+> (ppr wrap_dmds $$ ppr cpr)) $+    do { mb_stuff <- mkWwBodies ww_opts fn_id arg_vars (exprType body) wrap_dmds cpr        ; case mb_stuff of-            Nothing -> return [(fn_id, rhs)]+            Nothing -> -- No useful wrapper; leave the binding alone+                       return [(fn_id, rhs)]              Just stuff-              | Just stable_unf <- certainlyWillInline (unfoldingOpts dflags) fn_info-              ->  return [ (fn_id `setIdUnfolding` stable_unf, rhs) ]-                  -- See Note [Don't w/w INLINE things]-                  -- See Note [Don't w/w inline small non-loop-breaker things]+              | let opt_wwd_rhs = simpleOptExpr (wo_simple_opts ww_opts) rhs+                  -- We need to stabilise the WW'd (and optimised) RHS below+              , Just stable_unf <- certainlyWillInline uf_opts fn_info opt_wwd_rhs+                -- We could make a w/w split, but in fact the RHS is small+                -- See Note [Don't w/w inline small non-loop-breaker things]+              , let id_w_unf = fn_id `setIdUnfolding` stable_unf+                -- See Note [Inline pragma for certainlyWillInline]+              ->  return [ (id_w_unf, rhs) ]                | otherwise               -> do { work_uniq <- getUniqueM-                    ; return (mkWWBindPair dflags fn_id fn_info arity rhs+                    ; return (mkWWBindPair ww_opts fn_id fn_info arg_vars body                                            work_uniq div stuff) } }   where-    rhs_fvs = exprFreeVars rhs-    arity   = arityInfo fn_info-            -- The arity is set by the simplifier using exprEtaExpandArity-            -- So it may be more than the number of top-level-visible lambdas+    uf_opts = so_uf_opts (wo_simple_opts ww_opts)+    fn_info = idInfo fn_id+    (arg_vars, body) = collectBinders rhs -    -- use_cpr_info is the CPR we w/w for. Note that we kill it for join points,-    -- see Note [Don't w/w join points for CPR].-    use_cpr_info  | isJoinId fn_id = topCpr-                  | otherwise      = cpr+    (wrap_dmds, div) = splitDmdSig (dmdSigInfo fn_info) +    cpr_ty = getCprSig (cprSigInfo fn_info)+    -- Arity of the CPR sig should match idArity when it's not a join point.+    -- See Note [Arity trimming for CPR signatures] in GHC.Core.Opt.CprAnal+    cpr = assertPpr (isJoinId fn_id || cpr_ty == topCprType || ct_arty cpr_ty == arityInfo fn_info)+                    (ppr fn_id <> colon <+> text "ct_arty:" <+> int (ct_arty cpr_ty)+                      <+> text "arityInfo:" <+> ppr (arityInfo fn_info)) $+          ct_cpr cpr_ty -mkWWBindPair :: DynFlags -> Id -> IdInfo -> Arity-             -> CoreExpr -> Unique -> Divergence-             -> ([Demand], JoinArity, Id -> CoreExpr, Expr CoreBndr -> CoreExpr)+mkWWBindPair :: WwOpts -> Id -> IdInfo+             -> [Var] -> CoreExpr -> Unique -> Divergence+             -> ([Demand],JoinArity, Id -> CoreExpr, Expr CoreBndr -> CoreExpr)              -> [(Id, CoreExpr)]-mkWWBindPair dflags fn_id fn_info arity rhs work_uniq div+mkWWBindPair ww_opts fn_id fn_info fn_args fn_body work_uniq div              (work_demands, join_arity, wrap_fn, work_fn)-  = [(work_id, work_rhs), (wrap_id, wrap_rhs)]+  = -- pprTrace "mkWWBindPair" (ppr fn_id <+> ppr wrap_id <+> ppr work_id $$ ppr wrap_rhs) $+    [(work_id, work_rhs), (wrap_id, wrap_rhs)]      -- Worker first, because wrapper mentions it   where-    simpl_opts = initSimpleOpts dflags+    arity = arityInfo fn_info+            -- The arity is set by the simplifier using exprEtaExpandArity+            -- So it may be more than the number of top-level-visible lambdas -    work_rhs = work_fn rhs+    simpl_opts = wo_simple_opts ww_opts++    work_rhs = work_fn (mkLams fn_args fn_body)     work_act = case fn_inline_spec of  -- See Note [Worker activation]-                   NoInline -> inl_act fn_inl_prag-                   _        -> inl_act wrap_prag+                   NoInline _  -> inl_act fn_inl_prag+                   _           -> inl_act wrap_prag      work_prag = InlinePragma { inl_src = SourceText "{-# INLINE"                              , inl_inline = fn_inline_spec                              , inl_sat    = Nothing                              , inl_act    = work_act                              , inl_rule   = FunLike }-      -- inl_inline: copy from fn_id; see Note [Worker-wrapper for INLINABLE functions]+      -- inl_inline: copy from fn_id; see Note [Worker/wrapper for INLINABLE functions]       -- inl_act:    see Note [Worker activation]       -- inl_rule:   it does not make sense for workers to be constructorlike. @@ -686,7 +823,8 @@       -- worker is join point iff wrapper is join point       -- (see Note [Don't w/w join points for CPR]) -    work_id  = mkWorkerId work_uniq fn_id (exprType work_rhs)+    work_id  = asWorkerLikeId $+               mkWorkerId work_uniq fn_id (exprType work_rhs)                 `setIdOccInfo` occInfo fn_info                         -- Copy over occurrence info from parent                         -- Notably whether it's a loop breaker@@ -696,13 +834,13 @@                 `setInlinePragma` work_prag                  `setIdUnfolding` mkWorkerUnfolding simpl_opts work_fn fn_unfolding-                        -- See Note [Worker-wrapper for INLINABLE functions]+                        -- See Note [Worker/wrapper for INLINABLE functions] -                `setIdStrictness` mkClosedStrictSig work_demands div+                `setIdDmdSig` mkClosedDmdSig work_demands div                         -- Even though we may not be at top level,                         -- it's ok to give it an empty DmdEnv -                `setIdCprInfo` topCprSig+                `setIdCprSig` topCprSig                  `setIdDemandInfo` worker_demand @@ -710,19 +848,21 @@                         -- Set the arity so that the Core Lint check that the                         -- arity is consistent with the demand type goes                         -- through+                 `asJoinId_maybe` work_join_arity -    work_arity = length work_demands+    work_arity = length work_demands :: Int -    -- See Note [Demand on the Worker]+    -- See Note [Demand on the worker]     single_call = saturatedByOneShots arity (demandInfo fn_info)     worker_demand | single_call = mkWorkerDemand work_arity                   | otherwise   = topDmd      wrap_rhs  = wrap_fn work_id-    wrap_prag = mkStrWrapperInlinePrag fn_inl_prag+    wrap_prag = mkStrWrapperInlinePrag fn_inl_prag fn_rules+    wrap_unf  = mkWrapperUnfolding simpl_opts wrap_rhs arity -    wrap_id   = fn_id `setIdUnfolding`  mkWwInlineRule simpl_opts wrap_rhs arity+    wrap_id   = fn_id `setIdUnfolding`  wrap_unf                       `setInlinePragma` wrap_prag                       `setIdOccInfo`    noOccInfo                         -- Zap any loop-breaker-ness, to avoid bleating from Lint@@ -730,27 +870,30 @@      fn_inl_prag     = inlinePragInfo fn_info     fn_inline_spec  = inl_inline fn_inl_prag-    fn_unfolding    = unfoldingInfo fn_info+    fn_unfolding    = realUnfoldingInfo fn_info+    fn_rules        = ruleInfoRules (ruleInfo fn_info) -mkStrWrapperInlinePrag :: InlinePragma -> InlinePragma-mkStrWrapperInlinePrag (InlinePragma { inl_act = act, inl_rule = rule_info })+mkStrWrapperInlinePrag :: InlinePragma -> [CoreRule] -> InlinePragma+-- See Note [Wrapper activation]+mkStrWrapperInlinePrag (InlinePragma { inl_act = act, inl_rule = rule_info }) rules   = InlinePragma { inl_src    = SourceText "{-# INLINE"-                 , inl_inline = NoUserInlinePrag -- See Note [Wrapper NoUserInline]+                 , inl_inline = NoUserInlinePrag -- See Note [Wrapper NoUserInlinePrag]                  , inl_sat    = Nothing-                 , inl_act    = wrap_act+                 , inl_act    = activeAfter wrapper_phase                  , inl_rule   = rule_info }  -- RuleMatchInfo is (and must be) unaffected   where-    wrap_act  = case act of  -- See Note [Wrapper activation]-                   NeverActive     -> activateDuringFinal-                   FinalActive     -> act-                   ActiveAfter {}  -> act-                   ActiveBefore {} -> activateAfterInitial-                   AlwaysActive    -> activateAfterInitial-      -- For the last two cases, see (4) in Note [Wrapper activation]-      -- NB: the (ActiveBefore n) isn't quite right. We really want-      -- it to be active *after* Initial but *before* n.  We don't have-      -- a way to say that, alas.+    -- See Note [Wrapper activation]+    wrapper_phase = foldr (laterPhase . get_rule_phase) earliest_inline_phase rules+    earliest_inline_phase = beginPhase act `laterPhase` nextPhase InitialPhase+          -- laterPhase (nextPhase InitialPhase) is a temporary hack+          -- to inline no earlier than phase 2.  I got regressions in+          -- 'mate', due to changes in full laziness due to Note [Case+          -- MFEs], when I did earlier inlining. +    get_rule_phase :: CoreRule -> CompilerPhase+    -- The phase /after/ the rule is first active+    get_rule_phase rule = nextPhase (beginPhase (ruleActivation rule))+ {- Note [Demand on the worker] ~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -782,55 +925,62 @@ The demand on the worker is then calculated using mkWorkerDemand, and always of the form [Demand=<L,1*(C1(...(C1(U))))>] --Note [Do not split void functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this rather common form of binding:-        $j = \x:Void# -> ...no use of x...--Since x is not used it'll be marked as absent.  But there is no point-in w/w-ing because we'll simply add (\y:Void#), see GHC.Core.Opt.WorkWrap.Utils.mkWorerArgs.--If x has a more interesting type (eg Int, or Int#), there *is* a point-in w/w so that we don't pass the argument at all.- Note [Thunk splitting] ~~~~~~~~~~~~~~~~~~~~~~-Suppose x is used strictly (never mind whether it has the CPR-property).+Suppose x is used strictly; never mind whether it has the CPR+property.  I'll use a '*' to mean "x* is demanded strictly".        let         x* = x-rhs       in body  splitThunk transforms like this:-       let-        x* = case x-rhs of { I# a -> I# a }+        x* = let x = x-rhs in+             case x of { I# a -> I# a }       in body -Now simplifier will transform to-+This is a little strange: we are re-using the same `x` in the RHS; and+the RHS takes `x` apart and reboxes it. But because the outer 'let' is+strict, and the inner let mentions `x` only once, the simplifier+transform it to       case x-rhs of         I# a -> let x* = I# a                 in body -which is what we want. Now suppose x-rhs is itself a case:--        x-rhs = case e of { T -> I# a; F -> I# b }+That is good: in `body` we know the form of `x`, which+  * gives the CPR property, and+  * allows case-of-case to happen on x -The join point will abstract over a, rather than over (which is-what would have happened before) which is fine.+Notes+* I tried transforming like this:+      let+        x* = let x = x-rhs in+             case x of { I# a -> x }+      in body+  where I return `x` itself, rather than reboxing it.  But this+  turned out to cause some regressions, which I never fully+  investigated. -Notice that x certainly has the CPR property now!+* Suppose x-rhs is itself a case:+        x-rhs = case e of { T -> I# e1; F -> I# e2 }+  Then we'll get+      join j a = let x* = I# a in body+      in case e of { T -> j e1; F -> j e2 }+  which is good (no boxing).  But in the original, unsplit program+  we would transform+      let x* = case e of ... in body+  ==> join j2 x = body+      in case e of { T -> j2 (I# e1); F -> j (I# e2) }+  which is not good (boxing). -In fact, splitThunk uses the function argument w/w splitting-function, so that if x's demand is deeper (say U(U(L,L),L))-then the splitting will go deeper too.+* In fact, splitThunk uses the function argument w/w splitting+  function, mkWWstr_one, so that if x's demand is deeper (say U(U(L,L),L))+  then the splitting will go deeper too. -NB: For recursive thunks, the Simplifier is unable to float `x-rhs` out of-`x*`'s RHS, because `x*` occurs freely in `x-rhs`, and will just change it-back to the original definition, so we just split non-recursive thunks.+* For recursive thunks, the Simplifier is unable to float `x-rhs` out of+  `x*`'s RHS, because `x*` occurs freely in `x-rhs`, and will just change it+  back to the original definition, so we just split non-recursive thunks.  Note [Thunk splitting for top-level binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -878,12 +1028,13 @@ -- -- How can we do thunk-splitting on a top-level binder?  See -- Note [Thunk splitting for top-level binders].-splitThunk :: DynFlags -> FamInstEnvs -> RecFlag -> Var -> Expr Var -> UniqSM [(Var, Expr Var)]-splitThunk dflags fam_envs is_rec x rhs-  = ASSERT(not (isJoinId x))+splitThunk :: WwOpts -> RecFlag -> Var -> Expr Var -> UniqSM [(Var, Expr Var)]+splitThunk ww_opts is_rec x rhs+  = assert (not (isJoinId x)) $     do { let x' = localiseId x -- See comment above-       ; (useful,_, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False [x']-       ; let res = [ (x, Let (NonRec x' rhs) (wrap_fn (work_fn (Var x')))) ]-       ; if useful then ASSERT2( isNonRec is_rec, ppr x ) -- The thunk must be non-recursive+       ; (useful,_args, wrap_fn, fn_arg)+           <- mkWWstr_one ww_opts x' NotMarkedStrict+       ; let res = [ (x, Let (NonRec x' rhs) (wrap_fn fn_arg)) ]+       ; if useful then assertPpr (isNonRec is_rec) (ppr x) -- The thunk must be non-recursive                    return res                    else return [(x, rhs)] }
compiler/GHC/Core/Opt/WorkWrap/Utils.hs view
@@ -4,1424 +4,1615 @@ A library for the ``worker\/wrapper'' back-end to the strictness analyser -} -{-# LANGUAGE CPP #-}--module GHC.Core.Opt.WorkWrap.Utils-   ( mkWwBodies, mkWWstr, mkWorkerArgs-   , DataConPatContext(..), UnboxingDecision(..), splitArgType_maybe, wantToUnbox-   , findTypeShape-   , isWorkerSmallEnough-   )-where--#include "GhclibHsVersions.h"--import GHC.Prelude--import GHC.Core-import GHC.Core.Utils   ( exprType, mkCast, mkDefaultCase, mkSingleAltCase-                        , bindNonRec, dataConRepFSInstPat )-import GHC.Types.Id-import GHC.Types.Id.Info ( JoinArity )-import GHC.Core.DataCon-import GHC.Types.Demand-import GHC.Types.Cpr-import GHC.Core.Make    ( mkAbsentErrorApp, mkCoreUbxTup-                        , mkCoreApp, mkCoreLet )-import GHC.Types.Id.Make ( voidArgId, voidPrimId )-import GHC.Builtin.Types      ( tupleDataCon )-import GHC.Core.Make ( mkLitRubbish )-import GHC.Types.Var.Env ( mkInScopeSet )-import GHC.Types.Var.Set ( VarSet )-import GHC.Core.Type-import GHC.Core.Multiplicity-import GHC.Core.Predicate ( isClassPred )-import GHC.Core.Coercion-import GHC.Core.FamInstEnv-import GHC.Types.Basic       ( Boxity(..) )-import GHC.Core.TyCon-import GHC.Core.TyCon.RecWalk-import GHC.Types.Unique.Supply-import GHC.Types.Unique-import GHC.Types.Name ( getOccFS )-import GHC.Data.Maybe-import GHC.Utils.Misc-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Driver.Session-import GHC.Driver.Ppr-import GHC.Data.FastString-import GHC.Data.List.SetOps--import GHC.Types.RepType--{--************************************************************************-*                                                                      *-\subsection[mkWrapperAndWorker]{@mkWrapperAndWorker@}-*                                                                      *-************************************************************************--Here's an example.  The original function is:--\begin{verbatim}-g :: forall a . Int -> [a] -> a--g = \/\ a -> \ x ys ->-        case x of-          0 -> head ys-          _ -> head (tail ys)-\end{verbatim}--From this, we want to produce:-\begin{verbatim}--- wrapper (an unfolding)-g :: forall a . Int -> [a] -> a--g = \/\ a -> \ x ys ->-        case x of-          I# x# -> $wg a x# ys-            -- call the worker; don't forget the type args!---- worker-$wg :: forall a . Int# -> [a] -> a--$wg = \/\ a -> \ x# ys ->-        let-            x = I# x#-        in-            case x of               -- note: body of g moved intact-              0 -> head ys-              _ -> head (tail ys)-\end{verbatim}--Something we have to be careful about:  Here's an example:--\begin{verbatim}--- "f" strictness: U(P)U(P)-f (I# a) (I# b) = a +# b--g = f   -- "g" strictness same as "f"-\end{verbatim}--\tr{f} will get a worker all nice and friendly-like; that's good.-{\em But we don't want a worker for \tr{g}}, even though it has the-same strictness as \tr{f}.  Doing so could break laziness, at best.--Consequently, we insist that the number of strictness-info items is-exactly the same as the number of lambda-bound arguments.  (This is-probably slightly paranoid, but OK in practice.)  If it isn't the-same, we ``revise'' the strictness info, so that we won't propagate-the unusable strictness-info into the interfaces.---************************************************************************-*                                                                      *-\subsection{The worker wrapper core}-*                                                                      *-************************************************************************--@mkWwBodies@ is called when doing the worker\/wrapper split inside a module.--}--type WwResult-  = ([Demand],              -- Demands for worker (value) args-     JoinArity,             -- Number of worker (type OR value) args-     Id -> CoreExpr,        -- Wrapper body, lacking only the worker Id-     CoreExpr -> CoreExpr)  -- Worker body, lacking the original function rhs--mkWwBodies :: DynFlags-           -> FamInstEnvs-           -> VarSet         -- Free vars of RHS-                             -- See Note [Freshen WW arguments]-           -> Id             -- The original function-           -> [Demand]       -- Strictness of original function-           -> Cpr            -- Info about function result-           -> UniqSM (Maybe WwResult)---- wrap_fn_args E       = \x y -> E--- work_fn_args E       = E x y---- wrap_fn_str E        = case x of { (a,b) ->---                        case a of { (a1,a2) ->---                        E a1 a2 b y }}--- work_fn_str E        = \a1 a2 b y ->---                        let a = (a1,a2) in---                        let x = (a,b) in---                        E--mkWwBodies dflags fam_envs rhs_fvs fun_id demands cpr_info-  = do  { let empty_subst = mkEmptyTCvSubst (mkInScopeSet rhs_fvs)-                -- See Note [Freshen WW arguments]--        ; (wrap_args, wrap_fn_args, work_fn_args, res_ty)-             <- mkWWargs empty_subst fun_ty demands-        ; (useful1, work_args, wrap_fn_str, work_fn_str)-             <- mkWWstr dflags fam_envs has_inlineable_prag wrap_args--        -- Do CPR w/w.  See Note [Always do CPR w/w]-        ; (useful2, wrap_fn_cpr, work_fn_cpr, cpr_res_ty)-              <- mkWWcpr (gopt Opt_CprAnal dflags) fam_envs res_ty cpr_info--        ; let (work_lam_args, work_call_args) = mkWorkerArgs dflags work_args cpr_res_ty-              worker_args_dmds = [idDemandInfo v | v <- work_call_args, isId v]-              wrapper_body = wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var-              worker_body = mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args--        ; if isWorkerSmallEnough dflags (length demands) work_args-             && not (too_many_args_for_join_point wrap_args)-             && ((useful1 && not only_one_void_argument) || useful2)-          then return (Just (worker_args_dmds, length work_call_args,-                       wrapper_body, worker_body))-          else return Nothing-        }-        -- We use an INLINE unconditionally, even if the wrapper turns out to be-        -- something trivial like-        --      fw = ...-        --      f = __inline__ (coerce T fw)-        -- The point is to propagate the coerce to f's call sites, so even though-        -- f's RHS is now trivial (size 1) we still want the __inline__ to prevent-        -- fw from being inlined into f's RHS-  where-    fun_ty        = idType fun_id-    mb_join_arity = isJoinId_maybe fun_id-    has_inlineable_prag = isStableUnfolding (realIdUnfolding fun_id)-                          -- See Note [Do not unpack class dictionaries]--    -- Note [Do not split void functions]-    only_one_void_argument-      | [d] <- demands-      , Just (_, arg_ty1, _) <- splitFunTy_maybe fun_ty-      , isAbsDmd d && isVoidTy arg_ty1-      = True-      | otherwise-      = False--    -- Note [Join points returning functions]-    too_many_args_for_join_point wrap_args-      | Just join_arity <- mb_join_arity-      , wrap_args `lengthExceeds` join_arity-      = WARN(True, text "Unable to worker/wrapper join point with arity " <+>-                     int join_arity <+> text "but" <+>-                     int (length wrap_args) <+> text "args")-        True-      | otherwise-      = False---- See Note [Limit w/w arity]-isWorkerSmallEnough :: DynFlags -> Int -> [Var] -> Bool-isWorkerSmallEnough dflags old_n_args vars-  = count isId vars <= max old_n_args (maxWorkerArgs dflags)-    -- We count only Free variables (isId) to skip Type, Kind-    -- variables which have no runtime representation.-    -- Also if the function took 82 arguments before (old_n_args), it's fine if-    -- it takes <= 82 arguments afterwards.--{--Note [Always do CPR w/w]-~~~~~~~~~~~~~~~~~~~~~~~~-At one time we refrained from doing CPR w/w for thunks, on the grounds that-we might duplicate work.  But that is already handled by the demand analyser,-which doesn't give the CPR property if w/w might waste work: see-Note [CPR for thunks] in GHC.Core.Opt.DmdAnal.--And if something *has* been given the CPR property and we don't w/w, it's-a disaster, because then the enclosing function might say it has the CPR-property, but now doesn't and there a cascade of disaster.  A good example-is #5920.--Note [Limit w/w arity]-~~~~~~~~~~~~~~~~~~~~~~~~-Guard against high worker arity as it generates a lot of stack traffic.-A simplified example is #11565#comment:6--Current strategy is very simple: don't perform w/w transformation at all-if the result produces a wrapper with arity higher than -fmax-worker-args-and the number arguments before w/w (see #18122).--It is a bit all or nothing, consider--        f (x,y) (a,b,c,d,e ... , z) = rhs--Currently we will remove all w/w ness entirely. But actually we could-w/w on the (x,y) pair... it's the huge product that is the problem.--Could we instead refrain from w/w on an arg-by-arg basis? Yes, that'd-solve f. But we can get a lot of args from deeply-nested products:--        g (a, (b, (c, (d, ...)))) = rhs--This is harder to spot on an arg-by-arg basis. Previously mkWwStr was-given some "fuel" saying how many arguments it could add; when we ran-out of fuel it would stop w/wing.--Still not very clever because it had a left-right bias.--************************************************************************-*                                                                      *-\subsection{Making wrapper args}-*                                                                      *-************************************************************************--During worker-wrapper stuff we may end up with an unlifted thing-which we want to let-bind without losing laziness.  So we-add a void argument.  E.g.--        f = /\a -> \x y z -> E::Int#    -- E does not mention x,y,z-==>-        fw = /\ a -> \void -> E-        f  = /\ a -> \x y z -> fw realworld--We use the state-token type which generates no code.--}--mkWorkerArgs :: DynFlags -> [Var]-             -> Type    -- Type of body-             -> ([Var], -- Lambda bound args-                 [Var]) -- Args at call site-mkWorkerArgs dflags args res_ty-    | any isId args || not needsAValueLambda-    = (args, args)-    | otherwise-    = (args ++ [voidArgId], args ++ [voidPrimId])-    where-      -- See "Making wrapper args" section above-      needsAValueLambda =-        lifted-        -- We may encounter a levity-polymorphic result, in which case we-        -- conservatively assume that we have laziness that needs preservation.-        -- See #15186.-        || not (gopt Opt_FunToThunk dflags)-           -- see Note [Protecting the last value argument]--      -- Might the result be lifted?-      lifted =-        case isLiftedType_maybe res_ty of-          Just lifted -> lifted-          Nothing     -> True--{--Note [Protecting the last value argument]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If the user writes (\_ -> E), they might be intentionally disallowing-the sharing of E. Since absence analysis and worker-wrapper are keen-to remove such unused arguments, we add in a void argument to prevent-the function from becoming a thunk.--The user can avoid adding the void argument with the -ffun-to-thunk-flag. However, this can create sharing, which may be bad in two ways. 1) It can-create a space leak. 2) It can prevent inlining *under a lambda*. If w/w-removes the last argument from a function f, then f now looks like a thunk, and-so f can't be inlined *under a lambda*.--Note [Join points and beta-redexes]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--Originally, the worker would invoke the original function by calling it with-arguments, thus producing a beta-redex for the simplifier to munch away:--  \x y z -> e => (\x y z -> e) wx wy wz--Now that we have special rules about join points, however, this is Not Good if-the original function is itself a join point, as then it may contain invocations-of other join points:--  join j1 x = ...-  join j2 y = if y == 0 then 0 else j1 y--  =>--  join j1 x = ...-  join $wj2 y# = let wy = I# y# in (\y -> if y == 0 then 0 else jump j1 y) wy-  join j2 y = case y of I# y# -> jump $wj2 y#--There can't be an intervening lambda between a join point's declaration and its-occurrences, so $wj2 here is wrong. But of course, this is easy enough to fix:--  ...-  let join $wj2 y# = let wy = I# y# in let y = wy in if y == 0 then 0 else j1 y-  ...--Hence we simply do the beta-reduction here. (This would be harder if we had to-worry about hygiene, but luckily wy is freshly generated.)--Note [Join points returning functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--It is crucial that the arity of a join point depends on its *callers,* not its-own syntax. What this means is that a join point can have "extra lambdas":--f :: Int -> Int -> (Int, Int) -> Int-f x y = join j (z, w) = \(u, v) -> ...-        in jump j (x, y)--Typically this happens with functions that are seen as computing functions,-rather than being curried. (The real-life example was GHC.Data.Graph.Ops.addConflicts.)--When we create the wrapper, it *must* be in "eta-contracted" form so that the-jump has the right number of arguments:--f x y = join $wj z' w' = \u' v' -> let {z = z'; w = w'; u = u'; v = v'} in ...-             j (z, w)  = jump $wj z w--(See Note [Join points and beta-redexes] for where the lets come from.) If j-were a function, we would instead say--f x y = let $wj = \z' w' u' v' -> let {z = z'; w = w'; u = u'; v = v'} in ...-            j (z, w) (u, v) = $wj z w u v--Notice that the worker ends up with the same lambdas; it's only the wrapper we-have to be concerned about.--FIXME Currently the functionality to produce "eta-contracted" wrappers is-unimplemented; we simply give up.--************************************************************************-*                                                                      *-\subsection{Coercion stuff}-*                                                                      *-************************************************************************--We really want to "look through" coerces.-Reason: I've seen this situation:--        let f = coerce T (\s -> E)-        in \x -> case x of-                    p -> coerce T' f-                    q -> \s -> E2-                    r -> coerce T' f--If only we w/w'd f, we'd get-        let f = coerce T (\s -> fw s)-            fw = \s -> E-        in ...--Now we'll inline f to get--        let fw = \s -> E-        in \x -> case x of-                    p -> fw-                    q -> \s -> E2-                    r -> fw--Now we'll see that fw has arity 1, and will arity expand-the \x to get what we want.--}---- mkWWargs just does eta expansion--- is driven off the function type and arity.--- It chomps bites off foralls, arrows, newtypes--- and keeps repeating that until it's satisfied the supplied arity--mkWWargs :: TCvSubst            -- Freshening substitution to apply to the type-                                --   See Note [Freshen WW arguments]-         -> Type                -- The type of the function-         -> [Demand]     -- Demands and one-shot info for value arguments-         -> UniqSM  ([Var],            -- Wrapper args-                     CoreExpr -> CoreExpr,      -- Wrapper fn-                     CoreExpr -> CoreExpr,      -- Worker fn-                     Type)                      -- Type of wrapper body--mkWWargs subst fun_ty demands-  | null demands-  = return ([], id, id, substTyUnchecked subst fun_ty)-    -- I got an ASSERT failure here with `substTy`, and I was-    -- disinclined to pursue it since this code is about to be-    -- deleted by Sebastian--  | (dmd:demands') <- demands-  , Just (mult, arg_ty, fun_ty') <- splitFunTy_maybe fun_ty-  = do  { uniq <- getUniqueM-        ; let arg_ty' = substScaledTy subst (Scaled mult arg_ty)-              id = mk_wrap_arg uniq arg_ty' dmd-        ; (wrap_args, wrap_fn_args, work_fn_args, res_ty)-              <- mkWWargs subst fun_ty' demands'-        ; return (id : wrap_args,-                  Lam id . wrap_fn_args,-                  apply_or_bind_then work_fn_args (varToCoreExpr id),-                  res_ty) }--  | Just (tv, fun_ty') <- splitForAllTyCoVar_maybe fun_ty-  = do  { uniq <- getUniqueM-        ; let (subst', tv') = cloneTyVarBndr subst tv uniq-                -- See Note [Freshen WW arguments]-        ; (wrap_args, wrap_fn_args, work_fn_args, res_ty)-             <- mkWWargs subst' fun_ty' demands-        ; return (tv' : wrap_args,-                  Lam tv' . wrap_fn_args,-                  apply_or_bind_then work_fn_args (mkTyArg (mkTyVarTy tv')),-                  res_ty) }--  | Just (co, rep_ty) <- topNormaliseNewType_maybe fun_ty-        -- The newtype case is for when the function has-        -- a newtype after the arrow (rare)-        ---        -- It's also important when we have a function returning (say) a pair-        -- wrapped in a  newtype, at least if CPR analysis can look-        -- through such newtypes, which it probably can since they are-        -- simply coerces.--  = do { (wrap_args, wrap_fn_args, work_fn_args, res_ty)-            <-  mkWWargs subst rep_ty demands-       ; let co' = substCo subst co-       ; return (wrap_args,-                  \e -> Cast (wrap_fn_args e) (mkSymCo co'),-                  \e -> work_fn_args (Cast e co'),-                  res_ty) }--  | otherwise-  = WARN( True, ppr fun_ty )                    -- Should not happen: if there is a demand-    return ([], id, id, substTy subst fun_ty)   -- then there should be a function arrow-  where-    -- See Note [Join points and beta-redexes]-    apply_or_bind_then k arg (Lam bndr body)-      = mkCoreLet (NonRec bndr arg) (k body)    -- Important that arg is fresh!-    apply_or_bind_then k arg fun-      = k $ mkCoreApp (text "mkWWargs") fun arg-applyToVars :: [Var] -> CoreExpr -> CoreExpr-applyToVars vars fn = mkVarApps fn vars--mk_wrap_arg :: Unique -> Scaled Type -> Demand -> Id-mk_wrap_arg uniq (Scaled w ty) dmd-  = mkSysLocalOrCoVar (fsLit "w") uniq w ty-       `setIdDemandInfo` dmd--{- Note [Freshen WW arguments]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Wen we do a worker/wrapper split, we must not in-scope names as the arguments-of the worker, else we'll get name capture.  E.g.--   -- y1 is in scope from further out-   f x = ..y1..--If we accidentally choose y1 as a worker argument disaster results:--   fww y1 y2 = let x = (y1,y2) in ...y1...--To avoid this:--  * We use a fresh unique for both type-variable and term-variable binders-    Originally we lacked this freshness for type variables, and that led-    to the very obscure #12562.  (A type variable in the worker shadowed-    an outer term-variable binding.)--  * Because of this cloning we have to substitute in the type/kind of the-    new binders.  That's why we carry the TCvSubst through mkWWargs.--    So we need a decent in-scope set, just in case that type/kind-    itself has foralls.  We get this from the free vars of the RHS of the-    function since those are the only variables that might be captured.-    It's a lazy thunk, which will only be poked if the type/kind has a forall.--    Another tricky case was when f :: forall a. a -> forall a. a->a-    (i.e. with shadowing), and then the worker used the same 'a' twice.--}--{--************************************************************************-*                                                                      *-\subsection{Unboxing Decision for Strictness and CPR}-*                                                                      *-************************************************************************--}---- | The information needed to build a pattern for a DataCon to be unboxed.--- The pattern can be generated from 'dcpc_dc' and 'dcpc_tc_args' via--- 'GHC.Core.Utils.dataConRepInstPat'. The coercion 'dcpc_co' is for newtype--- wrappers.------ If we get @DataConPatContext dc tys co@ for some type @ty@--- and @dataConRepInstPat ... dc tys = (exs, flds)@, then------   * @dc @exs flds :: T tys@---   * @co :: T tys ~ ty@-data DataConPatContext-  = DataConPatContext-  { dcpc_dc      :: !DataCon-  , dcpc_tc_args :: ![Type]-  , dcpc_co      :: !Coercion-  }---- | If @splitArgType_maybe ty = Just (dc, tys, co)@--- then @dc \@tys \@_ex_tys (_args::_arg_tys) :: tc tys@--- and  @co :: ty ~ tc tys@--- where underscore prefixes are holes, e.g. yet unspecified.------ See Note [Which types are unboxed?].-splitArgType_maybe :: FamInstEnvs -> Type -> Maybe DataConPatContext-splitArgType_maybe fam_envs ty-  | let (co, ty1) = topNormaliseType_maybe fam_envs ty-                    `orElse` (mkRepReflCo ty, ty)-  , Just (tc, tc_args) <- splitTyConApp_maybe ty1-  , Just con <- tyConSingleAlgDataCon_maybe tc-  = Just DataConPatContext { dcpc_dc      = con-                           , dcpc_tc_args = tc_args-                           , dcpc_co      = co }-splitArgType_maybe _ _ = Nothing---- | If @splitResultType_maybe n ty = Just (dc, tys, co)@--- then @dc \@tys \@_ex_tys (_args::_arg_tys) :: tc tys@--- and  @co :: ty ~ tc tys@--- where underscore prefixes are holes, e.g. yet unspecified.--- @dc@ is the @n@th data constructor of @tc@.------ See Note [Which types are unboxed?].-splitResultType_maybe :: FamInstEnvs -> ConTag -> Type -> Maybe DataConPatContext-splitResultType_maybe fam_envs con_tag ty-  | let (co, ty1) = topNormaliseType_maybe fam_envs ty-                    `orElse` (mkRepReflCo ty, ty)-  , Just (tc, tc_args) <- splitTyConApp_maybe ty1-  , isDataTyCon tc -- NB: rules out unboxed sums and pairs!-  , let cons = tyConDataCons tc-  , cons `lengthAtLeast` con_tag -- This might not be true if we import the-                                 -- type constructor via a .hs-boot file (#8743)-  , let con = cons `getNth` (con_tag - fIRST_TAG)-  , null (dataConExTyCoVars con) -- no existentials;-                                 -- See Note [Which types are unboxed?]-                                 -- and GHC.Core.Opt.CprAnal.extendEnvForDataAlt-                                 -- where we also check this.-  , all isLinear (dataConInstArgTys con tc_args)-  -- Deactivates CPR worker/wrapper splits on constructors with non-linear-  -- arguments, for the moment, because they require unboxed tuple with variable-  -- multiplicity fields.-  = Just DataConPatContext { dcpc_dc = con-                           , dcpc_tc_args = tc_args-                           , dcpc_co = co }-splitResultType_maybe _ _ _ = Nothing--isLinear :: Scaled a -> Bool-isLinear (Scaled w _ ) =-  case w of-    One -> True-    _ -> False---- | Describes the outer shape of an argument to be unboxed or left as-is--- Depending on how @s@ is instantiated (e.g., 'Demand').-data UnboxingDecision s-  = StopUnboxing-  -- ^ We ran out of strictness info. Leave untouched.-  | Unbox !DataConPatContext [s]-  -- ^ The argument is used strictly or the returned product was constructed, so-  -- unbox it.-  -- The 'DataConPatContext' carries the bits necessary for-  -- instantiation with 'dataConRepInstPat'.-  -- The @[s]@ carries the bits of information with which we can continue-  -- unboxing, e.g. @s@ will be 'Demand'.--wantToUnbox :: FamInstEnvs -> Bool -> Type -> Demand -> UnboxingDecision Demand--- See Note [Which types are unboxed?]-wantToUnbox fam_envs has_inlineable_prag ty dmd =-  case splitArgType_maybe fam_envs ty of-    Just dcpc@DataConPatContext{ dcpc_dc = dc }-      | isStrUsedDmd dmd || isUnliftedType ty-      , let arity = dataConRepArity dc-      -- See Note [Unpacking arguments with product and polymorphic demands]-      , Just cs <- split_prod_dmd_arity dmd arity-      -- See Note [Do not unpack class dictionaries]-      , not (has_inlineable_prag && isClassPred ty)-      -- See Note [mkWWstr and unsafeCoerce]-      , cs `lengthIs` arity-      -- See Note [Add demands for strict constructors]-      , let cs' = addDataConStrictness dc cs-      -> Unbox dcpc cs'-    _ -> StopUnboxing-  where-    split_prod_dmd_arity dmd arity-      -- For seqDmd, it should behave like <S(AAAA)>, for some-      -- suitable arity-      | isSeqDmd dmd        = Just (replicate arity absDmd)-      | _ :* Prod ds <- dmd = Just ds-      | otherwise           = Nothing--{- Note [Which types are unboxed?]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Worker/wrapper will unbox--  1. A strict data type argument, that-       * is an algebraic data type (not a newtype)-       * has a single constructor (thus is a "product")-       * that may bind existentials-     We can transform-     > f (D @ex a b) = e-     to-     > $wf @ex a b = e-     via 'mkWWstr'.--  2. The constructed result of a function, if-       * its type is an algebraic data type (not a newtype)-       * (might have multiple constructors, in contrast to (1))-       * the applied data constructor *does not* bind existentials-     We can transform-     > f x y = let ... in D a b-     to-     > $wf x y = let ... in (# a, b #)-     via 'mkWWcpr'.--     NB: We don't allow existentials for CPR W/W, because we don't have unboxed-     dependent tuples (yet?). Otherwise, we could transform-     > f x y = let ... in D @ex (a :: ..ex..) (b :: ..ex..)-     to-     > $wf x y = let ... in (# @ex, (a :: ..ex..), (b :: ..ex..) #)--The respective tests are in 'splitArgType_maybe' and-'splitResultType_maybe', respectively.--Note that the data constructor /can/ have evidence arguments: equality-constraints, type classes etc.  So it can be GADT.  These evidence-arguments are simply value arguments, and should not get in the way.--Note [Unpacking arguments with product and polymorphic demands]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The argument is unpacked in a case if it has a product type and has a-strict *and* used demand put on it. I.e., arguments, with demands such-as the following ones:--   <S,U(U, L)>-   <S(L,S),U>--will be unpacked, but--   <S,U> or <B,U>--will not, because the pieces aren't used. This is quite important otherwise-we end up unpacking massive tuples passed to the bottoming function. Example:--        f :: ((Int,Int) -> String) -> (Int,Int) -> a-        f g pr = error (g pr)--        main = print (f fst (1, error "no"))--Does 'main' print "error 1" or "error no"?  We don't really want 'f'-to unbox its second argument.  This actually happened in GHC's onwn-source code, in Packages.applyPackageFlag, which ended up un-boxing-the enormous DynFlags tuple, and being strict in the-as-yet-un-filled-in unitState files.--Note [Do not unpack class dictionaries]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have-   f :: Ord a => [a] -> Int -> a-   {-# INLINABLE f #-}-and we worker/wrapper f, we'll get a worker with an INLINABLE pragma-(see Note [Worker-wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap),-which can still be specialised by the type-class specialiser, something like-   fw :: Ord a => [a] -> Int# -> a--BUT if f is strict in the Ord dictionary, we might unpack it, to get-   fw :: (a->a->Bool) -> [a] -> Int# -> a-and the type-class specialiser can't specialise that. An example is #6056.--But in any other situation a dictionary is just an ordinary value,-and can be unpacked.  So we track the INLINABLE pragma, and switch-off the unpacking in mkWWstr_one (see the isClassPred test).--Historical note: #14955 describes how I got this fix wrong the first time.--Note [mkWWstr and unsafeCoerce]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-By using unsafeCoerce, it is possible to make the number of demands fail to-match the number of constructor arguments; this happened in #8037.-If so, the worker/wrapper split doesn't work right and we get a Core Lint-bug.  The fix here is simply to decline to do w/w if that happens.--Note [Add demands for strict constructors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this program (due to Roman):--    data X a = X !a--    foo :: X Int -> Int -> Int-    foo (X a) n = go 0-     where-       go i | i < n     = a + go (i+1)-            | otherwise = 0--We want the worker for 'foo' too look like this:--    $wfoo :: Int# -> Int# -> Int#--with the first argument unboxed, so that it is not eval'd each time-around the 'go' loop (which would otherwise happen, since 'foo' is not-strict in 'a').  It is sound for the wrapper to pass an unboxed arg-because X is strict, so its argument must be evaluated.  And if we-*don't* pass an unboxed argument, we can't even repair it by adding a-`seq` thus:--    foo (X a) n = a `seq` go 0--because the seq is discarded (very early) since X is strict!--So here's what we do--* We leave the demand-analysis alone.  The demand on 'a' in the-  definition of 'foo' is <L, U(U)>; the strictness info is Lazy-  because foo's body may or may not evaluate 'a'; but the usage info-  says that 'a' is unpacked and its content is used.--* During worker/wrapper, if we unpack a strict constructor (as we do-  for 'foo'), we use 'addDataConStrictness' to bump up the strictness on-  the strict arguments of the data constructor.--* That in turn means that, if the usage info supports doing so-  (i.e. splitProdDmd_maybe returns Just), we will unpack that argument-  -- even though the original demand (e.g. on 'a') was lazy.--* What does "bump up the strictness" mean?  Just add a head-strict-  demand to the strictness!  Even for a demand like <L,A> we can-  safely turn it into <S,A>; remember case (1) of-  Note [How to do the worker/wrapper split].--The net effect is that the w/w transformation is more aggressive about-unpacking the strict arguments of a data constructor, when that-eagerness is supported by the usage info.--There is the usual danger of reboxing, which as usual we ignore. But-if X is monomorphic, and has an UNPACK pragma, then this optimisation-is even more important.  We don't want the wrapper to rebox an unboxed-argument, and pass an Int to $wfoo!--This works in nested situations like--    data family Bar a-    data instance Bar (a, b) = BarPair !(Bar a) !(Bar b)-    newtype instance Bar Int = Bar Int--    foo :: Bar ((Int, Int), Int) -> Int -> Int-    foo f k = case f of BarPair x y ->-              case burble of-                 True -> case x of-                           BarPair p q -> ...-                 False -> ...--The extra eagerness lets us produce a worker of type:-     $wfoo :: Int# -> Int# -> Int# -> Int -> Int-     $wfoo p# q# y# = ...--even though the `case x` is only lazily evaluated.----------- Historical note -------------We used to add data-con strictness demands when demand analysing case-expression. However, it was noticed in #15696 that this misses some cases. For-instance, consider the program (from T10482)--    data family Bar a-    data instance Bar (a, b) = BarPair !(Bar a) !(Bar b)-    newtype instance Bar Int = Bar Int--    foo :: Bar ((Int, Int), Int) -> Int -> Int-    foo f k =-      case f of-        BarPair x y -> case burble of-                          True -> case x of-                                    BarPair p q -> ...-                          False -> ...--We really should be able to assume that `p` is already evaluated since it came-from a strict field of BarPair. This strictness would allow us to produce a-worker of type:--    $wfoo :: Int# -> Int# -> Int# -> Int -> Int-    $wfoo p# q# y# = ...--even though the `case x` is only lazily evaluated--Indeed before we fixed #15696 this would happen since we would float the inner-`case x` through the `case burble` to get:--    foo f k =-      case f of-        BarPair x y -> case x of-                          BarPair p q -> case burble of-                                          True -> ...-                                          False -> ...--However, after fixing #15696 this could no longer happen (for the reasons-discussed in ticket:15696#comment:76). This means that the demand placed on `f`-would then be significantly weaker (since the False branch of the case on-`burble` is not strict in `p` or `q`).--Consequently, we now instead account for data-con strictness in mkWWstr_one,-applying the strictness demands to the final result of DmdAnal. The result is-that we get the strict demand signature we wanted even if we can't float-the case on `x` up through the case on `burble`.--}--{--************************************************************************-*                                                                      *-\subsection{Strictness stuff}-*                                                                      *-************************************************************************--}--mkWWstr :: DynFlags-        -> FamInstEnvs-        -> Bool    -- True <=> INLINEABLE pragma on this function defn-                   -- See Note [Do not unpack class dictionaries]-        -> [Var]                                -- Wrapper args; have their demand info on them-                                                --  *Includes type variables*-        -> UniqSM (Bool,                        -- Is this useful-                   [Var],                       -- Worker args-                   CoreExpr -> CoreExpr,        -- Wrapper body, lacking the worker call-                                                -- and without its lambdas-                                                -- This fn adds the unboxing--                   CoreExpr -> CoreExpr)        -- Worker body, lacking the original body of the function,-                                                -- and lacking its lambdas.-                                                -- This fn does the reboxing-mkWWstr dflags fam_envs has_inlineable_prag args-  = go args-  where-    go_one arg = mkWWstr_one dflags fam_envs has_inlineable_prag arg--    go []           = return (False, [], nop_fn, nop_fn)-    go (arg : args) = do { (useful1, args1, wrap_fn1, work_fn1) <- go_one arg-                         ; (useful2, args2, wrap_fn2, work_fn2) <- go args-                         ; return ( useful1 || useful2-                                  , args1 ++ args2-                                  , wrap_fn1 . wrap_fn2-                                  , work_fn1 . work_fn2) }--------------------------- mkWWstr_one wrap_arg = (useful, work_args, wrap_fn, work_fn)---   *  wrap_fn assumes wrap_arg is in scope,---        brings into scope work_args (via cases)---   * work_fn assumes work_args are in scope, a---        brings into scope wrap_arg (via lets)--- See Note [How to do the worker/wrapper split]-mkWWstr_one :: DynFlags -> FamInstEnvs-            -> Bool    -- True <=> INLINEABLE pragma on this function defn-                       -- See Note [Do not unpack class dictionaries]-            -> Var-            -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)-mkWWstr_one dflags fam_envs has_inlineable_prag arg-  | isTyVar arg-  = return (False, [arg],  nop_fn, nop_fn)--  | isAbsDmd dmd-  , Just work_fn <- mk_absent_let dflags arg dmd-     -- Absent case.  We can't always handle absence for rep-polymorphic-     -- types, so we need to choose just the cases we can-     -- (that's what mk_absent_let does)-  = return (True, [], nop_fn, work_fn)--  | Unbox dcpc cs <- wantToUnbox fam_envs has_inlineable_prag arg_ty dmd-  = unbox_one dflags fam_envs arg cs dcpc--  | otherwise   -- Other cases-  = return (False, [arg], nop_fn, nop_fn)--  where-    arg_ty = idType arg-    dmd    = idDemandInfo arg--unbox_one :: DynFlags -> FamInstEnvs -> Var-          -> [Demand]-          -> DataConPatContext-          -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)-unbox_one dflags fam_envs arg cs-          DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args-                            , dcpc_co = co }-  = do { (case_bndr_uniq:pat_bndrs_uniqs) <- getUniquesM-       ; let ex_name_fss     = map getOccFS $ dataConExTyCoVars dc-             (ex_tvs', arg_ids) =-               dataConRepFSInstPat (ex_name_fss ++ repeat ww_prefix) pat_bndrs_uniqs (idMult arg) dc tc_args-             arg_ids'  = zipWithEqual "unbox_one" setIdDemandInfo arg_ids cs-             unbox_fn  = mkUnpackCase (Var arg) co (idMult arg) case_bndr_uniq-                                      dc (ex_tvs' ++ arg_ids')-             arg_no_unf = zapStableUnfolding arg-                          -- See Note [Zap unfolding when beta-reducing]-                          -- in GHC.Core.Opt.Simplify; and see #13890-             rebox_fn   = Let (NonRec arg_no_unf con_app)-             con_app    = mkConApp2 dc tc_args (ex_tvs' ++ arg_ids') `mkCast` mkSymCo co-       ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False (ex_tvs' ++ arg_ids')-       ; return (True, worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) }-                          -- Don't pass the arg, rebox instead--nop_fn :: CoreExpr -> CoreExpr-nop_fn body = body--addDataConStrictness :: DataCon -> [Demand] -> [Demand]--- See Note [Add demands for strict constructors]-addDataConStrictness con ds-  | Nothing <- dataConWrapId_maybe con-  -- DataCon worker=wrapper. Implies no strict fields, so nothing to do-  = ds-addDataConStrictness con ds-  = zipWithEqual "addDataConStrictness" add ds strs-  where-    strs = dataConRepStrictness con-    add dmd str | isMarkedStrict str = strictifyDmd dmd-                | otherwise          = dmd--{- Note [How to do the worker/wrapper split]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The worker-wrapper transformation, mkWWstr_one, takes into account-several possibilities to decide if the function is worthy for-splitting:--1. If an argument is absent, it would be silly to pass it to-   the worker.  Hence the isAbsDmd case.  This case must come-   first because a demand like <S,A> or <B,A> is possible.-   E.g. <B,A> comes from a function like-       f x = error "urk"-   and <S,A> can come from Note [Add demands for strict constructors]--2. If the argument is evaluated strictly, and we can split the-   product demand (splitProdDmd_maybe), then unbox it and w/w its-   pieces.  For example--    f :: (Int, Int) -> Int-    f p = (case p of (a,b) -> a) + 1-  is split to-    f :: (Int, Int) -> Int-    f p = case p of (a,b) -> $wf a--    $wf :: Int -> Int-    $wf a = a + 1--  and-    g :: Bool -> (Int, Int) -> Int-    g c p = case p of (a,b) ->-               if c then a else b-  is split to-   g c p = case p of (a,b) -> $gw c a b-   $gw c a b = if c then a else b--2a But do /not/ split if the components are not used; that is, the-   usage is just 'Used' rather than 'UProd'. In this case-   splitProdDmd_maybe returns Nothing.  Otherwise we risk decomposing-   a massive tuple which is barely used.  Example:--        f :: ((Int,Int) -> String) -> (Int,Int) -> a-        f g pr = error (g pr)--        main = print (f fst (1, error "no"))--   Here, f does not take 'pr' apart, and it's stupid to do so.-   Imagine that it had millions of fields. This actually happened-   in GHC itself where the tuple was DynFlags--3. A plain 'seqDmd', which is head-strict with usage UHead, can't-   be split by splitProdDmd_maybe.  But we want it to behave just-   like U(AAAA) for suitable number of absent demands. So we have-   a special case for it, with arity coming from the data constructor.--Note [Worker-wrapper for bottoming functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We used not to split if the result is bottom.-[Justification:  there's no efficiency to be gained.]--But it's sometimes bad not to make a wrapper.  Consider-        fw = \x# -> let x = I# x# in case e of-                                        p1 -> error_fn x-                                        p2 -> error_fn x-                                        p3 -> the real stuff-The re-boxing code won't go away unless error_fn gets a wrapper too.-[We don't do reboxing now, but in general it's better to pass an-unboxed thing to f, and have it reboxed in the error cases....]--Note [Record evaluated-ness in worker/wrapper]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have--   data T = MkT !Int Int--   f :: T -> T-   f x = e--and f's is strict, and has the CPR property.  The we are going to generate-this w/w split--   f x = case x of-           MkT x1 x2 -> case $wf x1 x2 of-                           (# r1, r2 #) -> MkT r1 r2--   $wfw x1 x2 = let x = MkT x1 x2 in-                case e of-                  MkT r1 r2 -> (# r1, r2 #)--Note that--* In the worker $wf, inside 'e' we can be sure that x1 will be-  evaluated (it came from unpacking the argument MkT.  But that's no-  immediately apparent in $wf--* In the wrapper 'f', which we'll inline at call sites, we can be sure-  that 'r1' has been evaluated (because it came from unpacking the result-  MkT.  But that is not immediately apparent from the wrapper code.--Missing these facts isn't unsound, but it loses possible future-opportunities for optimisation.--Solution: use setCaseBndrEvald when creating- (A) The arg binders x1,x2 in mkWstr_one-         See #13077, test T13077- (B) The result binders r1,r2 in mkWWcpr_help-         See Trace #13077, test T13077a-         And #13027 comment:20, item (4)-to record that the relevant binder is evaluated.---************************************************************************-*                                                                      *-         Type scrutiny that is specific to demand analysis-*                                                                      *-************************************************************************--}--findTypeShape :: FamInstEnvs -> Type -> TypeShape--- Uncover the arrow and product shape of a type--- The data type TypeShape is defined in GHC.Types.Demand--- See Note [Trimming a demand to a type] in GHC.Core.Opt.DmdAnal-findTypeShape fam_envs ty-  = go (setRecTcMaxBound 2 initRecTc) ty-       -- You might think this bound of 2 is low, but actually-       -- I think even 1 would be fine.  This only bites for recursive-       -- product types, which are rare, and we really don't want-       -- to look deep into such products -- see #18034-  where-    go rec_tc ty-       | Just (_, _, res) <- splitFunTy_maybe ty-       = TsFun (go rec_tc res)--       | Just (tc, tc_args)  <- splitTyConApp_maybe ty-       = go_tc rec_tc tc tc_args--       | Just (_, ty') <- splitForAllTyCoVar_maybe ty-       = go rec_tc ty'--       | otherwise-       = TsUnk--    go_tc rec_tc tc tc_args-       | Just (_, rhs, _) <- topReduceTyFamApp_maybe fam_envs tc tc_args-       = go rec_tc rhs--       | Just con <- tyConSingleAlgDataCon_maybe tc-       , Just rec_tc <- if isTupleTyCon tc-                        then Just rec_tc-                        else checkRecTc rec_tc tc-         -- We treat tuples specially because they can't cause loops.-         -- Maybe we should do so in checkRecTc.-         -- The use of 'dubiousDataConInstArgTys' is OK, since this-         -- function performs no substitution at all, hence the uniques-         -- don't matter.-       = TsProd (map (go rec_tc) (dubiousDataConInstArgTys con tc_args))--       | Just (ty', _) <- instNewTyCon_maybe tc tc_args-       , Just rec_tc <- checkRecTc rec_tc tc-       = go rec_tc ty'--       | otherwise-       = TsUnk---- | Exactly 'dataConInstArgTys', but lacks the (ASSERT'ed) precondition that--- the 'DataCon' may not have existentials. The lack of cloning the existentials--- compared to 'dataConInstExAndArgVars' makes this function \"dubious\";--- only use it where type variables aren't substituted for!-dubiousDataConInstArgTys :: DataCon -> [Type] -> [Type]-dubiousDataConInstArgTys dc tc_args = arg_tys-  where-    univ_tvs = dataConUnivTyVars dc-    ex_tvs   = dataConExTyCoVars dc-    subst    = extendTCvInScopeList (zipTvSubst univ_tvs tc_args) ex_tvs-    arg_tys  = map (substTy subst . scaledThing) (dataConRepArgTys dc)--{--************************************************************************-*                                                                      *-\subsection{CPR stuff}-*                                                                      *-************************************************************************---@mkWWcpr@ takes the worker/wrapper pair produced from the strictness-info and adds in the CPR transformation.  The worker returns an-unboxed tuple containing non-CPR components.  The wrapper takes this-tuple and re-produces the correct structured output.--The non-CPR results appear ordered in the unboxed tuple as if by a-left-to-right traversal of the result structure.--}--mkWWcpr :: Bool-        -> FamInstEnvs-        -> Type                              -- function body type-        -> Cpr                               -- CPR analysis results-        -> UniqSM (Bool,                     -- Is w/w'ing useful?-                   CoreExpr -> CoreExpr,     -- New wrapper-                   CoreExpr -> CoreExpr,     -- New worker-                   Type)                     -- Type of worker's body--mkWWcpr opt_CprAnal fam_envs body_ty cpr-    -- CPR explicitly turned off (or in -O0)-  | not opt_CprAnal = return (False, id, id, body_ty)-    -- CPR is turned on by default for -O and O2-  | otherwise-  = case asConCpr cpr of-       Nothing      -> return (False, id, id, body_ty)  -- No CPR info-       Just (con_tag, _cprs)-         | Just dcpc <- splitResultType_maybe fam_envs con_tag body_ty-         -> mkWWcpr_help dcpc-         |  otherwise-         -- See Note [non-algebraic or open body type warning]-         -> WARN( True, text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty )-            return (False, id, id, body_ty)--mkWWcpr_help :: DataConPatContext-             -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)--mkWWcpr_help (DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args-                                , dcpc_co = co })-  | [arg_ty]   <- dataConInstArgTys dc tc_args -- NB: No existentials!-  , [str_mark] <- dataConRepStrictness dc-  , isUnliftedType (scaledThing arg_ty)-  , isLinear arg_ty-        -- Special case when there is a single result of unlifted, linear, type-        ---        -- Wrapper:     case (..call worker..) of x -> C x-        -- Worker:      case (   ..body..    ) of C x -> x-  = do { (work_uniq : arg_uniq : _) <- getUniquesM-       ; let arg_id    = mk_ww_local arg_uniq str_mark arg_ty-             con_app   = mkConApp2 dc tc_args [arg_id] `mkCast` mkSymCo co--       ; return ( True-                , \ wkr_call -> mkDefaultCase wkr_call arg_id con_app-                , \ body     -> mkUnpackCase body co One work_uniq dc [arg_id] (varToCoreExpr arg_id)-                                -- varToCoreExpr important here: arg can be a coercion-                                -- Lacking this caused #10658-                , scaledThing arg_ty ) }--  | otherwise   -- The general case-        -- Wrapper: case (..call worker..) of (# a, b #) -> C a b-        -- Worker:  case (   ...body...  ) of C a b -> (# a, b #)-        ---        -- Remark on linearity: in both the case of the wrapper and the worker,-        -- we build a linear case. All the multiplicity information is kept in-        -- the constructors (both C and (#, #)). In particular (#,#) is-        -- parametrised by the multiplicity of its fields. Specifically, in this-        -- instance, the multiplicity of the fields of (#,#) is chosen to be the-        -- same as those of C.-  = do { (work_uniq : wild_uniq : pat_bndrs_uniqs) <- getUniquesM-       ; let case_mult       = One -- see above-             (_exs, arg_ids) =-               dataConRepFSInstPat (repeat ww_prefix) pat_bndrs_uniqs case_mult dc tc_args-             wrap_wild       = mk_ww_local wild_uniq MarkedStrict (Scaled case_mult ubx_tup_ty)-             ubx_tup_ty      = exprType ubx_tup_app-             ubx_tup_app     = mkCoreUbxTup (map idType arg_ids) (map varToCoreExpr arg_ids)-             con_app         = mkConApp2 dc tc_args arg_ids `mkCast` mkSymCo co-             tup_con         = tupleDataCon Unboxed (length arg_ids)--       ; MASSERT( null _exs ) -- Should have been caught by splitResultType_maybe--       ; return (True-                , \ wkr_call -> mkSingleAltCase wkr_call wrap_wild-                                                (DataAlt tup_con) arg_ids con_app-                , \ body     -> mkUnpackCase body co case_mult work_uniq dc arg_ids ubx_tup_app-                , ubx_tup_ty ) }--mkUnpackCase ::  CoreExpr -> Coercion -> Mult -> Unique -> DataCon -> [Id] -> CoreExpr -> CoreExpr--- (mkUnpackCase e co uniq Con args body)---      returns--- case e |> co of bndr { Con args -> body }--mkUnpackCase (Tick tickish e) co mult uniq con args body   -- See Note [Profiling and unpacking]-  = Tick tickish (mkUnpackCase e co mult uniq con args body)-mkUnpackCase scrut co mult uniq boxing_con unpk_args body-  = mkSingleAltCase casted_scrut bndr-                    (DataAlt boxing_con) unpk_args body-  where-    casted_scrut = scrut `mkCast` co-    bndr = mk_ww_local uniq MarkedStrict (Scaled mult (exprType casted_scrut))-      -- An unpacking case can always be chosen linear, because the variables-      -- are always passed to a constructor. This limits the-{--Note [non-algebraic or open body type warning]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--There are a few cases where the W/W transformation is told that something-returns a constructor, but the type at hand doesn't really match this. One-real-world example involves unsafeCoerce:-  foo = IO a-  foo = unsafeCoerce c_exit-  foreign import ccall "c_exit" c_exit :: IO ()-Here CPR will tell you that `foo` returns a () constructor for sure, but trying-to create a worker/wrapper for type `a` obviously fails.-(This was a real example until ee8e792  in libraries/base.)--It does not seem feasible to avoid all such cases already in the analyser (and-after all, the analysis is not really wrong), so we simply do nothing here in-mkWWcpr. But we still want to emit warning with -DDEBUG, to hopefully catch-other cases where something went avoidably wrong.--This warning also triggers for the stream fusion library within `text`.-We can'easily W/W constructed results like `Stream` because we have no simple-way to express existential types in the worker's type signature.--Note [Profiling and unpacking]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If the original function looked like-        f = \ x -> {-# SCC "foo" #-} E--then we want the CPR'd worker to look like-        \ x -> {-# SCC "foo" #-} (case E of I# x -> x)-and definitely not-        \ x -> case ({-# SCC "foo" #-} E) of I# x -> x)--This transform doesn't move work or allocation-from one cost centre to another.--Later [SDM]: presumably this is because we want the simplifier to-eliminate the case, and the scc would get in the way?  I'm ok with-including the case itself in the cost centre, since it is morally-part of the function (post transformation) anyway.---************************************************************************-*                                                                      *-\subsection{Utilities}-*                                                                      *-************************************************************************--Note [Absent fillers]-~~~~~~~~~~~~~~~~~~~~~-Consider--  data T = MkT [Int] [Int] ![Int]  -- NB: last field is strict-  f :: T -> Int# -> blah-  f ps w = case ps of MkT xs ys zs -> <body mentioning xs>--Then f gets a strictness sig of <S(L,A,A)><A>. We make a worker $wf thus:--  $wf :: [Int] -> blah-  $wf xs = case ps of MkT xs _ _ -> <body mentioning xs>-    where-      ys = absentError "ys :: [Int]"-      zs = RUBBISH[LiftedRep] @[Int]-      ps = MkT xs ys zs-      w  = RUBBISH[IntRep] @Int#--The absent arguments 'ys', 'zs' and 'w' aren't even passed to the worker.-And neither should they! They are never used, their value is irrelevant (hence-they are *dead code*) and they are probably discarded after the next run of the-Simplifier (when they are in fact *unreachable code*). Yet, we have to come up-with "filler" values that we bind the absent arg Ids to.--That is exactly what Note [Rubbish literals] are for: A convenient way to-conjure filler values at any type (and any representation or levity!).--Needless to say, there are some wrinkles:--  1. In case we have a absent, /lazy/, and /lifted/ arg, we use an error-thunk-     instead. If absence analysis was wrong (e.g., #11126) and the binding-     in fact is used, then we get a nice panic message instead of undefined-     runtime behavior (See Modes of failure from Note [Rubbish literals]).--     Obviously, we can't use an error-thunk if the value is of unlifted rep-     (like 'Int#' or 'MutVar#'), because we'd immediately evaluate the panic.--  2. We also mustn't put an error-thunk (that fills in for an absent value of-     lifted rep) in a strict field, because #16970 establishes the invariant-     that strict fields are always evaluated, by (re-)evaluating what is put in-     a strict field. That's the reason why 'zs' binds a rubbish literal instead-     of an error-thunk, see #19133.--     How do we detect when we are about to put an error-thunk in a strict field?-     Ideally, we'd just look at the 'StrictnessMark' of the DataCon's field, but-     it's quite nasty to thread the marks though 'mkWWstr' and 'mkWWstr_one'.-     So we rather look out for a necessary condition for strict fields:-     Note [Add demands for strict constructors] makes it so that the demand on-     'zs' is absent and /strict/: It will get cardinality 'C_10', the empty-     interval, rather than 'C_00'. Hence the 'isStrictDmd' check: It guarantees-     we never fill in an error-thunk for an absent strict field.-     But that also means we emit a rubbish lit for other args that have-     cardinality 'C_10' (say, the arg to a bottoming function) where we could've-     used an error-thunk, but that's a small price to pay for simplicity.--  3. We can only emit a RubbishLit if the arg's type @arg_ty@ is mono-rep, e.g.-     of the form @TYPE rep@ where @rep@ is not (and doesn't contain) a variable.-     Why? Because if we don't know its representation (e.g. size in memory,-     register class), we don't know what or how much rubbish to emit in codegen.-     'typeMonoPrimRep_maybe' returns 'Nothing' in this case and we simply fall-     back to passing the original parameter to the worker.--     Note that currently this case should not occur, because binders always-     have to be representation monomorphic. But in the future, we might allow-     levity polymorphism, e.g. a polymorphic levity variable in 'BoxedRep'.--While (1) and (2) are simply an optimisation in terms of compiler debugging-experience, (3) should be irrelevant in most programs, if not all.--Historical note: I did try the experiment of using an error thunk for unlifted-things too, relying on the simplifier to drop it as dead code.  But this is-fragile-- - It fails when profiling is on, which disables various optimisations-- - It fails when reboxing happens. E.g.-      data T = MkT Int Int#-      f p@(MkT a _) = ...g p....-   where g is /lazy/ in 'p', but only uses the first component.  Then-   'f' is /strict/ in 'p', and only uses the first component.  So we only-   pass that component to the worker for 'f', which reconstructs 'p' to-   pass it to 'g'.  Alas we can't say-       ...f (MkT a (absentError Int# "blah"))...-   because `MkT` is strict in its Int# argument, so we get an absentError-   exception when we shouldn't.  Very annoying!--}---- | Tries to find a suitable dummy RHS to bind the given absent identifier to.------ If @mk_absent_let _ id == Just wrap@, then @wrap e@ will wrap a let binding--- for @id@ with that RHS around @e@. Otherwise, there could no suitable RHS be--- found.-mk_absent_let :: DynFlags -> Id -> Demand -> Maybe (CoreExpr -> CoreExpr)-mk_absent_let dflags arg dmd-  -- The lifted case: Bind 'absentError' for a nice panic message if we are-  -- wrong (like we were in #11126). See (1) in Note [Absent fillers]-  | not (isUnliftedType arg_ty)-  , not (isStrictDmd dmd) -- See (2) in Note [Absent fillers]-  = Just (Let (NonRec arg panic_rhs))--  -- The default case for mono rep: Bind `RUBBISH[rr] \@arg_ty`-  -- See Note [Absent fillers], the main part-  | Just lit_expr <- mkLitRubbish arg_ty-  = Just (bindNonRec arg lit_expr)--  -- Catch all: Either @arg_ty@ wasn't of form @TYPE rep@ or @rep@ wasn't mono rep.-  -- See (3) in Note [Absent fillers]-  | otherwise-  = WARN( True, text "No absent value for" <+> ppr arg_ty )-    Nothing-  where-    arg_ty            = idType arg--    panic_rhs = mkAbsentErrorApp arg_ty msg--    msg       = showSDoc (gopt_set dflags Opt_SuppressUniques)-                         (vcat-                           [ text "Arg:" <+> ppr arg-                           , text "Type:" <+> ppr arg_ty-                           , file_msg-                           ])-              -- We need to suppress uniques here because otherwise they'd-              -- end up in the generated code as strings. This is bad for-              -- determinism, because with different uniques the strings-              -- will have different lengths and hence different costs for-              -- the inliner leading to different inlining.-              -- See also Note [Unique Determinism] in GHC.Types.Unique-    file_msg  = case outputFile dflags of-                  Nothing -> empty-                  Just f  -> text "In output file " <+> quotes (text f)--ww_prefix :: FastString-ww_prefix = fsLit "ww"--mk_ww_local :: Unique -> StrictnessMark -> Scaled Type -> Id--- The StrictnessMark comes form the data constructor and says--- whether this field is strict--- See Note [Record evaluated-ness in worker/wrapper]-mk_ww_local uniq str (Scaled w ty)-  = setCaseBndrEvald str $-    mkSysLocalOrCoVar ww_prefix uniq w ty++{-# LANGUAGE ViewPatterns #-}++module GHC.Core.Opt.WorkWrap.Utils+   ( WwOpts(..), initWwOpts, mkWwBodies, mkWWstr, mkWWstr_one+   , needsVoidWorkerArg, addVoidWorkerArg+   , DataConPatContext(..)+   , UnboxingDecision(..), wantToUnboxArg+   , findTypeShape, IsRecDataConResult(..), isRecDataCon+   , mkAbsentFiller+   , isWorkerSmallEnough, dubiousDataConInstArgTys+   , isGoodWorker, badWorker , goodWorker+   )+where++import GHC.Prelude++import GHC.Driver.Session+import GHC.Driver.Config (initSimpleOpts)++import GHC.Core+import GHC.Core.Utils+import GHC.Core.DataCon+import GHC.Core.Make+import GHC.Core.Subst+import GHC.Core.Type+import GHC.Core.Multiplicity+import GHC.Core.Coercion+import GHC.Core.Reduction+import GHC.Core.FamInstEnv+import GHC.Core.TyCon+import GHC.Core.TyCon.Set+import GHC.Core.TyCon.RecWalk+import GHC.Core.SimpleOpt( SimpleOpts )++import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Demand+import GHC.Types.Cpr+import GHC.Types.Id.Make ( voidArgId, voidPrimId )+import GHC.Types.Var.Env+import GHC.Types.Basic+import GHC.Types.Unique.Supply+import GHC.Types.Name ( getOccFS )++import GHC.Data.FastString+import GHC.Data.OrdList+import GHC.Data.List.SetOps++import GHC.Builtin.Types ( tupleDataCon )++import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Utils.Trace++import Control.Applicative ( (<|>) )+import Control.Monad ( zipWithM )+import Data.List ( unzip4 )++import GHC.Types.RepType+import GHC.Unit.Types++{-+************************************************************************+*                                                                      *+\subsection[mkWrapperAndWorker]{@mkWrapperAndWorker@}+*                                                                      *+************************************************************************++Here's an example.  The original function is:++\begin{verbatim}+g :: forall a . Int -> [a] -> a++g = \/\ a -> \ x ys ->+        case x of+          0 -> head ys+          _ -> head (tail ys)+\end{verbatim}++From this, we want to produce:+\begin{verbatim}+-- wrapper (an unfolding)+g :: forall a . Int -> [a] -> a++g = \/\ a -> \ x ys ->+        case x of+          I# x# -> $wg a x# ys+            -- call the worker; don't forget the type args!++-- worker+$wg :: forall a . Int# -> [a] -> a++$wg = \/\ a -> \ x# ys ->+        let+            x = I# x#+        in+            case x of               -- note: body of g moved intact+              0 -> head ys+              _ -> head (tail ys)+\end{verbatim}++Something we have to be careful about:  Here's an example:++\begin{verbatim}+-- "f" strictness: U(P)U(P)+f (I# a) (I# b) = a +# b++g = f   -- "g" strictness same as "f"+\end{verbatim}++\tr{f} will get a worker all nice and friendly-like; that's good.+{\em But we don't want a worker for \tr{g}}, even though it has the+same strictness as \tr{f}.  Doing so could break laziness, at best.++Consequently, we insist that the number of strictness-info items is+exactly the same as the number of lambda-bound arguments.  (This is+probably slightly paranoid, but OK in practice.)  If it isn't the+same, we ``revise'' the strictness info, so that we won't propagate+the unusable strictness-info into the interfaces.+++************************************************************************+*                                                                      *+\subsection{The worker wrapper core}+*                                                                      *+************************************************************************++@mkWwBodies@ is called when doing the worker\/wrapper split inside a module.+-}++data WwOpts+  = MkWwOpts+  { wo_fam_envs          :: !FamInstEnvs+  , wo_simple_opts       :: !SimpleOpts+  , wo_cpr_anal          :: !Bool++  -- Used for absent argument error message+  , wo_module            :: !Module+  , wo_unlift_strict     :: !Bool -- Generate workers even if the only effect is some args+                                  -- get passed unlifted.+                                  -- See Note [WW for calling convention]+  }++initWwOpts :: Module -> DynFlags -> FamInstEnvs -> WwOpts+initWwOpts this_mod dflags fam_envs = MkWwOpts+  { wo_fam_envs          = fam_envs+  , wo_simple_opts       = initSimpleOpts dflags+  , wo_cpr_anal          = gopt Opt_CprAnal dflags+  , wo_module            = this_mod+  , wo_unlift_strict     = gopt Opt_WorkerWrapperUnlift dflags+  }++type WwResult+  = ([Demand],              -- Demands for worker (value) args+     JoinArity,             -- Number of worker (type OR value) args+     Id -> CoreExpr,        -- Wrapper body, lacking only the worker Id+     CoreExpr -> CoreExpr)  -- Worker body, lacking the original function rhs++nop_fn :: CoreExpr -> CoreExpr+nop_fn body = body+++mkWwBodies :: WwOpts+           -> Id             -- ^ The original function+           -> [Var]          -- ^ Manifest args of original function+           -> Type           -- ^ Result type of the original function,+                             --   after being stripped of args+           -> [Demand]       -- ^ Strictness of original function+           -> Cpr            -- ^ Info about function result+           -> UniqSM (Maybe WwResult)+-- ^ Given a function definition+--+-- > data T = MkT Int Bool Char+-- > f :: (a, b) -> Int -> T+-- > f = \x y -> E+--+-- @mkWwBodies _ 'f' ['x::(a,b)','y::Int'] '(a,b)' ['1P(L,L)', '1P(L)'] '1'@+-- returns+--+--   * The wrapper body context for the call to the worker function, lacking+--     only the 'Id' for the worker function:+--+--     > W[_] :: Id -> CoreExpr+--     > W[work_fn] = \x y ->          -- args of the wrapper    (cloned_arg_vars)+--     >   case x of (a, b) ->         -- unbox wrapper args     (wrap_fn_str)+--     >   case y of I# n ->           --+--     >   case <work_fn> a b n of     -- call to the worker fun (call_work)+--     >   (# i, b, c #) -> MkT i b c  -- rebox result           (wrap_fn_cpr)+--+--   * The worker body context that wraps around its hole reboxing defns for x+--     and y, as well as returning CPR transit variables of the unboxed MkT+--     result in an unboxed tuple:+--+--     > w[_] :: CoreExpr -> CoreExpr+--     > w[fn_rhs] = \a b n ->              -- args of the worker       (work_lam_args)+--     >   let { y = I# n; x = (a, b) } in  -- reboxing wrapper args    (work_fn_str)+--     >   case <fn_rhs> x y of             -- call to the original RHS (call_rhs)+--     >   MkT i b c -> (# i, b, c #)       -- return CPR transit vars  (work_fn_cpr)+--+--     NB: The wrap_rhs hole is to be filled with the original wrapper RHS+--     @\x y -> E@. This is so that we can also use @w@ to transform stable+--     unfoldings, the lambda args of which may be different than x and y.+--+--   * Id details for the worker function like demands on arguments and its join+--     arity.+--+-- All without looking at E (except for beta reduction, see Note [Join points+-- and beta-redexes]), which allows us to apply the same split to function body+-- and its unfolding(s) alike.+--+mkWwBodies opts fun_id arg_vars res_ty demands res_cpr+  = do  { massertPpr (filter isId arg_vars `equalLength` demands)+                     (text "wrong wrapper arity" $$ ppr fun_id $$ ppr arg_vars $$ ppr res_ty $$ ppr demands)++        -- Clone and prepare arg_vars of the original fun RHS+        -- See Note [Freshen WW arguments]+        -- and Note [Zap IdInfo on worker args]+        ; uniq_supply <- getUniqueSupplyM+        ; let args_free_tcvs = tyCoVarsOfTypes (res_ty : map varType arg_vars)+              empty_subst = mkEmptySubst (mkInScopeSet args_free_tcvs)+              zapped_arg_vars = map zap_var arg_vars+              (subst, cloned_arg_vars) = cloneBndrs empty_subst uniq_supply zapped_arg_vars+              res_ty' = GHC.Core.Subst.substTy subst res_ty+              init_cbv_marks = map (const NotMarkedStrict) cloned_arg_vars++        ; (useful1, work_args_cbv, wrap_fn_str, fn_args)+             <- mkWWstr opts cloned_arg_vars init_cbv_marks++        ; let (work_args, work_marks) = unzip work_args_cbv++        -- Do CPR w/w.  See Note [Always do CPR w/w]+        ; (useful2, wrap_fn_cpr, work_fn_cpr)+              <- mkWWcpr_entry opts res_ty' res_cpr++        ; let (work_lam_args, work_call_args, work_call_cbv)+                | needsVoidWorkerArg fun_id arg_vars work_args+                = addVoidWorkerArg work_args work_marks+                | otherwise+                = (work_args, work_args, work_marks)++              call_work work_fn  = mkVarApps (Var work_fn) work_call_args+              call_rhs fn_rhs = mkAppsBeta fn_rhs fn_args+                                  -- See Note [Join points and beta-redexes]+              wrapper_body = mkLams cloned_arg_vars . wrap_fn_cpr . wrap_fn_str . call_work+                                  -- See Note [Call-by-value for worker args]+              work_seq_str_flds = mkStrictFieldSeqs (zip work_lam_args work_call_cbv)+              worker_body = mkLams work_lam_args . work_seq_str_flds . work_fn_cpr . call_rhs+              worker_args_dmds= [(idDemandInfo v) | v <- work_call_args, isId v]++        ; if ((useful1 && not only_one_void_argument) || useful2)+          then return (Just (worker_args_dmds, length work_call_args,+                       wrapper_body, worker_body))+          else return Nothing+        }+        -- We use an INLINE unconditionally, even if the wrapper turns out to be+        -- something trivial like+        --      fw = ...+        --      f = __inline__ (coerce T fw)+        -- The point is to propagate the coerce to f's call sites, so even though+        -- f's RHS is now trivial (size 1) we still want the __inline__ to prevent+        -- fw from being inlined into f's RHS+  where+    zap_var v | isTyVar v = v+              | otherwise = modifyIdInfo zap_info v+    zap_info info -- See Note [Zap IdInfo on worker args]+      = info `setOccInfo`       noOccInfo++    -- Note [Do not split void functions]+    only_one_void_argument+      | [d] <- demands+      , [v] <- filter isId arg_vars+      , isAbsDmd d && isZeroBitTy (idType v)+      = True+      | otherwise+      = False++-- | Version of 'GHC.Core.mkApps' that does beta reduction on-the-fly.+-- PRECONDITION: The arg expressions are not free in any of the lambdas binders.+mkAppsBeta :: CoreExpr -> [CoreArg] -> CoreExpr+-- The precondition holds for our call site in mkWwBodies, because all the FVs+-- of as are either cloned_arg_vars (and thus fresh) or fresh worker args.+mkAppsBeta (Lam b body) (a:as) = bindNonRec b a $! mkAppsBeta body as+mkAppsBeta f            as     = mkApps f as++-- See Note [Limit w/w arity]+isWorkerSmallEnough :: Int -> Int -> [Var] -> Bool+isWorkerSmallEnough max_worker_args old_n_args vars+  = count isId vars <= max old_n_args max_worker_args+    -- We count only Free variables (isId) to skip Type, Kind+    -- variables which have no runtime representation.+    -- Also if the function took 82 arguments before (old_n_args), it's fine if+    -- it takes <= 82 arguments afterwards.++{-+Note [Always do CPR w/w]+~~~~~~~~~~~~~~~~~~~~~~~~+At one time we refrained from doing CPR w/w for thunks, on the grounds that+we might duplicate work.  But that is already handled by the demand analyser,+which doesn't give the CPR property if w/w might waste work: see+Note [CPR for thunks] in GHC.Core.Opt.DmdAnal.++And if something *has* been given the CPR property and we don't w/w, it's+a disaster, because then the enclosing function might say it has the CPR+property, but now doesn't and there a cascade of disaster.  A good example+is #5920.++Note [Limit w/w arity]+~~~~~~~~~~~~~~~~~~~~~~~~+Guard against high worker arity as it generates a lot of stack traffic.+A simplified example is #11565#comment:6++Current strategy is very simple: don't perform w/w transformation at all+if the result produces a wrapper with arity higher than -fmax-worker-args+and the number arguments before w/w (see #18122).++It is a bit all or nothing, consider++        f (x,y) (a,b,c,d,e ... , z) = rhs++Currently we will remove all w/w ness entirely. But actually we could+w/w on the (x,y) pair... it's the huge product that is the problem.++Could we instead refrain from w/w on an arg-by-arg basis? Yes, that'd+solve f. But we can get a lot of args from deeply-nested products:++        g (a, (b, (c, (d, ...)))) = rhs++This is harder to spot on an arg-by-arg basis. Previously mkWwStr was+given some "fuel" saying how many arguments it could add; when we ran+out of fuel it would stop w/wing.++Still not very clever because it had a left-right bias.++Note [Zap IdInfo on worker args]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We have to zap the following IdInfo when re-using arg variables of the original+function for the worker:++  * OccInfo: Dead wrapper args now occur in Apps of the worker's call to the+    original fun body. Those occurrences will quickly cancel away with the lambdas+    of the fun body in the next run of the Simplifier, but CoreLint will complain+    in the meantime, so zap it.++We zap in mkWwBodies because we need the zapped variables when binding them in+mkWWstr (mkAbsentFiller, specifically).++Note [Do not split void functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this rather common form of binding:+        $j = \x:Void# -> ...no use of x...++Since x is not used it'll be marked as absent.  But there is no point+in w/w-ing because we'll simply add (\y:Void#), see addVoidWorkerArg.++If x has a more interesting type (eg Int, or Int#), there *is* a point+in w/w so that we don't pass the argument at all.++************************************************************************+*                                                                      *+\subsection{Making wrapper args}+*                                                                      *+************************************************************************++During worker-wrapper stuff we may end up with an unlifted thing+which we want to let-bind without losing laziness.  So we+add a void argument.  E.g.++        f = /\a -> \x y z -> E::Int#    -- E does not mention x,y,z+==>+        fw = /\ a -> \void -> E+        f  = /\ a -> \x y z -> fw realworld++We use the state-token type which generates no code.+-}++-- | Whether the worker needs an additional `Void#` arg as per+-- Note [Protecting the last value argument] or+-- Note [Preserving float barriers].+needsVoidWorkerArg :: Id -> [Var] -> [Var] -> Bool+needsVoidWorkerArg fn_id wrap_args work_args+  =  not (isJoinId fn_id) && no_value_arg -- See Note [Protecting the last value argument]+  || needs_float_barrier                  -- See Note [Preserving float barriers]+  where+    no_value_arg        = all (not . isId) work_args+    is_float_barrier v  = isId v && hasNoOneShotInfo (idOneShotInfo v)+    wrap_had_barrier    = any is_float_barrier wrap_args+    work_has_barrier    = any is_float_barrier work_args+    needs_float_barrier = wrap_had_barrier && not work_has_barrier++-- | Inserts a `Void#` arg before the first argument.+--+-- Why as the first argument? See Note [SpecConst needs to add void args first]+-- in SpecConstr.+addVoidWorkerArg :: [Var] -> [StrictnessMark]+                 -> ([Var],     -- Lambda bound args+                     [Var],     -- Args at call site+                     [StrictnessMark]) -- cbv semantics for the worker args.+addVoidWorkerArg work_args cbv_marks+  = (voidArgId : work_args, voidPrimId:work_args, NotMarkedStrict:cbv_marks)++{-+Note [Protecting the last value argument]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If the user writes (\_ -> E), they might be intentionally disallowing+the sharing of E. Since absence analysis and worker-wrapper are keen+to remove such unused arguments, we add in a void argument to prevent+the function from becoming a thunk.  Three reasons why turning a function+into a thunk might be bad:++1) It can create a space leak. e.g.+      f x = let y () = [1..x]+            in (sum (y ()) + length (y ()))+   As written it'll calculate [1..x] twice, and avoid keeping a big+   list around.  (Of course let-floating may introduce the leak; but+   at least w/w doesn't.)++2) It can prevent inlining *under a lambda*. e.g.+       g = \y. [1..100]+       f = \t. g ()+   Here we can inline g under the \t.  But we won't if we remove the \y.++3) It can create an unlifted binding.  E.g.+       g :: Int -> Int#+       g = \x. 30#+   Removing the \x would leave an unlifted binding.++NB: none of these apply to a join point.++Note [Preserving float barriers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+```+let+  t = sum [0..x]+  f a{os} b[Dmd=A] c{os} = ... t ...+in f 1 2 3 + f 4 5 6+```+Here, we would like to drop the argument `b` because it's absent. But doing so+leaves behind only one-shot lambdas, `$wf a{os} c{os} = ...`, and then the+Simplifier will inline `t` into `$wf`, because `$wf` says "I'm only called+once". That's bad, because we lost sharing of `t`! Similarly, FloatIn would+happily float `t` into `$wf`, see Note [Floating in past a lambda group].++Why does floating happen after dropping `b` but not before? Because `b` was the+only non-one-shot value lambda left, acting as our "float barrier".++Definition:  A float barrier is a non-one-shot value lambda.+Key insight: If `f` had a float barrier, `$wf` has to have one, too.++To this end, in `needsVoidWorkerArg`, we check whether the wrapper had a float+barrier and if the worker has none so far. If that is the case, we add a `Void#`+argument at the end as an artificial float barrier.++The issue is tracked in #21150. It came up when compiling GHC itself, in+GHC.Tc.Gen.Bind.mkEdges. There the key_map thunk was inlined after WW dropped a+leading absent non-one-shot arg. Here are some example wrapper arguments of+which some are absent or one-shot and the resulting worker arguments:++  * \a{Abs}.\b{os}.\c{os}... ==> \b{os}.\c{os}.\(_::Void#)...+    Wrapper arg `a` was the only float barrier and had been dropped. Hence Void#+  * \a{Abs,os}.\b{os}.\c... ==> \b{os}.\c...+    Worker arg `c` is a float barrier.+  * \a.\b{Abs}.\c{os}... ==> \a.\c{os}...+    Worker arg `a` is a float barrier.+  * \a{os}.\b{Abs,os}.\c{os}... ==> \a{os}.\c{os}...+    Wrapper didn't have a float barrier, no need for Void#.+  * \a{Abs,os}.... ==> ... (no value lambda left)+    This examples simply demonstrates that preserving float barriers is not+    enough to subsume Note [Protecting the last value argument].++Executable examples in T21150.++Note [Join points and beta-redexes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Originally, the worker would invoke the original function by calling it with+arguments, thus producing a beta-redex for the simplifier to munch away:++  \x y z -> e => (\x y z -> e) wx wy wz++Now that we have special rules about join points, however, this is Not Good if+the original function is itself a join point, as then it may contain invocations+of other join points:++  join j1 x = ...+  join j2 y = if y == 0 then 0 else j1 y++  =>++  join j1 x = ...+  join $wj2 y# = let wy = I# y# in (\y -> if y == 0 then 0 else jump j1 y) wy+  join j2 y = case y of I# y# -> jump $wj2 y#++There can't be an intervening lambda between a join point's declaration and its+occurrences, so $wj2 here is wrong. But of course, this is easy enough to fix:++  ...+  let join $wj2 y# = let wy = I# y# in let y = wy in if y == 0 then 0 else j1 y+  ...++Hence we simply do the beta-reduction here. (This would be harder if we had to+worry about hygiene, but luckily wy is freshly generated.)++Note [Freshen WW arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we do a worker/wrapper split, we must freshen the arg vars of the original+fun RHS because they might shadow each other. E.g.++  f :: forall a. Maybe a -> forall a. Maybe a -> Int -> Int+  f @a x @a y z = case x <|> y of+    Nothing -> z+    Just _  -> z + 1++  ==> {WW split unboxing the Int}++  $wf :: forall a. Maybe a -> forall a. Maybe a -> Int# -> Int+  $wf @a x @a y wz = (\@a x @a y z -> case x <|> y of ...) ??? x @a y (I# wz)++(Notice that the code we actually emit will sort-of ANF-ise the lambda args,+leading to even more shadowing issues. The above demonstrates that even if we+try harder we'll still get shadowing issues.)++What should we put in place for ??? ? Certainly not @a, because that would+reference the wrong, inner a. A similar situation occurred in #12562, we even+saw a type variable in the worker shadowing an outer term-variable binding.++We avoid the issue by freshening the argument variables from the original fun+RHS through 'cloneBndrs', which will also take care of subsitution in binder+types. Fortunately, it's sufficient to pick the FVs of the arg vars as in-scope+set, so that we don't need to do a FV traversal over the whole body of the+original function.++At the moment, #12562 has no regression test. As such, this Note is not covered+by any test logic or when bootstrapping the compiler. Yet we clearly want to+freshen the binders, as the example above demonstrates.+Adding a Core pass that maximises shadowing for testing purposes might help,+see #17478.+-}++{-+************************************************************************+*                                                                      *+\subsection{Unboxing Decision for Strictness and CPR}+*                                                                      *+************************************************************************+-}++-- | The information needed to build a pattern for a DataCon to be unboxed.+-- The pattern can be generated from 'dcpc_dc' and 'dcpc_tc_args' via+-- 'GHC.Core.Utils.dataConRepInstPat'. The coercion 'dcpc_co' is for newtype+-- wrappers.+--+-- If we get @DataConPatContext dc tys co@ for some type @ty@+-- and @dataConRepInstPat ... dc tys = (exs, flds)@, then+--+--   * @dc @exs flds :: T tys@+--   * @co :: T tys ~ ty@+data DataConPatContext+  = DataConPatContext+  { dcpc_dc      :: !DataCon+  , dcpc_tc_args :: ![Type]+  , dcpc_co      :: !Coercion+  }++-- | Describes the outer shape of an argument to be unboxed or left as-is+-- Depending on how @s@ is instantiated (e.g., 'Demand' or 'Cpr').+data UnboxingDecision s+  = StopUnboxing+  -- ^ We ran out of strictness info. Leave untouched.+  | DropAbsent+  -- ^ The argument/field was absent. Drop it.+  | Unbox !DataConPatContext [s]+  -- ^ The argument is used strictly or the returned product was constructed, so+  -- unbox it.+  -- The 'DataConPatContext' carries the bits necessary for+  -- instantiation with 'dataConRepInstPat'.+  -- The @[s]@ carries the bits of information with which we can continue+  -- unboxing, e.g. @s@ will be 'Demand' or 'Cpr'.+  | Unlift+  -- ^ The argument can't be unboxed, but we want it to be passed evaluated to the worker.++-- Do we want to create workers just for unlifting?+wwForUnlifting :: WwOpts -> Bool+wwForUnlifting !opts+    -- Always unlift if possible+    | wo_unlift_strict opts = goodWorker+    -- Don't unlift  it would cause additional W/W splits.+    | otherwise = badWorker++badWorker :: Bool+badWorker = False++goodWorker :: Bool+goodWorker = True++isGoodWorker :: Bool -> Bool+isGoodWorker = id+++-- | Unwraps the 'Boxity' decision encoded in the given 'SubDemand' and returns+-- a 'DataConPatContext' as well the nested demands on fields of the 'DataCon'+-- to unbox.+wantToUnboxArg+  :: Bool                -- ^ Consider unlifting+  -> FamInstEnvs+  -> Type                -- ^ Type of the argument+  -> Demand              -- ^ How the arg was used+  -> UnboxingDecision Demand+-- See Note [Which types are unboxed?]+wantToUnboxArg do_unlifting fam_envs ty dmd@(n :* sd)+  | isAbs n+  = DropAbsent++  | Just (tc, tc_args, co) <- normSplitTyConApp_maybe fam_envs ty+  , Just dc <- tyConSingleAlgDataCon_maybe tc+  , let arity = dataConRepArity dc+  , Just (Unboxed, ds) <- viewProd arity sd -- See Note [Boxity analysis]+  -- NB: No strictness or evaluatedness checks for unboxing here.+  -- That is done by 'finaliseArgBoxities'!+  = Unbox (DataConPatContext dc tc_args co) ds++  -- See Note [CBV Function Ids]+  | do_unlifting+  , isStrUsedDmd dmd+  , not (isFunTy ty)+  , not (isUnliftedType ty) -- Already unlifted!+    -- NB: function arguments have a fixed RuntimeRep, so it's OK to call isUnliftedType here+  = Unlift++  | otherwise+  = StopUnboxing+++-- | Unboxing strategy for constructed results.+wantToUnboxResult :: FamInstEnvs -> Type -> Cpr -> UnboxingDecision Cpr+-- See Note [Which types are unboxed?]+wantToUnboxResult fam_envs ty cpr+  | Just (con_tag, arg_cprs) <- asConCpr cpr+  , Just (tc, tc_args, co) <- normSplitTyConApp_maybe fam_envs ty+  , Just dcs <- tyConAlgDataCons_maybe tc <|> open_body_ty_warning+  , dcs `lengthAtLeast` con_tag -- This might not be true if we import the+                                -- type constructor via a .hs-boot file (#8743)+  , let dc = dcs `getNth` (con_tag - fIRST_TAG)+  , null (dataConExTyCoVars dc) -- no existentials;+                                -- See Note [Which types are unboxed?]+                                -- and GHC.Core.Opt.CprAnal.argCprType+                                -- where we also check this.+  , all isLinear (dataConInstArgTys dc tc_args)+  -- Deactivates CPR worker/wrapper splits on constructors with non-linear+  -- arguments, for the moment, because they require unboxed tuple with variable+  -- multiplicity fields.+  = Unbox (DataConPatContext dc tc_args co) arg_cprs++  | otherwise+  = StopUnboxing++  where+    -- See Note [non-algebraic or open body type warning]+    open_body_ty_warning = warnPprTrace True "wantToUnboxResult: non-algebraic or open body type" (ppr ty) Nothing++isLinear :: Scaled a -> Bool+isLinear (Scaled w _ ) =+  case w of+    One -> True+    _ -> False+++{- Note [Which types are unboxed?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Worker/wrapper will unbox++  1. A strict data type argument, that+       * is an algebraic data type (not a newtype)+       * is not recursive (as per 'isRecDataCon')+       * has a single constructor (thus is a "product")+       * that may bind existentials+     We can transform+     > data D a = forall b. D a b+     > f (D @ex a b) = e+     to+     > $wf @ex a b = e+     via 'mkWWstr'.++  2. The constructed result of a function, if+       * its type is an algebraic data type (not a newtype)+       * is not recursive (as per 'isRecDataCon')+       * (might have multiple constructors, in contrast to (1))+       * the applied data constructor *does not* bind existentials+     We can transform+     > f x y = let ... in D a b+     to+     > $wf x y = let ... in (# a, b #)+     via 'mkWWcpr'.++     NB: We don't allow existentials for CPR W/W, because we don't have unboxed+     dependent tuples (yet?). Otherwise, we could transform+     > f x y = let ... in D @ex (a :: ..ex..) (b :: ..ex..)+     to+     > $wf x y = let ... in (# @ex, (a :: ..ex..), (b :: ..ex..) #)++The respective tests are in 'wantToUnboxArg' and+'wantToUnboxResult', respectively.++Note that the data constructor /can/ have evidence arguments: equality+constraints, type classes etc.  So it can be GADT.  These evidence+arguments are simply value arguments, and should not get in the way.++Note [mkWWstr and unsafeCoerce]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+By using unsafeCoerce, it is possible to make the number of demands fail to+match the number of constructor arguments; this happened in #8037.+If so, the worker/wrapper split doesn't work right and we get a Core Lint+bug.  The fix here is simply to decline to do w/w if that happens.++Note [non-algebraic or open body type warning]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are a few cases where the W/W transformation is told that something+returns a constructor, but the type at hand doesn't really match this. One+real-world example involves unsafeCoerce:+  foo = IO a+  foo = unsafeCoerce c_exit+  foreign import ccall "c_exit" c_exit :: IO ()+Here CPR will tell you that `foo` returns a () constructor for sure, but trying+to create a worker/wrapper for type `a` obviously fails.+(This was a real example until ee8e792  in libraries/base.)++It does not seem feasible to avoid all such cases already in the analyser (and+after all, the analysis is not really wrong), so we simply do nothing here in+mkWWcpr. But we still want to emit warning with -DDEBUG, to hopefully catch+other cases where something went avoidably wrong.++This warning also triggers for the stream fusion library within `text`.+We can'easily W/W constructed results like `Stream` because we have no simple+way to express existential types in the worker's type signature.++Note [WW for calling convention]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we know a function f will always evaluate a particular argument+we might decide that it should rather get evaluated by the caller.+We call this "unlifting" the argument.+Sometimes the caller knows that the argument is already evaluated,+so we won't generate any code to enter/evaluate the argument.+This evaluation avoidance can be quite beneficial.+Especially for recursive functions who pass the same lifted argument+along on each iteration or walk over strict data structures.++One way to achieve this is to do a W/W split, where the wrapper does+the evaluation, and the worker can treat its arguments as unlifted.+The wrapper is small and will be inlined at almost all call sites and+the evaluation code in the wrapper can then cancel out with evaluation+done by the calling context if the argument is evaluated there.+Same idea as W/W to avoid allocation really, just for a different kind+of work.++Performing W/W might not always be a win. In particular it's easy to break+(badly written, but common) rule frameworks by doing additional W/W splits.+See #20364 for a more detailed explaination.++Hence we have the following strategies with different trade-offs:+A) Never do W/W *just* for unlifting of arguments.+  + Very conservative - doesn't break any rules+  - Lot's of performance left on the table+B) Do W/W on just about anything where it might be+  beneficial.+  + Exploits pretty much every oppertunity for unlifting.+  - A bit of compile time/code size cost for all the wrappers.+  - Can break rules which would otherwise fire. See #20364.+C) Unlift *any* (non-boot exported) functions arguments if they are strict.+  That is instead of creating a Worker with the new calling convention we+  change the calling convention of the binding itself.+  + Exploits every opportunity for unlifting.+  + Maybe less bad interactions with rules.+  - Requires tracking of boot-exported definitions.+  - Requires either:+    ~ Eta-expansion at *all* call sites in order to generate+      an impedance matcher function. Leading to massive code bloat.+      Essentially we end up creating a imprompto wrapper function+      wherever we wouldn't inline the wrapper with a W/W approach.+    ~ There is the option of achieving this without eta-expansion if we instead expand+      the partial application code to check for demands on the calling convention and+      for it to evaluate the arguments. The main downsides there would be the complexity+      of the implementation and that it carries a certain overhead even for functions who+      don't take advantage of this functionality. I haven't tried this approach because it's+      not trivial to implement and doing W/W splits seems to work well enough.++Currently we use the first approach A) by default, with a flag that allows users to fall back to the+more aggressive approach B).+I also tried the third approach C) using eta-expansion at call sites to avoid modifying the PAP-handling+code which wasn't fruitful. See https://gitlab.haskell.org/ghc/ghc/-/merge_requests/5614#note_389903.+We could still try to do C) in the future by having PAP calls which will evaluate the required arguments+before calling the partially applied function. But this would be neither a small nor simple change so we+stick with A) and a flag for B) for now.+See also Note [Tag Inference] and Note [CBV Function Ids]+-}++{-+************************************************************************+*                                                                      *+\subsection{Worker/wrapper for Strictness and Absence}+*                                                                      *+************************************************************************+-}++mkWWstr :: WwOpts+        -> [Var]                         -- Wrapper args; have their demand info on them+                                         --  *Includes type variables*+        -> [StrictnessMark]                     -- cbv info for arguments+        -> UniqSM (Bool,                 -- Will this result in a useful worker+                   [(Var,StrictnessMark)],      -- Worker args/their call-by-value semantics.+                   CoreExpr -> CoreExpr, -- Wrapper body, lacking the worker call+                                         -- and without its lambdas+                                         -- This fn adds the unboxing+                   [CoreExpr])           -- Reboxed args for the call to the+                                         -- original RHS. Corresponds one-to-one+                                         -- with the wrapper arg vars+mkWWstr opts args cbv_info+  = go args cbv_info+  where+    go_one arg cbv = mkWWstr_one opts arg cbv++    go []           _ = return (badWorker, [], nop_fn, [])+    go (arg : args) (cbv:cbvs)+      =               do { (useful1, args1, wrap_fn1, wrap_arg)  <- go_one arg cbv+                         ; (useful2, args2, wrap_fn2, wrap_args) <- go args cbvs+                         ; return ( useful1 || useful2+                                  , args1 ++ args2+                                  , wrap_fn1 . wrap_fn2+                                  , wrap_arg:wrap_args ) }+    go _ _ = panic "mkWWstr: Impossible - cbv/arg length missmatch"++----------------------+-- mkWWstr_one wrap_var = (useful, work_args, wrap_fn, wrap_arg)+--   *  wrap_fn assumes wrap_var is in scope,+--        brings into scope work_args (via cases)+--   * wrap_arg assumes work_args are in scope, and builds a ConApp that+--        reconstructs the RHS of wrap_var that we pass to the original RHS+-- See Note [Worker/wrapper for Strictness and Absence]+mkWWstr_one :: WwOpts+            -> Var+            -> StrictnessMark+            -> UniqSM (Bool, [(Var,StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)+mkWWstr_one opts arg banged =+  case wantToUnboxArg True fam_envs arg_ty arg_dmd of+    _ | isTyVar arg -> do_nothing++    DropAbsent+      | Just absent_filler <- mkAbsentFiller opts arg banged+         -- Absent case.  Dropt the argument from the worker.+         -- We can't always handle absence for arbitrary+         -- unlifted types, so we need to choose just the cases we can+         -- (that's what mkAbsentFiller does)+      -> return (goodWorker, [], nop_fn, absent_filler)++    Unbox dcpc ds -> unbox_one_arg opts arg ds dcpc banged++    Unlift -> return  ( wwForUnlifting opts+                      , [(arg, MarkedStrict)]+                      , nop_fn+                      , varToCoreExpr arg)++    _ -> do_nothing -- Other cases, like StopUnboxing++  where+    fam_envs   = wo_fam_envs opts+    arg_ty     = idType arg+    arg_dmd    = idDemandInfo arg+    -- Type args don't get cbv marks+    arg_cbv    = if isTyVar arg then NotMarkedStrict else banged++    do_nothing = return (badWorker, [(arg,arg_cbv)], nop_fn, varToCoreExpr arg)++unbox_one_arg :: WwOpts+          -> Var+          -> [Demand]+          -> DataConPatContext+          -> StrictnessMark+          -> UniqSM (Bool, [(Var,StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)+unbox_one_arg opts arg_var ds+          DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args+                            , dcpc_co = co }+          _marked_cbv+  = do { pat_bndrs_uniqs <- getUniquesM+       ; let ex_name_fss = map getOccFS $ dataConExTyCoVars dc+             -- Create new arguments we get when unboxing dc+             (ex_tvs', arg_ids) =+               dataConRepFSInstPat (ex_name_fss ++ repeat ww_prefix) pat_bndrs_uniqs (idMult arg_var) dc tc_args+             con_str_marks = dataConRepStrictness dc+             -- Apply str info to new args. Also remove OtherCon unfoldings so they don't end up in lambda binders+             -- of the worker. See Note [Never put `OtherCon` unfoldings on lambda binders]+             arg_ids' = map zapIdUnfolding $ zipWithEqual "unbox_one_arg" setIdDemandInfo arg_ids ds+             unbox_fn = mkUnpackCase (Var arg_var) co (idMult arg_var)+                                     dc (ex_tvs' ++ arg_ids')+             -- Mark arguments coming out of strict fields so we can make the worker strict on those+             -- argumnets later. seq them later. See Note [Call-by-value for worker args]+             strict_marks = (map (const NotMarkedStrict) ex_tvs') ++ con_str_marks+       ; (_sub_args_quality, worker_args, wrap_fn, wrap_args) <- mkWWstr opts (ex_tvs' ++ arg_ids') strict_marks+       ; let wrap_arg = mkConApp dc (map Type tc_args ++ wrap_args) `mkCast` mkSymCo co+       ; return (goodWorker, worker_args, unbox_fn . wrap_fn, wrap_arg) }+                          -- Don't pass the arg, rebox instead++-- | Tries to find a suitable absent filler to bind the given absent identifier+-- to. See Note [Absent fillers].+--+-- If @mkAbsentFiller _ id == Just e@, then @e@ is an absent filler with the+-- same type as @id@. Otherwise, no suitable filler could be found.+mkAbsentFiller :: WwOpts -> Id -> StrictnessMark -> Maybe CoreExpr+mkAbsentFiller opts arg str+  -- The lifted case: Bind 'absentError' for a nice panic message if we are+  -- wrong (like we were in #11126). See (1) in Note [Absent fillers]+  | mightBeLiftedType arg_ty+  , not is_strict+  , not (isMarkedStrict str) -- See (2) in Note [Absent fillers]+  = Just (mkAbsentErrorApp arg_ty msg)++  -- The default case for mono rep: Bind `RUBBISH[rr] arg_ty`+  -- See Note [Absent fillers], the main part+  | otherwise+  = mkLitRubbish arg_ty++  where+    arg_ty    = idType arg+    is_strict = isStrictDmd (idDemandInfo arg)++    msg = renderWithContext+            (defaultSDocContext { sdocSuppressUniques = True })+            (vcat+              [ text "Arg:" <+> ppr arg+              , text "Type:" <+> ppr arg_ty+              , file_msg ])+              -- We need to suppress uniques here because otherwise they'd+              -- end up in the generated code as strings. This is bad for+              -- determinism, because with different uniques the strings+              -- will have different lengths and hence different costs for+              -- the inliner leading to different inlining.+              -- See also Note [Unique Determinism] in GHC.Types.Unique+    file_msg = text "In module" <+> quotes (ppr $ wo_module opts)++{- Note [Worker/wrapper for Strictness and Absence]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The worker/wrapper transformation, mkWWstr_one, takes concrete action+based on the 'UnboxingDescision' returned by 'wantToUnboxArg'.+The latter takes into account several possibilities to decide if the+function is worthy for splitting:++1. If an argument is absent, it would be silly to pass it to+   the worker.  Hence the DropAbsent case.  This case must come+   first because the bottom demand B is also strict.+   E.g. B comes from a function like+       f x = error "urk"+   and the absent demand A can come from Note [Unboxing evaluated arguments]+   in GHC.Core.Opt.DmdAnal.++2. If the argument is evaluated strictly (or known to be eval'd),+   we can take a view into the product demand ('viewProd'). In accordance+   with Note [Boxity analysis], 'wantToUnboxArg' will say 'Unbox'.+   'mkWWstr_one' then follows suit it and recurses into the fields of the+   product demand. For example++     f :: (Int, Int) -> Int+     f p = (case p of (a,b) -> a) + 1+   is split to+     f :: (Int, Int) -> Int+     f p = case p of (a,b) -> $wf a++     $wf :: Int -> Int+     $wf a = a + 1++   and+     g :: Bool -> (Int, Int) -> Int+     g c p = case p of (a,b) ->+                if c then a else b+   is split to+     g c p = case p of (a,b) -> $gw c a b+     $gw c a b = if c then a else b++2a But do /not/ unbox if Boxity Analysis said "Boxed".+   In this case, 'wantToUnboxArg' returns 'StopUnboxing'.+   Otherwise we risk decomposing and reboxing a massive+   tuple which is barely used. Example:++        f :: ((Int,Int) -> String) -> (Int,Int) -> a+        f g pr = error (g pr)++        main = print (f fst (1, error "no"))++   Here, f does not take 'pr' apart, and it's stupid to do so.+   Imagine that it had millions of fields. This actually happened+   in GHC itself where the tuple was DynFlags++2b But if e.g. a large tuple or product type is always demanded we might+   decide to "unlift" it. That is tighten the calling convention for that+   argument to require it to be passed as a pointer to the value itself.+   See Note [WW for calling convention].++3. In all other cases (e.g., lazy, used demand and not eval'd),+   'finaliseArgBoxities' will have cleared the Boxity flag to 'Boxed'+   (see Note [Finalising boxity for demand signatures] in GHC.Core.Opt.DmdAnal)+   and 'wantToUnboxArg' returns 'StopUnboxing' so that 'mkWWstr_one'+   stops unboxing.++Note [Worker/wrapper for bottoming functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We used not to split if the result is bottom.+[Justification:  there's no efficiency to be gained.]++But it's sometimes bad not to make a wrapper.  Consider+        fw = \x# -> let x = I# x# in case e of+                                        p1 -> error_fn x+                                        p2 -> error_fn x+                                        p3 -> the real stuff+The re-boxing code won't go away unless error_fn gets a wrapper too.+[We don't do reboxing now, but in general it's better to pass an+unboxed thing to f, and have it reboxed in the error cases....]++Note [Record evaluated-ness in worker/wrapper]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have++   data T = MkT !Int Int++   f :: T -> T+   f x = e++and f's is strict, and has the CPR property.  The we are going to generate+this w/w split++   f x = case x of+           MkT x1 x2 -> case $wf x1 x2 of+                           (# r1, r2 #) -> MkT r1 r2++   $wfw x1 x2 = let x = MkT x1 x2 in+                case e of+                  MkT r1 r2 -> (# r1, r2 #)++Note that++* In the worker $wf, inside 'e' we can be sure that x1 will be+  evaluated (it came from unpacking the argument MkT.  But that's no+  immediately apparent in $wf++* In the wrapper 'f', which we'll inline at call sites, we can be sure+  that 'r1' has been evaluated (because it came from unpacking the result+  MkT.  But that is not immediately apparent from the wrapper code.++Missing these facts isn't unsound, but it loses possible future+opportunities for optimisation.++Solution: use setCaseBndrEvald when creating+ (A) The arg binders x1,x2 in mkWstr_one via mkUnpackCase+         See #13077, test T13077+ (B) The result binders r1,r2 in mkWWcpr_entry+         See Trace #13077, test T13077a+         And #13027 comment:20, item (4)+to record that the relevant binder is evaluated.++Note [Absent fillers]+~~~~~~~~~~~~~~~~~~~~~+Consider++  data T = MkT [Int] [Int] ![Int]  -- NB: last field is strict+  f :: T -> Int# -> blah+  f ps w = case ps of MkT xs ys zs -> <body mentioning xs>++Then f gets a strictness sig of <S(L,A,A)><A>. We make a worker $wf thus:++  $wf :: [Int] -> blah+  $wf xs = case ps of MkT xs _ _ -> <body mentioning xs>+    where+      ys = absentError "ys :: [Int]"+      zs = RUBBISH[LiftedRep] @[Int]+      ps = MkT xs ys zs+      w  = RUBBISH[IntRep] @Int#++The absent arguments 'ys', 'zs' and 'w' aren't even passed to the worker.+And neither should they! They are never used, their value is irrelevant (hence+they are *dead code*) and they are probably discarded after the next run of the+Simplifier (when they are in fact *unreachable code*). Yet, we have to come up+with "filler" values that we bind the absent arg Ids to.++That is exactly what Note [Rubbish literals] are for: A convenient way to+conjure filler values at any type (and any representation or levity!).++Needless to say, there are some wrinkles:++  1. In case we have a absent, /lazy/, and /lifted/ arg, we use an error-thunk+     instead. If absence analysis was wrong (e.g., #11126) and the binding+     in fact is used, then we get a nice panic message instead of undefined+     runtime behavior (See Modes of failure from Note [Rubbish literals]).++     Obviously, we can't use an error-thunk if the value is of unlifted rep+     (like 'Int#' or 'MutVar#'), because we'd immediately evaluate the panic.++  2. We also mustn't put an error-thunk (that fills in for an absent value of+     lifted rep) in a strict field, because #16970 establishes the invariant+     that strict fields are always evaluated, by possibly (re-)evaluating what is put in+     a strict field. That's the reason why 'zs' binds a rubbish literal instead+     of an error-thunk, see #19133.++     How do we detect when we are about to put an error-thunk in a strict field?+     Ideally, we'd just look at the 'StrictnessMark' of the DataCon's field. So that's+     what we do!++     There are other necessary conditions for strict fields:+     Note [Unboxing evaluated arguments] in DmdAnal makes it so that the demand on+     'zs' is absent and /strict/: It will get cardinality 'C_10', the empty+     interval, rather than 'C_00'. Hence the 'isStrictDmd' check: It further+     guarantees e never fill in an error-thunk for an absent strict field.+     But that also means we emit a rubbish lit for other args that have+     cardinality 'C_10' (say, the arg to a bottoming function) where we could've+     used an error-thunk.+     NB from Andreas: But I think using an error thunk there would be dodgy no matter what+     for example if we decide to pass the argument to the bottoming function cbv.+     As we might do if the function in question is a worker.+     See Note [CBV Function Ids] in GHC.CoreToStg.Prep. So I just left the strictness check+     in place on top of threading through the marks from the constructor. It's a *really* cheap+     and easy check to make anyway.++  3. We can only emit a LitRubbish if the arg's type @arg_ty@ is mono-rep, e.g.+     of the form @TYPE rep@ where @rep@ is not (and doesn't contain) a variable.+     Why? Because if we don't know its representation (e.g. size in memory,+     register class), we don't know what or how much rubbish to emit in codegen.+     'mkLitRubbish' returns 'Nothing' in this case and we simply fall+     back to passing the original parameter to the worker.++     Note that currently this case should not occur, because binders always+     have to be representation monomorphic. But in the future, we might allow+     levity polymorphism, e.g. a polymorphic levity variable in 'BoxedRep'.++While (1) and (2) are simply an optimisation in terms of compiler debugging+experience, (3) should be irrelevant in most programs, if not all.++Historical note: I did try the experiment of using an error thunk for unlifted+things too, relying on the simplifier to drop it as dead code.  But this is+fragile++ - It fails when profiling is on, which disables various optimisations++ - It fails when reboxing happens. E.g.+      data T = MkT Int Int#+      f p@(MkT a _) = ...g p....+   where g is /lazy/ in 'p', but only uses the first component.  Then+   'f' is /strict/ in 'p', and only uses the first component.  So we only+   pass that component to the worker for 'f', which reconstructs 'p' to+   pass it to 'g'.  Alas we can't say+       ...f (MkT a (absentError Int# "blah"))...+   because `MkT` is strict in its Int# argument, so we get an absentError+   exception when we shouldn't.  Very annoying!++************************************************************************+*                                                                      *+         Type scrutiny that is specific to demand analysis+*                                                                      *+************************************************************************+-}++-- | Exactly 'dataConInstArgTys', but lacks the (ASSERT'ed) precondition that+-- the 'DataCon' may not have existentials. The lack of cloning the existentials+-- compared to 'dataConInstExAndArgVars' makes this function \"dubious\";+-- only use it where type variables aren't substituted for!+dubiousDataConInstArgTys :: DataCon -> [Type] -> [Type]+dubiousDataConInstArgTys dc tc_args = arg_tys+  where+    univ_tvs = dataConUnivTyVars dc+    ex_tvs   = dataConExTyCoVars dc+    subst    = extendTCvInScopeList (zipTvSubst univ_tvs tc_args) ex_tvs+    arg_tys  = map (GHC.Core.Type.substTy subst . scaledThing) (dataConRepArgTys dc)++findTypeShape :: FamInstEnvs -> Type -> TypeShape+-- Uncover the arrow and product shape of a type+-- The data type TypeShape is defined in GHC.Types.Demand+-- See Note [Trimming a demand to a type] in GHC.Core.Opt.DmdAnal+findTypeShape fam_envs ty+  = go (setRecTcMaxBound 2 initRecTc) ty+       -- You might think this bound of 2 is low, but actually+       -- I think even 1 would be fine.  This only bites for recursive+       -- product types, which are rare, and we really don't want+       -- to look deep into such products -- see #18034+  where+    go rec_tc ty+       | Just (_, _, res) <- splitFunTy_maybe ty+       = TsFun (go rec_tc res)++       | Just (tc, tc_args)  <- splitTyConApp_maybe ty+       = go_tc rec_tc tc tc_args++       | Just (_, ty') <- splitForAllTyCoVar_maybe ty+       = go rec_tc ty'++       | otherwise+       = TsUnk++    go_tc rec_tc tc tc_args+       | Just (HetReduction (Reduction _ rhs) _) <- topReduceTyFamApp_maybe fam_envs tc tc_args+       = go rec_tc rhs++       | Just con <- tyConSingleAlgDataCon_maybe tc+       , Just rec_tc <- if isTupleTyCon tc+                        then Just rec_tc+                        else checkRecTc rec_tc tc+         -- We treat tuples specially because they can't cause loops.+         -- Maybe we should do so in checkRecTc.+         -- The use of 'dubiousDataConInstArgTys' is OK, since this+         -- function performs no substitution at all, hence the uniques+         -- don't matter.+         -- We really do encounter existentials here, see+         -- Note [Which types are unboxed?] for an example.+       = TsProd (map (go rec_tc) (dubiousDataConInstArgTys con tc_args))++       | Just (ty', _) <- instNewTyCon_maybe tc tc_args+       , Just rec_tc <- checkRecTc rec_tc tc+       = go rec_tc ty'++       | otherwise+       = TsUnk++-- | Returned by 'isRecDataCon'.+-- See also Note [Detecting recursive data constructors].+data IsRecDataConResult+  = DefinitelyRecursive  -- ^ The algorithm detected a loop+  | NonRecursiveOrUnsure -- ^ The algorithm detected no loop, went out of fuel+                         -- or hit an .hs-boot file+  deriving (Eq, Show)++instance Outputable IsRecDataConResult where+  ppr = text . show++combineIRDCR :: IsRecDataConResult -> IsRecDataConResult -> IsRecDataConResult+combineIRDCR DefinitelyRecursive _                   = DefinitelyRecursive+combineIRDCR _                   DefinitelyRecursive = DefinitelyRecursive+combineIRDCR _                   _                   = NonRecursiveOrUnsure++combineIRDCRs :: [IsRecDataConResult] -> IsRecDataConResult+combineIRDCRs = foldl' combineIRDCR NonRecursiveOrUnsure+{-# INLINE combineIRDCRs #-}++-- | @isRecDataCon _ fuel dc@, where @tc = dataConTyCon dc@ returns+--+--   * @DefinitelyRecursive@ if the analysis found that @tc@ is reachable+--     through one of @dc@'s @arg_tys@.+--   * @NonRecursiveOrUnsure@ if the analysis found that @tc@ is not reachable+--     through one of @dc@'s fields (so surely non-recursive).+--   * @NonRecursiveOrUnsure@ when @fuel /= Infinity@+--     and @fuel@ expansions of nested data TyCons were not enough to prove+--     non-recursivenss, nor arrive at an occurrence of @tc@ thus proving+--     recursiveness. (So not sure if non-recursive.)+--   * @NonRecursiveOrUnsure@ when we hit an abstract TyCon (one without+--     visible DataCons), such as those imported from .hs-boot files.+--     Similarly for stuck type and data families.+--+-- If @fuel = 'Infinity'@ and there are no boot files involved, then the result+-- is never @Nothing@ and the analysis is a depth-first search. If @fuel = 'Int'+-- f@, then the analysis behaves like a depth-limited DFS and returns @Nothing@+-- if the search was inconclusive.+--+-- See Note [Detecting recursive data constructors] for which recursive DataCons+-- we want to flag.+isRecDataCon :: FamInstEnvs -> IntWithInf -> DataCon -> IsRecDataConResult+isRecDataCon fam_envs fuel orig_dc+  | isTupleDataCon orig_dc || isUnboxedSumDataCon orig_dc+  = NonRecursiveOrUnsure+  | otherwise+  = -- pprTraceWith "isRecDataCon" (\answer -> ppr dc <+> dcolon <+> ppr (dataConRepType dc) $$ ppr fuel $$ ppr answer) $+    go_dc fuel emptyTyConSet orig_dc+  where+    go_dc :: IntWithInf -> TyConSet -> DataCon -> IsRecDataConResult+    go_dc fuel visited_tcs dc =+      combineIRDCRs [ go_arg_ty fuel visited_tcs arg_ty+                    | arg_ty <- map scaledThing (dataConRepArgTys dc) ]++    go_arg_ty :: IntWithInf -> TyConSet -> Type -> IsRecDataConResult+    go_arg_ty fuel visited_tcs ty+      --- | pprTrace "arg_ty" (ppr ty) False = undefined++      | Just (_tcv, ty') <- splitForAllTyCoVar_maybe ty+      = go_arg_ty fuel visited_tcs ty'+          -- See Note [Detecting recursive data constructors], point (A)++      | Just (tc, tc_args) <- splitTyConApp_maybe ty+      = go_tc_app fuel visited_tcs tc tc_args++      | otherwise+      = NonRecursiveOrUnsure++    go_tc_app :: IntWithInf -> TyConSet -> TyCon -> [Type] -> IsRecDataConResult+    go_tc_app fuel visited_tcs tc tc_args =+      case tyConDataCons_maybe tc of+      --- | pprTrace "tc_app" (vcat [ppr tc, ppr tc_args]) False = undefined+        _ | Just (HetReduction (Reduction _ rhs) _) <- topReduceTyFamApp_maybe fam_envs tc tc_args+          -- This is the only place where we look at tc_args, which might have+          -- See Note [Detecting recursive data constructors], point (C) and (5)+          -> go_arg_ty fuel visited_tcs rhs++        _ | tc == dataConTyCon orig_dc+          -> DefinitelyRecursive -- loop found!++        Just dcs+          | DefinitelyRecursive <- combineIRDCRs [ go_arg_ty fuel visited_tcs' ty | ty <- tc_args ]+              -- Check tc_args, See Note [Detecting recursive data constructors], point (5)+              -- The new visited_tcs', so that we don't recursively check tc,+              -- promising that we will check it below.+              -- Do the tc_args check *before* the dcs check below, otherwise+              -- we might miss an obvious rec occ in tc_args when we run out of+              -- fuel and respond NonRecursiveOrUnsure instead+          -> DefinitelyRecursive++          | fuel >= 0+              -- See Note [Detecting recursive data constructors], point (4)+          , not (tc `elemTyConSet` visited_tcs)+              -- only need to check tc if we haven't visited it already. NB: original visited_tcs+          -> combineIRDCRs [ go_dc (subWithInf fuel 1) visited_tcs' dc | dc <- dcs ]+              -- Finally: check ds++        _ -> NonRecursiveOrUnsure+        where+          visited_tcs' = extendTyConSet visited_tcs tc++{-+************************************************************************+*                                                                      *+\subsection{Worker/wrapper for CPR}+*                                                                      *+************************************************************************+See Note [Worker/wrapper for CPR] for an overview.+-}++mkWWcpr_entry+  :: WwOpts+  -> Type                              -- function body+  -> Cpr                               -- CPR analysis results+  -> UniqSM (Bool,            -- Is w/w'ing useful?+             CoreExpr -> CoreExpr,     -- New wrapper. 'nop_fn' if not useful+             CoreExpr -> CoreExpr)     -- New worker.  'nop_fn' if not useful+-- ^ Entrypoint to CPR W/W. See Note [Worker/wrapper for CPR] for an overview.+mkWWcpr_entry opts body_ty body_cpr+  | not (wo_cpr_anal opts) = return (badWorker, nop_fn, nop_fn)+  | otherwise = do+    -- Part (1)+    res_bndr <- mk_res_bndr body_ty+    let bind_res_bndr body scope = mkDefaultCase body res_bndr scope++    -- Part (2)+    (useful, fromOL -> transit_vars, rebuilt_result, work_unpack_res) <-+      mkWWcpr_one opts res_bndr body_cpr++    -- Part (3)+    let (unbox_transit_tup, transit_tup) = move_transit_vars transit_vars++    -- Stacking unboxer (work_fn) and builder (wrap_fn) together+    let wrap_fn      = unbox_transit_tup rebuilt_result                 -- 3 2+        work_fn body = bind_res_bndr body (work_unpack_res transit_tup) -- 1 2 3+    return $ if not useful+                then (badWorker, nop_fn, nop_fn)+                else (goodWorker, wrap_fn, work_fn)++-- | Part (1) of Note [Worker/wrapper for CPR].+mk_res_bndr :: Type -> UniqSM Id+mk_res_bndr body_ty = do+  -- See Note [Linear types and CPR]+  bndr <- mkSysLocalOrCoVarM ww_prefix cprCaseBndrMult body_ty+  -- See Note [Record evaluated-ness in worker/wrapper]+  pure (setCaseBndrEvald MarkedStrict bndr)++-- | What part (2) of Note [Worker/wrapper for CPR] collects.+--+--   1. A Bool capturing whether the transformation did anything useful.+--   2. The list of transit variables (see the Note).+--   3. The result builder expression for the wrapper.  The original case binder if not useful.+--   4. The result unpacking expression for the worker. 'nop_fn' if not useful.+type CprWwResultOne  = (Bool, OrdList Var,  CoreExpr , CoreExpr -> CoreExpr)+type CprWwResultMany = (Bool, OrdList Var, [CoreExpr], CoreExpr -> CoreExpr)++mkWWcpr :: WwOpts -> [Id] -> [Cpr] -> UniqSM CprWwResultMany+mkWWcpr _opts vars []   =+  -- special case: No CPRs means all top (for example from FlatConCpr),+  -- hence stop WW.+  return (badWorker, toOL vars, map varToCoreExpr vars, nop_fn)+mkWWcpr opts  vars cprs = do+  -- No existentials in 'vars'. 'wantToUnboxResult' should have checked that.+  massertPpr (not (any isTyVar vars)) (ppr vars $$ ppr cprs)+  massertPpr (equalLength vars cprs) (ppr vars $$ ppr cprs)+  (usefuls, varss, rebuilt_results, work_unpack_ress) <-+    unzip4 <$> zipWithM (mkWWcpr_one opts) vars cprs+  return ( or usefuls+         , concatOL varss+         , rebuilt_results+         , foldl' (.) nop_fn work_unpack_ress )++mkWWcpr_one :: WwOpts -> Id -> Cpr -> UniqSM CprWwResultOne+-- ^ See if we want to unbox the result and hand off to 'unbox_one_result'.+mkWWcpr_one opts res_bndr cpr+  | assert (not (isTyVar res_bndr) ) True+  , Unbox dcpc arg_cprs <- wantToUnboxResult (wo_fam_envs opts) (idType res_bndr) cpr+  = unbox_one_result opts res_bndr arg_cprs dcpc+  | otherwise+  = return (badWorker, unitOL res_bndr, varToCoreExpr res_bndr, nop_fn)++unbox_one_result+  :: WwOpts -> Id -> [Cpr] -> DataConPatContext -> UniqSM CprWwResultOne+-- ^ Implements the main bits of part (2) of Note [Worker/wrapper for CPR]+unbox_one_result opts res_bndr arg_cprs+                 DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args+                                   , dcpc_co = co } = do+  -- unboxer (free in `res_bndr`):       |   builder (where <i> builds what was+  --   ( case res_bndr of (i, j) -> )    |            bound to i)+  --   ( case i of I# a ->          )    |+  --   ( case j of I# b ->          )    |     (      (<i>, <j>)      )+  --   ( <hole>                     )    |+  pat_bndrs_uniqs <- getUniquesM+  let (_exs, arg_ids) =+        dataConRepFSInstPat (repeat ww_prefix) pat_bndrs_uniqs cprCaseBndrMult dc tc_args+  massert (null _exs) -- Should have been caught by wantToUnboxResult++  (nested_useful, transit_vars, con_args, work_unbox_res) <-+    mkWWcpr opts arg_ids arg_cprs++  let -- rebuilt_result = (C a b |> sym co)+      rebuilt_result = mkConApp dc (map Type tc_args ++ con_args) `mkCast` mkSymCo co+      -- this_work_unbox_res alt = (case res_bndr |> co of C a b -> <alt>[a,b])+      this_work_unbox_res = mkUnpackCase (Var res_bndr) co cprCaseBndrMult dc arg_ids++  -- Don't try to WW an unboxed tuple return type when there's nothing inside+  -- to unbox further.+  return $ if isUnboxedTupleDataCon dc && not nested_useful+              then ( badWorker, unitOL res_bndr, Var res_bndr, nop_fn )+              else ( goodWorker+                   , transit_vars+                   , rebuilt_result+                   , this_work_unbox_res . work_unbox_res+                   )++-- | Implements part (3) of Note [Worker/wrapper for CPR].+--+-- If `move_transit_vars [a,b] = (unbox, tup)` then+--     * `a` and `b` are the *transit vars* to be returned from the worker+--       to the wrapper+--     * `unbox scrut alt = (case <scrut> of (# a, b #) -> <alt>)`+--     * `tup = (# a, b #)`+-- There is a special case for when there's 1 transit var,+-- see Note [No unboxed tuple for single, unlifted transit var].+move_transit_vars :: [Id] -> (CoreExpr -> CoreExpr -> CoreExpr, CoreExpr)+move_transit_vars vars+  | [var] <- vars+  , let var_ty = idType var+  , isUnliftedType var_ty || exprIsHNF (Var var)+  -- See Note [No unboxed tuple for single, unlifted transit var]+  --   * Wrapper: `unbox scrut alt = (case <scrut> of a -> <alt>)`+  --   * Worker:  `tup = a`+  = ( \build_res wkr_call -> mkDefaultCase wkr_call var build_res+    , varToCoreExpr var ) -- varToCoreExpr important here: var can be a coercion+                          -- Lacking this caused #10658+  | otherwise+  -- The general case: Just return an unboxed tuple from the worker+  --   * Wrapper: `unbox scrut alt = (case <scrut> of (# a, b #) -> <alt>)`+  --   * Worker:  `tup = (# a, b #)`+  = ( \build_res wkr_call -> mkSingleAltCase wkr_call case_bndr+                                    (DataAlt tup_con) vars build_res+    , ubx_tup_app )+   where+    ubx_tup_app = mkCoreUbxTup (map idType vars) (map varToCoreExpr vars)+    tup_con     = tupleDataCon Unboxed (length vars)+    -- See also Note [Linear types and CPR]+    case_bndr   = mkWildValBinder cprCaseBndrMult (exprType ubx_tup_app)+++{- Note [Worker/wrapper for CPR]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+'mkWWcpr_entry' is the entry-point to the worker/wrapper transformation that+exploits CPR info. Here's an example:+```+  f :: ... -> (Int, Int)+  f ... = <body>+```+Let's assume the CPR info `body_cpr` for the body of `f` says+"unbox the pair and its components" and `body_ty` is the type of the function+body `body` (i.e., `(Int, Int)`). Then `mkWWcpr_entry body_ty body_cpr` returns++  * A result-unpacking expression for the worker, with a hole for the fun body:+    ```+      unpack body = ( case <body> of r __DEFAULT -> )    -- (1)+                    ( case r of (i, j) ->           )    -- (2)+                    ( case i of I# a ->             )    -- (2)+                    ( case j of I# b ->             )    -- (2)+                    ( (# a, b #)                    )    -- (3)+    ```+  * A result-building expression for the wrapper, with a hole for the worker call:+    ```+      build wkr_call = ( case <wkr_call> of (# a, b #) -> )    -- (3)+                       ( (I# a, I# b)                     )    -- (2)+    ```+  * The result type of the worker, e.g., `(# Int#, Int# #)` above.++To achieve said transformation, 'mkWWcpr_entry'++  1. First allocates a fresh result binder `r`, giving a name to the `body`+     expression and contributing part (1) of the unpacker and builder.+  2. Then it delegates to 'mkWWcpr_one', which recurses into all result fields+     to unbox, contributing the parts marked with (2). Crucially, it knows+     what belongs in the case scrutinee of the unpacker through the communicated+     Id `r`: The unpacking expression will be free in that variable.+     (This is a similar contract as that of 'mkWWstr_one' for strict args.)+  3. 'mkWWstr_one' produces a bunch of *transit vars*: Those result variables+     that have to be transferred from the worker to the wrapper, where the+     constructed result can be rebuilt, `a` and `b` above. Part (3) is+     responsible for tupling them up in the worker and taking the tuple apart+     in the wrapper. This is implemented in 'move_transit_vars'.++Note [No unboxed tuple for single, unlifted transit var]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When there's only a single, unlifted transit var (Note [Worker/wrapper for CPR]),+we don't wrap an unboxed singleton tuple around it (which otherwise would be+needed to suspend evaluation) and return the unlifted thing directly. E.g.+```+  f :: Int -> Int+  f x = x+1+```+We certainly want `$wf :: Int# -> Int#`, not `$wf :: Int# -> (# Int# #)`.+This is OK as long as we know that evaluation of the returned thing terminates+quickly, as is the case for fields of unlifted type like `Int#`.++But more generally, this should also be true for *lifted* types that terminate+quickly! Consider from `T18109`:+```+  data F = F (Int -> Int)+  f :: Int -> F+  f n = F (+n)++  data T = T (Int, Int)+  g :: T -> T+  g t@(T p) = p `seq` t++  data U = U ![Int]+  h :: Int -> U+  h n = U [0..n]+```+All of the nested fields are actually ok-for-speculation and thus OK to+return unboxed instead of in an unboxed singleton tuple:++ 1. The field of `F` is a HNF.+    We want `$wf :: Int -> Int -> Int`.+    We get  `$wf :: Int -> (# Int -> Int #)`.+ 2. The field of `T` is `seq`'d in `g`.+    We want `$wg :: (Int, Int) -> (Int, Int)`.+    We get  `$wg :: (Int, Int) -> (# (Int, Int) #)`.+ 3. The field of `U` is strict and thus always evaluated.+    We want  `$wh :: Int# -> [Int]`.+    We'd get `$wh :: Int# -> (# [Int] #)`.++By considering vars as unlifted that satsify 'exprIsHNF', we catch (3).+Why not check for 'exprOkForSpeculation'? Quite perplexingly, evaluated vars+are not ok-for-spec, see Note [exprOkForSpeculation and evaluated variables].+For (1) and (2) we would have to look at the term. WW only looks at the+type and the CPR signature, so the only way to fix (1) and (2) would be to+have a nested termination signature, like in MR !1866.++Note [Linear types and CPR]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Remark on linearity: in both the case of the wrapper and the worker,+we build a linear case to unpack constructed products. All the+multiplicity information is kept in the constructors (both C and (#, #)).+In particular (#,#) is parametrised by the multiplicity of its fields.+Specifically, in this instance, the multiplicity of the fields of (#,#)+is chosen to be the same as those of C.+++************************************************************************+*                                                                      *+\subsection{Utilities}+*                                                                      *+************************************************************************+-}++mkUnpackCase ::  CoreExpr -> Coercion -> Mult -> DataCon -> [Id] -> CoreExpr -> CoreExpr+-- (mkUnpackCase e co Con args body)+--      returns+-- case e |> co of _dead { Con args -> body }+mkUnpackCase (Tick tickish e) co mult con args body   -- See Note [Profiling and unpacking]+  = Tick tickish (mkUnpackCase e co mult con args body)+mkUnpackCase scrut co mult boxing_con unpk_args body+  = mkSingleAltCase casted_scrut bndr+                    (DataAlt boxing_con) unpk_args body+  where+    casted_scrut = scrut `mkCast` co+    bndr = mkWildValBinder mult (exprType casted_scrut)++-- | The multiplicity of a case binder unboxing a constructed result.+-- See Note [Linear types and CPR]+cprCaseBndrMult :: Mult+cprCaseBndrMult = One++ww_prefix :: FastString+ww_prefix = fsLit "ww"++{- Note [Profiling and unpacking]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If the original function looked like+        f = \ x -> {-# SCC "foo" #-} E++then we want the CPR'd worker to look like+        \ x -> {-# SCC "foo" #-} (case E of I# x -> x)+and definitely not+        \ x -> case ({-# SCC "foo" #-} E) of I# x -> x)++This transform doesn't move work or allocation+from one cost centre to another.++Later [SDM]: presumably this is because we want the simplifier to+eliminate the case, and the scc would get in the way?  I'm ok with+including the case itself in the cost centre, since it is morally+part of the function (post transformation) anyway.+-}
− compiler/GHC/Core/Rules.hs 
@@ -1,1588 +0,0 @@-{--(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--\section[CoreRules]{Rewrite rules}--}--{-# LANGUAGE CPP #-}---- | Functions for collecting together and applying rewrite rules to a module.--- The 'CoreRule' datatype itself is declared elsewhere.-module GHC.Core.Rules (-        -- ** Constructing-        emptyRuleBase, mkRuleBase, extendRuleBaseList,-        unionRuleBase, pprRuleBase,--        -- ** Checking rule applications-        ruleCheckProgram,--        -- ** Manipulating 'RuleInfo' rules-        extendRuleInfo, addRuleInfo,-        addIdSpecialisations,--        -- * Misc. CoreRule helpers-        rulesOfBinds, getRules, pprRulesForUser,--        lookupRule, mkRule, roughTopNames, initRuleOpts-    ) where--#include "GhclibHsVersions.h"--import GHC.Prelude--import GHC.Core         -- All of it-import GHC.Unit.Types    ( primUnitId, bignumUnitId )-import GHC.Unit.Module   ( Module )-import GHC.Unit.Module.Env-import GHC.Core.Subst-import GHC.Core.SimpleOpt ( exprIsLambda_maybe )-import GHC.Core.FVs       ( exprFreeVars, exprsFreeVars, bindFreeVars-                          , rulesFreeVarsDSet, exprsOrphNames, exprFreeVarsList )-import GHC.Core.Utils     ( exprType, eqExpr, mkTick, mkTicks-                          , stripTicksTopT, stripTicksTopE-                          , isJoinBind, mkCastMCo )-import GHC.Core.Ppr       ( pprRules )-import GHC.Core.Type as Type-   ( Type, TCvSubst, extendTvSubst, extendCvSubst-   , mkEmptyTCvSubst, getTyVar_maybe, substTy )-import GHC.Tc.Utils.TcType  ( tcSplitTyConApp_maybe )-import GHC.Builtin.Types    ( anyTypeOfKind )-import GHC.Core.Coercion as Coercion-import GHC.Core.Tidy     ( tidyRules )-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.Core.Unify as Unify ( ruleMatchTyKiX )-import GHC.Types.Basic-import GHC.Driver.Session      ( DynFlags, gopt, targetPlatform, homeUnitId_ )-import GHC.Driver.Ppr-import GHC.Driver.Flags-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Data.FastString-import GHC.Data.Maybe-import GHC.Data.Bag-import GHC.Utils.Misc as Utils-import 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, we combine (b-d) into a single-  RuleBase, reading-     (b) from the ModGuts,-     (c) from the GHC.Core.Opt.Monad, and-     (d) from its mutable variable-  [Of course this means that we won't see new EPS rules that come in-  during a single simplifier iteration, but that probably does not-  matter.]---************************************************************************-*                                                                      *-\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 ++ filter (ruleIsVisible orphs) imp_rules-  where-    imp_rules = lookupNameEnv rule_base (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--unionRuleBase :: RuleBase -> RuleBase -> RuleBase-unionRuleBase rb1 rb2 = plusNameEnv_C (++) rb1 rb2--extendRuleBase :: RuleBase -> CoreRule -> RuleBase-extendRuleBase rule_base rule-  = extendNameEnv_Acc (:) Utils.singleton rule_base (ruleIdName rule) rule--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 -> [CoreExpr]-           -> [CoreRule] -> 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----      I now think this is probably a bad idea.---      Should the template (map f xs) match (map g)?  I think not.---      For a start, in general eta expansion wastes work.---      SLPJ July 99--{- Note [Casts in the target]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-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 argument] 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-  = ASSERT2(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 eqExpr (rnInScopeSet rn_env) 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/Tidy.hs 
@@ -1,291 +0,0 @@-{--(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.--}--{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}-module GHC.Core.Tidy (-        tidyExpr, tidyRules, tidyUnfolding-    ) where--#include "GhclibHsVersions.h"--import GHC.Prelude--import GHC.Core-import GHC.Core.Seq ( seqUnfolding )-import GHC.Types.Id-import GHC.Types.Id.Info-import GHC.Types.Demand ( zapDmdEnvSig )-import GHC.Core.Type     ( tidyType, tidyVarBndr )-import GHC.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.SrcLoc-import GHC.Types.Tickish-import GHC.Data.Maybe-import Data.List (mapAccumL)--{--************************************************************************-*                                                                      *-\subsection{Tidying expressions, rules}-*                                                                      *-************************************************************************--}--tidyBind :: TidyEnv-         -> CoreBind-         ->  (TidyEnv, CoreBind)--tidyBind env (NonRec bndr rhs)-  = tidyLetBndr env env bndr =: \ (env', bndr') ->-    (env', NonRec bndr' (tidyExpr env' rhs))--tidyBind env (Rec prs)-  = let-       (bndrs, rhss)  = unzip prs-       (env', bndrs') = mapAccumL (tidyLetBndr env') env bndrs-    in-    map (tidyExpr env') rhss =: \ rhss' ->-    (env', Rec (zip bndrs' rhss'))---------------  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  = unfoldingInfo old_info-        new_unf  = zapUnfolding 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-                    `setStrictnessInfo` zapDmdEnvSig (strictnessInfo old_info)-                    `setDemandInfo`     demandInfo old_info-                    `setInlinePragInfo` inlinePragInfo old_info-                    `setUnfoldingInfo`  new_unf--        old_unf = unfoldingInfo old_info-        new_unf | isStableUnfolding old_unf = tidyUnfolding rec_tidy_env old_unf old_unf-                | otherwise                 = zapUnfolding 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/TyCon/Set.hs view
@@ -4,8 +4,8 @@  -} -{-# LANGUAGE CPP #-} + module GHC.Core.TyCon.Set (         -- * TyCons set type         TyConSet,@@ -17,8 +17,6 @@         intersectsTyConSet, disjointTyConSet, intersectTyConSet,         nameSetAny, nameSetAll     ) where--#include "GhclibHsVersions.h"  import GHC.Prelude
compiler/GHC/CoreToStg.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TypeFamilies #-} @@ -15,50 +16,54 @@  module GHC.CoreToStg ( coreToStg ) where -#include "GhclibHsVersions.h"- import GHC.Prelude +import GHC.Driver.Session+import GHC.Driver.Config.Stg.Debug+ import GHC.Core import GHC.Core.Utils   ( exprType, findDefault, isJoinBind                         , exprIsTickedString_maybe ) import GHC.Core.Opt.Arity   ( manifestArity )+import GHC.Core.Type+import GHC.Core.TyCon+import GHC.Core.DataCon+ import GHC.Stg.Syntax import GHC.Stg.Debug+import GHC.Stg.Utils -import GHC.Core.Type import GHC.Types.RepType-import GHC.Core.TyCon import GHC.Types.Id.Make ( coercionTokenId ) import GHC.Types.Id import GHC.Types.Id.Info-import GHC.Core.DataCon import GHC.Types.CostCentre import GHC.Types.Tickish import GHC.Types.Var.Env-import GHC.Unit.Module import GHC.Types.Name   ( isExternalName, nameModule_maybe ) import GHC.Types.Basic  ( Arity )-import GHC.Builtin.Types ( unboxedUnitDataCon ) import GHC.Types.Literal-import GHC.Utils.Outputable-import GHC.Utils.Monad-import GHC.Data.FastString-import GHC.Utils.Misc-import GHC.Utils.Panic-import GHC.Driver.Session-import GHC.Platform.Ways-import GHC.Driver.Ppr import GHC.Types.ForeignCall import GHC.Types.IPE import GHC.Types.Demand    ( isUsedOnceDmd )-import GHC.Builtin.PrimOps ( PrimCall(..) ) import GHC.Types.SrcLoc    ( mkGeneralSrcSpan ) +import GHC.Unit.Module+import GHC.Builtin.Types ( unboxedUnitDataCon )+import GHC.Data.FastString+import GHC.Platform.Ways+import GHC.Builtin.PrimOps ( PrimCall(..) )++import GHC.Utils.Outputable+import GHC.Utils.Monad+import GHC.Utils.Misc (HasDebugCallStack)+import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Utils.Trace+ import Control.Monad (ap) import Data.Maybe (fromMaybe) import Data.Tuple (swap)-import qualified Data.Set as Set  -- Note [Live vs free] -- ~~~~~~~~~~~~~~~~~~~@@ -242,10 +247,10 @@     -- See Note [Mapping Info Tables to Source Positions]     (!pgm'', !denv) =         if gopt Opt_InfoTableMap dflags-          then collectDebugInformation dflags ml pgm'+          then collectDebugInformation (initStgDebugOpts dflags) ml pgm'           else (pgm', emptyInfoTableProvMap) -    prof = WayProf `Set.member` ways dflags+    prof = ways dflags `hasWay` WayProf      final_ccs       | prof && gopt Opt_AutoSccsOnIndividualCafs dflags@@ -311,7 +316,7 @@     (env', ccs', bind)  coreTopBindToStg dflags this_mod env ccs (Rec pairs)-  = ASSERT( not (null pairs) )+  = assert (not (null pairs)) $     let         binders = map fst pairs @@ -344,7 +349,7 @@              stg_arity =                stgRhsArity stg_rhs -       ; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs,+       ; return (assertPpr (arity_ok stg_arity) (mk_arity_msg stg_arity) stg_rhs,                  ccs') }   where         -- It's vital that the arity on a top-level Id matches@@ -384,10 +389,9 @@ -- on these components, but it in turn is not scrutinised as the basis for any -- decisions.  Hence no black holes. --- No LitInteger's or LitNatural's should be left by the time this is called.+-- No bignum literal should be left by the time this is called. -- CorePrep should have converted them all to a real core representation.-coreToStgExpr (Lit (LitNumber LitNumInteger _)) = panic "coreToStgExpr: LitInteger"-coreToStgExpr (Lit (LitNumber LitNumNatural _)) = panic "coreToStgExpr: LitNatural"+coreToStgExpr (Lit (LitNumber LitNumBigNat _))  = panic "coreToStgExpr: LitNumBigNat" coreToStgExpr (Lit l)                           = return (StgLit l) coreToStgExpr (Var v) = coreToStgApp v [] [] coreToStgExpr (Coercion _)@@ -452,22 +456,26 @@        ; alts2 <- extendVarEnvCts [(bndr, LambdaBound)] (mapM vars_alt alts)        ; return (StgCase scrut2 bndr (mkStgAltType bndr alts) alts2) }   where-    vars_alt :: CoreAlt -> CtsM (AltCon, [Var], StgExpr)+    vars_alt :: CoreAlt -> CtsM StgAlt     vars_alt (Alt con binders rhs)       | DataAlt c <- con, c == unboxedUnitDataCon       = -- This case is a bit smelly.         -- See Note [Nullary unboxed tuple] in GHC.Core.Type         -- where a nullary tuple is mapped to (State# World#)-        ASSERT( null binders )+        assert (null binders) $         do { rhs2 <- coreToStgExpr rhs-           ; return (DEFAULT, [], rhs2)  }+           ; return GenStgAlt{alt_con=DEFAULT,alt_bndrs=mempty,alt_rhs=rhs2}+           }       | otherwise       = let     -- Remove type variables             binders' = filterStgBinders binders         in         extendVarEnvCts [(b, LambdaBound) | b <- binders'] $ do         rhs2 <- coreToStgExpr rhs-        return (con, binders', rhs2)+        return $! GenStgAlt{ alt_con   = con+                           , alt_bndrs = binders'+                           , alt_rhs   = rhs2+                           }  coreToStgExpr (Let bind body) = coreToStgLet bind body coreToStgExpr e               = pprPanic "coreToStgExpr" (ppr e)@@ -484,8 +492,7 @@           Just tc             | isAbstractTyCon tc -> look_for_better_tycon             | isAlgTyCon tc      -> AlgAlt tc-            | otherwise          -> ASSERT2( _is_poly_alt_tycon tc, ppr tc )-                                    PolyAlt+            | otherwise          -> assertPpr (_is_poly_alt_tycon tc) (ppr tc) PolyAlt           Nothing                -> PolyAlt       [non_gcd] -> PrimAlt non_gcd       not_unary -> MultiValAlt (length not_unary)@@ -508,7 +515,7 @@         | ((Alt (DataAlt con) _ _) : _) <- data_alts =                 AlgAlt (dataConTyCon con)         | otherwise =-                ASSERT(null data_alts)+                assert (null data_alts)                 PolyAlt         where                 (data_alts, _deflt) = findDefault alts@@ -547,17 +554,17 @@                 -- Some primitive operator that might be implemented as a library call.                 -- As noted by Note [Eta expanding primops] in GHC.Builtin.PrimOps                 -- we require that primop applications be saturated.-                PrimOpId op      -> ASSERT( saturated )+                PrimOpId op      -> assert saturated $                                     StgOpApp (StgPrimOp op) args' res_ty                  -- A call to some primitive Cmm function.                 FCallId (CCall (CCallSpec (StaticTarget _ lbl (Just pkgId) True)                                           PrimCallConv _))-                                 -> ASSERT( saturated )+                                 -> assert saturated $                                     StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) args' res_ty                  -- A regular foreign call.-                FCallId call     -> ASSERT( saturated )+                FCallId call     -> assert saturated $                                     StgOpApp (StgFCallOp call (idType f)) args' res_ty                  TickBoxOpId {}   -> pprPanic "coreToStg TickBox" $ ppr (f,args')@@ -588,7 +595,7 @@        ; return (StgVarArg coercionTokenId : args', ts) }  coreToStgArgs (Tick t e : args)-  = ASSERT( not (tickishIsCode t) )+  = assert (not (tickishIsCode t)) $     do { (args', ts) <- coreToStgArgs (e : args)        ; let !t' = coreToStgTick (exprType e) t        ; return (args', t':ts) }@@ -620,7 +627,7 @@         stg_arg_rep = typePrimRep (stgArgType stg_arg)         bad_args = not (primRepsCompatible platform arg_rep stg_arg_rep) -    WARN( bad_args, text "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" $$ ppr arg )+    warnPprTrace bad_args "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" (ppr arg) $      return (stg_arg : stg_args, ticks ++ aticks)  coreToStgTick :: Type -- type of the ticked expression@@ -725,10 +732,10 @@   -- so this is not a function binding   | StgConApp con mn args _ <- unticked_rhs   , -- Dynamic StgConApps are updatable-    not (isDllConApp dflags this_mod con args)+    not (isDllConApp (targetPlatform dflags) (gopt Opt_ExternalDynamicRefs dflags) this_mod con args)   = -- CorePrep does this right, but just to make sure-    ASSERT2( not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con)-           , ppr bndr $$ ppr con $$ ppr args)+    assertPpr (not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con))+              (ppr bndr $$ ppr con $$ ppr args)     ( StgRhsCon dontCareCCS con mn ticks args, ccs )    -- Otherwise it's a CAF, see Note [Cost-centre initialization plan].@@ -774,8 +781,10 @@    -- After this point we know that `bndrs` is empty,   -- so this is not a function binding-  | isJoinId bndr -- must be a nullary join point-  = ASSERT(idJoinArity bndr == 0)++  | isJoinId bndr -- Must be a nullary join point+  = -- It might have /type/ arguments (T18328),+    -- so its JoinArity might be >0     StgRhsClosure noExtFieldSilent                   currentCCS                   ReEntrant -- ignored for LNE@@ -930,7 +939,7 @@ lookupBinding :: IdEnv HowBound -> Id -> HowBound lookupBinding env v = case lookupVarEnv env v of                         Just xx -> xx-                        Nothing -> ASSERT2( isGlobalId v, ppr v ) ImportBound+                        Nothing -> assertPpr (isGlobalId v) (ppr v) ImportBound  getAllCAFsCC :: Module -> (CostCentre, CostCentreStack) getAllCAFsCC this_mod =@@ -962,8 +971,8 @@   where     go h@(Var _v)       as ts = (h, as, ts)     go (App f a)        as ts = go f (a:as) ts-    go (Tick t e)       as ts = ASSERT2( not (tickishIsCode t) || all isTypeArg as-                                       , ppr e $$ ppr as $$ ppr ts )+    go (Tick t e)       as ts = assertPpr (not (tickishIsCode t) || all isTypeArg as)+                                          (ppr e $$ ppr as $$ ppr ts) $                                 -- See Note [Ticks in applications]                                 go e as (t:ts) -- ticks can appear in type apps     go (Cast e _)       as ts = go e as ts
compiler/GHC/CoreToStg/Prep.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP          #-}+ {-# LANGUAGE BangPatterns #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}@@ -17,12 +17,9 @@    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Platform-import GHC.Platform.Ways  import GHC.Driver.Session import GHC.Driver.Env@@ -33,7 +30,6 @@  import GHC.Builtin.Names import GHC.Builtin.Types-import GHC.Types.Id.Make ( realWorldPrimId )  import GHC.Core.Utils import GHC.Core.Opt.Arity@@ -49,17 +45,19 @@ import GHC.Core.Opt.OccurAnal import GHC.Core.TyCo.Rep( UnivCoProvenance(..) ) - import GHC.Data.Maybe import GHC.Data.OrdList import GHC.Data.FastString+import GHC.Data.Pair  import GHC.Utils.Error import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Outputable import GHC.Utils.Monad  ( mapAccumLM ) import GHC.Utils.Logger+import GHC.Utils.Trace  import GHC.Types.Demand import GHC.Types.Var@@ -67,25 +65,22 @@ import GHC.Types.Var.Env import GHC.Types.Id import GHC.Types.Id.Info+import GHC.Types.Id.Make ( realWorldPrimId ) import GHC.Types.Basic import GHC.Types.Name   ( NamedThing(..), nameSrcSpan, isInternalName ) import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc ) import GHC.Types.Literal import GHC.Types.Tickish import GHC.Types.TyThing-import GHC.Types.CostCentre ( CostCentre, ccFromThisModule ) import GHC.Types.Unique.Supply -import GHC.Data.Pair import Data.List        ( unfoldr ) import Data.Functor.Identity import Control.Monad-import qualified Data.Set as S  {---- ------------------------------------------------------------------------------ Note [CorePrep Overview]--- ---------------------------------------------------------------------------+Note [CorePrep Overview]+~~~~~~~~~~~~~~~~~~~~~~~~  The goal of this pass is to prepare for code generation. @@ -133,8 +128,7 @@ 9.  Replace (lazy e) by e.  See Note [lazyId magic] in GHC.Types.Id.Make     Also replace (noinline e) by e. -10. Convert bignum literals (LitNatural and LitInteger) into their-    core representation.+10. Convert bignum literals into their core representation.  11. Uphold tick consistency while doing this: We move ticks out of     (non-type) applications where we can, and make sure that we@@ -142,7 +136,7 @@  12. Collect cost centres (including cost centres in unfoldings) if we're in     profiling mode. We have to do this here beucase we won't have unfoldings-    after this pass (see `zapUnfolding` and Note [Drop unfoldings and rules].+    after this pass (see `trimUnfolding` and Note [Drop unfoldings and rules].  13. Eliminate case clutter in favour of unsafe coercions.     See Note [Unsafe coercions]@@ -240,20 +234,15 @@ -}  corePrepPgm :: HscEnv -> Module -> ModLocation -> CoreProgram -> [TyCon]-            -> IO (CoreProgram, S.Set CostCentre)+            -> IO CoreProgram corePrepPgm hsc_env this_mod mod_loc binds data_tycons =-    withTiming logger dflags+    withTiming logger                (text "CorePrep"<+>brackets (ppr this_mod))-               (\(a,b) -> a `seqList` b `seq` ()) $ do+               (\a -> a `seqList` ()) $ do     us <- mkSplitUniqSupply 's'     initialCorePrepEnv <- mkInitialCorePrepEnv hsc_env -    let cost_centres-          | WayProf `S.member` ways dflags-          = collectCostCentres this_mod binds-          | otherwise-          = S.empty-+    let         implicit_binds = mkDataConWorkers dflags mod_loc data_tycons             -- NB: we must feed mkImplicitBinds through corePrep too             -- so that they are suitably cloned and eta-expanded@@ -264,20 +253,19 @@                       return (deFloatTop (floats1 `appendFloats` floats2))      endPassIO hsc_env alwaysQualify CorePrep binds_out []-    return (binds_out, cost_centres)+    return binds_out   where     dflags = hsc_dflags hsc_env     logger = hsc_logger hsc_env  corePrepExpr :: HscEnv -> CoreExpr -> IO CoreExpr corePrepExpr hsc_env expr = do-    let dflags = hsc_dflags hsc_env     let logger = hsc_logger hsc_env-    withTiming logger dflags (text "CorePrep [expr]") (\e -> e `seq` ()) $ do+    withTiming logger (text "CorePrep [expr]") (\e -> e `seq` ()) $ do       us <- mkSplitUniqSupply 's'       initialCorePrepEnv <- mkInitialCorePrepEnv hsc_env       let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr)-      dumpIfSet_dyn logger dflags Opt_D_dump_prep "CorePrep" FormatCore (ppr new_expr)+      putDumpFileMaybe logger Opt_D_dump_prep "CorePrep" FormatCore (ppr new_expr)       return new_expr  corePrepTopBinds :: CorePrepEnv -> [CoreBind] -> UniqSM Floats@@ -288,7 +276,7 @@     go _   []             = return emptyFloats     go env (bind : binds) = do (env', floats, maybe_new_bind)                                  <- cpeBind TopLevel env bind-                               MASSERT(isNothing maybe_new_bind)+                               massert (isNothing maybe_new_bind)                                  -- Only join points get returned this way by                                  -- cpeBind, and no join point may float to top                                floatss <- go env' binds@@ -611,7 +599,7 @@        ; return (env2, floats1, Nothing) }    | otherwise -- A join point; see Note [Join points and floating]-  = ASSERT(not (isTopLevel top_lvl)) -- can't have top-level join point+  = assert (not (isTopLevel top_lvl)) $ -- can't have top-level join point     do { (_, bndr1) <- cpCloneBndr env bndr        ; (bndr2, rhs1) <- cpeJoinPair env bndr1 rhs        ; return (extendCorePrepEnv env bndr bndr2,@@ -656,7 +644,7 @@ -- Used for all bindings -- The binder is already cloned, hence an OutId cpePair top_lvl is_rec dmd is_unlifted env bndr rhs-  = ASSERT(not (isJoinId bndr)) -- those should use cpeJoinPair+  = assert (not (isJoinId bndr)) $ -- those should use cpeJoinPair     do { (floats1, rhs1) <- cpeRhsE env rhs         -- See if we are allowed to float this stuff out of the RHS@@ -666,7 +654,7 @@        ; (floats3, rhs3)             <- if manifestArity rhs1 <= arity                then return (floats2, cpeEtaExpand arity rhs2)-               else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr)+               else warnPprTrace True "CorePrep: silly extra arguments:" (ppr bndr) $                                -- Note [Silly extra arguments]                     (do { v <- newVar (idType bndr)                         ; let float = mkFloat topDmd False v rhs2@@ -734,7 +722,7 @@ -- Used for all join bindings -- No eta-expansion: see Note [Do not eta-expand join points] in GHC.Core.Opt.Simplify.Utils cpeJoinPair env bndr rhs-  = ASSERT(isJoinId bndr)+  = assert (isJoinId bndr) $     do { let Just join_arity = isJoinId_maybe bndr              (bndrs, body)   = collectNBinders join_arity rhs @@ -800,7 +788,8 @@        ; return (bind_floats `appendFloats` body_floats, expr') }  cpeRhsE env (Tick tickish expr)-  | tickishPlace tickish == PlaceNonLam && tickish `tickishScopesLike` SoftScope+  -- Pull out ticks if they are allowed to be floated.+  | floatableTick tickish   = do { (floats, body) <- cpeRhsE env expr          -- See [Floating Ticks in CorePrep]        ; return (unitFloat (FloatTick tickish) `appendFloats` floats, body) }@@ -864,7 +853,7 @@                  -- enabled we instead produce an 'error' expression to catch                  -- the case where a function we think should bottom                  -- unexpectedly returns.-               | gopt Opt_CatchBottoms (cpe_dynFlags env)+               | gopt Opt_CatchNonexhaustiveCases (cpe_dynFlags env)                , not (altsAreExhaustive alts)                = addDefault alts (Just err)                | otherwise = alts@@ -954,11 +943,51 @@   ppr (CpeCast co) = text "cast" <+> ppr co   ppr (CpeTick tick) = text "tick" <+> ppr tick +{- Note [Ticks and mandatory eta expansion]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Something like+    `foo x = ({-# SCC foo #-} tagToEnum#) x :: Bool`+caused a compiler panic in #20938. Why did this happen?+The simplifier will eta-reduce the rhs giving us a partial+application of tagToEnum#. The tick is then pushed inside the+type argument. That is we get+    `(Tick<foo> tagToEnum#) @Bool`+CorePrep would go on to see a undersaturated tagToEnum# application+and eta expand the expression under the tick. Giving us:+    (Tick<scc> (\forall a. x -> tagToEnum# @a x) @Bool+Suddenly tagToEnum# is applied to a polymorphic type and the code generator+panics as it needs a concrete type to determine the representation.++The problem in my eyes was that the tick covers a partial application+of a primop. There is no clear semantic for such a construct as we can't+partially apply a primop since they do not have bindings.+We fix this by expanding the scope of such ticks slightly to cover the body+of the eta-expanded expression.++We do this by:+* Checking if an application is headed by a primOpish thing.+* If so we collect floatable ticks and usually but also profiling ticks+  along with regular arguments.+* When rebuilding the application we check if any profiling ticks appear+  before the primop is fully saturated.+* If the primop isn't fully satured we eta expand the primop application+  and scope the tick to scope over the body of the saturated expression.++Going back to #20938 this means starting with+    `(Tick<foo> tagToEnum#) @Bool`+we check if the function head is a primop (yes). This means we collect the+profiling tick like if it was floatable. Giving us+    (tagToEnum#, [CpeTick foo, CpeApp @Bool]).+cpe_app filters out the tick as a underscoped tick on the expression+`tagToEnum# @Bool`. During eta expansion we then put that tick back onto the+body of the eta-expansion lambdas. Giving us `\x -> Tick<foo> (tagToEnum# @Bool x)`.+-} cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) -- May return a CpeRhs because of saturating primops cpeApp top_env expr-  = do { let (terminal, args, depth) = collect_args expr-       ; cpe_app top_env terminal args depth+  = do { let (terminal, args) = collect_args expr+      --  ; pprTraceM "cpeApp" $ (ppr expr)+       ; cpe_app top_env terminal args        }    where@@ -969,26 +998,34 @@     -- record casts and ticks.  Depth counts the number     -- of arguments that would consume strictness information     -- (so, no type or coercion arguments.)-    collect_args :: CoreExpr -> (CoreExpr, [ArgInfo], Int)-    collect_args e = go e [] 0+    collect_args :: CoreExpr -> (CoreExpr, [ArgInfo])+    collect_args e = go e []       where-        go (App fun arg)      as !depth+        go (App fun arg)      as             = go fun (CpeApp arg : as)-                (if isTyCoArg arg then depth else depth + 1)-        go (Cast fun co)      as depth-            = go fun (CpeCast co : as) depth-        go (Tick tickish fun) as depth-            | tickishPlace tickish == PlaceNonLam-            && tickish `tickishScopesLike` SoftScope-            = go fun (CpeTick tickish : as) depth-        go terminal as depth = (terminal, as, depth)+        go (Cast fun co)      as+            = go fun (CpeCast co : as)+        go (Tick tickish fun) as+            -- Profiling ticks are slightly less strict so we expand their scope+            -- if they cover partial applications of things like primOps.+            -- See Note [Ticks and mandatory eta expansion]+            | floatableTick tickish || isProfTick tickish+            , Var vh <- head+            , Var head' <- lookupCorePrepEnv top_env vh+            , hasNoBinding head'+            = (head,as')+            where+              (head,as') = go fun (CpeTick tickish : as) +        -- Terminal could still be an app if it's wrapped by a tick.+        -- E.g. Tick<foo> (f x) can give us (f x) as terminal.+        go terminal as = (terminal, as)+     cpe_app :: CorePrepEnv-            -> CoreExpr+            -> CoreExpr -- The thing we are calling             -> [ArgInfo]-            -> Int             -> UniqSM (Floats, CpeRhs)-    cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args) depth+    cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args)         | f `hasKey` lazyIdKey          -- Replace (lazy a) with a, and             -- See Note [lazyId magic] in GHC.Types.Id.Make        || f `hasKey` noinlineIdKey      -- Replace (noinline a) with a@@ -1007,36 +1044,43 @@         --      }         --         -- rather than the far superior "f x y".  Test case is par01.-        = let (terminal, args', depth') = collect_args arg-          in cpe_app env terminal (args' ++ args) (depth + depth' - 1)+        = let (terminal, args') = collect_args arg+          in cpe_app env terminal (args' ++ args) -    cpe_app env (Var f) (CpeApp _runtimeRep@Type{} : CpeApp _type@Type{} : CpeApp arg : rest) n+    -- runRW# magic+    cpe_app env (Var f) (CpeApp _runtimeRep@Type{} : CpeApp _type@Type{} : CpeApp arg : rest)         | f `hasKey` runRWKey         -- N.B. While it may appear that n == 1 in the case of runRW#         -- applications, keep in mind that we may have applications that return-        , n >= 1+        , has_value_arg (CpeApp arg : rest)         -- See Note [runRW magic]         -- Replace (runRW# f) by (f realWorld#), beta reducing if possible (this         -- is why we return a CorePrepEnv as well)         = case arg of-            Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body rest (n-2)-            _          -> cpe_app env arg (CpeApp (Var realWorldPrimId) : rest) (n-1)+            Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body rest+            _          -> cpe_app env arg (CpeApp (Var realWorldPrimId) : rest)              -- TODO: What about casts?+        where+          has_value_arg [] = False+          has_value_arg (CpeApp arg:_rest)+            | not (isTyCoArg arg) = True+          has_value_arg (_:rest) = has_value_arg rest -    cpe_app env (Var v) args depth+    cpe_app env (Var v) args       = do { v1 <- fiddleCCall v            ; let e2 = lookupCorePrepEnv env v1                  hd = getIdFromTrivialExpr_maybe e2-           -- NB: depth from collect_args is right, because e2 is a trivial expression-           -- and thus its embedded Id *must* be at the same depth as any-           -- Apps it is under are type applications only (c.f.-           -- exprIsTrivial).  But note that we need the type of the-           -- expression, not the id.-           ; (app, floats) <- rebuild_app env args e2 emptyFloats stricts-           ; mb_saturate hd app floats depth }+                 -- Determine number of required arguments. See Note [Ticks and mandatory eta expansion]+                 min_arity = case hd of+                   Just v_hd -> if hasNoBinding v_hd then Just $! (idArity v_hd) else Nothing+                   Nothing -> Nothing+          --  ; pprTraceM "cpe_app:stricts:" (ppr v <+> ppr args $$ ppr stricts $$ ppr (idCbvMarks_maybe v))+           ; (app, floats, unsat_ticks) <- rebuild_app env args e2 emptyFloats stricts min_arity+           ; mb_saturate hd app floats unsat_ticks depth }         where-          stricts = case idStrictness v of-                            StrictSig (DmdType _ demands _)+          depth = val_args args+          stricts = case idDmdSig v of+                            DmdSig (DmdType _ demands _)                               | listLengthCmp demands depth /= GT -> demands                                     -- length demands <= depth                               | otherwise                         -> []@@ -1048,22 +1092,45 @@          -- We inlined into something that's not a var and has no args.         -- Bounce it back up to cpeRhsE.-    cpe_app env fun [] _ = cpeRhsE env fun+    cpe_app env fun [] = cpeRhsE env fun -        -- N-variable fun, better let-bind it-    cpe_app env fun args depth+    -- Here we get:+    -- N-variable fun, better let-bind it+    -- This case covers literals, apps, lams or let expressions applied to arguments.+    -- Basically things we want to ANF before applying to arguments.+    cpe_app env fun args       = do { (fun_floats, fun') <- cpeArg env evalDmd fun-                          -- The evalDmd says that it's sure to be evaluated,-                          -- so we'll end up case-binding it-           ; (app, floats) <- rebuild_app env args fun' fun_floats []-           ; mb_saturate Nothing app floats depth }+                          -- If evalDmd says that it's sure to be evaluated,+                          -- we'll end up case-binding it+           ; (app, floats,unsat_ticks) <- rebuild_app env args fun' fun_floats [] Nothing+           ; mb_saturate Nothing app floats unsat_ticks (val_args args) } +    -- Count the number of value arguments *and* coercions (since we don't eliminate the later in STG)+    val_args :: [ArgInfo] -> Int+    val_args args = go args 0+      where+        go [] !n = n+        go (info:infos) n =+          case info of+            CpeCast {} -> go infos n+            CpeTick tickish+              | floatableTick tickish                 -> go infos n+              -- If we can't guarantee a tick will be floated out of the application+              -- we can't guarantee the value args following it will be applied.+              | otherwise                             -> n+            CpeApp e                                  -> go infos n'+              where+                !n'+                  | isTypeArg e = n+                  | otherwise   = n+1+     -- Saturate if necessary-    mb_saturate head app floats depth =+    mb_saturate head app floats unsat_ticks depth =        case head of-         Just fn_id -> do { sat_app <- maybeSaturate fn_id app depth+         Just fn_id -> do { sat_app <- maybeSaturate fn_id app depth unsat_ticks                           ; return (floats, sat_app) }-         _other              -> return (floats, app)+         _other     -> do { massert (null unsat_ticks)+                          ; return (floats, app) }      -- Deconstruct and rebuild the application, floating any non-atomic     -- arguments to the outside.  We collect the type of the expression,@@ -1073,25 +1140,51 @@     rebuild_app         :: CorePrepEnv         -> [ArgInfo]                  -- The arguments (inner to outer)+        -> CpeApp                     -- The function+        -> Floats+        -> [Demand]+        -> Maybe Arity+        -> UniqSM (CpeApp+                  ,Floats+                  ,[CoreTickish] -- Underscoped ticks. See Note [Ticks and mandatory eta expansion]+                  )+    rebuild_app env args app floats ss req_depth =+      rebuild_app' env args app floats ss [] (fromMaybe 0 req_depth)++    rebuild_app'+        :: CorePrepEnv+        -> [ArgInfo] -- The arguments (inner to outer)         -> CpeApp         -> Floats         -> [Demand]-        -> UniqSM (CpeApp, Floats)-    rebuild_app _ [] app floats ss-      = ASSERT(null ss) -- make sure we used all the strictness info-        return (app, floats)+        -> [CoreTickish]+        -> Int -- Number of arguments required to satisfy minimal tick scopes.+        -> UniqSM (CpeApp, Floats, [CoreTickish])+    rebuild_app' _ [] app floats ss rt_ticks !_req_depth+      = assertPpr (null ss) (ppr ss)-- make sure we used all the strictness info+        return (app, floats, rt_ticks) -    rebuild_app env (a : as) fun' floats ss = case a of+    rebuild_app' env (a : as) fun' floats ss rt_ticks req_depth = case a of+      -- See Note [Ticks and mandatory eta expansion]+      _+        | not (null rt_ticks)+        , req_depth <= 0+        ->+            let tick_fun = foldr mkTick fun' rt_ticks+            in rebuild_app' env (a : as) tick_fun floats ss rt_ticks req_depth        CpeApp (Type arg_ty)-        -> rebuild_app env as (App fun' (Type arg_ty')) floats ss+        -> rebuild_app' env as (App fun' (Type arg_ty')) floats ss rt_ticks req_depth         where           arg_ty' = cpSubstTy env arg_ty        CpeApp (Coercion co)-        -> rebuild_app env as (App fun' (Coercion co')) floats ss+        -> rebuild_app' env as (App fun' (Coercion co')) floats ss' rt_ticks req_depth         where             co' = cpSubstCo env co+            ss'+              | null ss = []+              | otherwise = tail ss        CpeApp arg -> do         let (ss1, ss_rest)  -- See Note [lazyId magic] in GHC.Types.Id.Make@@ -1100,16 +1193,21 @@                    (ss1 : ss_rest, False) -> (ss1,    ss_rest)                    ([],            _)     -> (topDmd, [])         (fs, arg') <- cpeArg top_env ss1 arg-        rebuild_app env as (App fun' arg') (fs `appendFloats` floats) ss_rest+        rebuild_app' env as (App fun' arg') (fs `appendFloats` floats) ss_rest rt_ticks (req_depth-1)        CpeCast co-        -> rebuild_app env as (Cast fun' co') floats ss+        -> rebuild_app' env as (Cast fun' co') floats ss rt_ticks req_depth         where            co' = cpSubstCo env co-+      -- See Note [Ticks and mandatory eta expansion]       CpeTick tickish+        | tickishPlace tickish == PlaceRuntime+        , req_depth > 0+        -> assert (isProfTick tickish) $+           rebuild_app' env as fun' floats ss (tickish:rt_ticks) req_depth+        | otherwise         -- See [Floating Ticks in CorePrep]-        -> rebuild_app env as fun' (addFloat floats (FloatTick tickish)) ss+        -> rebuild_app' env as fun' (addFloat floats (FloatTick tickish)) ss rt_ticks req_depth  isLazyExpr :: CoreExpr -> Bool -- See Note [lazyId magic] in GHC.Types.Id.Make@@ -1197,7 +1295,7 @@  The late inlining logic in cpe_app would transform this into: -   (case bot of {}) realWorldPrimId#+   (case bot of {}) realWorld#  Which would rise to a panic in CoreToStg.myCollectArgs, which expects only variables in function position.@@ -1393,8 +1491,9 @@ Note [Eta expansion of hasNoBinding things in CorePrep] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ maybeSaturate deals with eta expanding to saturate things that can't deal with-unsaturated applications (identified by 'hasNoBinding', currently just-foreign calls and unboxed tuple/sum constructors).+unsaturated applications (identified by 'hasNoBinding', currently+foreign calls, unboxed tuple/sum constructors, and representation-polymorphic+primitives such as 'coerce' and 'unsafeCoerce#').  Historical Note: Note that eta expansion in CorePrep used to be very fragile due to the "prediction" of CAFfyness that we used to make during tidying.@@ -1403,18 +1502,41 @@ with this another way, as described in Note [Primop wrappers] in GHC.Builtin.PrimOps. -} -maybeSaturate :: Id -> CpeApp -> Int -> UniqSM CpeRhs-maybeSaturate fn expr n_args+maybeSaturate :: Id -> CpeApp -> Int -> [CoreTickish] -> UniqSM CpeRhs+maybeSaturate fn expr n_args unsat_ticks   | hasNoBinding fn        -- There's no binding-  = return sat_expr+  = return $ wrapLamBody (\body -> foldr mkTick body unsat_ticks) sat_expr +  | mark_arity > 0 -- A call-by-value function. See Note [CBV Function Ids]+  , not applied_marks+  = assertPpr+      ( not (isJoinId fn)) -- See Note [Do not eta-expand join points]+      ( ppr fn $$ text "expr:" <+> ppr expr $$ text "n_args:" <+> ppr n_args $$+          text "marks:" <+> ppr (idCbvMarks_maybe fn) $$+          text "join_arity" <+> ppr (isJoinId_maybe fn) $$+          text "fn_arity" <+> ppr fn_arity+       ) $+    -- pprTrace "maybeSat"+    --   ( ppr fn $$ text "expr:" <+> ppr expr $$ text "n_args:" <+> ppr n_args $$+    --       text "marks:" <+> ppr (idCbvMarks_maybe fn) $$+    --       text "join_arity" <+> ppr (isJoinId_maybe fn) $$+    --       text "fn_arity" <+> ppr fn_arity $$+    --       text "excess_arity" <+> ppr excess_arity $$+    --       text "mark_arity" <+> ppr mark_arity+    --    ) $+    return sat_expr+   | otherwise-  = return expr+  = assert (null unsat_ticks) $+    return expr   where-    fn_arity     = idArity fn-    excess_arity = fn_arity - n_args-    sat_expr     = cpeEtaExpand excess_arity expr-+    mark_arity    = idCbvMarkArity fn+    fn_arity      = idArity fn+    excess_arity  = (max fn_arity mark_arity) - n_args+    sat_expr      = cpeEtaExpand excess_arity expr+    applied_marks = n_args >= (length . dropWhile (not . isMarkedCbv) . reverse . expectJust "maybeSaturate" $ (idCbvMarks_maybe fn))+    -- For join points we never eta-expand (See Note [Do not eta-expand join points])+    -- so we assert all arguments that need to be passed cbv are visible so that the backend can evalaute them if required.. {- ************************************************************************ *                                                                      *@@ -1494,19 +1616,24 @@   , not (any (`elemVarSet` fvs_remaining) bndrs)   , exprIsHNF remaining_expr   -- Don't turn value into a non-value                                -- else the behaviour with 'seq' changes-  = Just remaining_expr+  =+    -- pprTrace "prep-reduce" (+    --   text "reduced:" <> ppr remaining_expr $$+    --   ppr (remaining_args)+    --   ) $+    Just remaining_expr   where     (f, args) = collectArgs expr     remaining_expr = mkApps f remaining_args     fvs_remaining = exprFreeVars remaining_expr     (remaining_args, last_args) = splitAt n_remaining args     n_remaining = length args - length bndrs+    n_remaining_vals = length $ filter isRuntimeArg remaining_args      ok bndr (Var arg) = bndr == arg     ok _    _         = False -    -- We can't eta reduce something which must be saturated.-    ok_to_eta_reduce (Var f) = not (hasNoBinding f) && not (isLinearType (idType f))+    ok_to_eta_reduce (Var f) = canEtaReduceToArity f n_remaining n_remaining_vals     ok_to_eta_reduce _       = False -- Safe. ToDo: generalise  @@ -1596,7 +1723,7 @@     -- Otherwise we get  case (\x -> e) of ...!    | is_unlifted = FloatCase rhs bndr DEFAULT [] True-      -- we used to ASSERT2(ok_for_spec, ppr rhs) here, but it is now disabled+      -- we used to assertPpr ok_for_spec (ppr rhs) here, but it is now disabled       -- because exprOkForSpeculation isn't stable under ANF-ing. See for       -- example #19489 where the following unlifted expression:       --@@ -1977,7 +2104,7 @@        -- Drop (now-useless) rules/unfoldings        -- See Note [Drop unfoldings and rules]        -- and Note [Preserve evaluatedness] in GHC.Core.Tidy-       ; let unfolding' = zapUnfolding (realIdUnfolding bndr)+       ; let unfolding' = trimUnfolding (realIdUnfolding bndr)                           -- Simplifier will set the Id's unfolding               bndr'' = bndr' `setIdUnfolding`      unfolding'@@ -2040,7 +2167,7 @@ -- --------------------------------------------------------------------------- -- -- Note [Floating Ticks in CorePrep]---+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- It might seem counter-intuitive to float ticks by default, given -- that we don't actually want to move them if we can help it. On the -- other hand, nothing gets very far in CorePrep anyway, and we want@@ -2077,7 +2204,7 @@         -- those early, as relying on mkTick to spot it after the fact         -- can yield O(n^3) complexity [#11095]         go (floats, ticks) (FloatTick t)-          = ASSERT(tickishPlace t == PlaceNonLam)+          = assert (tickishPlace t == PlaceNonLam)             (floats, if any (flip tickishContains t) ticks                      then ticks else t:ticks)         go (floats, ticks) f@@ -2090,42 +2217,10 @@         wrapBind t (NonRec binder rhs) = NonRec binder (mkTick t rhs)         wrapBind t (Rec pairs)         = Rec (mapSnd (mkTick t) pairs) ---------------------------------------------------------------------------------- Collecting cost centres--- ------------------------------------------------------------------------------- | Collect cost centres defined in the current module, including those in--- unfoldings.-collectCostCentres :: Module -> CoreProgram -> S.Set CostCentre-collectCostCentres mod_name-  = foldl' go_bind S.empty-  where-    go cs e = case e of-      Var{} -> cs-      Lit{} -> cs-      App e1 e2 -> go (go cs e1) e2-      Lam _ e -> go cs e-      Let b e -> go (go_bind cs b) e-      Case scrt _ _ alts -> go_alts (go cs scrt) alts-      Cast e _ -> go cs e-      Tick (ProfNote cc _ _) e ->-        go (if ccFromThisModule cc mod_name then S.insert cc cs else cs) e-      Tick _ e -> go cs e-      Type{} -> cs-      Coercion{} -> cs--    go_alts = foldl' (\cs (Alt _con _bndrs e) -> go cs e)--    go_bind :: S.Set CostCentre -> CoreBind -> S.Set CostCentre-    go_bind cs (NonRec b e) =-      go (maybe cs (go cs) (get_unf b)) e-    go_bind cs (Rec bs) =-      foldl' (\cs' (b, e) -> go (maybe cs' (go cs') (get_unf b)) e) cs bs--    -- Unfoldings may have cost centres that in the original definion are-    -- optimized away, see #5889.-    get_unf = maybeUnfoldingTemplate . realIdUnfolding-+floatableTick :: GenTickish pass -> Bool+floatableTick tickish =+    tickishPlace tickish == PlaceNonLam &&+    tickish `tickishScopesLike` SoftScope  ------------------------------------------------------------------------------ -- Numeric literals@@ -2159,37 +2254,9 @@     let       convertNumLit nt i = case nt of-         LitNumInteger -> Just (convertInteger i)-         LitNumNatural -> Just (convertNatural i)+         LitNumBigNat  -> Just (convertBignatPrim i)          _             -> Nothing -      convertInteger i-         | platformInIntRange platform i -- fit in a Int#-         = mkConApp integerISDataCon [Lit (mkLitInt platform i)]--         | otherwise -- build a BigNat and embed into IN or IP-         = let con = if i > 0 then integerIPDataCon else integerINDataCon-           in mkBigNum con (convertBignatPrim (abs i))--      convertNatural i-         | platformInWordRange platform i -- fit in a Word#-         = mkConApp naturalNSDataCon [Lit (mkLitWord platform i)]--         | otherwise --build a BigNat and embed into NB-         = mkBigNum naturalNBDataCon (convertBignatPrim i)--      -- we can't simply generate:-      ---      --    NB (bigNatFromWordList# [W# 10, W# 20])-      ---      -- using `mkConApp` because it isn't in ANF form. Instead we generate:-      ---      --    case bigNatFromWordList# [W# 10, W# 20] of ba { DEFAULT -> NB ba }-      ---      -- via `mkCoreApps`--      mkBigNum con ba = mkCoreApps (Var (dataConWorkId con)) [ba]-       convertBignatPrim i =          let             target    = targetPlatform dflags@@ -2216,3 +2283,4 @@      return convertNumLit+
compiler/GHC/Data/Graph/Base.hs view
@@ -42,7 +42,7 @@ --      There used to be more fields, but they were turfed out in a previous revision. --      maybe we'll want more later.. ---data Graph k cls color+newtype Graph k cls color         = Graph {         -- | All active nodes in the graph.           graphMap              :: UniqFM k (Node k cls color)  }
compiler/GHC/Data/Graph/Color.hs view
@@ -268,9 +268,9 @@ assignColors colors graph ks         = assignColors' colors graph [] ks - where  assignColors' :: UniqFM cls (UniqSet color)       -- ^ map of (node class -> set of colors available for this class).-                        -> Graph k cls color            -- ^ the graph-                        -> [k]                          -- ^ nodes to assign a color to.+ where  assignColors' :: UniqFM cls (UniqSet color)     -- map of (node class -> set of colors available for this class).+                        -> Graph k cls color            -- the graph+                        -> [k]                          -- nodes to assign a color to.                         -> [k]                         -> ( Graph k cls color          -- the colored graph                         , [k])@@ -303,9 +303,9 @@ selectColor         :: ( Uniquable k, Uniquable cls, Uniquable color            , Outputable cls)-        => UniqFM cls (UniqSet color)       -- ^ map of (node class -> set of colors available for this class).-        -> Graph k cls color            -- ^ the graph-        -> k                            -- ^ key of the node to select a color for.+        => UniqFM cls (UniqSet color)   -- map of (node class -> set of colors available for this class).+        -> Graph k cls color            -- the graph+        -> k                            -- key of the node to select a color for.         -> Maybe color  selectColor colors graph u
+ compiler/GHC/Driver/Backpack.hs view
@@ -0,0 +1,938 @@++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+++-- | This is the driver for the 'ghc --backpack' mode, which+-- is a reimplementation of the "package manager" bits of+-- Backpack directly in GHC.  The basic method of operation+-- is to compile packages and then directly insert them into+-- GHC's in memory database.+--+-- The compilation products of this mode aren't really suitable+-- for Cabal, because GHC makes up component IDs for the things+-- it builds and doesn't serialize out the database contents.+-- But it's still handy for constructing tests.++module GHC.Driver.Backpack (doBackpack) where++import GHC.Prelude++-- In a separate module because it hooks into the parser.+import GHC.Driver.Backpack.Syntax+import GHC.Driver.Config.Finder (initFinderOpts)+import GHC.Driver.Config.Parser (initParserOpts)+import GHC.Driver.Config.Diagnostic+import GHC.Driver.Monad+import GHC.Driver.Session+import GHC.Driver.Ppr+import GHC.Driver.Main+import GHC.Driver.Make+import GHC.Driver.Env+import GHC.Driver.Errors+import GHC.Driver.Errors.Types++import GHC.Parser+import GHC.Parser.Header+import GHC.Parser.Lexer+import GHC.Parser.Annotation++import GHC.Rename.Names++import GHC hiding (Failed, Succeeded)+import GHC.Tc.Utils.Monad+import GHC.Iface.Recomp+import GHC.Builtin.Names++import GHC.Types.SrcLoc+import GHC.Types.SourceError+import GHC.Types.SourceFile+import GHC.Types.Unique.FM+import GHC.Types.Unique.DFM+import GHC.Types.Unique.DSet++import GHC.Utils.Outputable+import GHC.Utils.Fingerprint+import GHC.Utils.Misc+import GHC.Utils.Panic+import GHC.Utils.Error+import GHC.Utils.Logger++import GHC.Unit+import GHC.Unit.Env+import GHC.Unit.External+import GHC.Unit.Finder+import GHC.Unit.Module.Graph+import GHC.Unit.Module.ModSummary+import GHC.Unit.Home.ModInfo++import GHC.Linker.Types++import qualified GHC.LanguageExtensions as LangExt++import GHC.Data.Maybe+import GHC.Data.StringBuffer+import GHC.Data.FastString+import qualified GHC.Data.EnumSet as EnumSet+import qualified GHC.Data.ShortText as ST++import Data.List ( partition )+import System.Exit+import Control.Monad+import System.FilePath+import Data.Version++-- for the unification+import Data.IORef+import Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.Set as Set++-- | Entry point to compile a Backpack file.+doBackpack :: [FilePath] -> Ghc ()+doBackpack [src_filename] = do+    -- Apply options from file to dflags+    dflags0 <- getDynFlags+    let dflags1 = dflags0+    let parser_opts1 = initParserOpts dflags1+    (p_warns, src_opts) <- liftIO $ getOptionsFromFile parser_opts1 src_filename+    (dflags, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags1 src_opts+    modifySession (hscSetFlags dflags)+    logger <- getLogger -- Get the logger after having set the session flags,+                        -- so that logger options are correctly set.+                        -- Not doing so caused #20396.+    -- Cribbed from: preprocessFile / GHC.Driver.Pipeline+    liftIO $ checkProcessArgsResult unhandled_flags+    liftIO $ printOrThrowDiagnostics logger (initDiagOpts dflags) (GhcPsMessage <$> p_warns)+    liftIO $ handleFlagWarnings logger (initDiagOpts dflags) warns+    -- TODO: Preprocessing not implemented++    buf <- liftIO $ hGetStringBuffer src_filename+    let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 -- TODO: not great+    case unP parseBackpack (initParserState (initParserOpts dflags) buf loc) of+        PFailed pst -> throwErrors (GhcPsMessage <$> getPsErrorMessages pst)+        POk _ pkgname_bkp -> do+            -- OK, so we have an LHsUnit PackageName, but we want an+            -- LHsUnit HsComponentId.  So let's rename it.+            hsc_env <- getSession+            let bkp = renameHsUnits (hsc_units hsc_env) (bkpPackageNameMap pkgname_bkp) pkgname_bkp+            initBkpM src_filename bkp $+                forM_ (zip [1..] bkp) $ \(i, lunit) -> do+                    let comp_name = unLoc (hsunitName (unLoc lunit))+                    msgTopPackage (i,length bkp) comp_name+                    innerBkpM $ do+                        let (cid, insts) = computeUnitId lunit+                        if null insts+                            then if cid == UnitId (fsLit "main")+                                    then compileExe lunit+                                    else compileUnit cid []+                            else typecheckUnit cid insts+doBackpack _ =+    throwGhcException (CmdLineError "--backpack can only process a single file")++computeUnitId :: LHsUnit HsComponentId -> (UnitId, [(ModuleName, Module)])+computeUnitId (L _ unit) = (cid, [ (r, mkHoleModule r) | r <- reqs ])+  where+    cid = hsComponentId (unLoc (hsunitName unit))+    reqs = uniqDSetToList (unionManyUniqDSets (map (get_reqs . unLoc) (hsunitBody unit)))+    get_reqs (DeclD HsigFile (L _ modname) _) = unitUniqDSet modname+    get_reqs (DeclD HsSrcFile _ _) = emptyUniqDSet+    get_reqs (DeclD HsBootFile _ _) = emptyUniqDSet+    get_reqs (IncludeD (IncludeDecl (L _ hsuid) _ _)) =+        unitFreeModuleHoles (convertHsComponentId hsuid)++-- | Tiny enum for all types of Backpack operations we may do.+data SessionType+    -- | A compilation operation which will result in a+    -- runnable executable being produced.+    = ExeSession+    -- | A type-checking operation which produces only+    -- interface files, no object files.+    | TcSession+    -- | A compilation operation which produces both+    -- interface files and object files.+    | CompSession+    deriving (Eq)++-- | Create a temporary Session to do some sort of type checking or+-- compilation.+withBkpSession :: UnitId+               -> [(ModuleName, Module)]+               -> [(Unit, ModRenaming)]+               -> SessionType   -- what kind of session are we doing+               -> BkpM a        -- actual action to run+               -> BkpM a+withBkpSession cid insts deps session_type do_this = do+    dflags <- getDynFlags+    let cid_fs = unitFS cid+        is_primary = False+        uid_str = unpackFS (mkInstantiatedUnitHash cid insts)+        cid_str = unpackFS cid_fs+        -- There are multiple units in a single Backpack file, so we+        -- need to separate out the results in those cases.  Right now,+        -- we follow this hierarchy:+        --      $outputdir/$compid          --> typecheck results+        --      $outputdir/$compid/$unitid  --> compile results+        key_base p | Just f <- p dflags = f+                   | otherwise          = "."+        sub_comp p | is_primary = p+                   | otherwise = p </> cid_str+        outdir p | CompSession <- session_type+                 -- Special case when package is definite+                 , not (null insts) = sub_comp (key_base p) </> uid_str+                 | otherwise = sub_comp (key_base p)++        mk_temp_env hsc_env =+          hscUpdateFlags (\dflags -> mk_temp_dflags (hsc_units hsc_env) dflags) hsc_env+        mk_temp_dflags unit_state dflags = dflags+            { backend = case session_type of+                            TcSession -> NoBackend+                            _         -> backend dflags+            , ghcLink = case session_type of+                            TcSession -> NoLink+                            _         -> ghcLink dflags+            , homeUnitInstantiations_ = insts+                                     -- if we don't have any instantiation, don't+                                     -- fill `homeUnitInstanceOfId` as it makes no+                                     -- sense (we're not instantiating anything)+            , homeUnitInstanceOf_   = if null insts then Nothing else Just cid+            , homeUnitId_ = case session_type of+                TcSession -> newUnitId cid Nothing+                -- No hash passed if no instances+                _ | null insts -> newUnitId cid Nothing+                  | otherwise  -> newUnitId cid (Just (mkInstantiatedUnitHash cid insts))+++            -- If we're type-checking an indefinite package, we want to+            -- turn on interface writing.  However, if the user also+            -- explicitly passed in `-fno-code`, we DON'T want to write+            -- interfaces unless the user also asked for `-fwrite-interface`.+            -- See Note [-fno-code mode]+            , generalFlags = case session_type of+                -- Make sure to write interfaces when we are type-checking+                -- indefinite packages.+                TcSession+                  | backend dflags /= NoBackend+                  -> EnumSet.insert Opt_WriteInterface (generalFlags dflags)+                _ -> generalFlags dflags++            -- Setup all of the output directories according to our hierarchy+            , objectDir   = Just (outdir objectDir)+            , hiDir       = Just (outdir hiDir)+            , stubDir     = Just (outdir stubDir)+            -- Unset output-file for non exe builds+            , outputFile_ = case session_type of+                ExeSession -> outputFile_ dflags+                _          -> Nothing+            , dynOutputFile_ = case session_type of+                ExeSession -> dynOutputFile_ dflags+                _          -> Nothing+            -- Clear the import path so we don't accidentally grab anything+            , importPaths = []+            -- Synthesize the flags+            , packageFlags = packageFlags dflags ++ map (\(uid0, rn) ->+              let uid = unwireUnit unit_state+                        $ improveUnit unit_state+                        $ renameHoleUnit unit_state (listToUFM insts) uid0+              in ExposePackage+                (showSDoc dflags+                    (text "-unit-id" <+> ppr uid <+> ppr rn))+                (UnitIdArg uid) rn) deps+            }+    withTempSession mk_temp_env $ do+      dflags <- getSessionDynFlags+      -- pprTrace "flags" (ppr insts <> ppr deps) $ return ()+      setSessionDynFlags dflags -- calls initUnits+      do_this++withBkpExeSession :: [(Unit, ModRenaming)] -> BkpM a -> BkpM a+withBkpExeSession deps do_this =+    withBkpSession (UnitId (fsLit "main")) [] deps ExeSession do_this++getSource :: UnitId -> BkpM (LHsUnit HsComponentId)+getSource cid = do+    bkp_env <- getBkpEnv+    case Map.lookup cid (bkp_table bkp_env) of+        Nothing -> pprPanic "missing needed dependency" (ppr cid)+        Just lunit -> return lunit++typecheckUnit :: UnitId -> [(ModuleName, Module)] -> BkpM ()+typecheckUnit cid insts = do+    lunit <- getSource cid+    buildUnit TcSession cid insts lunit++compileUnit :: UnitId -> [(ModuleName, Module)] -> BkpM ()+compileUnit cid insts = do+    -- Let everyone know we're building this unit+    msgUnitId (mkVirtUnit cid insts)+    lunit <- getSource cid+    buildUnit CompSession cid insts lunit++-- | Compute the dependencies with instantiations of a syntactic+-- HsUnit; e.g., wherever you see @dependency p[A=<A>]@ in a+-- unit file, return the 'Unit' corresponding to @p[A=<A>]@.+-- The @include_sigs@ parameter controls whether or not we also+-- include @dependency signature@ declarations in this calculation.+--+-- Invariant: this NEVER returns UnitId.+hsunitDeps :: Bool {- include sigs -} -> HsUnit HsComponentId -> [(Unit, ModRenaming)]+hsunitDeps include_sigs unit = concatMap get_dep (hsunitBody unit)+  where+    get_dep (L _ (IncludeD (IncludeDecl (L _ hsuid) mb_lrn is_sig)))+        | include_sigs || not is_sig = [(convertHsComponentId hsuid, go mb_lrn)]+        | otherwise = []+      where+        go Nothing = ModRenaming True []+        go (Just lrns) = ModRenaming False (map convRn lrns)+          where+            convRn (L _ (Renaming (L _ from) Nothing))         = (from, from)+            convRn (L _ (Renaming (L _ from) (Just (L _ to)))) = (from, to)+    get_dep _ = []++buildUnit :: SessionType -> UnitId -> [(ModuleName, Module)] -> LHsUnit HsComponentId -> BkpM ()+buildUnit session cid insts lunit = do+    -- NB: include signature dependencies ONLY when typechecking.+    -- If we're compiling, it's not necessary to recursively+    -- compile a signature since it isn't going to produce+    -- any object files.+    let deps_w_rns = hsunitDeps (session == TcSession) (unLoc lunit)+        raw_deps = map fst deps_w_rns+    hsc_env <- getSession+    -- The compilation dependencies are just the appropriately filled+    -- in unit IDs which must be compiled before we can compile.+    let hsubst = listToUFM insts+        deps0 = map (renameHoleUnit (hsc_units hsc_env) hsubst) raw_deps++    -- Build dependencies OR make sure they make sense. BUT NOTE,+    -- we can only check the ones that are fully filled; the rest+    -- we have to defer until we've typechecked our local signature.+    -- TODO: work this into GHC.Driver.Make!!+    forM_ (zip [1..] deps0) $ \(i, dep) ->+        case session of+            TcSession -> return ()+            _ -> compileInclude (length deps0) (i, dep)++    -- IMPROVE IT+    let deps = map (improveUnit (hsc_units hsc_env)) deps0++    mb_old_eps <- case session of+                    TcSession -> fmap Just getEpsGhc+                    _ -> return Nothing++    conf <- withBkpSession cid insts deps_w_rns session $ do++        dflags <- getDynFlags+        mod_graph <- hsunitModuleGraph False (unLoc lunit)++        msg <- mkBackpackMsg+        ok <- load' noIfaceCache LoadAllTargets (Just msg) mod_graph+        when (failed ok) (liftIO $ exitWith (ExitFailure 1))++        let hi_dir = expectJust (panic "hiDir Backpack") $ hiDir dflags+            export_mod ms = (ms_mod_name ms, ms_mod ms)+            -- Export everything!+            mods = [ export_mod ms | ms <- mgModSummaries mod_graph+                                   , ms_hsc_src ms == HsSrcFile ]++        -- Compile relevant only+        hsc_env <- getSession+        let home_mod_infos = eltsUDFM (hsc_HPT hsc_env)+            linkables = map (expectJust "bkp link" . hm_linkable)+                      . filter ((==HsSrcFile) . mi_hsc_src . hm_iface)+                      $ home_mod_infos+            getOfiles LM{ linkableUnlinked = us } = map nameOfObject (filter isObject us)+            obj_files = concatMap getOfiles linkables+            state     = hsc_units hsc_env++        let compat_fs = unitIdFS cid+            compat_pn = PackageName compat_fs+            unit_id   = homeUnitId (hsc_home_unit hsc_env)++        return GenericUnitInfo {+            -- Stub data+            unitAbiHash = "",+            unitPackageId = PackageId compat_fs,+            unitPackageName = compat_pn,+            unitPackageVersion = makeVersion [],+            unitId = unit_id,+            unitComponentName = Nothing,+            unitInstanceOf = cid,+            unitInstantiations = insts,+            -- Slight inefficiency here haha+            unitExposedModules = map (\(m,n) -> (m,Just n)) mods,+            unitHiddenModules = [], -- TODO: doc only+            unitDepends = case session of+                        -- Technically, we should state that we depend+                        -- on all the indefinite libraries we used to+                        -- typecheck this.  However, this field isn't+                        -- really used for anything, so we leave it+                        -- blank for now.+                        TcSession -> []+                        _ -> map (toUnitId . unwireUnit state)+                                $ deps ++ [ moduleUnit mod+                                          | (_, mod) <- insts+                                          , not (isHoleModule mod) ],+            unitAbiDepends = [],+            unitLinkerOptions = case session of+                                 TcSession -> []+                                 _ -> map ST.pack $ obj_files,+            unitImportDirs = [ ST.pack $ hi_dir ],+            unitIsExposed = False,+            unitIsIndefinite = case session of+                                 TcSession -> True+                                 _ -> False,+            -- nope+            unitLibraries = [],+            unitExtDepLibsSys = [],+            unitExtDepLibsGhc = [],+            unitLibraryDynDirs = [],+            unitLibraryDirs = [],+            unitExtDepFrameworks = [],+            unitExtDepFrameworkDirs = [],+            unitCcOptions = [],+            unitIncludes = [],+            unitIncludeDirs = [],+            unitHaddockInterfaces = [],+            unitHaddockHTMLs = [],+            unitIsTrusted = False+            }+++    addUnit conf+    case mb_old_eps of+        Just old_eps -> updateEpsGhc_ (const old_eps)+        _ -> return ()++compileExe :: LHsUnit HsComponentId -> BkpM ()+compileExe lunit = do+    msgUnitId mainUnit+    let deps_w_rns = hsunitDeps False (unLoc lunit)+        deps = map fst deps_w_rns+        -- no renaming necessary+    forM_ (zip [1..] deps) $ \(i, dep) ->+        compileInclude (length deps) (i, dep)+    withBkpExeSession deps_w_rns $ do+        mod_graph <- hsunitModuleGraph True (unLoc lunit)+        msg <- mkBackpackMsg+        ok <- load' noIfaceCache LoadAllTargets (Just msg) mod_graph+        when (failed ok) (liftIO $ exitWith (ExitFailure 1))++-- | Register a new virtual unit database containing a single unit+addUnit :: GhcMonad m => UnitInfo -> m ()+addUnit u = do+    hsc_env <- getSession+    logger <- getLogger+    let dflags0 = hsc_dflags hsc_env+    let old_unit_env = hsc_unit_env hsc_env+    newdbs <- case ue_unit_dbs old_unit_env of+        Nothing  -> panic "addUnit: called too early"+        Just dbs ->+         let newdb = UnitDatabase+               { unitDatabasePath  = "(in memory " ++ showSDoc dflags0 (ppr (unitId u)) ++ ")"+               , unitDatabaseUnits = [u]+               }+         in return (dbs ++ [newdb]) -- added at the end because ordering matters+    (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 (Just newdbs) (hsc_all_home_unit_ids hsc_env)++    -- update platform constants+    dflags <- liftIO $ updatePlatformConstants dflags0 mconstants++    let unit_env = ue_setUnits unit_state $ ue_setUnitDbs (Just dbs) $ UnitEnv+          { ue_platform  = targetPlatform dflags+          , ue_namever   = ghcNameVersion dflags+          , ue_current_unit = homeUnitId home_unit++          , ue_home_unit_graph =+                unitEnv_singleton+                    (homeUnitId home_unit)+                    (mkHomeUnitEnv dflags (ue_hpt old_unit_env) (Just home_unit))+          , ue_eps       = ue_eps old_unit_env+          }+    setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env }++compileInclude :: Int -> (Int, Unit) -> BkpM ()+compileInclude n (i, uid) = do+    hsc_env <- getSession+    let pkgs = hsc_units hsc_env+    msgInclude (i, n) uid+    -- Check if we've compiled it already+    case uid of+      HoleUnit   -> return ()+      RealUnit _ -> return ()+      VirtUnit i -> case lookupUnit pkgs uid of+        Nothing -> innerBkpM $ compileUnit (instUnitInstanceOf i) (instUnitInsts i)+        Just _  -> return ()++-- ----------------------------------------------------------------------------+-- Backpack monad++-- | Backpack monad is a 'GhcMonad' which also maintains a little extra state+-- beyond the 'Session', c.f. 'BkpEnv'.+type BkpM = IOEnv BkpEnv++-- | Backpack environment.  NB: this has a 'Session' and not an 'HscEnv',+-- because we are going to update the 'HscEnv' as we go.+data BkpEnv+    = BkpEnv {+        -- | The session+        bkp_session :: Session,+        -- | The filename of the bkp file we're compiling+        bkp_filename :: FilePath,+        -- | Table of source units which we know how to compile+        bkp_table :: Map UnitId (LHsUnit HsComponentId),+        -- | When a package we are compiling includes another package+        -- which has not been compiled, we bump the level and compile+        -- that.+        bkp_level :: Int+    }++-- Blah, to get rid of the default instance for IOEnv+-- TODO: just make a proper new monad for BkpM, rather than use IOEnv+instance {-# OVERLAPPING #-} HasDynFlags BkpM where+    getDynFlags = fmap hsc_dflags getSession+instance {-# OVERLAPPING #-} HasLogger BkpM where+    getLogger = fmap hsc_logger getSession+++instance GhcMonad BkpM where+    getSession = do+        Session s <- fmap bkp_session getEnv+        readMutVar s+    setSession hsc_env = do+        Session s <- fmap bkp_session getEnv+        writeMutVar s hsc_env++-- | Get the current 'BkpEnv'.+getBkpEnv :: BkpM BkpEnv+getBkpEnv = getEnv++-- | Get the nesting level, when recursively compiling modules.+getBkpLevel :: BkpM Int+getBkpLevel = bkp_level `fmap` getBkpEnv++-- | Run a 'BkpM' computation, with the nesting level bumped one.+innerBkpM :: BkpM a -> BkpM a+innerBkpM do_this =+    -- NB: withTempSession mutates, so we don't have to worry+    -- about bkp_session being stale.+    updEnv (\env -> env { bkp_level = bkp_level env + 1 }) do_this++-- | Update the EPS from a 'GhcMonad'. TODO move to appropriate library spot.+updateEpsGhc_ :: GhcMonad m => (ExternalPackageState -> ExternalPackageState) -> m ()+updateEpsGhc_ f = do+    hsc_env <- getSession+    liftIO $ atomicModifyIORef' (euc_eps (ue_eps (hsc_unit_env hsc_env))) (\x -> (f x, ()))++-- | Get the EPS from a 'GhcMonad'.+getEpsGhc :: GhcMonad m => m ExternalPackageState+getEpsGhc = do+    hsc_env <- getSession+    liftIO $ hscEPS hsc_env++-- | Run 'BkpM' in 'Ghc'.+initBkpM :: FilePath -> [LHsUnit HsComponentId] -> BkpM a -> Ghc a+initBkpM file bkp m =+  reifyGhc $ \session -> do+    let env = BkpEnv {+        bkp_session = session,+        bkp_table = Map.fromList [(hsComponentId (unLoc (hsunitName (unLoc u))), u) | u <- bkp],+        bkp_filename = file,+        bkp_level = 0+      }+    runIOEnv env m++-- ----------------------------------------------------------------------------+-- Messaging++-- | Print a compilation progress message, but with indentation according+-- to @level@ (for nested compilation).+backpackProgressMsg :: Int -> Logger -> SDoc -> IO ()+backpackProgressMsg level logger msg =+    compilationProgressMsg logger $ text (replicate (level * 2) ' ') -- TODO: use GHC.Utils.Ppr.RStr+                                    <> msg++-- | Creates a 'Messager' for Backpack compilation; this is basically+-- a carbon copy of 'batchMsg' but calling 'backpackProgressMsg', which+-- handles indentation.+mkBackpackMsg :: BkpM Messager+mkBackpackMsg = do+    level <- getBkpLevel+    return $ \hsc_env mod_index recomp node ->+      let dflags = hsc_dflags hsc_env+          logger = hsc_logger hsc_env+          state = hsc_units hsc_env+          showMsg msg reason =+            backpackProgressMsg level logger $ pprWithUnitState state $+                showModuleIndex mod_index <>+                msg <> showModMsg dflags (recompileRequired recomp) node+                    <> reason+      in case node of+        InstantiationNode _ _ ->+          case recomp of+            UpToDate+              | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping  ") empty+              | otherwise -> return ()+            NeedsRecompile reason0 -> showMsg (text "Instantiating ") $ case reason0 of+              MustCompile -> empty+              RecompBecause reason -> text " [" <> pprWithUnitState state (ppr reason) <> text "]"+        ModuleNode _ _ ->+          case recomp of+            UpToDate+              | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping  ") empty+              | otherwise -> return ()+            NeedsRecompile reason0 -> showMsg (text "Compiling ") $ case reason0 of+              MustCompile -> empty+              RecompBecause reason -> text " [" <> pprWithUnitState state (ppr reason) <> text "]"+        LinkNode _ _ -> showMsg (text "Linking ")  empty++-- | 'PprStyle' for Backpack messages; here we usually want the module to+-- be qualified (so we can tell how it was instantiated.) But we try not+-- to qualify packages so we can use simple names for them.+backpackStyle :: PprStyle+backpackStyle =+    mkUserStyle+        (QueryQualify neverQualifyNames+                      alwaysQualifyModules+                      neverQualifyPackages) AllTheWay++-- | Message when we initially process a Backpack unit.+msgTopPackage :: (Int,Int) -> HsComponentId -> BkpM ()+msgTopPackage (i,n) (HsComponentId (PackageName fs_pn) _) = do+    logger <- getLogger+    level <- getBkpLevel+    liftIO . backpackProgressMsg level logger+        $ showModuleIndex (i, n) <> text "Processing " <> ftext fs_pn++-- | Message when we instantiate a Backpack unit.+msgUnitId :: Unit -> BkpM ()+msgUnitId pk = do+    logger <- getLogger+    hsc_env <- getSession+    level <- getBkpLevel+    let state = hsc_units hsc_env+    liftIO . backpackProgressMsg level logger+        $ pprWithUnitState state+        $ text "Instantiating "+           <> withPprStyle backpackStyle (ppr pk)++-- | Message when we include a Backpack unit.+msgInclude :: (Int,Int) -> Unit -> BkpM ()+msgInclude (i,n) uid = do+    logger <- getLogger+    hsc_env <- getSession+    level <- getBkpLevel+    let state = hsc_units hsc_env+    liftIO . backpackProgressMsg level logger+        $ pprWithUnitState state+        $ showModuleIndex (i, n) <> text "Including "+            <> withPprStyle backpackStyle (ppr uid)++-- ----------------------------------------------------------------------------+-- Conversion from PackageName to HsComponentId++type PackageNameMap a = UniqFM PackageName a++-- For now, something really simple, since we're not actually going+-- to use this for anything+unitDefines :: LHsUnit PackageName -> (PackageName, HsComponentId)+unitDefines (L _ HsUnit{ hsunitName = L _ pn@(PackageName fs) })+    = (pn, HsComponentId pn (UnitId fs))++bkpPackageNameMap :: [LHsUnit PackageName] -> PackageNameMap HsComponentId+bkpPackageNameMap units = listToUFM (map unitDefines units)++renameHsUnits :: UnitState -> PackageNameMap HsComponentId -> [LHsUnit PackageName] -> [LHsUnit HsComponentId]+renameHsUnits pkgstate m units = map (fmap renameHsUnit) units+  where++    renamePackageName :: PackageName -> HsComponentId+    renamePackageName pn =+        case lookupUFM m pn of+            Nothing ->+                case lookupPackageName pkgstate pn of+                    Nothing -> error "no package name"+                    Just cid -> HsComponentId pn cid+            Just hscid -> hscid++    renameHsUnit :: HsUnit PackageName -> HsUnit HsComponentId+    renameHsUnit u =+        HsUnit {+            hsunitName = fmap renamePackageName (hsunitName u),+            hsunitBody = map (fmap renameHsUnitDecl) (hsunitBody u)+        }++    renameHsUnitDecl :: HsUnitDecl PackageName -> HsUnitDecl HsComponentId+    renameHsUnitDecl (DeclD a b c) = DeclD a b c+    renameHsUnitDecl (IncludeD idecl) =+        IncludeD IncludeDecl {+            idUnitId = fmap renameHsUnitId (idUnitId idecl),+            idModRenaming = idModRenaming idecl,+            idSignatureInclude = idSignatureInclude idecl+        }++    renameHsUnitId :: HsUnitId PackageName -> HsUnitId HsComponentId+    renameHsUnitId (HsUnitId ln subst)+        = HsUnitId (fmap renamePackageName ln) (map (fmap renameHsModuleSubst) subst)++    renameHsModuleSubst :: HsModuleSubst PackageName -> HsModuleSubst HsComponentId+    renameHsModuleSubst (lk, lm)+        = (lk, fmap renameHsModuleId lm)++    renameHsModuleId :: HsModuleId PackageName -> HsModuleId HsComponentId+    renameHsModuleId (HsModuleVar lm) = HsModuleVar lm+    renameHsModuleId (HsModuleId luid lm) = HsModuleId (fmap renameHsUnitId luid) lm++convertHsComponentId :: HsUnitId HsComponentId -> Unit+convertHsComponentId (HsUnitId (L _ hscid) subst)+    = mkVirtUnit (hsComponentId hscid) (map (convertHsModuleSubst . unLoc) subst)++convertHsModuleSubst :: HsModuleSubst HsComponentId -> (ModuleName, Module)+convertHsModuleSubst (L _ modname, L _ m) = (modname, convertHsModuleId m)++convertHsModuleId :: HsModuleId HsComponentId -> Module+convertHsModuleId (HsModuleVar (L _ modname)) = mkHoleModule modname+convertHsModuleId (HsModuleId (L _ hsuid) (L _ modname)) = mkModule (convertHsComponentId hsuid) modname++++{-+************************************************************************+*                                                                      *+                        Module graph construction+*                                                                      *+************************************************************************+-}++-- | This is our version of GHC.Driver.Make.downsweep, but with a few modifications:+--+--  1. Every module is required to be mentioned, so we don't do any funny+--     business with targets or recursively grabbing dependencies.  (We+--     could support this in principle).+--  2. We support inline modules, whose summary we have to synthesize ourself.+--+-- We don't bother trying to support GHC.Driver.Make for now, it's more trouble+-- than it's worth for inline modules.+hsunitModuleGraph :: Bool -> HsUnit HsComponentId -> BkpM ModuleGraph+hsunitModuleGraph do_link unit = do+    hsc_env <- getSession++    let decls = hsunitBody unit+        pn = hsPackageName (unLoc (hsunitName unit))+        home_unit = hsc_home_unit hsc_env++        sig_keys = flip map (homeUnitInstantiations home_unit) $ \(mod_name, _) -> NodeKey_Module (ModNodeKeyWithUid (GWIB mod_name NotBoot) (homeUnitId home_unit))+        keys = [NodeKey_Module (ModNodeKeyWithUid gwib (homeUnitId home_unit)) | (DeclD hsc_src lmodname _) <- map unLoc decls, let gwib = GWIB (unLoc lmodname) (hscSourceToIsBoot hsc_src) ]++    --  1. Create a HsSrcFile/HsigFile summary for every+    --  explicitly mentioned module/signature.+    let get_decl (L _ (DeclD hsc_src lmodname hsmod)) =+          Just <$> summariseDecl pn hsc_src lmodname hsmod (keys ++ sig_keys)+        get_decl _ = return Nothing+    nodes <- mapMaybeM get_decl decls++    --  2. For each hole which does not already have an hsig file,+    --  create an "empty" hsig file to induce compilation for the+    --  requirement.+    let hsig_set = Set.fromList+          [ ms_mod_name ms+          | ModuleNode _ ms <- nodes+          , ms_hsc_src ms == HsigFile+          ]+    req_nodes <- fmap catMaybes . forM (homeUnitInstantiations home_unit) $ \(mod_name, _) ->+        if Set.member mod_name hsig_set+            then return Nothing+            else fmap Just $ summariseRequirement pn mod_name++    let graph_nodes = nodes ++ req_nodes ++ (instantiationNodes (homeUnitId $ hsc_home_unit hsc_env) (hsc_units hsc_env))+        key_nodes = map mkNodeKey graph_nodes+        all_nodes = graph_nodes ++ [LinkNode key_nodes (homeUnitId $ hsc_home_unit hsc_env) | do_link]+    -- This error message is not very good but .bkp mode is just for testing so+    -- better to be direct rather than pretty.+    when+      (length key_nodes /= length (ordNub key_nodes))+      (pprPanic "Duplicate nodes keys in backpack file" (ppr key_nodes))++    -- 3. Return the kaboodle+    return $ mkModuleGraph $ all_nodes+++summariseRequirement :: PackageName -> ModuleName -> BkpM ModuleGraphNode+summariseRequirement pn mod_name = do+    hsc_env <- getSession+    let dflags = hsc_dflags hsc_env+    let home_unit = hsc_home_unit hsc_env+    let fopts = initFinderOpts dflags++    let PackageName pn_fs = pn+    let location = mkHomeModLocation2 fopts mod_name+                    (unpackFS pn_fs </> moduleNameSlashes mod_name) "hsig"++    env <- getBkpEnv+    src_hash <- liftIO $ getFileHash (bkp_filename env)+    hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)+    hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)+    let loc = srcLocSpan (mkSrcLoc (mkFastString (bkp_filename env)) 1 1)++    let fc = hsc_FC hsc_env+    mod <- liftIO $ addHomeModuleToFinder fc home_unit mod_name location++    extra_sig_imports <- liftIO $ findExtraSigImports hsc_env HsigFile mod_name++    let ms = ModSummary {+        ms_mod = mod,+        ms_hsc_src = HsigFile,+        ms_location = location,+        ms_hs_hash = src_hash,+        ms_obj_date = Nothing,+        ms_dyn_obj_date = Nothing,+        ms_iface_date = hi_timestamp,+        ms_hie_date = hie_timestamp,+        ms_srcimps = [],+        ms_textual_imps = ((,) NoPkgQual . noLoc) <$> extra_sig_imports,+        ms_ghc_prim_import = False,+        ms_parsed_mod = Just (HsParsedModule {+                hpm_module = L loc (HsModule {+                        hsmodAnn = noAnn,+                        hsmodLayout = NoLayoutInfo,+                        hsmodName = Just (L (noAnnSrcSpan loc) mod_name),+                        hsmodExports = Nothing,+                        hsmodImports = [],+                        hsmodDecls = [],+                        hsmodDeprecMessage = Nothing,+                        hsmodHaddockModHeader = Nothing+                    }),+                hpm_src_files = []+            }),+        ms_hspp_file = "", -- none, it came inline+        ms_hspp_opts = dflags,+        ms_hspp_buf = Nothing+        }+    let nodes = [NodeKey_Module (ModNodeKeyWithUid (GWIB mn NotBoot) (homeUnitId home_unit)) | mn <- extra_sig_imports ]+    return (ModuleNode nodes ms)++summariseDecl :: PackageName+              -> HscSource+              -> Located ModuleName+              -> Located HsModule+              -> [NodeKey]+              -> BkpM ModuleGraphNode+summariseDecl pn hsc_src (L _ modname) hsmod home_keys = hsModuleToModSummary home_keys pn hsc_src modname hsmod++-- | Up until now, GHC has assumed a single compilation target per source file.+-- Backpack files with inline modules break this model, since a single file+-- may generate multiple output files.  How do we decide to name these files?+-- Should there only be one output file? This function our current heuristic,+-- which is we make a "fake" module and use that.+hsModuleToModSummary :: [NodeKey]+                     -> PackageName+                     -> HscSource+                     -> ModuleName+                     -> Located HsModule+                     -> BkpM ModuleGraphNode+hsModuleToModSummary home_keys pn hsc_src modname+                     hsmod = do+    let imps = hsmodImports (unLoc hsmod)+        loc  = getLoc hsmod+    hsc_env <- getSession+    -- Sort of the same deal as in GHC.Driver.Pipeline's getLocation+    -- Use the PACKAGE NAME to find the location+    let PackageName unit_fs = pn+        dflags = hsc_dflags hsc_env+        fopts = initFinderOpts dflags+    -- Unfortunately, we have to define a "fake" location in+    -- order to appease the various code which uses the file+    -- name to figure out where to put, e.g. object files.+    -- To add insult to injury, we don't even actually use+    -- these filenames to figure out where the hi files go.+    -- A travesty!+    let location0 = mkHomeModLocation2 fopts modname+                             (unpackFS unit_fs </>+                              moduleNameSlashes modname)+                              (case hsc_src of+                                HsigFile -> "hsig"+                                HsBootFile -> "hs-boot"+                                HsSrcFile -> "hs")+    -- DANGEROUS: bootifying can POISON the module finder cache+    let location = case hsc_src of+                        HsBootFile -> addBootSuffixLocnOut location0+                        _ -> location0+    -- This duplicates a pile of logic in GHC.Driver.Make+    hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)+    hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)++    -- Also copied from 'getImports'+    let (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps++             -- GHC.Prim doesn't exist physically, so don't go looking for it.+        (ordinary_imps, ghc_prim_import)+          = partition ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc)+              ord_idecls++        implicit_prelude = xopt LangExt.ImplicitPrelude dflags+        implicit_imports = mkPrelImports modname loc+                                         implicit_prelude imps++        rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) modname+        convImport (L _ i) = (rn_pkg_qual (ideclPkgQual i), reLoc $ ideclName i)++    extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname++    let normal_imports = map convImport (implicit_imports ++ ordinary_imps)+    (implicit_sigs, inst_deps) <- liftIO $ implicitRequirementsShallow hsc_env normal_imports++    -- So that Finder can find it, even though it doesn't exist...+    this_mod <- liftIO $ do+      let home_unit = hsc_home_unit hsc_env+      let fc        = hsc_FC hsc_env+      addHomeModuleToFinder fc home_unit modname location+    let ms = ModSummary {+            ms_mod = this_mod,+            ms_hsc_src = hsc_src,+            ms_location = location,+            ms_hspp_file = (case hiDir dflags of+                            Nothing -> ""+                            Just d -> d) </> ".." </> moduleNameSlashes modname <.> "hi",+            ms_hspp_opts = dflags,+            ms_hspp_buf = Nothing,+            ms_srcimps = map convImport src_idecls,+            ms_ghc_prim_import = not (null ghc_prim_import),+            ms_textual_imps = normal_imports+                           -- We have to do something special here:+                           -- due to merging, requirements may end up with+                           -- extra imports+                           ++ ((,) NoPkgQual . noLoc <$> extra_sig_imports)+                           ++ ((,) NoPkgQual . noLoc <$> implicit_sigs),+            -- This is our hack to get the parse tree to the right spot+            ms_parsed_mod = Just (HsParsedModule {+                    hpm_module = hsmod,+                    hpm_src_files = [] -- TODO if we preprocessed it+                }),+            -- Source hash = fingerprint0, so the recompilation tests do not recompile+            -- too much. In future, if necessary then could get the hash by just hashing the+            -- relevant part of the .bkp file.+            ms_hs_hash = fingerprint0,+            ms_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS+            ms_dyn_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS+            ms_iface_date = hi_timestamp,+            ms_hie_date = hie_timestamp+          }++    -- Now, what are the dependencies.+    let inst_nodes = map NodeKey_Unit inst_deps+        mod_nodes  =+          -- hs-boot edge+          [k | k <- [NodeKey_Module (ModNodeKeyWithUid (GWIB (ms_mod_name ms) IsBoot)  (moduleUnitId this_mod))], NotBoot == isBootSummary ms,  k `elem` home_keys ] +++          -- Normal edges+          [k | (_, mnwib) <- msDeps ms, let k = NodeKey_Module (ModNodeKeyWithUid (fmap unLoc mnwib) (moduleUnitId this_mod)), k `elem` home_keys]+++    return (ModuleNode (mod_nodes ++ inst_nodes) ms)++-- | Create a new, externally provided hashed unit id from+-- a hash.+newUnitId :: UnitId -> Maybe FastString -> UnitId+newUnitId uid mhash = case mhash of+   Nothing   -> uid+   Just hash -> UnitId (unitIdFS uid `appendFS` mkFastString "+" `appendFS` hash)
compiler/GHC/Driver/CodeOutput.hs view
@@ -4,7 +4,7 @@ \section{Code output phase} -} -{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}  module GHC.Driver.CodeOutput    ( codeOutput@@ -14,8 +14,6 @@    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Platform import GHC.ForeignSrcLang@@ -25,10 +23,13 @@  import GHC.CmmToC           ( cmmToC ) import GHC.Cmm.Lint         ( cmmLint )-import GHC.Cmm              ( RawCmmGroup )+import GHC.Cmm import GHC.Cmm.CLabel  import GHC.Driver.Session+import GHC.Driver.Config.Finder    (initFinderOpts)+import GHC.Driver.Config.CmmToAsm  (initNCGConfig)+import GHC.Driver.Config.CmmToLlvm (initLlvmCgConfig) import GHC.Driver.Ppr import GHC.Driver.Backend @@ -43,9 +44,10 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Logger+import GHC.Utils.Exception (bracket)+import GHC.Utils.Ppr (Mode(..))  import GHC.Unit-import GHC.Unit.State import GHC.Unit.Finder      ( mkStubPaths )  import GHC.Types.SrcLoc@@ -53,10 +55,11 @@ import GHC.Types.ForeignStubs import GHC.Types.Unique.Supply ( mkSplitUniqSupply ) -import Control.Exception import System.Directory import System.FilePath import System.IO+import Data.Set (Set)+import qualified Data.Set as Set  {- ************************************************************************@@ -67,7 +70,8 @@ -}  codeOutput-    :: Logger+    :: forall a.+       Logger     -> TmpFs     -> DynFlags     -> UnitState@@ -77,7 +81,7 @@     -> (a -> ForeignStubs)     -> [(ForeignSrcLang, FilePath)]     -- ^ additional files to be compiled with the C compiler-    -> [UnitId]+    -> Set UnitId -- ^ Dependencies     -> Stream IO RawCmmGroup a                       -- Compiled C--     -> IO (FilePath,            (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}),@@ -94,34 +98,52 @@                     else cmm_stream                do_lint cmm = withTimingSilent logger-                  dflags                   (text "CmmLint"<+>brackets (ppr this_mod))                   (const ()) $ do                 { case cmmLint (targetPlatform dflags) cmm of-                        Just err -> do { putLogMsg logger-                                                   dflags-                                                   NoReason-                                                   SevDump+                        Just err -> do { logMsg logger+                                                   MCDump                                                    noSrcSpan                                                    $ withPprStyle defaultDumpStyle err-                                       ; ghcExit logger dflags 1+                                       ; ghcExit logger 1                                        }                         Nothing  -> return ()                 ; return cmm                 } -        ; a <- case backend dflags of+        ; let final_stream :: Stream IO RawCmmGroup (ForeignStubs, a)+              final_stream = do+                  { a <- linted_cmm_stream+                  ; let stubs = genForeignStubs a+                  ; emitInitializerDecls this_mod stubs+                  ; return (stubs, a) }++        ; (stubs, a) <- case backend dflags of                  NCG         -> outputAsm logger dflags this_mod location filenm-                                          linted_cmm_stream-                 ViaC        -> outputC logger dflags filenm linted_cmm_stream pkg_deps-                 LLVM        -> outputLlvm logger dflags filenm linted_cmm_stream+                                          final_stream+                 ViaC        -> outputC logger dflags filenm final_stream pkg_deps+                 LLVM        -> outputLlvm logger dflags filenm final_stream                  Interpreter -> panic "codeOutput: Interpreter"                  NoBackend   -> panic "codeOutput: NoBackend"-        ; let stubs = genForeignStubs a         ; stubs_exist <- outputForeignStubs logger tmpfs dflags unit_state this_mod location stubs         ; return (filenm, stubs_exist, foreign_fps, a)         } +-- | See Note [Initializers and finalizers in Cmm] in GHC.Cmm.InitFini for details.+emitInitializerDecls :: Module -> ForeignStubs -> Stream IO RawCmmGroup ()+emitInitializerDecls this_mod (ForeignStubs _ cstub)+  | initializers <- getInitializers cstub+  , not $ null initializers =+      let init_array = CmmData sect statics+          lbl = mkInitializerArrayLabel this_mod+          sect = Section InitArray lbl+          statics = CmmStaticsRaw lbl+            [ CmmStaticLit $ CmmLabel fn_name+            | fn_name <- initializers+            ]+    in Stream.yield [init_array]+emitInitializerDecls _ _ = return ()+ doOutput :: String -> (Handle -> IO a) -> IO a doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action @@ -137,22 +159,23 @@         -> DynFlags         -> FilePath         -> Stream IO RawCmmGroup a-        -> [UnitId]+        -> Set UnitId         -> IO a-outputC logger dflags filenm cmm_stream packages =-  withTiming logger dflags (text "C codegen") (\a -> seq a () {- FIXME -}) $ do-    let pkg_names = map unitIdString packages+outputC logger dflags filenm cmm_stream unit_deps =+  withTiming logger (text "C codegen") (\a -> seq a () {- FIXME -}) $ do+    let pkg_names = map unitIdString (Set.toAscList unit_deps)     doOutput filenm $ \ h -> do       hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")       hPutStr h "#include \"Stg.h\"\n"       let platform = targetPlatform dflags           writeC cmm = do             let doc = cmmToC platform cmm-            dumpIfSet_dyn logger dflags Opt_D_dump_c_backend+            putDumpFileMaybe logger Opt_D_dump_c_backend                           "C backend output"                           FormatC                           doc-            printForC dflags h doc+            let ctx = initSDocContext dflags (PprCode CStyle)+            printSDocLn ctx LeftMode h doc       Stream.consume cmm_stream id writeC  {-@@ -172,10 +195,11 @@           -> IO a outputAsm logger dflags this_mod location filenm cmm_stream = do   ncg_uniqs <- mkSplitUniqSupply 'n'-  debugTraceMsg logger dflags 4 (text "Outputing asm to" <+> text filenm)+  debugTraceMsg logger 4 (text "Outputing asm to" <+> text filenm)+  let ncg_config = initNCGConfig dflags this_mod   {-# SCC "OutputAsm" #-} doOutput filenm $     \h -> {-# SCC "NativeCodeGen" #-}-      nativeCodeGen logger dflags this_mod location h ncg_uniqs cmm_stream+      nativeCodeGen logger ncg_config location h ncg_uniqs cmm_stream  {- ************************************************************************@@ -186,10 +210,11 @@ -}  outputLlvm :: Logger -> DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a-outputLlvm logger dflags filenm cmm_stream =+outputLlvm logger dflags filenm cmm_stream = do+  lcg_config <- initLlvmCgConfig logger dflags   {-# SCC "llvm_output" #-} doOutput filenm $     \f -> {-# SCC "llvm_CodeGen" #-}-      llvmCodeGen logger dflags f cmm_stream+      llvmCodeGen logger lcg_config f cmm_stream  {- ************************************************************************@@ -220,14 +245,14 @@            Maybe FilePath) -- C file created outputForeignStubs logger tmpfs dflags unit_state mod location stubs  = do-   let stub_h = mkStubPaths dflags (moduleName mod) location-   stub_c <- newTempName logger tmpfs dflags TFL_CurrentModule "c"+   let stub_h = mkStubPaths (initFinderOpts dflags) (moduleName mod) location+   stub_c <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "c"     case stubs of      NoStubs ->         return (False, Nothing) -     ForeignStubs (CHeader h_code) (CStub c_code) -> do+     ForeignStubs (CHeader h_code) (CStub c_code _ _) -> do         let             stub_c_output_d = pprCode CStyle c_code             stub_c_output_w = showSDoc dflags stub_c_output_d@@ -238,7 +263,7 @@          createDirectoryIfMissing True (takeDirectory stub_h) -        dumpIfSet_dyn logger dflags Opt_D_dump_foreign+        putDumpFileMaybe logger Opt_D_dump_foreign                       "Foreign export header file"                       FormatC                       stub_h_output_d@@ -263,7 +288,7 @@            <- outputForeignStubs_help stub_h stub_h_output_w                 ("#include <HsFFI.h>\n" ++ cplusplus_hdr) cplusplus_ftr -        dumpIfSet_dyn logger dflags Opt_D_dump_foreign+        putDumpFileMaybe logger Opt_D_dump_foreign                       "Foreign export stubs" FormatC stub_c_output_d          stub_c_file_exists@@ -304,20 +329,19 @@ -- | Generate code to initialise cost centres profilingInitCode :: Platform -> Module -> CollectedCCs -> CStub profilingInitCode platform this_mod (local_CCs, singleton_CCSs)- = CStub $ vcat-    $  map emit_cc_decl local_CCs-    ++ map emit_ccs_decl singleton_CCSs-    ++ [emit_cc_list local_CCs]-    ++ [emit_ccs_list singleton_CCSs]-    ++ [ text "static void prof_init_" <> ppr this_mod-            <> text "(void) __attribute__((constructor));"-       , text "static void prof_init_" <> ppr this_mod <> text "(void)"-       , braces (vcat-                 [ text "registerCcList" <> parens local_cc_list_label <> semi-                 , text "registerCcsList" <> parens singleton_cc_list_label <> semi-                 ])-       ]+ = {-# SCC profilingInitCode #-}+   initializerCStub platform fn_name decls body  where+   fn_name = mkInitializerStubLabel this_mod "prof_init"+   decls = vcat+        $  map emit_cc_decl local_CCs+        ++ map emit_ccs_decl singleton_CCSs+        ++ [emit_cc_list local_CCs]+        ++ [emit_ccs_list singleton_CCSs]+   body = vcat+        [ text "registerCcList" <> parens local_cc_list_label <> semi+        , text "registerCcsList" <> parens singleton_cc_list_label <> semi+        ]    emit_cc_decl cc =        text "extern CostCentre" <+> cc_lbl <> text "[];"      where cc_lbl = pdoc platform (mkCCLabel cc)@@ -341,23 +365,22 @@       <> semi  -- | Generate code to initialise info pointer origin--- See note [Mapping Info Tables to Source Positions]-ipInitCode :: DynFlags -> Module -> [InfoProvEnt] -> CStub-ipInitCode dflags this_mod ents- = if not (gopt Opt_InfoTableMap dflags)-    then mempty-    else CStub $ vcat-    $  map emit_ipe_decl ents-    ++ [emit_ipe_list ents]-    ++ [ text "static void ip_init_" <> ppr this_mod-            <> text "(void) __attribute__((constructor));"-       , text "static void ip_init_" <> ppr this_mod <> text "(void)"-       , braces (vcat-                 [ text "registerInfoProvList" <> parens local_ipe_list_label <> semi-                 ])-       ]+-- See Note [Mapping Info Tables to Source Positions]+ipInitCode+  :: Bool            -- is Opt_InfoTableMap enabled or not+  -> Platform+  -> Module+  -> [InfoProvEnt]+  -> CStub+ipInitCode do_info_table platform this_mod ents+  | not do_info_table = mempty+  | otherwise = initializerCStub platform fn_nm decls body  where-   platform = targetPlatform dflags+   fn_nm = mkInitializerStubLabel this_mod "ip_init"+   decls = vcat+        $  map emit_ipe_decl ents+        ++ [emit_ipe_list ents]+   body = text "registerInfoProvList" <> parens local_ipe_list_label <> semi    emit_ipe_decl ipe =        text "extern InfoProvEnt" <+> ipe_lbl <> text "[];"      where ipe_lbl = pprCLabel platform CStyle (mkIPELabel ipe)
+ compiler/GHC/Driver/Config/Cmm.hs view
@@ -0,0 +1,33 @@+module GHC.Driver.Config.Cmm+  ( initCmmConfig+  ) where++import GHC.Cmm.Config+import GHC.Cmm.Switch (backendSupportsSwitch)++import GHC.Driver.Session+import GHC.Driver.Backend++import GHC.Platform++import GHC.Prelude++initCmmConfig :: DynFlags -> CmmConfig+initCmmConfig dflags = CmmConfig+  { cmmProfile             = targetProfile                dflags+  , cmmOptControlFlow      = gopt Opt_CmmControlFlow      dflags+  , cmmDoLinting           = gopt Opt_DoCmmLinting        dflags+  , cmmOptElimCommonBlks   = gopt Opt_CmmElimCommonBlocks dflags+  , cmmOptSink             = gopt Opt_CmmSink             dflags+  , cmmGenStackUnwindInstr = debugLevel dflags > 0+  , cmmExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags+  , cmmDoCmmSwitchPlans    = not . backendSupportsSwitch . backend $ dflags+  , cmmSplitProcPoints     = (backend dflags /= NCG)+                             || not (platformTablesNextToCode platform)+                             || usingInconsistentPicReg+  }+  where platform                = targetPlatform dflags+        usingInconsistentPicReg =+          case (platformArch platform, platformOS platform, positionIndependent dflags)+          of   (ArchX86, OSDarwin, pic) -> pic+               _                        -> False
+ compiler/GHC/Driver/Config/CmmToAsm.hs view
@@ -0,0 +1,75 @@+module GHC.Driver.Config.CmmToAsm+  ( initNCGConfig+  )+where++import GHC.Prelude++import GHC.Driver.Session++import GHC.Platform+import GHC.Unit.Types (Module)+import GHC.CmmToAsm.Config+import GHC.Utils.Outputable+import GHC.CmmToAsm.BlockLayout++-- | Initialize the native code generator configuration from the DynFlags+initNCGConfig :: DynFlags -> Module -> NCGConfig+initNCGConfig dflags this_mod = NCGConfig+   { ncgPlatform              = targetPlatform dflags+   , ncgThisModule            = this_mod+   , ncgAsmContext            = initSDocContext dflags (PprCode AsmStyle)+   , ncgProcAlignment         = cmmProcAlignment dflags+   , ncgExternalDynamicRefs   = gopt Opt_ExternalDynamicRefs dflags+   , ncgPIC                   = positionIndependent dflags+   , ncgInlineThresholdMemcpy = fromIntegral $ maxInlineMemcpyInsns dflags+   , ncgInlineThresholdMemset = fromIntegral $ maxInlineMemsetInsns dflags+   , ncgSplitSections         = gopt Opt_SplitSections dflags+   , ncgRegsIterative         = gopt Opt_RegsIterative dflags+   , ncgRegsGraph             = gopt Opt_RegsGraph dflags+   , ncgAsmLinting            = gopt Opt_DoAsmLinting dflags+   , ncgCfgWeights            = cfgWeights dflags+   , ncgCfgBlockLayout        = gopt Opt_CfgBlocklayout dflags+   , ncgCfgWeightlessLayout   = gopt Opt_WeightlessBlocklayout dflags++     -- When constant-folding is enabled, the cmmSink pass does constant-folding, so+     -- we don't need to do it again in the native code generator.+   , ncgDoConstantFolding     = not (gopt Opt_CoreConstantFolding dflags || gopt Opt_CmmSink dflags)++   , ncgDumpRegAllocStages    = dopt Opt_D_dump_asm_regalloc_stages dflags+   , ncgDumpAsmStats          = dopt Opt_D_dump_asm_stats dflags+   , ncgDumpAsmConflicts      = dopt Opt_D_dump_asm_conflicts dflags+   , ncgBmiVersion            = case platformArch (targetPlatform dflags) of+                                 ArchX86_64 -> bmiVersion dflags+                                 ArchX86    -> bmiVersion dflags+                                 _          -> Nothing++     -- We assume  SSE1 and SSE2 operations are available on both+     -- x86 and x86_64. Historically we didn't default to SSE2 and+     -- SSE1 on x86, which results in defacto nondeterminism for how+     -- rounding behaves in the associated x87 floating point instructions+     -- because variations in the spill/fpu stack placement of arguments for+     -- operations would change the precision and final result of what+     -- would otherwise be the same expressions with respect to single or+     -- double precision IEEE floating point computations.+   , ncgSseVersion =+      let v | sseVersion dflags < Just SSE2 = Just SSE2+            | otherwise                     = sseVersion dflags+      in case platformArch (targetPlatform dflags) of+            ArchX86_64 -> v+            ArchX86    -> v+            _          -> Nothing++   , ncgDwarfEnabled        = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags > 0 && platformArch (targetPlatform dflags) /= ArchAArch64+   , ncgDwarfUnwindings     = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags > 0+   , ncgDwarfStripBlockInfo = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags < 2 -- We strip out block information when running with -g0 or -g1.+   , ncgDwarfSourceNotes    = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags > 2 -- We produce GHC-specific source-note DIEs only with -g3+   , ncgExposeInternalSymbols = gopt Opt_ExposeInternalSymbols dflags+   , ncgCmmStaticPred       = gopt Opt_CmmStaticPred dflags+   , ncgEnableShortcutting  = gopt Opt_AsmShortcutting dflags+   , ncgComputeUnwinding    = debugLevel dflags > 0+   , ncgEnableDeadCodeElimination = not (gopt Opt_InfoTableMap dflags)+                                     -- Disable when -finfo-table-map is on (#20428)+                                     && backendMaintainsCfg (targetPlatform dflags)+                                     -- Enable if the platform maintains the CFG+   }
+ compiler/GHC/Driver/Config/CmmToLlvm.hs view
@@ -0,0 +1,30 @@+module GHC.Driver.Config.CmmToLlvm+  ( initLlvmCgConfig+  ) where++import GHC.Prelude+import GHC.Driver.Session+import GHC.Platform+import GHC.CmmToLlvm.Config+import GHC.SysTools.Tasks+import GHC.Utils.Outputable+import GHC.Utils.Logger++-- | Initialize the Llvm code generator configuration from DynFlags+initLlvmCgConfig :: Logger -> DynFlags -> IO LlvmCgConfig+initLlvmCgConfig logger dflags = do+  version <- figureLlvmVersion logger dflags+  pure $! LlvmCgConfig {+    llvmCgPlatform               = targetPlatform dflags+    , llvmCgContext              = initSDocContext dflags (PprCode CStyle)+    , llvmCgFillUndefWithGarbage = gopt Opt_LlvmFillUndefWithGarbage dflags+    , llvmCgSplitSection         = gopt Opt_SplitSections dflags+    , llvmCgBmiVersion           = case platformArch (targetPlatform dflags) of+                                      ArchX86_64 -> bmiVersion dflags+                                      ArchX86    -> bmiVersion dflags+                                      _          -> Nothing+    , llvmCgLlvmVersion          = version+    , llvmCgDoWarn               = wopt Opt_WarnUnsupportedLlvmVersion dflags+    , llvmCgLlvmTarget           = platformMisc_llvmTarget $! platformMisc dflags+    , llvmCgLlvmConfig           = llvmConfig dflags+    }
+ compiler/GHC/Driver/Config/Finder.hs view
@@ -0,0 +1,34 @@+module GHC.Driver.Config.Finder (+    FinderOpts(..),+    initFinderOpts+  ) where++import GHC.Prelude++import GHC.Driver.Session+import GHC.Unit.Finder.Types+import GHC.Data.FastString+++-- | Create a new 'FinderOpts' from DynFlags.+initFinderOpts :: DynFlags -> FinderOpts+initFinderOpts flags = FinderOpts+  { finder_importPaths = importPaths flags+  , finder_lookupHomeInterfaces = isOneShot (ghcMode flags)+  , finder_bypassHiFileCheck = MkDepend == (ghcMode flags)+  , finder_ways = ways flags+  , finder_enableSuggestions = gopt Opt_HelpfulErrors flags+  , finder_workingDirectory = workingDirectory flags+  , finder_thisPackageName  = mkFastString <$> thisPackageName flags+  , finder_hiddenModules = hiddenModules flags+  , finder_reexportedModules = reexportedModules flags+  , finder_hieDir = hieDir flags+  , finder_hieSuf = hieSuf flags+  , finder_hiDir = hiDir flags+  , finder_hiSuf = hiSuf_ flags+  , finder_dynHiSuf = dynHiSuf_ flags+  , finder_objectDir = objectDir flags+  , finder_objectSuf = objectSuf_ flags+  , finder_dynObjectSuf = dynObjectSuf_ flags+  , finder_stubDir = stubDir flags+  }
+ compiler/GHC/Driver/Config/HsToCore.hs view
@@ -0,0 +1,19 @@+module GHC.Driver.Config.HsToCore+  ( initBangOpts+  )+where++import GHC.Types.Id.Make+import GHC.Driver.Session+import qualified GHC.LanguageExtensions as LangExt++initBangOpts :: DynFlags -> BangOpts+initBangOpts dflags = BangOpts+  { bang_opt_strict_data   = xopt LangExt.StrictData dflags+  , bang_opt_unbox_disable = gopt Opt_OmitInterfacePragmas dflags+      -- Don't unbox if we aren't optimising; rather arbitrarily,+      -- we use -fomit-iface-pragmas as the indication+  , bang_opt_unbox_strict  = gopt Opt_UnboxStrictFields dflags+  , bang_opt_unbox_small   = gopt Opt_UnboxSmallStrictFields dflags+  }+
+ compiler/GHC/Driver/Config/Stg/Debug.hs view
@@ -0,0 +1,14 @@+module GHC.Driver.Config.Stg.Debug+  ( initStgDebugOpts+  ) where++import GHC.Stg.Debug++import GHC.Driver.Session++-- | Initialize STG pretty-printing options from DynFlags+initStgDebugOpts :: DynFlags -> StgDebugOpts+initStgDebugOpts dflags = StgDebugOpts+  { stgDebug_infoTableMap = gopt Opt_InfoTableMap dflags+  , stgDebug_distinctConstructorTables = gopt Opt_DistinctConstructorTables dflags+  }
+ compiler/GHC/Driver/Config/Stg/Lift.hs view
@@ -0,0 +1,15 @@+module GHC.Driver.Config.Stg.Lift+  ( initStgLiftConfig+  ) where++import GHC.Stg.Lift.Config++import GHC.Driver.Session++initStgLiftConfig :: DynFlags -> StgLiftConfig+initStgLiftConfig dflags = StgLiftConfig+    { c_targetProfile      = targetProfile dflags+    , c_liftLamsRecArgs    = liftLamsRecArgs dflags+    , c_liftLamsNonRecArgs = liftLamsNonRecArgs dflags+    , c_liftLamsKnown      = liftLamsKnown dflags+    }
+ compiler/GHC/Driver/Config/Stg/Pipeline.hs view
@@ -0,0 +1,47 @@+module GHC.Driver.Config.Stg.Pipeline+  ( initStgPipelineOpts+  ) where++import GHC.Prelude++import Control.Monad (guard)++import GHC.Stg.Pipeline++import GHC.Driver.Config.Diagnostic+import GHC.Driver.Config.Stg.Lift+import GHC.Driver.Config.Stg.Ppr+import GHC.Driver.Session++-- | Initialize STG pretty-printing options from DynFlags+initStgPipelineOpts :: DynFlags -> Bool -> StgPipelineOpts+initStgPipelineOpts dflags for_bytecode = StgPipelineOpts+  { stgPipeline_lint = do+      guard $ gopt Opt_DoStgLinting dflags+      Just $ initDiagOpts dflags+  , stgPipeline_pprOpts = initStgPprOpts dflags+  , stgPipeline_phases = getStgToDo for_bytecode dflags+  , stgPlatform = targetPlatform dflags+  }++-- | Which Stg-to-Stg passes to run. Depends on flags, ways etc.+getStgToDo+  :: Bool -- ^ Are we preparing for bytecode?+  -> DynFlags+  -> [StgToDo]+getStgToDo for_bytecode dflags =+  filter (/= StgDoNothing)+    [ mandatory StgUnarise+    -- Important that unarisation comes first+    -- See Note [StgCse after unarisation] in GHC.Stg.CSE+    , optional Opt_StgCSE StgCSE+    , optional Opt_StgLiftLams $ StgLiftLams $ initStgLiftConfig dflags+    , runWhen for_bytecode StgBcPrep+    , optional Opt_StgStats StgStats+    ] where+      optional opt = runWhen (gopt opt dflags)+      mandatory = id++runWhen :: Bool -> StgToDo -> StgToDo+runWhen True todo = todo+runWhen _    _    = StgDoNothing
+ compiler/GHC/Driver/Config/Stg/Ppr.hs view
@@ -0,0 +1,13 @@+module GHC.Driver.Config.Stg.Ppr+  ( initStgPprOpts+  ) where++import GHC.Stg.Syntax++import GHC.Driver.Session++-- | Initialize STG pretty-printing options from DynFlags+initStgPprOpts :: DynFlags -> StgPprOpts+initStgPprOpts dflags = StgPprOpts+   { stgSccEnabled = sccProfilingEnabled dflags+   }
+ compiler/GHC/Driver/Config/StgToCmm.hs view
@@ -0,0 +1,78 @@+module GHC.Driver.Config.StgToCmm+  ( initStgToCmmConfig+  ) where++import GHC.StgToCmm.Config++import GHC.Driver.Backend+import GHC.Driver.Session+import GHC.Platform+import GHC.Platform.Profile+import GHC.Unit.Module+import GHC.Utils.Outputable++import Data.Maybe+import Prelude++initStgToCmmConfig :: DynFlags -> Module -> StgToCmmConfig+initStgToCmmConfig dflags mod = StgToCmmConfig+  -- settings+  { stgToCmmProfile       = profile+  , stgToCmmThisModule    = mod+  , stgToCmmTmpDir        = tmpDir          dflags+  , stgToCmmContext       = initSDocContext dflags defaultDumpStyle+  , stgToCmmDebugLevel    = debugLevel      dflags+  , stgToCmmBinBlobThresh = b_blob+  , stgToCmmMaxInlAllocSize = maxInlineAllocSize           dflags+  -- ticky options+  , stgToCmmDoTicky       = gopt Opt_Ticky                 dflags+  , stgToCmmTickyAllocd   = gopt Opt_Ticky_Allocd          dflags+  , stgToCmmTickyLNE      = gopt Opt_Ticky_LNE             dflags+  , stgToCmmTickyDynThunk = gopt Opt_Ticky_Dyn_Thunk       dflags+  , stgToCmmTickyTag      = gopt Opt_Ticky_Tag             dflags+  -- flags+  , stgToCmmLoopification = gopt Opt_Loopification         dflags+  , stgToCmmAlignCheck    = gopt Opt_AlignmentSanitisation dflags+  , stgToCmmOptHpc        = gopt Opt_Hpc                   dflags+  , stgToCmmFastPAPCalls  = gopt Opt_FastPAPCalls          dflags+  , stgToCmmSCCProfiling  = sccProfilingEnabled            dflags+  , stgToCmmEagerBlackHole = gopt Opt_EagerBlackHoling     dflags+  , stgToCmmInfoTableMap  = gopt Opt_InfoTableMap          dflags+  , stgToCmmOmitYields    = gopt Opt_OmitYields            dflags+  , stgToCmmOmitIfPragmas = gopt Opt_OmitInterfacePragmas  dflags+  , stgToCmmPIC           = gopt Opt_PIC                   dflags+  , stgToCmmPIE           = gopt Opt_PIE                   dflags+  , stgToCmmExtDynRefs    = gopt Opt_ExternalDynamicRefs   dflags+  , stgToCmmDoBoundsCheck = gopt Opt_DoBoundsChecking      dflags+  , stgToCmmDoTagCheck    = gopt Opt_DoTagInferenceChecks  dflags+  -- backend flags+  , stgToCmmAllowBigArith             = not ncg+  , stgToCmmAllowQuotRemInstr         = ncg  && (x86ish || ppc)+  , stgToCmmAllowQuotRem2             = (ncg && (x86ish || ppc)) || llvm+  , stgToCmmAllowExtendedAddSubInstrs = (ncg && (x86ish || ppc)) || llvm+  , stgToCmmAllowIntMul2Instr         = (ncg && x86ish) || llvm+  , stgToCmmAllowFabsInstrs           = (ncg && (x86ish || ppc || aarch64)) || llvm+  -- SIMD flags+  , stgToCmmVecInstrsErr  = vec_err+  , stgToCmmAvx           = isAvxEnabled                   dflags+  , stgToCmmAvx2          = isAvx2Enabled                  dflags+  , stgToCmmAvx512f       = isAvx512fEnabled               dflags+  , stgToCmmTickyAP       = gopt Opt_Ticky_AP dflags+  } where profile  = targetProfile dflags+          platform = profilePlatform profile+          bk_end  = backend dflags+          ncg     = bk_end == NCG+          llvm    = bk_end == LLVM+          b_blob  = if not ncg then Nothing else binBlobThreshold dflags+          x86ish  = case platformArch platform of+                      ArchX86    -> True+                      ArchX86_64 -> True+                      _          -> False+          ppc     = case platformArch platform of+                      ArchPPC      -> True+                      ArchPPC_64 _ -> True+                      _            -> False+          aarch64 = platformArch platform == ArchAArch64+          vec_err = case backend dflags of+                      LLVM -> Nothing+                      _    -> Just (unlines ["SIMD vector instructions require the LLVM back-end.", "Please use -fllvm."])
+ compiler/GHC/Driver/Config/Tidy.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE LambdaCase #-}++module GHC.Driver.Config.Tidy+  ( initTidyOpts+  , initStaticPtrOpts+  )+where++import GHC.Prelude++import GHC.Iface.Tidy+import GHC.Iface.Tidy.StaticPtrTable++import GHC.Driver.Session+import GHC.Driver.Env+import GHC.Driver.Backend++import GHC.Core.Make (getMkStringIds)+import GHC.Data.Maybe+import GHC.Utils.Panic+import GHC.Utils.Outputable+import GHC.Builtin.Names+import GHC.Tc.Utils.Env (lookupGlobal_maybe)+import GHC.Types.TyThing+import GHC.Platform.Ways++import qualified GHC.LanguageExtensions as LangExt++initTidyOpts :: HscEnv -> IO TidyOpts+initTidyOpts hsc_env = do+  let dflags = hsc_dflags hsc_env+  static_ptr_opts <- if not (xopt LangExt.StaticPointers dflags)+    then pure Nothing+    else Just <$> initStaticPtrOpts hsc_env+  pure $ TidyOpts+    { opt_name_cache        = hsc_NC hsc_env+    , opt_collect_ccs       = ways dflags `hasWay` WayProf+    , opt_unfolding_opts    = unfoldingOpts dflags+    , opt_expose_unfoldings = if | gopt Opt_OmitInterfacePragmas dflags -> ExposeNone+                                 | gopt Opt_ExposeAllUnfoldings dflags  -> ExposeAll+                                 | otherwise                            -> ExposeSome+    , opt_expose_rules      = not (gopt Opt_OmitInterfacePragmas dflags)+    , opt_trim_ids          = gopt Opt_OmitInterfacePragmas dflags+    , opt_static_ptr_opts   = static_ptr_opts+    }++initStaticPtrOpts :: HscEnv -> IO StaticPtrOpts+initStaticPtrOpts hsc_env = do+  let dflags = hsc_dflags hsc_env++  let lookupM n = lookupGlobal_maybe hsc_env n >>= \case+        Succeeded r -> pure r+        Failed err  -> pprPanic "initStaticPtrOpts: couldn't find" (ppr (err,n))++  mk_string <- getMkStringIds (fmap tyThingId . lookupM)+  static_ptr_info_datacon <- tyThingDataCon <$> lookupM staticPtrInfoDataConName+  static_ptr_datacon      <- tyThingDataCon <$> lookupM staticPtrDataConName++  pure $ StaticPtrOpts+    { opt_platform = targetPlatform dflags++      -- If we are compiling for the interpreter we will insert any necessary+      -- SPT entries dynamically, otherwise we add a C stub to do so+    , opt_gen_cstub = case backend dflags of+                        Interpreter -> False+                        _           -> True++    , opt_mk_string = mk_string+    , opt_static_ptr_info_datacon = static_ptr_info_datacon+    , opt_static_ptr_datacon      = static_ptr_datacon+    }+
+ compiler/GHC/Driver/GenerateCgIPEStub.hs view
@@ -0,0 +1,269 @@+{-# LANGUAGE GADTs #-}++module GHC.Driver.GenerateCgIPEStub (generateCgIPEStub) where++import qualified Data.Map.Strict as Map+import Data.Maybe (catMaybes, listToMaybe)+import GHC.Cmm+import GHC.Cmm.CLabel (CLabel)+import GHC.Cmm.Dataflow (Block, C, O)+import GHC.Cmm.Dataflow.Block (blockSplit, blockToList)+import GHC.Cmm.Dataflow.Collections (mapToList)+import GHC.Cmm.Dataflow.Label (Label)+import GHC.Cmm.Info.Build (emptySRT)+import GHC.Cmm.Pipeline (cmmPipeline)+import GHC.Cmm.Utils (toBlockList)+import GHC.Data.Maybe (firstJusts)+import GHC.Data.Stream (Stream, liftIO)+import qualified GHC.Data.Stream as Stream+import GHC.Driver.Env (hsc_dflags)+import GHC.Driver.Env.Types (HscEnv)+import GHC.Driver.Flags (GeneralFlag (Opt_InfoTableMap))+import GHC.Driver.Session (gopt, targetPlatform)+import GHC.Driver.Config.StgToCmm+import GHC.Prelude+import GHC.Runtime.Heap.Layout (isStackRep)+import GHC.Settings (Platform, platformUnregisterised)+import GHC.StgToCmm.Monad (getCmm, initC, runC, initFCodeState)+import GHC.StgToCmm.Prof (initInfoTableProv)+import GHC.StgToCmm.Types (CgInfos (..), ModuleLFInfos)+import GHC.Stg.InferTags.TagSig (TagSig)+import GHC.Types.IPE (InfoTableProvMap (provInfoTables), IpeSourceLocation)+import GHC.Types.Name.Set (NonCaffySet)+import GHC.Types.Name.Env (NameEnv)+import GHC.Types.Tickish (GenTickish (SourceNote))+import GHC.Unit.Types (Module)+import GHC.Utils.Misc++{-+Note [Stacktraces from Info Table Provenance Entries (IPE based stack unwinding)]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Stacktraces can be created from return frames as they are pushed to stack for every case scrutinee.+But to make them readable / meaningful, one needs to know the source location of each return frame.++Every return frame has a distinct info table and thus a distinct code pointer (for tables next to+code) or at least a distict address itself. Info Table Provernance Entries (IPE) are searchable by+this pointer and contain a source location.++The info table / info table code pointer to source location map is described in:+Note [Mapping Info Tables to Source Positions]++To be able to lookup IPEs for return frames one needs to emit them during compile time. This is done+by `generateCgIPEStub`.++This leads to the question: How to figure out the source location of a return frame?++While the lookup algorithms for registerised and unregisterised builds differ in details, they have in+common that we want to lookup the `CmmNode.CmmTick` (containing a `SourceNote`) that is nearest+(before) the usage of the return frame's label. (Which label and label type is used differs between+these two use cases.)++Registerised+~~~~~~~~~~~~~++Let's consider this example:+```+ Main.returnFrame_entry() { //  [R2]+         { info_tbls: [(c18g,+                        label: block_c18g_info+                        rep: StackRep []+                        srt: Just GHC.CString.unpackCString#_closure),+                       (c18r,+                        label: Main.returnFrame_info+                        rep: HeapRep static { Fun {arity: 1 fun_type: ArgSpec 5} }+                        srt: Nothing)]+           stack_info: arg_space: 8+         }+     {offset++      [...]++       c18u: // global+           //tick src<Main.hs:(7,1)-(16,15)>+           I64[Hp - 16] = sat_s16B_info;+           P64[Hp] = _s16r::P64;+           _c17j::P64 = Hp - 16;+           //tick src<Main.hs:8:25-39>+           I64[Sp - 8] = c18g;+           R3 = _c17j::P64;+           R2 = GHC.IO.Unsafe.unsafePerformIO_closure;+           R1 = GHC.Base.$_closure;+           Sp = Sp - 8;+           call stg_ap_pp_fast(R3,+                               R2,+                               R1) returns to c18g, args: 8, res: 8, upd: 8;+```++The return frame `block_c18g_info` has the label `c18g` which is used in the call to `stg_ap_pp_fast`+(`returns to c18g`) as continuation (`cml_cont`). The source location we're after, is the nearest+`//tick` before the call (`//tick src<Main.hs:8:25-39>`).++In code the Cmm program is represented as a Hoopl graph. Hoopl distinguishes nodes by defining if they+are open or closed on entry (one can fallthrough to them from the previous instruction) and if they are+open or closed on exit (one can fallthrough from them to the next node).++Please refer to the paper "Hoopl: A Modular, Reusable Library for Dataflow Analysis and Transformation"+for a detailed explanation.++Here we use the fact, that calls (represented by `CmmNode.CmmCall`) are always closed on exit+(`CmmNode O C`, `O` means open, `C` closed). In other words, they are always at the end of a block.++So, given a stack represented info table (likely representing a return frame, but this isn't completely+sure as there are e.g. update frames, too) with it's label (`c18g` in the example above) and a `CmmGraph`:+  - Look at the end of every block, if it's a `CmmNode.CmmCall` returning to the continuation with the+    label of the return frame.+  - If there's such a call, lookup the nearest `CmmNode.CmmTick` by traversing the middle part of the block+    backwards (from end to beginning).+  - Take the first `CmmNode.CmmTick` that contains a `Tickish.SourceNote` and return it's payload as+    `IpeSourceLocation`. (There are other `Tickish` constructors like `ProfNote` or `HpcTick`, these are+    ignored.)++Unregisterised+~~~~~~~~~~~~~++In unregisterised builds there is no return frame / continuation label in calls. The continuation (i.e. return+frame) is set in an explicit Cmm assignment. Thus the tick lookup algorithm has to be slightly different.++```+ sat_s16G_entry() { //  [R1]+         { info_tbls: [(c18O,+                        label: sat_s16G_info+                        rep: HeapRep { Thunk }+                        srt: Just _u18Z_srt)]+           stack_info: arg_space: 0+         }+     {offset+       c18O: // global+           _s16G::P64 = R1;+           if ((Sp + 8) - 40 < SpLim) (likely: False) goto c18P; else goto c18Q;+       c18P: // global+           R1 = _s16G::P64;+           call (stg_gc_enter_1)(R1) args: 8, res: 0, upd: 8;+       c18Q: // global+           I64[Sp - 16] = stg_upd_frame_info;+           P64[Sp - 8] = _s16G::P64;+           //tick src<Main.hs:20:9-13>+           I64[Sp - 24] = block_c18M_info;+           R1 = GHC.Show.$fShow[]_closure;+           P64[Sp - 32] = GHC.Show.$fShowChar_closure;+           Sp = Sp - 32;+           call stg_ap_p_fast(R1) args: 16, res: 8, upd: 24;+     }+ },+ _blk_c18M() { //  [R1]+         { info_tbls: [(c18M,+                        label: block_c18M_info+                        rep: StackRep []+                        srt: Just System.IO.print_closure)]+           stack_info: arg_space: 0+         }+     {offset+       c18M: // global+           _s16F::P64 = R1;+           R1 = System.IO.print_closure;+           P64[Sp] = _s16F::P64;+           call stg_ap_p_fast(R1) args: 32, res: 0, upd: 24;+     }+ },+```++In this example we have to lookup `//tick src<Main.hs:20:9-13>` for the return frame `c18M`.+Notice, that this cannot be done with the `Label` `c18M`, but with the `CLabel` `block_c18M_info`+(`label: block_c18M_info` is actually a `CLabel`).++The find the tick:+  - Every `Block` is checked from top (first) to bottom (last) node for an assignment like+   `I64[Sp - 24] = block_c18M_info;`. The lefthand side is actually ignored.+  - If such an assignment is found the search is over, because the payload (content of+    `Tickish.SourceNote`, represented as `IpeSourceLocation`) of last visited tick is always+    remembered in a `Maybe`.+-}++generateCgIPEStub :: HscEnv -> Module -> InfoTableProvMap -> NameEnv TagSig -> Stream IO CmmGroupSRTs (NonCaffySet, ModuleLFInfos) -> Stream IO CmmGroupSRTs CgInfos+generateCgIPEStub hsc_env this_mod denv tag_sigs s = do+  let dflags   = hsc_dflags hsc_env+      platform = targetPlatform dflags+      fstate   = initFCodeState platform+  cgState <- liftIO initC++  -- Collect info tables, but only if -finfo-table-map is enabled, otherwise labeledInfoTablesWithTickishes is empty.+  let collectFun = if gopt Opt_InfoTableMap dflags then collect platform else collectNothing+  (labeledInfoTablesWithTickishes, (nonCaffySet, moduleLFInfos)) <- Stream.mapAccumL_ collectFun [] s++  -- Yield Cmm for Info Table Provenance Entries (IPEs)+  let denv' = denv {provInfoTables = Map.fromList (map (\(_, i, t) -> (cit_lbl i, t)) labeledInfoTablesWithTickishes)}+      ((ipeStub, ipeCmmGroup), _) = runC (initStgToCmmConfig dflags this_mod) fstate cgState $ getCmm (initInfoTableProv (map sndOf3 labeledInfoTablesWithTickishes) denv')++  (_, ipeCmmGroupSRTs) <- liftIO $ cmmPipeline hsc_env (emptySRT this_mod) ipeCmmGroup+  Stream.yield ipeCmmGroupSRTs++  return CgInfos {cgNonCafs = nonCaffySet, cgLFInfos = moduleLFInfos, cgIPEStub = ipeStub, cgTagSigs = tag_sigs}+  where+    collect :: Platform -> [(Label, CmmInfoTable, Maybe IpeSourceLocation)] -> CmmGroupSRTs -> IO ([(Label, CmmInfoTable, Maybe IpeSourceLocation)], CmmGroupSRTs)+    collect platform acc cmmGroupSRTs = do+      let labelsToInfoTables = collectInfoTables cmmGroupSRTs+          labelsToInfoTablesToTickishes = map (\(l, i) -> (l, i, lookupEstimatedTick platform cmmGroupSRTs l i)) labelsToInfoTables+      return (acc ++ labelsToInfoTablesToTickishes, cmmGroupSRTs)++    collectNothing :: [a] -> CmmGroupSRTs -> IO ([a], CmmGroupSRTs)+    collectNothing _ cmmGroupSRTs = pure ([], cmmGroupSRTs)++    collectInfoTables :: CmmGroupSRTs -> [(Label, CmmInfoTable)]+    collectInfoTables cmmGroup = concat $ catMaybes $ map extractInfoTables cmmGroup++    extractInfoTables :: GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph -> Maybe [(Label, CmmInfoTable)]+    extractInfoTables (CmmProc h _ _ _) = Just $ mapToList (info_tbls h)+    extractInfoTables _ = Nothing++    lookupEstimatedTick :: Platform -> CmmGroupSRTs -> Label -> CmmInfoTable -> Maybe IpeSourceLocation+    lookupEstimatedTick platform cmmGroup infoTableLabel infoTable = do+      -- All return frame info tables are stack represented, though not all stack represented info+      -- tables have to be return frames.+      if (isStackRep . cit_rep) infoTable+        then do+          let findFun =+                if platformUnregisterised platform+                  then findCmmTickishForForUnregistered (cit_lbl infoTable)+                  else findCmmTickishForRegistered infoTableLabel+              blocks = concatMap toBlockList (graphs cmmGroup)+          firstJusts $ map findFun blocks+        else Nothing+    graphs :: CmmGroupSRTs -> [CmmGraph]+    graphs = foldl' go []+      where+        go :: [CmmGraph] -> GenCmmDecl d h CmmGraph -> [CmmGraph]+        go acc (CmmProc _ _ _ g) = g : acc+        go acc _ = acc++    findCmmTickishForRegistered :: Label -> Block CmmNode C C -> Maybe IpeSourceLocation+    findCmmTickishForRegistered label block = do+      let (_, middleBlock, endBlock) = blockSplit block++      isCallWithReturnFrameLabel endBlock label+      lastTickInBlock middleBlock+      where+        isCallWithReturnFrameLabel :: CmmNode O C -> Label -> Maybe ()+        isCallWithReturnFrameLabel (CmmCall _ (Just l) _ _ _ _) clabel | l == clabel = Just ()+        isCallWithReturnFrameLabel _ _ = Nothing++        lastTickInBlock block =+          listToMaybe $+            catMaybes $+              map maybeTick $ (reverse . blockToList) block++        maybeTick :: CmmNode O O -> Maybe IpeSourceLocation+        maybeTick (CmmTick (SourceNote span name)) = Just (span, name)+        maybeTick _ = Nothing++    findCmmTickishForForUnregistered :: CLabel -> Block CmmNode C C -> Maybe IpeSourceLocation+    findCmmTickishForForUnregistered cLabel block = do+      let (_, middleBlock, _) = blockSplit block+      find cLabel (blockToList middleBlock) Nothing+      where+        find :: CLabel -> [CmmNode O O] -> Maybe IpeSourceLocation -> Maybe IpeSourceLocation+        find label (b : blocks) lastTick = case b of+          (CmmStore _ (CmmLit (CmmLabel l)) _) -> if label == l then lastTick else find label blocks lastTick+          (CmmTick (SourceNote span name)) -> find label blocks $ Just (span, name)+          _ -> find label blocks lastTick+        find _ [] _ = Nothing
compiler/GHC/Driver/Main.hs view
@@ -1,2265 +1,2356 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE NondecreasingIndentation #-}--{-# OPTIONS_GHC -fprof-auto-top #-}--------------------------------------------------------------------------------------- | Main API for compiling plain Haskell source code.------ This module implements compilation of a Haskell source. It is--- /not/ concerned with preprocessing of source files; this is handled--- in "GHC.Driver.Pipeline"------ There are various entry points depending on what mode we're in:--- "batch" mode (@--make@), "one-shot" mode (@-c@, @-S@ etc.), and--- "interactive" mode (GHCi). There are also entry points for--- individual passes: parsing, typechecking/renaming, desugaring, and--- simplification.------ All the functions here take an 'HscEnv' as a parameter, but none of--- them return a new one: 'HscEnv' is treated as an immutable value--- from here on in (although it has mutable components, for the--- caches).------ We use the Hsc monad to deal with warning messages consistently:--- specifically, while executing within an Hsc monad, warnings are--- collected. When a Hsc monad returns to an IO monad, the--- warnings are printed, or compilation aborts if the @-Werror@--- flag is enabled.------ (c) The GRASP/AQUA Project, Glasgow University, 1993-2000-------------------------------------------------------------------------------------module GHC.Driver.Main-    (-    -- * Making an HscEnv-      newHscEnv--    -- * Compiling complete source files-    , Messager, batchMsg-    , HscStatus (..)-    , hscIncrementalCompile-    , initModDetails-    , hscMaybeWriteIface-    , hscCompileCmmFile--    , hscGenHardCode-    , hscInteractive--    -- * Running passes separately-    , hscParse-    , hscTypecheckRename-    , hscDesugar-    , makeSimpleDetails-    , hscSimplify -- ToDo, shouldn't really export this--    -- * Safe Haskell-    , hscCheckSafe-    , hscGetSafe--    -- * Support for interactive evaluation-    , hscParseIdentifier-    , hscTcRcLookupName-    , hscTcRnGetInfo-    , hscIsGHCiMonad-    , hscGetModuleInterface-    , hscRnImportDecls-    , hscTcRnLookupRdrName-    , hscStmt, hscParseStmtWithLocation, hscStmtWithLocation, hscParsedStmt-    , hscDecls, hscParseDeclsWithLocation, hscDeclsWithLocation, hscParsedDecls-    , hscTcExpr, TcRnExprMode(..), hscImport, hscKcType-    , hscParseExpr-    , hscParseType-    , hscCompileCoreExpr-    -- * Low-level exports for hooks-    , hscCompileCoreExpr'-      -- We want to make sure that we export enough to be able to redefine-      -- hsc_typecheck in client code-    , hscParse', hscSimplify', hscDesugar', tcRnModule', doCodeGen-    , getHscEnv-    , hscSimpleIface'-    , oneShotMsg-    , dumpIfaceStats-    , ioMsgMaybe-    , showModuleIndex-    , hscAddSptEntries-    ) where--import GHC.Prelude--import GHC.Driver.Plugins-import GHC.Driver.Session-import GHC.Driver.Backend-import GHC.Driver.Env-import GHC.Driver.Errors-import GHC.Driver.CodeOutput-import GHC.Driver.Config-import GHC.Driver.Hooks-import GHC.Parser.Errors--import GHC.Runtime.Context-import GHC.Runtime.Interpreter ( addSptEntry, hscInterp )-import GHC.Runtime.Loader      ( initializePlugins )-import GHCi.RemoteTypes        ( ForeignHValue )-import GHC.ByteCode.Types--import GHC.Linker.Loader-import GHC.Linker.Types--import GHC.Hs-import GHC.Hs.Dump-import GHC.Hs.Stats         ( ppSourceStats )--import GHC.HsToCore--import GHC.StgToByteCode    ( byteCodeGen )--import GHC.IfaceToCore  ( typecheckIface )--import GHC.Iface.Load   ( ifaceStats, initExternalPackageState, writeIface )-import GHC.Iface.Make-import GHC.Iface.Recomp-import GHC.Iface.Tidy-import GHC.Iface.Ext.Ast    ( mkHieFile )-import GHC.Iface.Ext.Types  ( getAsts, hie_asts, hie_module )-import GHC.Iface.Ext.Binary ( readHieFile, writeHieFile , hie_file_result, NameCacheUpdater(..))-import GHC.Iface.Ext.Debug  ( diffFile, validateScopes )-import GHC.Iface.Env        ( updNameCache )--import GHC.Core-import GHC.Core.Tidy           ( tidyExpr )-import GHC.Core.Type           ( Type, Kind )-import GHC.Core.Lint           ( lintInteractiveExpr )-import GHC.Core.Multiplicity-import GHC.Core.Utils          ( exprType )-import GHC.Core.ConLike-import GHC.Core.Opt.Pipeline-import GHC.Core.TyCon-import GHC.Core.InstEnv-import GHC.Core.FamInstEnv--import GHC.CoreToStg.Prep-import GHC.CoreToStg    ( coreToStg )--import GHC.Parser.Errors.Ppr-import GHC.Parser-import GHC.Parser.Lexer as Lexer--import GHC.Tc.Module-import GHC.Tc.Utils.Monad-import GHC.Tc.Utils.Zonk    ( ZonkFlexi (DefaultFlexi) )--import GHC.Stg.Syntax-import GHC.Stg.FVs      ( annTopBindingsFreeVars )-import GHC.Stg.Pipeline ( stg2stg )--import GHC.Builtin.Utils-import GHC.Builtin.Names-import GHC.Builtin.Uniques ( mkPseudoUniqueE )--import qualified GHC.StgToCmm as StgToCmm ( codeGen )-import GHC.StgToCmm.Types (CgInfos (..), ModuleLFInfos)--import GHC.Cmm-import GHC.Cmm.Parser       ( parseCmmFile )-import GHC.Cmm.Info.Build-import GHC.Cmm.Pipeline-import GHC.Cmm.Info--import GHC.Unit-import GHC.Unit.External-import GHC.Unit.State-import GHC.Unit.Module.ModDetails-import GHC.Unit.Module.ModGuts-import GHC.Unit.Module.ModIface-import GHC.Unit.Module.ModSummary-import GHC.Unit.Module.Graph-import GHC.Unit.Module.Imported-import GHC.Unit.Module.Deps-import GHC.Unit.Module.Status-import GHC.Unit.Home.ModInfo--import GHC.Types.Id-import GHC.Types.SourceError-import GHC.Types.SafeHaskell-import GHC.Types.ForeignStubs-import GHC.Types.Var.Env       ( emptyTidyEnv )-import GHC.Types.Error-import GHC.Types.Fixity.Env-import GHC.Types.CostCentre-import GHC.Types.IPE-import GHC.Types.Unique.Supply-import GHC.Types.SourceFile-import GHC.Types.SrcLoc-import GHC.Types.Name-import GHC.Types.Name.Env-import GHC.Types.Name.Cache ( initNameCache )-import GHC.Types.Name.Reader-import GHC.Types.Name.Ppr-import GHC.Types.TyThing-import GHC.Types.HpcInfo--import GHC.Utils.Fingerprint ( Fingerprint )-import GHC.Utils.Panic-import GHC.Utils.Error-import GHC.Utils.Outputable-import GHC.Utils.Exception-import GHC.Utils.Misc-import GHC.Utils.Logger-import GHC.Utils.TmpFs--import GHC.Data.FastString-import GHC.Data.Bag-import GHC.Data.StringBuffer-import qualified GHC.Data.Stream as Stream-import GHC.Data.Stream (Stream)--import Data.Data hiding (Fixity, TyCon)-import Data.List        ( nub, isPrefixOf, partition )-import Control.Monad-import Data.IORef-import System.FilePath as FilePath-import System.Directory-import System.IO (fixIO)-import qualified Data.Set as S-import Data.Set (Set)-import Data.Functor-import Control.DeepSeq (force)-import Data.Bifunctor (first, bimap)-import GHC.Data.Maybe-import Data.List.NonEmpty (NonEmpty ((:|)))--#include "GhclibHsVersions.h"---{- **********************************************************************-%*                                                                      *-                Initialisation-%*                                                                      *-%********************************************************************* -}--newHscEnv :: DynFlags -> IO HscEnv-newHscEnv dflags = do-    -- we don't store the unit databases and the unit state to still-    -- allow `setSessionDynFlags` to be used to set unit db flags.-    eps_var <- newIORef initExternalPackageState-    us      <- mkSplitUniqSupply 'r'-    nc_var  <- newIORef (initNameCache us knownKeyNames)-    fc_var  <- newIORef emptyInstalledModuleEnv-    logger  <- initLogger-    tmpfs   <- initTmpFs-    -- FIXME: it's sad that we have so many "unitialized" fields filled with-    -- empty stuff or lazy panics. We should have two kinds of HscEnv-    -- (initialized or not) instead and less fields that are mutable over time.-    return HscEnv {  hsc_dflags         = dflags-                  ,  hsc_logger         = logger-                  ,  hsc_targets        = []-                  ,  hsc_mod_graph      = emptyMG-                  ,  hsc_IC             = emptyInteractiveContext dflags-                  ,  hsc_HPT            = emptyHomePackageTable-                  ,  hsc_EPS            = eps_var-                  ,  hsc_NC             = nc_var-                  ,  hsc_FC             = fc_var-                  ,  hsc_type_env_var   = Nothing-                  ,  hsc_interp         = Nothing-                  ,  hsc_unit_env       = panic "hsc_unit_env not initialized"-                  ,  hsc_plugins        = []-                  ,  hsc_static_plugins = []-                  ,  hsc_unit_dbs       = Nothing-                  ,  hsc_hooks          = emptyHooks-                  ,  hsc_tmpfs          = tmpfs-                  }---- -------------------------------------------------------------------------------getWarnings :: Hsc WarningMessages-getWarnings = Hsc $ \_ w -> return (w, w)--clearWarnings :: Hsc ()-clearWarnings = Hsc $ \_ _ -> return ((), emptyBag)--logWarnings :: WarningMessages -> Hsc ()-logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w)--getHscEnv :: Hsc HscEnv-getHscEnv = Hsc $ \e w -> return (e, w)--handleWarnings :: Hsc ()-handleWarnings = do-    dflags <- getDynFlags-    logger <- getLogger-    w <- getWarnings-    liftIO $ printOrThrowWarnings logger dflags w-    clearWarnings---- | log warning in the monad, and if there are errors then--- throw a SourceError exception.-logWarningsReportErrors :: (Bag PsWarning, Bag PsError) -> Hsc ()-logWarningsReportErrors (warnings,errors) = do-    let warns = fmap pprWarning warnings-        errs  = fmap pprError   errors-    logWarnings warns-    when (not $ isEmptyBag errs) $ throwErrors errs---- | Log warnings and throw errors, assuming the messages--- contain at least one error (e.g. coming from PFailed)-handleWarningsThrowErrors :: (Bag PsWarning, Bag PsError) -> Hsc a-handleWarningsThrowErrors (warnings, errors) = do-    let warns = fmap pprWarning warnings-        errs  = fmap pprError   errors-    logWarnings warns-    dflags <- getDynFlags-    logger <- getLogger-    (wWarns, wErrs) <- warningsToMessages dflags <$> getWarnings-    liftIO $ printBagOfErrors logger dflags wWarns-    throwErrors (unionBags errs wErrs)---- | Deal with errors and warnings returned by a compilation step------ In order to reduce dependencies to other parts of the compiler, functions--- outside the "main" parts of GHC return warnings and errors as a parameter--- and signal success via by wrapping the result in a 'Maybe' type. This--- function logs the returned warnings and propagates errors as exceptions--- (of type 'SourceError').------ This function assumes the following invariants:------  1. If the second result indicates success (is of the form 'Just x'),---     there must be no error messages in the first result.------  2. If there are no error messages, but the second result indicates failure---     there should be warnings in the first result. That is, if the action---     failed, it must have been due to the warnings (i.e., @-Werror@).-ioMsgMaybe :: IO (Messages DecoratedSDoc, Maybe a) -> Hsc a-ioMsgMaybe ioA = do-    (msgs, mb_r) <- liftIO ioA-    let (warns, errs) = partitionMessages msgs-    logWarnings warns-    case mb_r of-        Nothing -> throwErrors errs-        Just r  -> ASSERT( isEmptyBag errs ) return r---- | like ioMsgMaybe, except that we ignore error messages and return--- 'Nothing' instead.-ioMsgMaybe' :: IO (Messages DecoratedSDoc, Maybe a) -> Hsc (Maybe a)-ioMsgMaybe' ioA = do-    (msgs, mb_r) <- liftIO $ ioA-    logWarnings (getWarningMessages msgs)-    return mb_r---- -------------------------------------------------------------------------------- | Lookup things in the compiler's environment--hscTcRnLookupRdrName :: HscEnv -> LocatedN RdrName -> IO [Name]-hscTcRnLookupRdrName hsc_env0 rdr_name-  = runInteractiveHsc hsc_env0 $-    do { hsc_env <- getHscEnv-       ; ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name }--hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)-hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do-  hsc_env <- getHscEnv-  ioMsgMaybe' $ tcRnLookupName hsc_env name-      -- ignore errors: the only error we're likely to get is-      -- "name not found", and the Maybe in the return type-      -- is used to indicate that.--hscTcRnGetInfo :: HscEnv -> Name-               -> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))-hscTcRnGetInfo hsc_env0 name-  = runInteractiveHsc hsc_env0 $-    do { hsc_env <- getHscEnv-       ; ioMsgMaybe' $ tcRnGetInfo hsc_env name }--hscIsGHCiMonad :: HscEnv -> String -> IO Name-hscIsGHCiMonad hsc_env name-  = runHsc hsc_env $ ioMsgMaybe $ isGHCiMonad hsc_env name--hscGetModuleInterface :: HscEnv -> Module -> IO ModIface-hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do-  hsc_env <- getHscEnv-  ioMsgMaybe $ getModuleInterface hsc_env mod---- -------------------------------------------------------------------------------- | Rename some import declarations-hscRnImportDecls :: HscEnv -> [LImportDecl GhcPs] -> IO GlobalRdrEnv-hscRnImportDecls hsc_env0 import_decls = runInteractiveHsc hsc_env0 $ do-  hsc_env <- getHscEnv-  ioMsgMaybe $ tcRnImportDecls hsc_env import_decls---- -------------------------------------------------------------------------------- | parse a file, returning the abstract syntax--hscParse :: HscEnv -> ModSummary -> IO HsParsedModule-hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary---- internal version, that doesn't fail due to -Werror-hscParse' :: ModSummary -> Hsc HsParsedModule-hscParse' mod_summary- | Just r <- ms_parsed_mod mod_summary = return r- | otherwise = do-    dflags <- getDynFlags-    logger <- getLogger-    {-# SCC "Parser" #-} withTiming logger dflags-                (text "Parser"<+>brackets (ppr $ ms_mod mod_summary))-                (const ()) $ do-    let src_filename  = ms_hspp_file mod_summary-        maybe_src_buf = ms_hspp_buf  mod_summary--    --------------------------  Parser  -----------------    -- sometimes we already have the buffer in memory, perhaps-    -- because we needed to parse the imports out of it, or get the-    -- module name.-    buf <- case maybe_src_buf of-               Just b  -> return b-               Nothing -> liftIO $ hGetStringBuffer src_filename--    let loc = mkRealSrcLoc (mkFastString src_filename) 1 1--    when (wopt Opt_WarnUnicodeBidirectionalFormatCharacters dflags) $ do-      case checkBidirectionFormatChars (PsLoc loc (BufPos 0)) buf of-        Nothing -> pure ()-        Just chars ->-          logWarnings $ unitBag $ pprWarning $-               PsWarnBidirectionalFormatChars chars--    let parseMod | HsigFile == ms_hsc_src mod_summary-                 = parseSignature-                 | otherwise = parseModule--    case unP parseMod (initParserState (initParserOpts dflags) buf loc) of-        PFailed pst ->-            handleWarningsThrowErrors (getMessages pst)-        POk pst rdr_module -> do-            let (warns, errs) = bimap (fmap pprWarning) (fmap pprError) (getMessages pst)-            logWarnings warns-            liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed "Parser"-                        FormatHaskell (ppr rdr_module)-            liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed_ast "Parser AST"-                        FormatHaskell (showAstData NoBlankSrcSpan-                                                   NoBlankEpAnnotations-                                                   rdr_module)-            liftIO $ dumpIfSet_dyn logger dflags Opt_D_source_stats "Source Statistics"-                        FormatText (ppSourceStats False rdr_module)-            when (not $ isEmptyBag errs) $ throwErrors errs--            -- To get the list of extra source files, we take the list-            -- that the parser gave us,-            --   - eliminate files beginning with '<'.  gcc likes to use-            --     pseudo-filenames like "<built-in>" and "<command-line>"-            --   - normalise them (eliminate differences between ./f and f)-            --   - filter out the preprocessed source file-            --   - filter out anything beginning with tmpdir-            --   - remove duplicates-            --   - filter out the .hs/.lhs source filename if we have one-            ---            let n_hspp  = FilePath.normalise src_filename-                srcs0 = nub $ filter (not . (tmpDir dflags `isPrefixOf`))-                            $ filter (not . (== n_hspp))-                            $ map FilePath.normalise-                            $ filter (not . isPrefixOf "<")-                            $ map unpackFS-                            $ srcfiles pst-                srcs1 = case ml_hs_file (ms_location mod_summary) of-                          Just f  -> filter (/= FilePath.normalise f) srcs0-                          Nothing -> srcs0--            -- sometimes we see source files from earlier-            -- preprocessing stages that cannot be found, so just-            -- filter them out:-            srcs2 <- liftIO $ filterM doesFileExist srcs1--            let res = HsParsedModule {-                      hpm_module    = rdr_module,-                      hpm_src_files = srcs2-                   }--            -- apply parse transformation of plugins-            let applyPluginAction p opts-                  = parsedResultAction p opts mod_summary-            hsc_env <- getHscEnv-            withPlugins hsc_env applyPluginAction res--checkBidirectionFormatChars :: PsLoc -> StringBuffer -> Maybe (NonEmpty (PsLoc, Char, String))-checkBidirectionFormatChars start_loc sb-  | containsBidirectionalFormatChar sb = Just $ go start_loc sb-  | otherwise = Nothing-  where-    go :: PsLoc -> StringBuffer -> NonEmpty (PsLoc, Char, String)-    go loc sb-      | atEnd sb = panic "checkBidirectionFormatChars: no char found"-      | otherwise = case nextChar sb of-          (chr, sb)-            | Just desc <- lookup chr bidirectionalFormatChars ->-                (loc, chr, desc) :| go1 (advancePsLoc loc chr) sb-            | otherwise -> go (advancePsLoc loc chr) sb--    go1 :: PsLoc -> StringBuffer -> [(PsLoc, Char, String)]-    go1 loc sb-      | atEnd sb = []-      | otherwise = case nextChar sb of-          (chr, sb)-            | Just desc <- lookup chr bidirectionalFormatChars ->-                (loc, chr, desc) : go1 (advancePsLoc loc chr) sb-            | otherwise -> go1 (advancePsLoc loc chr) sb----- -------------------------------------------------------------------------------- | If the renamed source has been kept, extract it. Dump it if requested.---extract_renamed_stuff :: ModSummary -> TcGblEnv -> Hsc RenamedStuff-extract_renamed_stuff mod_summary tc_result = do-    let rn_info = getRenamedStuff tc_result--    dflags <- getDynFlags-    logger <- getLogger-    liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_rn_ast "Renamer"-                FormatHaskell (showAstData NoBlankSrcSpan NoBlankEpAnnotations rn_info)--    -- Create HIE files-    when (gopt Opt_WriteHie dflags) $ do-        -- I assume this fromJust is safe because `-fwrite-hie-file`-        -- enables the option which keeps the renamed source.-        hieFile <- mkHieFile mod_summary tc_result (fromJust rn_info)-        let out_file = ml_hie_file $ ms_location mod_summary-        liftIO $ writeHieFile out_file hieFile-        liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_hie "HIE AST" FormatHaskell (ppr $ hie_asts hieFile)--        -- Validate HIE files-        when (gopt Opt_ValidateHie dflags) $ do-            hs_env <- Hsc $ \e w -> return (e, w)-            liftIO $ do-              -- Validate Scopes-              case validateScopes (hie_module hieFile) $ getAsts $ hie_asts hieFile of-                  [] -> putMsg logger dflags $ text "Got valid scopes"-                  xs -> do-                    putMsg logger dflags $ text "Got invalid scopes"-                    mapM_ (putMsg logger dflags) xs-              -- Roundtrip testing-              file' <- readHieFile (NCU $ updNameCache $ hsc_NC hs_env) out_file-              case diffFile hieFile (hie_file_result file') of-                [] ->-                  putMsg logger dflags $ text "Got no roundtrip errors"-                xs -> do-                  putMsg logger dflags $ text "Got roundtrip errors"-                  mapM_ (putMsg logger (dopt_set dflags Opt_D_ppr_debug)) xs-    return rn_info----- -------------------------------------------------------------------------------- | Rename and typecheck a module, additionally returning the renamed syntax-hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule-                   -> IO (TcGblEnv, RenamedStuff)-hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $-    hsc_typecheck True mod_summary (Just rdr_module)----- | A bunch of logic piled around @tcRnModule'@, concerning a) backpack--- b) concerning dumping rename info and hie files. It would be nice to further--- separate this stuff out, probably in conjunction better separating renaming--- and type checking (#17781).-hsc_typecheck :: Bool -- ^ Keep renamed source?-              -> ModSummary -> Maybe HsParsedModule-              -> Hsc (TcGblEnv, RenamedStuff)-hsc_typecheck keep_rn mod_summary mb_rdr_module = do-    hsc_env <- getHscEnv-    let hsc_src = ms_hsc_src mod_summary-        dflags = hsc_dflags hsc_env-        home_unit = hsc_home_unit hsc_env-        outer_mod = ms_mod mod_summary-        mod_name = moduleName outer_mod-        outer_mod' = mkHomeModule home_unit mod_name-        inner_mod = homeModuleNameInstantiation home_unit mod_name-        src_filename  = ms_hspp_file mod_summary-        real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1-        keep_rn' = gopt Opt_WriteHie dflags || keep_rn-    MASSERT( isHomeModule home_unit outer_mod )-    tc_result <- if hsc_src == HsigFile && not (isHoleModule inner_mod)-        then ioMsgMaybe $ tcRnInstantiateSignature hsc_env outer_mod' real_loc-        else-         do hpm <- case mb_rdr_module of-                    Just hpm -> return hpm-                    Nothing -> hscParse' mod_summary-            tc_result0 <- tcRnModule' mod_summary keep_rn' hpm-            if hsc_src == HsigFile-                then do (iface, _, _) <- liftIO $ hscSimpleIface hsc_env tc_result0 Nothing-                        ioMsgMaybe $-                            tcRnMergeSignatures hsc_env hpm tc_result0 iface-                else return tc_result0-    -- TODO are we extracting anything when we merely instantiate a signature?-    -- If not, try to move this into the "else" case above.-    rn_info <- extract_renamed_stuff mod_summary tc_result-    return (tc_result, rn_info)---- wrapper around tcRnModule to handle safe haskell extras-tcRnModule' :: ModSummary -> Bool -> HsParsedModule-            -> Hsc TcGblEnv-tcRnModule' sum save_rn_syntax mod = do-    hsc_env <- getHscEnv-    dflags   <- getDynFlags--    -- -Wmissing-safe-haskell-mode-    when (not (safeHaskellModeEnabled dflags)-          && wopt Opt_WarnMissingSafeHaskellMode dflags) $-        logWarnings $ unitBag $-        makeIntoWarning (Reason Opt_WarnMissingSafeHaskellMode) $-        mkPlainWarnMsg (getLoc (hpm_module mod)) $-        warnMissingSafeHaskellMode--    tcg_res <- {-# SCC "Typecheck-Rename" #-}-               ioMsgMaybe $-                   tcRnModule hsc_env sum-                     save_rn_syntax mod--    -- See Note [Safe Haskell Overlapping Instances Implementation]-    -- although this is used for more than just that failure case.-    (tcSafeOK, whyUnsafe) <- liftIO $ readIORef (tcg_safeInfer tcg_res)-    let allSafeOK = safeInferred dflags && tcSafeOK--    -- end of the safe haskell line, how to respond to user?-    if not (safeHaskellOn dflags)-         || (safeInferOn dflags && not allSafeOK)-      -- if safe Haskell off or safe infer failed, mark unsafe-      then markUnsafeInfer tcg_res whyUnsafe--      -- module (could be) safe, throw warning if needed-      else do-          tcg_res' <- hscCheckSafeImports tcg_res-          safe <- liftIO $ fst <$> readIORef (tcg_safeInfer tcg_res')-          when safe $-            case wopt Opt_WarnSafe dflags of-              True-                | safeHaskell dflags == Sf_Safe -> return ()-                | otherwise -> (logWarnings $ unitBag $-                       makeIntoWarning (Reason Opt_WarnSafe) $-                       mkPlainWarnMsg (warnSafeOnLoc dflags) $-                       errSafe tcg_res')-              False | safeHaskell dflags == Sf_Trustworthy &&-                      wopt Opt_WarnTrustworthySafe dflags ->-                      (logWarnings $ unitBag $-                       makeIntoWarning (Reason Opt_WarnTrustworthySafe) $-                       mkPlainWarnMsg (trustworthyOnLoc dflags) $-                       errTwthySafe tcg_res')-              False -> return ()-          return tcg_res'-  where-    pprMod t  = ppr $ moduleName $ tcg_mod t-    errSafe t = quotes (pprMod t) <+> text "has been inferred as safe!"-    errTwthySafe t = quotes (pprMod t)-      <+> text "is marked as Trustworthy but has been inferred as safe!"-    warnMissingSafeHaskellMode = ppr (moduleName (ms_mod sum))-      <+> text "is missing Safe Haskell mode"---- | Convert a typechecked module to Core-hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts-hscDesugar hsc_env mod_summary tc_result =-    runHsc hsc_env $ hscDesugar' (ms_location mod_summary) tc_result--hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts-hscDesugar' mod_location tc_result = do-    hsc_env <- getHscEnv-    r <- ioMsgMaybe $-      {-# SCC "deSugar" #-}-      deSugar hsc_env mod_location tc_result--    -- always check -Werror after desugaring, this is the last opportunity for-    -- warnings to arise before the backend.-    handleWarnings-    return r---- | Make a 'ModDetails' from the results of typechecking. Used when--- typechecking only, as opposed to full compilation.-makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails-makeSimpleDetails hsc_env tc_result = mkBootModDetailsTc hsc_env tc_result---{- **********************************************************************-%*                                                                      *-                The main compiler pipeline-%*                                                                      *-%********************************************************************* -}--{--                   ---------------------------------                        The compilation proper-                   ----------------------------------It's the task of the compilation proper to compile Haskell, hs-boot and core-files to either byte-code, hard-code (C, asm, LLVM, etc.) or to nothing at all-(the module is still parsed and type-checked. This feature is mostly used by-IDE's and the likes). Compilation can happen in either 'one-shot', 'batch',-'nothing', or 'interactive' mode. 'One-shot' mode targets hard-code, 'batch'-mode targets hard-code, 'nothing' mode targets nothing and 'interactive' mode-targets byte-code.--The modes are kept separate because of their different types and meanings:-- * In 'one-shot' mode, we're only compiling a single file and can therefore- discard the new ModIface and ModDetails. This is also the reason it only- targets hard-code; compiling to byte-code or nothing doesn't make sense when- we discard the result.-- * 'Batch' mode is like 'one-shot' except that we keep the resulting ModIface- and ModDetails. 'Batch' mode doesn't target byte-code since that require us to- return the newly compiled byte-code.-- * 'Nothing' mode has exactly the same type as 'batch' mode but they're still- kept separate. This is because compiling to nothing is fairly special: We- don't output any interface files, we don't run the simplifier and we don't- generate any code.-- * 'Interactive' mode is similar to 'batch' mode except that we return the- compiled byte-code together with the ModIface and ModDetails.--Trying to compile a hs-boot file to byte-code will result in a run-time error.-This is the only thing that isn't caught by the type-system.--}---type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModuleGraphNode -> IO ()---- | This function runs GHC's frontend with recompilation--- avoidance. Specifically, it checks if recompilation is needed,--- and if it is, it parses and typechecks the input module.--- It does not write out the results of typechecking (See--- compileOne and hscIncrementalCompile).-hscIncrementalFrontend :: Bool -- always do basic recompilation check?-                       -> Maybe TcGblEnv-                       -> Maybe Messager-                       -> ModSummary-                       -> SourceModified-                       -> Maybe ModIface  -- Old interface, if available-                       -> (Int,Int)       -- (i,n) = module i of n (for msgs)-                       -> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint))--hscIncrementalFrontend-  always_do_basic_recompilation_check m_tc_result-  mHscMessage mod_summary source_modified mb_old_iface mod_index-    = do-    hsc_env <- getHscEnv--    let msg what = case mHscMessage of-          -- We use extendModSummaryNoDeps because extra backpack deps are only needed for batch mode-          Just hscMessage -> hscMessage hsc_env mod_index what (ModuleNode (extendModSummaryNoDeps mod_summary))-          Nothing -> return ()--        skip iface = do-            liftIO $ msg UpToDate-            return $ Left iface--        compile mb_old_hash reason = do-            liftIO $ msg reason-            tc_result <- case hscFrontendHook (hsc_hooks hsc_env) of-              Nothing -> FrontendTypecheck . fst <$> hsc_typecheck False mod_summary Nothing-              Just h  -> h mod_summary-            return $ Right (tc_result, mb_old_hash)--        stable = case source_modified of-                     SourceUnmodifiedAndStable -> True-                     _                         -> False--    case m_tc_result of-         Just tc_result-          | not always_do_basic_recompilation_check ->-             return $ Right (FrontendTypecheck tc_result, Nothing)-         _ -> do-            (recomp_reqd, mb_checked_iface)-                <- {-# SCC "checkOldIface" #-}-                   liftIO $ checkOldIface hsc_env mod_summary-                                source_modified mb_old_iface-            -- save the interface that comes back from checkOldIface.-            -- In one-shot mode we don't have the old iface until this-            -- point, when checkOldIface reads it from the disk.-            let mb_old_hash = fmap (mi_iface_hash . mi_final_exts) mb_checked_iface--            case mb_checked_iface of-                Just iface | not (recompileRequired recomp_reqd) ->-                    -- If the module used TH splices when it was last-                    -- compiled, then the recompilation check is not-                    -- accurate enough (#481) and we must ignore-                    -- it.  However, if the module is stable (none of-                    -- the modules it depends on, directly or-                    -- indirectly, changed), then we *can* skip-                    -- recompilation. This is why the SourceModified-                    -- type contains SourceUnmodifiedAndStable, and-                    -- it's pretty important: otherwise ghc --make-                    -- would always recompile TH modules, even if-                    -- nothing at all has changed. Stability is just-                    -- the same check that make is doing for us in-                    -- one-shot mode.-                    case m_tc_result of-                    Nothing-                     | mi_used_th iface && not stable ->-                        compile mb_old_hash (RecompBecause "TH")-                    _ ->-                        skip iface-                _ ->-                    case m_tc_result of-                    Nothing -> compile mb_old_hash recomp_reqd-                    Just tc_result ->-                        return $ Right (FrontendTypecheck tc_result, mb_old_hash)------------------------------------------------------------------- Compilers------------------------------------------------------------------- | Used by both OneShot and batch mode. Runs the pipeline HsSyn and Core parts--- of the pipeline.--- We return a interface if we already had an old one around and recompilation--- was not needed. Otherwise it will be created during later passes when we--- run the compilation pipeline.-hscIncrementalCompile :: Bool-                      -> Maybe TcGblEnv-                      -> Maybe Messager-                      -> HscEnv-                      -> ModSummary-                      -> SourceModified-                      -> Maybe ModIface-                      -> (Int,Int)-                      -> IO (HscStatus, HscEnv)-hscIncrementalCompile always_do_basic_recompilation_check m_tc_result-    mHscMessage hsc_env' mod_summary source_modified mb_old_iface mod_index-  = do-    hsc_env'' <- initializePlugins hsc_env'--    -- One-shot mode needs a knot-tying mutable variable for interface-    -- files. See GHC.Tc.Utils.TcGblEnv.tcg_type_env_var.-    -- See also Note [hsc_type_env_var hack]-    type_env_var <- newIORef emptyNameEnv-    let mod = ms_mod mod_summary-        hsc_env | isOneShot (ghcMode (hsc_dflags hsc_env''))-                = hsc_env'' { hsc_type_env_var = Just (mod, type_env_var) }-                | otherwise-                = hsc_env''--    -- NB: enter Hsc monad here so that we don't bail out early with-    -- -Werror on typechecker warnings; we also want to run the desugarer-    -- to get those warnings too. (But we'll always exit at that point-    -- because the desugarer runs ioMsgMaybe.)-    runHsc hsc_env $ do-    e <- hscIncrementalFrontend always_do_basic_recompilation_check m_tc_result mHscMessage-            mod_summary source_modified mb_old_iface mod_index-    case e of-        -- We didn't need to do any typechecking; the old interface-        -- file on disk was good enough.-        Left iface -> do-            details <- liftIO $ initModDetails hsc_env mod_summary iface-            return (HscUpToDate iface details, hsc_env')-        -- We finished type checking.  (mb_old_hash is the hash of-        -- the interface that existed on disk; it's possible we had-        -- to retypecheck but the resulting interface is exactly-        -- the same.)-        Right (FrontendTypecheck tc_result, mb_old_hash) -> do-            status <- finish mod_summary tc_result mb_old_hash-            return (status, hsc_env)---- Knot tying!  See Note [Knot-tying typecheckIface]--- See Note [ModDetails and --make mode]-initModDetails :: HscEnv -> ModSummary -> ModIface -> IO ModDetails-initModDetails hsc_env mod_summary iface =-  fixIO $ \details' -> do-    let hsc_env' =-          hsc_env {-              hsc_HPT = addToHpt (hsc_HPT hsc_env)-                          (ms_mod_name mod_summary)-                          (HomeModInfo iface details' Nothing)-                  }-    -- NB: This result is actually not that useful-    -- in one-shot mode, since we're not going to do-    -- any further typechecking.  It's much more useful-    -- in make mode, since this HMI will go into the HPT.-    genModDetails hsc_env' iface---{--Note [ModDetails and --make mode]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--An interface file consists of two parts--* The `ModIface` which ends up getting written to disk.-  The `ModIface` is a completely acyclic tree, which can be serialised-  and de-serialised completely straightforwardly.  The `ModIface` is-  also the structure that is finger-printed for recompilation control.--* The `ModDetails` which provides a more structured view that is suitable-  for usage during compilation.  The `ModDetails` is heavily cyclic:-  An `Id` contains a `Type`, which mentions a `TyCon` that contains kind-  that mentions other `TyCons`; the `Id` also includes an unfolding that-  in turn mentions more `Id`s;  And so on.--The `ModIface` can be created from the `ModDetails` and the `ModDetails` from-a `ModIface`.--During tidying, just before interfaces are written to disk,-the ModDetails is calculated and then converted into a ModIface (see GHC.Iface.Make.mkIface_).-Then when GHC needs to restart typechecking from a certain point it can read the-interface file, and regenerate the ModDetails from the ModIface (see GHC.IfaceToCore.typecheckIface).-The key part about the loading is that the ModDetails is regenerated lazily-from the ModIface, so that there's only a detailed in-memory representation-for declarations which are actually used from the interface. This mode is-also used when reading interface files from external packages.--In the old --make mode implementation, the interface was written after compiling a module-but the in-memory ModDetails which was used to compute the ModIface was retained.-The result was that --make mode used much more memory than `-c` mode, because a large amount of-information about a module would be kept in the ModDetails but never used.--The new idea is that even in `--make` mode, when there is an in-memory `ModDetails`-at hand, we re-create the `ModDetails` from the `ModIface`. Doing this means that-we only have to keep the `ModIface` decls in memory and then lazily load-detailed representations if needed. It turns out this makes a really big difference-to memory usage, halving maximum memory used in some cases.--See !5492 and #13586--}---- Runs the post-typechecking frontend (desugar and simplify). We want to--- generate most of the interface as late as possible. This gets us up-to-date--- and good unfoldings and other info in the interface file.------ We might create a interface right away, in which case we also return the--- updated HomeModInfo. But we might also need to run the backend first. In the--- later case Status will be HscRecomp and we return a function from ModIface ->--- HomeModInfo.------ HscRecomp in turn will carry the information required to compute a interface--- when passed the result of the code generator. So all this can and is done at--- the call site of the backend code gen if it is run.-finish :: ModSummary-       -> TcGblEnv-       -> Maybe Fingerprint-       -> Hsc HscStatus-finish summary tc_result mb_old_hash = do-  hsc_env <- getHscEnv-  dflags <- getDynFlags-  logger <- getLogger-  let bcknd  = backend dflags-      hsc_src = ms_hsc_src summary--  -- Desugar, if appropriate-  ---  -- We usually desugar even when we are not generating code, otherwise we-  -- would miss errors thrown by the desugaring (see #10600). The only-  -- exceptions are when the Module is Ghc.Prim or when it is not a-  -- HsSrcFile Module.-  mb_desugar <--      if ms_mod summary /= gHC_PRIM && hsc_src == HsSrcFile-      then Just <$> hscDesugar' (ms_location summary) tc_result-      else pure Nothing--  -- Simplify, if appropriate, and (whether we simplified or not) generate an-  -- interface file.-  case mb_desugar of-      -- Just cause we desugared doesn't mean we are generating code, see above.-      Just desugared_guts | bcknd /= NoBackend -> do-          plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result)-          simplified_guts <- hscSimplify' plugins desugared_guts--          (cg_guts, details) <- {-# SCC "CoreTidy" #-}-              liftIO $ tidyProgram hsc_env simplified_guts--          let !partial_iface =-                {-# SCC "GHC.Driver.Main.mkPartialIface" #-}-                -- This `force` saves 2M residency in test T10370-                -- See Note [Avoiding space leaks in toIface*] for details.-                force (mkPartialIface hsc_env details simplified_guts)--          return HscRecomp { hscs_guts = cg_guts,-                             hscs_mod_location = ms_location summary,-                             hscs_partial_iface = partial_iface,-                             hscs_old_iface_hash = mb_old_hash-                           }--      -- We are not generating code, so we can skip simplification-      -- and generate a simple interface.-      _ -> do-        (iface, mb_old_iface_hash, details) <- liftIO $-          hscSimpleIface hsc_env tc_result mb_old_hash--        liftIO $ hscMaybeWriteIface logger dflags True iface mb_old_iface_hash (ms_location summary)--        return $ case bcknd of-          NoBackend -> HscNotGeneratingCode iface details-          _         -> case hsc_src of-                        HsBootFile -> HscUpdateBoot iface details-                        HsigFile   -> HscUpdateSig iface details-                        _          -> panic "finish"--{--Note [Writing interface files]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--We write one interface file per module and per compilation, except with--dynamic-too where we write two interface files (non-dynamic and dynamic).--We can write two kinds of interfaces (see Note [Interface file stages] in-"GHC.Driver.Types"):--   * simple interface: interface generated after the core pipeline--   * full interface: simple interface completed with information from the-     backend--Depending on the situation, we write one or the other (using-`hscMaybeWriteIface`). We must be careful with `-dynamic-too` because only the-backend is run twice, so if we write a simple interface we need to write both-the non-dynamic and the dynamic interfaces at the same time (with the same-contents).--Cases for which we generate simple interfaces:--   * GHC.Driver.Main.finish: when a compilation does NOT require (re)compilation-   of the hard code--   * GHC.Driver.Pipeline.compileOne': when we run in One Shot mode and target-   bytecode (if interface writing is forced).--   * GHC.Driver.Backpack uses simple interfaces for indefinite units-   (units with module holes). It writes them indirectly by forcing the-   -fwrite-interface flag while setting backend to NoBackend.--Cases for which we generate full interfaces:--   * GHC.Driver.Pipeline.runPhase: when we must be compiling to regular hard-   code and/or require recompilation.--By default interface file names are derived from module file names by adding-suffixes. The interface file name can be overloaded with "-ohi", except when-`-dynamic-too` is used.---}---- | Write interface files-hscMaybeWriteIface :: Logger -> DynFlags -> Bool -> ModIface -> Maybe Fingerprint -> ModLocation -> IO ()-hscMaybeWriteIface logger dflags is_simple iface old_iface mod_location = do-    let force_write_interface = gopt Opt_WriteInterface dflags-        write_interface = case backend dflags of-                            NoBackend    -> False-                            Interpreter  -> False-                            _            -> True--      -- mod_location only contains the base name, so we rebuild the-      -- correct file extension from the dynflags.-        baseName = ml_hi_file mod_location-        buildIfName suffix is_dynamic-          | Just name <- (if is_dynamic then dynOutputHi else outputHi) dflags-          = name-          | otherwise-          = let with_hi = replaceExtension baseName suffix-            in  addBootSuffix_maybe (mi_boot iface) with_hi--        write_iface dflags' iface =-          let !iface_name = buildIfName (hiSuf dflags') (dynamicNow dflags')-          in-          {-# SCC "writeIface" #-}-          withTiming logger dflags'-              (text "WriteIface"<+>brackets (text iface_name))-              (const ())-              (writeIface logger dflags' iface_name iface)--    when (write_interface || force_write_interface) $ do--      -- FIXME: with -dynamic-too, "no_change" is only meaningful for the-      -- non-dynamic interface, not for the dynamic one. We should have another-      -- flag for the dynamic interface. In the meantime:-      ---      --    * when we write a single full interface, we check if we are-      --    currently writing the dynamic interface due to -dynamic-too, in-      --    which case we ignore "no_change".-      ---      --    * when we write two simple interfaces at once because of-      --    dynamic-too, we use "no_change" both for the non-dynamic and the-      --    dynamic interfaces. Hopefully both the dynamic and the non-dynamic-      --    interfaces stay in sync...-      ---      let no_change = old_iface == Just (mi_iface_hash (mi_final_exts iface))--      dt <- dynamicTooState dflags--      when (dopt Opt_D_dump_if_trace dflags) $ putMsg logger dflags $-        hang (text "Writing interface(s):") 2 $ vcat-         [ text "Kind:" <+> if is_simple then text "simple" else text "full"-         , text "Hash change:" <+> ppr (not no_change)-         , text "DynamicToo state:" <+> text (show dt)-         ]--      if is_simple-         then unless no_change $ do -- FIXME: see no_change' comment above-            write_iface dflags iface-            case dt of-               DT_Dont   -> return ()-               DT_Failed -> return ()-               DT_Dyn    -> panic "Unexpected DT_Dyn state when writing simple interface"-               DT_OK     -> write_iface (setDynamicNow dflags) iface-         else case dt of-               DT_Dont | not no_change             -> write_iface dflags iface-               DT_OK   | not no_change             -> write_iface dflags iface-               -- FIXME: see no_change' comment above-               DT_Dyn                              -> write_iface dflags iface-               DT_Failed | not (dynamicNow dflags) -> write_iface dflags iface-               _                                   -> return ()------------------------------------------------------------------- NoRecomp handlers------------------------------------------------------------------- NB: this must be knot-tied appropriately, see hscIncrementalCompile-genModDetails :: HscEnv -> ModIface -> IO ModDetails-genModDetails hsc_env old_iface-  = do-    new_details <- {-# SCC "tcRnIface" #-}-                   initIfaceLoad hsc_env (typecheckIface old_iface)-    dumpIfaceStats hsc_env-    return new_details------------------------------------------------------------------- Progress displayers.-----------------------------------------------------------------oneShotMsg :: HscEnv -> RecompileRequired -> IO ()-oneShotMsg hsc_env recomp =-    case recomp of-        UpToDate ->-            compilationProgressMsg logger dflags $-                   text "compilation IS NOT required"-        _ ->-            return ()-    where-        dflags = hsc_dflags hsc_env-        logger = hsc_logger hsc_env--batchMsg :: Messager-batchMsg hsc_env mod_index recomp node = case node of-    InstantiationNode _ ->-        case recomp of-            MustCompile -> showMsg (text "Instantiating ") empty-            UpToDate-                | verbosity dflags >= 2 -> showMsg (text "Skipping  ") empty-                | otherwise -> return ()-            RecompBecause reason -> showMsg (text "Instantiating ") (text " [" <> text reason <> text "]")-    ModuleNode _ ->-        case recomp of-            MustCompile -> showMsg (text "Compiling ") empty-            UpToDate-                | verbosity dflags >= 2 -> showMsg (text "Skipping  ") empty-                | otherwise -> return ()-            RecompBecause reason -> showMsg (text "Compiling ") (text " [" <> text reason <> text "]")-    where-        dflags = hsc_dflags hsc_env-        logger = hsc_logger hsc_env-        showMsg msg reason =-            compilationProgressMsg logger dflags $-            (showModuleIndex mod_index <>-            msg <> showModMsg dflags (recompileRequired recomp) node)-                <> reason------------------------------------------------------------------- Safe Haskell------------------------------------------------------------------- Note [Safe Haskell Trust Check]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- Safe Haskell checks that an import is trusted according to the following--- rules for an import of module M that resides in Package P:------   * If M is recorded as Safe and all its trust dependencies are OK---     then M is considered safe.---   * If M is recorded as Trustworthy and P is considered trusted and---     all M's trust dependencies are OK then M is considered safe.------ By trust dependencies we mean that the check is transitive. So if--- a module M that is Safe relies on a module N that is trustworthy,--- importing module M will first check (according to the second case)--- that N is trusted before checking M is trusted.------ This is a minimal description, so please refer to the user guide--- for more details. The user guide is also considered the authoritative--- source in this matter, not the comments or code.----- Note [Safe Haskell Inference]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- Safe Haskell does Safe inference on modules that don't have any specific--- safe haskell mode flag. The basic approach to this is:---   * When deciding if we need to do a Safe language check, treat---     an unmarked module as having -XSafe mode specified.---   * For checks, don't throw errors but return them to the caller.---   * Caller checks if there are errors:---     * For modules explicitly marked -XSafe, we throw the errors.---     * For unmarked modules (inference mode), we drop the errors---       and mark the module as being Unsafe.------ It used to be that we only did safe inference on modules that had no Safe--- Haskell flags, but now we perform safe inference on all modules as we want--- to allow users to set the `-Wsafe`, `-Wunsafe` and--- `-Wtrustworthy-safe` flags on Trustworthy and Unsafe modules so that a--- user can ensure their assumptions are correct and see reasons for why a--- module is safe or unsafe.------ This is tricky as we must be careful when we should throw an error compared--- to just warnings. For checking safe imports we manage it as two steps. First--- we check any imports that are required to be safe, then we check all other--- imports to see if we can infer them to be safe.----- | Check that the safe imports of the module being compiled are valid.--- If not we either issue a compilation error if the module is explicitly--- using Safe Haskell, or mark the module as unsafe if we're in safe--- inference mode.-hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv-hscCheckSafeImports tcg_env = do-    dflags   <- getDynFlags-    tcg_env' <- checkSafeImports tcg_env-    checkRULES dflags tcg_env'--  where-    checkRULES dflags tcg_env' =-      case safeLanguageOn dflags of-          True -> do-              -- XSafe: we nuke user written RULES-              logWarnings $ warns (tcg_rules tcg_env')-              return tcg_env' { tcg_rules = [] }-          False-                -- SafeInferred: user defined RULES, so not safe-              | safeInferOn dflags && not (null $ tcg_rules tcg_env')-              -> markUnsafeInfer tcg_env' $ warns (tcg_rules tcg_env')--                -- Trustworthy OR SafeInferred: with no RULES-              | otherwise-              -> return tcg_env'--    warns rules = listToBag $ map warnRules rules--    warnRules :: LRuleDecl GhcTc -> MsgEnvelope DecoratedSDoc-    warnRules (L loc (HsRule { rd_name = n })) =-        mkPlainWarnMsg (locA loc) $-            text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$-            text "User defined rules are disabled under Safe Haskell"---- | Validate that safe imported modules are actually safe.  For modules in the--- HomePackage (the package the module we are compiling in resides) this just--- involves checking its trust type is 'Safe' or 'Trustworthy'. For modules--- that reside in another package we also must check that the external package--- is trusted. See the Note [Safe Haskell Trust Check] above for more--- information.------ The code for this is quite tricky as the whole algorithm is done in a few--- distinct phases in different parts of the code base. See--- 'GHC.Rename.Names.rnImportDecl' for where package trust dependencies for a--- module are collected and unioned.  Specifically see the Note [Tracking Trust--- Transitively] in "GHC.Rename.Names" and the Note [Trust Own Package] in--- "GHC.Rename.Names".-checkSafeImports :: TcGblEnv -> Hsc TcGblEnv-checkSafeImports tcg_env-    = do-        dflags <- getDynFlags-        imps <- mapM condense imports'-        let (safeImps, regImps) = partition (\(_,_,s) -> s) imps--        -- We want to use the warning state specifically for detecting if safe-        -- inference has failed, so store and clear any existing warnings.-        oldErrs <- getWarnings-        clearWarnings--        -- Check safe imports are correct-        safePkgs <- S.fromList <$> mapMaybeM checkSafe safeImps-        safeErrs <- getWarnings-        clearWarnings--        -- Check non-safe imports are correct if inferring safety-        -- See the Note [Safe Haskell Inference]-        (infErrs, infPkgs) <- case (safeInferOn dflags) of-          False -> return (emptyBag, S.empty)-          True -> do infPkgs <- S.fromList <$> mapMaybeM checkSafe regImps-                     infErrs <- getWarnings-                     clearWarnings-                     return (infErrs, infPkgs)--        -- restore old errors-        logWarnings oldErrs--        logger <- getLogger-        -- Will throw if failed safe check-        ---        -- Zubin: printOrThrowWarnings doesn't actually throw if we-        -- have SevError warnings, so we need to do an additional check-        -- before calling it to see if we need to throw, because SevError-        -- safe haskell warnings are supposed to be fatal.-        -- We don't want to modify printOrThrowWarnings on GHC 9.2 to-        -- perform this check because it affects other error messages (like T10647)-        -- and changes the behavior of the compiler.-        -- This is fixed in GHC 9.4-        when (anyBag isErrorMessage safeErrs) $-          liftIO $ throwIO (mkSrcErr safeErrs)-        liftIO $ printOrThrowWarnings logger dflags safeErrs--        -- No fatal warnings or errors: passed safe check-        let infPassed = isEmptyBag infErrs-        tcg_env' <- case (not infPassed) of-          True  -> markUnsafeInfer tcg_env infErrs-          False -> return tcg_env-        when (packageTrustOn dflags) $ checkPkgTrust pkgReqs-        let newTrust = pkgTrustReqs dflags safePkgs infPkgs infPassed-        return tcg_env' { tcg_imports = impInfo `plusImportAvails` newTrust }--  where-    impInfo  = tcg_imports tcg_env     -- ImportAvails-    imports  = imp_mods impInfo        -- ImportedMods-    imports1 = moduleEnvToList imports -- (Module, [ImportedBy])-    imports' = map (fmap importedByUser) imports1 -- (Module, [ImportedModsVal])-    pkgReqs  = imp_trust_pkgs impInfo  -- [Unit]--    condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport)-    condense (_, [])   = panic "GHC.Driver.Main.condense: Pattern match failure!"-    condense (m, x:xs) = do imv <- foldlM cond' x xs-                            return (m, imv_span imv, imv_is_safe imv)--    -- ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport)-    cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal-    cond' v1 v2-        | imv_is_safe v1 /= imv_is_safe v2-        = throwOneError $ mkPlainMsgEnvelope (imv_span v1)-              (text "Module" <+> ppr (imv_name v1) <+>-              (text $ "is imported both as a safe and unsafe import!"))-        | otherwise-        = return v1--    -- easier interface to work with-    checkSafe :: (Module, SrcSpan, a) -> Hsc (Maybe UnitId)-    checkSafe (m, l, _) = fst `fmap` hscCheckSafe' m l--    -- what pkg's to add to our trust requirements-    pkgTrustReqs :: DynFlags -> Set UnitId -> Set UnitId ->-          Bool -> ImportAvails-    pkgTrustReqs dflags req inf infPassed | safeInferOn dflags-                                  && not (safeHaskellModeEnabled dflags) && infPassed-                                   = emptyImportAvails {-                                       imp_trust_pkgs = req `S.union` inf-                                   }-    pkgTrustReqs dflags _   _ _ | safeHaskell dflags == Sf_Unsafe-                         = emptyImportAvails-    pkgTrustReqs _ req _ _ = emptyImportAvails { imp_trust_pkgs = req }---- | Check that a module is safe to import.------ We return True to indicate the import is safe and False otherwise--- although in the False case an exception may be thrown first.-hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool-hscCheckSafe hsc_env m l = runHsc hsc_env $ do-    dflags <- getDynFlags-    pkgs <- snd `fmap` hscCheckSafe' m l-    when (packageTrustOn dflags) $ checkPkgTrust pkgs-    errs <- getWarnings-    return $ isEmptyBag errs---- | Return if a module is trusted and the pkgs it depends on to be trusted.-hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set UnitId)-hscGetSafe hsc_env m l = runHsc hsc_env $ do-    (self, pkgs) <- hscCheckSafe' m l-    good         <- isEmptyBag `fmap` getWarnings-    clearWarnings -- don't want them printed...-    let pkgs' | Just p <- self = S.insert p pkgs-              | otherwise      = pkgs-    return (good, pkgs')---- | Is a module trusted? If not, throw or log errors depending on the type.--- Return (regardless of trusted or not) if the trust type requires the modules--- own package be trusted and a list of other packages required to be trusted--- (these later ones haven't been checked) but the own package trust has been.-hscCheckSafe' :: Module -> SrcSpan-  -> Hsc (Maybe UnitId, Set UnitId)-hscCheckSafe' m l = do-    hsc_env <- getHscEnv-    let home_unit = hsc_home_unit hsc_env-    (tw, pkgs) <- isModSafe home_unit m l-    case tw of-        False                           -> return (Nothing, pkgs)-        True | isHomeModule home_unit m -> return (Nothing, pkgs)-             -- TODO: do we also have to check the trust of the instantiation?-             -- Not necessary if that is reflected in dependencies-             | otherwise   -> return (Just $ toUnitId (moduleUnit m), pkgs)-  where-    isModSafe :: HomeUnit -> Module -> SrcSpan -> Hsc (Bool, Set UnitId)-    isModSafe home_unit m l = do-        hsc_env <- getHscEnv-        dflags <- getDynFlags-        iface <- lookup' m-        case iface of-            -- can't load iface to check trust!-            Nothing -> throwOneError $ mkPlainMsgEnvelope l-                         $ text "Can't load the interface file for" <+> ppr m-                           <> text ", to check that it can be safely imported"--            -- got iface, check trust-            Just iface' ->-                let trust = getSafeMode $ mi_trust iface'-                    trust_own_pkg = mi_trust_pkg iface'-                    -- check module is trusted-                    safeM = trust `elem` [Sf_Safe, Sf_SafeInferred, Sf_Trustworthy]-                    -- check package is trusted-                    safeP = packageTrusted dflags (hsc_units hsc_env) home_unit trust trust_own_pkg m-                    -- pkg trust reqs-                    pkgRs = S.fromList . map fst $ filter snd $ dep_pkgs $ mi_deps iface'-                    -- warn if Safe module imports Safe-Inferred module.-                    warns = if wopt Opt_WarnInferredSafeImports dflags-                                && safeLanguageOn dflags-                                && trust == Sf_SafeInferred-                                then inferredImportWarn-                                else emptyBag-                    -- General errors we throw but Safe errors we log-                    errs = case (safeM, safeP) of-                        (True, True ) -> emptyBag-                        (True, False) -> pkgTrustErr-                        (False, _   ) -> modTrustErr-                in do-                    logWarnings warns-                    logWarnings errs-                    return (trust == Sf_Trustworthy, pkgRs)--                where-                    state = hsc_units hsc_env-                    inferredImportWarn = unitBag-                        $ makeIntoWarning (Reason Opt_WarnInferredSafeImports)-                        $ mkWarnMsg l (pkgQual state)-                        $ sep-                            [ text "Importing Safe-Inferred module "-                                <> ppr (moduleName m)-                                <> text " from explicitly Safe module"-                            ]-                    pkgTrustErr = unitBag $ mkMsgEnvelope l (pkgQual state) $-                        sep [ ppr (moduleName m)-                                <> text ": Can't be safely imported!"-                            , text "The package ("-                                <> (pprWithUnitState state $ ppr (moduleUnit m))-                                <> text ") the module resides in isn't trusted."-                            ]-                    modTrustErr = unitBag $ mkMsgEnvelope l (pkgQual state) $-                        sep [ ppr (moduleName m)-                                <> text ": Can't be safely imported!"-                            , text "The module itself isn't safe." ]--    -- | Check the package a module resides in is trusted. Safe compiled-    -- modules are trusted without requiring that their package is trusted. For-    -- trustworthy modules, modules in the home package are trusted but-    -- otherwise we check the package trust flag.-    packageTrusted :: DynFlags -> UnitState -> HomeUnit -> SafeHaskellMode -> Bool -> Module -> Bool-    packageTrusted dflags unit_state home_unit safe_mode trust_own_pkg mod =-        case safe_mode of-            Sf_None      -> False -- shouldn't hit these cases-            Sf_Ignore    -> False -- shouldn't hit these cases-            Sf_Unsafe    -> False -- prefer for completeness.-            _ | not (packageTrustOn dflags)     -> True-            Sf_Safe | not trust_own_pkg         -> True-            Sf_SafeInferred | not trust_own_pkg -> True-            _ | isHomeModule home_unit mod      -> True-            _ -> unitIsTrusted $ unsafeLookupUnit unit_state (moduleUnit m)--    lookup' :: Module -> Hsc (Maybe ModIface)-    lookup' m = do-        hsc_env <- getHscEnv-        hsc_eps <- liftIO $ hscEPS hsc_env-        let pkgIfaceT = eps_PIT hsc_eps-            homePkgT  = hsc_HPT hsc_env-            iface     = lookupIfaceByModule homePkgT pkgIfaceT m-        -- the 'lookupIfaceByModule' method will always fail when calling from GHCi-        -- as the compiler hasn't filled in the various module tables-        -- so we need to call 'getModuleInterface' to load from disk-        case iface of-            Just _  -> return iface-            Nothing -> snd `fmap` (liftIO $ getModuleInterface hsc_env m)----- | Check the list of packages are trusted.-checkPkgTrust :: Set UnitId -> Hsc ()-checkPkgTrust pkgs = do-    hsc_env <- getHscEnv-    let errors = S.foldr go [] pkgs-        state  = hsc_units hsc_env-        go pkg acc-            | unitIsTrusted $ unsafeLookupUnitId state pkg-            = acc-            | otherwise-            = (:acc) $ mkMsgEnvelope noSrcSpan (pkgQual state)-                     $ pprWithUnitState state-                     $ text "The package ("-                        <> ppr pkg-                        <> text ") is required to be trusted but it isn't!"-    case errors of-        [] -> return ()-        _  -> (liftIO . throwIO . mkSrcErr . listToBag) errors---- | Set module to unsafe and (potentially) wipe trust information.------ Make sure to call this method to set a module to inferred unsafe, it should--- be a central and single failure method. We only wipe the trust information--- when we aren't in a specific Safe Haskell mode.------ While we only use this for recording that a module was inferred unsafe, we--- may call it on modules using Trustworthy or Unsafe flags so as to allow--- warning flags for safety to function correctly. See Note [Safe Haskell--- Inference].-markUnsafeInfer :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv-markUnsafeInfer tcg_env whyUnsafe = do-    dflags <- getDynFlags--    when (wopt Opt_WarnUnsafe dflags)-         (logWarnings $ unitBag $ makeIntoWarning (Reason Opt_WarnUnsafe) $-             mkPlainWarnMsg (warnUnsafeOnLoc dflags) (whyUnsafe' dflags))--    liftIO $ writeIORef (tcg_safeInfer tcg_env) (False, whyUnsafe)-    -- NOTE: Only wipe trust when not in an explicitly safe haskell mode. Other-    -- times inference may be on but we are in Trustworthy mode -- so we want-    -- to record safe-inference failed but not wipe the trust dependencies.-    case not (safeHaskellModeEnabled dflags) of-      True  -> return $ tcg_env { tcg_imports = wiped_trust }-      False -> return tcg_env--  where-    wiped_trust   = (tcg_imports tcg_env) { imp_trust_pkgs = S.empty }-    pprMod        = ppr $ moduleName $ tcg_mod tcg_env-    whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!"-                         , text "Reason:"-                         , nest 4 $ (vcat $ badFlags df) $+$-                                    (vcat $ pprMsgEnvelopeBagWithLoc whyUnsafe) $+$-                                    (vcat $ badInsts $ tcg_insts tcg_env)-                         ]-    badFlags df   = concatMap (badFlag df) unsafeFlagsForInfer-    badFlag df (str,loc,on,_)-        | on df     = [mkLocMessage SevOutput (loc df) $-                            text str <+> text "is not allowed in Safe Haskell"]-        | otherwise = []-    badInsts insts = concatMap badInst insts--    checkOverlap (NoOverlap _) = False-    checkOverlap _             = True--    badInst ins | checkOverlap (overlapMode (is_flag ins))-                = [mkLocMessage SevOutput (nameSrcSpan $ getName $ is_dfun ins) $-                      ppr (overlapMode $ is_flag ins) <+>-                      text "overlap mode isn't allowed in Safe Haskell"]-                | otherwise = []----- | Figure out the final correct safe haskell mode-hscGetSafeMode :: TcGblEnv -> Hsc SafeHaskellMode-hscGetSafeMode tcg_env = do-    dflags  <- getDynFlags-    liftIO $ finalSafeMode dflags tcg_env------------------------------------------------------------------- Simplifiers------------------------------------------------------------------- | Run Core2Core simplifier. The list of String is a list of (Core) plugin--- module names added via TH (cf 'addCorePlugin').-hscSimplify :: HscEnv -> [String] -> ModGuts -> IO ModGuts-hscSimplify hsc_env plugins modguts =-    runHsc hsc_env $ hscSimplify' plugins modguts---- | Run Core2Core simplifier. The list of String is a list of (Core) plugin--- module names added via TH (cf 'addCorePlugin').-hscSimplify' :: [String] -> ModGuts -> Hsc ModGuts-hscSimplify' plugins ds_result = do-    hsc_env <- getHscEnv-    hsc_env_with_plugins <- if null plugins -- fast path-        then return hsc_env-        else liftIO $ initializePlugins $ hsc_env-                { hsc_dflags = foldr addPluginModuleName (hsc_dflags hsc_env) plugins-                }-    {-# SCC "Core2Core" #-}-      liftIO $ core2core hsc_env_with_plugins ds_result------------------------------------------------------------------- Interface generators------------------------------------------------------------------- | Generate a striped down interface file, e.g. for boot files or when ghci--- generates interface files. See Note [simpleTidyPgm - mkBootModDetailsTc]-hscSimpleIface :: HscEnv-               -> TcGblEnv-               -> Maybe Fingerprint-               -> IO (ModIface, Maybe Fingerprint, ModDetails)-hscSimpleIface hsc_env tc_result mb_old_iface-    = runHsc hsc_env $ hscSimpleIface' tc_result mb_old_iface--hscSimpleIface' :: TcGblEnv-                -> Maybe Fingerprint-                -> Hsc (ModIface, Maybe Fingerprint, ModDetails)-hscSimpleIface' tc_result mb_old_iface = do-    hsc_env   <- getHscEnv-    details   <- liftIO $ mkBootModDetailsTc hsc_env tc_result-    safe_mode <- hscGetSafeMode tc_result-    new_iface-        <- {-# SCC "MkFinalIface" #-}-           liftIO $-               mkIfaceTc hsc_env safe_mode details tc_result-    -- And the answer is ...-    liftIO $ dumpIfaceStats hsc_env-    return (new_iface, mb_old_iface, details)------------------------------------------------------------------- BackEnd combinators------------------------------------------------------------------- | Compile to hard-code.-hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath-               -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], CgInfos)-               -- ^ @Just f@ <=> _stub.c is f-hscGenHardCode hsc_env cgguts location output_filename = do-        let CgGuts{ -- This is the last use of the ModGuts in a compilation.-                    -- From now on, we just use the bits we need.-                    cg_module   = this_mod,-                    cg_binds    = core_binds,-                    cg_tycons   = tycons,-                    cg_foreign  = foreign_stubs0,-                    cg_foreign_files = foreign_files,-                    cg_dep_pkgs = dependencies,-                    cg_hpc_info = hpc_info } = cgguts-            dflags = hsc_dflags hsc_env-            logger = hsc_logger hsc_env-            hooks  = hsc_hooks hsc_env-            tmpfs  = hsc_tmpfs hsc_env-            data_tycons = filter isDataTyCon tycons-            -- cg_tycons includes newtypes, for the benefit of External Core,-            -- but we don't generate any code for newtypes--        --------------------        -- PREPARE FOR CODE GENERATION-        -- Do saturation and convert to A-normal form-        (prepd_binds, local_ccs) <- {-# SCC "CorePrep" #-}-                       corePrepPgm hsc_env this_mod location-                                   core_binds data_tycons--        -----------------  Convert to STG -------------------        (stg_binds, denv, (caf_ccs, caf_cc_stacks))-            <- {-# SCC "CoreToStg" #-}-               withTiming logger dflags-                   (text "CoreToStg"<+>brackets (ppr this_mod))-                   (\(a, b, (c,d)) -> a `seqList` b `seq` c `seqList` d `seqList` ())-                   (myCoreToStg logger dflags (hsc_IC hsc_env) this_mod location prepd_binds)--        let cost_centre_info =-              (S.toList local_ccs ++ caf_ccs, caf_cc_stacks)-            platform = targetPlatform dflags-            prof_init-              | sccProfilingEnabled dflags = profilingInitCode platform this_mod cost_centre_info-              | otherwise = mempty--        ------------------  Code generation -------------------        -- The back-end is streamed: each top-level function goes-        -- from Stg all the way to asm before dealing with the next-        -- top-level function, so showPass isn't very useful here.-        -- Hence we have one showPass for the whole backend, the-        -- next showPass after this will be "Assembler".-        withTiming logger dflags-                   (text "CodeGen"<+>brackets (ppr this_mod))-                   (const ()) $ do-            cmms <- {-# SCC "StgToCmm" #-}-                            doCodeGen hsc_env this_mod denv data_tycons-                                cost_centre_info-                                stg_binds hpc_info--            ------------------  Code output ------------------------            rawcmms0 <- {-# SCC "cmmToRawCmm" #-}-                        case cmmToRawCmmHook hooks of-                            Nothing -> cmmToRawCmm logger dflags cmms-                            Just h  -> h dflags (Just this_mod) cmms--            let dump a = do-                  unless (null a) $-                    dumpIfSet_dyn logger dflags Opt_D_dump_cmm_raw "Raw Cmm" FormatCMM (pdoc platform a)-                  return a-                rawcmms1 = Stream.mapM dump rawcmms0--            let foreign_stubs st = foreign_stubs0 `appendStubC` prof_init-                                                  `appendStubC` cgIPEStub st--            (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cg_infos)-                <- {-# SCC "codeOutput" #-}-                  codeOutput logger tmpfs dflags (hsc_units hsc_env) this_mod output_filename location-                  foreign_stubs foreign_files dependencies rawcmms1-            return (output_filename, stub_c_exists, foreign_fps, cg_infos)---hscInteractive :: HscEnv-               -> CgGuts-               -> ModLocation-               -> IO (Maybe FilePath, CompiledByteCode, [SptEntry])-hscInteractive hsc_env cgguts location = do-    let dflags = hsc_dflags hsc_env-    let logger = hsc_logger hsc_env-    let tmpfs  = hsc_tmpfs hsc_env-    let CgGuts{ -- This is the last use of the ModGuts in a compilation.-                -- From now on, we just use the bits we need.-               cg_module   = this_mod,-               cg_binds    = core_binds,-               cg_tycons   = tycons,-               cg_foreign  = foreign_stubs,-               cg_modBreaks = mod_breaks,-               cg_spt_entries = spt_entries } = cgguts--        data_tycons = filter isDataTyCon tycons-        -- cg_tycons includes newtypes, for the benefit of External Core,-        -- but we don't generate any code for newtypes--    --------------------    -- PREPARE FOR CODE GENERATION-    -- Do saturation and convert to A-normal form-    (prepd_binds, _) <- {-# SCC "CorePrep" #-}-                   corePrepPgm hsc_env this_mod location core_binds data_tycons--    (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks)-      <- {-# SCC "CoreToStg" #-}-          myCoreToStg logger dflags (hsc_IC hsc_env) this_mod location prepd_binds-    -----------------  Generate byte code -------------------    comp_bc <- byteCodeGen hsc_env this_mod stg_binds data_tycons mod_breaks-    ------------------ Create f-x-dynamic C-side stuff ------    (_istub_h_exists, istub_c_exists)-        <- outputForeignStubs logger tmpfs dflags (hsc_units hsc_env) this_mod location foreign_stubs-    return (istub_c_exists, comp_bc, spt_entries)----------------------------------hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO (Maybe FilePath)-hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do-    let dflags   = hsc_dflags hsc_env-    let logger   = hsc_logger hsc_env-    let hooks    = hsc_hooks hsc_env-    let tmpfs    = hsc_tmpfs hsc_env-        home_unit = hsc_home_unit hsc_env-        platform  = targetPlatform dflags-        -- Make up a module name to give the NCG. We can't pass bottom here-        -- lest we reproduce #11784.-        mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename-        cmm_mod = mkHomeModule home_unit mod_name-    (cmm, ents) <- ioMsgMaybe-               $ do-                  (warns,errs,cmm) <- withTiming logger dflags (text "ParseCmm"<+>brackets (text filename)) (\_ -> ())-                                       $ parseCmmFile dflags cmm_mod home_unit filename-                  return (mkMessages (fmap pprWarning warns `unionBags` fmap pprError errs), cmm)-    liftIO $ do-        dumpIfSet_dyn logger dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform cmm)--        -- Compile decls in Cmm files one decl at a time, to avoid re-ordering-        -- them in SRT analysis.-        ---        -- Re-ordering here causes breakage when booting with C backend because-        -- in C we must declare before use, but SRT algorithm is free to-        -- re-order [A, B] (B refers to A) when A is not CAFFY and return [B, A]-        cmmgroup <--          concatMapM (\cmm -> snd <$> cmmPipeline hsc_env (emptySRT cmm_mod) [cmm]) cmm--        unless (null cmmgroup) $-          dumpIfSet_dyn logger dflags Opt_D_dump_cmm "Output Cmm"-            FormatCMM (pdoc platform cmmgroup)--        rawCmms <- case cmmToRawCmmHook hooks of-          Nothing -> cmmToRawCmm logger dflags         (Stream.yield cmmgroup)-          Just h  -> h                  dflags Nothing (Stream.yield cmmgroup)--        let foreign_stubs _ =-              let ip_init = ipInitCode dflags cmm_mod ents-              in NoStubs `appendStubC` ip_init--        (_output_filename, (_stub_h_exists, stub_c_exists), _foreign_fps, _caf_infos)-          <- codeOutput logger tmpfs dflags (hsc_units hsc_env) cmm_mod output_filename no_loc foreign_stubs [] []-             rawCmms-        return stub_c_exists-  where-    no_loc = ModLocation{ ml_hs_file  = Just filename,-                          ml_hi_file  = panic "hscCompileCmmFile: no hi file",-                          ml_obj_file = panic "hscCompileCmmFile: no obj file",-                          ml_hie_file = panic "hscCompileCmmFile: no hie file"}---------------------- Stuff for new code gen -----------------------{--Note [Forcing of stg_binds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~--The two last steps in the STG pipeline are:--* Sorting the bindings in dependency order.-* Annotating them with free variables.--We want to make sure we do not keep references to unannotated STG bindings-alive, nor references to bindings which have already been compiled to Cmm.--We explicitly force the bindings to avoid this.--This reduces residency towards the end of the CodeGen phase significantly-(5-10%).--}--doCodeGen   :: HscEnv -> Module -> InfoTableProvMap -> [TyCon]-            -> CollectedCCs-            -> [StgTopBinding]-            -> HpcInfo-            -> IO (Stream IO CmmGroupSRTs CgInfos)-         -- Note we produce a 'Stream' of CmmGroups, so that the-         -- backend can be run incrementally.  Otherwise it generates all-         -- the C-- up front, which has a significant space cost.-doCodeGen hsc_env this_mod denv data_tycons-              cost_centre_info stg_binds hpc_info = do-    let dflags = hsc_dflags hsc_env-    let logger = hsc_logger hsc_env-    let hooks  = hsc_hooks hsc_env-    let tmpfs  = hsc_tmpfs hsc_env-    let platform = targetPlatform dflags--    let stg_binds_w_fvs = annTopBindingsFreeVars stg_binds--    dumpIfSet_dyn logger dflags Opt_D_dump_stg_final "Final STG:" FormatSTG (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds_w_fvs)--    let stg_to_cmm = case stgToCmmHook hooks of-                        Nothing -> StgToCmm.codeGen logger tmpfs-                        Just h  -> h--    let cmm_stream :: Stream IO CmmGroup (CStub, ModuleLFInfos)-        -- See Note [Forcing of stg_binds]-        cmm_stream = stg_binds_w_fvs `seqList` {-# SCC "StgToCmm" #-}-            stg_to_cmm dflags this_mod denv data_tycons cost_centre_info stg_binds_w_fvs hpc_info--        -- codegen consumes a stream of CmmGroup, and produces a new-        -- stream of CmmGroup (not necessarily synchronised: one-        -- CmmGroup on input may produce many CmmGroups on output due-        -- to proc-point splitting).--    let dump1 a = do-          unless (null a) $-            dumpIfSet_dyn logger dflags Opt_D_dump_cmm_from_stg-              "Cmm produced by codegen" FormatCMM (pdoc platform a)-          return a--        ppr_stream1 = Stream.mapM dump1 cmm_stream--        pipeline_stream :: Stream IO CmmGroupSRTs CgInfos-        pipeline_stream = do-          (non_cafs, (used_info, lf_infos)) <--            {-# SCC "cmmPipeline" #-}-            Stream.mapAccumL_ (cmmPipeline hsc_env) (emptySRT this_mod) ppr_stream1-              <&> first (srtMapNonCAFs . moduleSRTMap)--          return CgInfos{ cgNonCafs = non_cafs, cgLFInfos = lf_infos, cgIPEStub = used_info }--        dump2 a = do-          unless (null a) $-            dumpIfSet_dyn logger dflags Opt_D_dump_cmm "Output Cmm" FormatCMM (pdoc platform a)-          return a--    return (Stream.mapM dump2 pipeline_stream)--myCoreToStgExpr :: Logger -> DynFlags -> InteractiveContext-                -> Module -> ModLocation -> CoreExpr-                -> IO ( Id-                      , [StgTopBinding]-                      , InfoTableProvMap-                      , CollectedCCs )-myCoreToStgExpr logger dflags ictxt this_mod ml prepd_expr = do-    {- Create a temporary binding (just because myCoreToStg needs a-       binding for the stg2stg step) -}-    let bco_tmp_id = mkSysLocal (fsLit "BCO_toplevel")-                                (mkPseudoUniqueE 0)-                                Many-                                (exprType prepd_expr)-    (stg_binds, prov_map, collected_ccs) <--       myCoreToStg logger-                   dflags-                   ictxt-                   this_mod-                   ml-                   [NonRec bco_tmp_id prepd_expr]-    return (bco_tmp_id, stg_binds, prov_map, collected_ccs)--myCoreToStg :: Logger -> DynFlags -> InteractiveContext-            -> Module -> ModLocation -> CoreProgram-            -> IO ( [StgTopBinding] -- output program-                  , InfoTableProvMap-                  , CollectedCCs )  -- CAF cost centre info (declared and used)-myCoreToStg logger dflags ictxt this_mod ml prepd_binds = do-    let (stg_binds, denv, cost_centre_info)-         = {-# SCC "Core2Stg" #-}-           coreToStg dflags this_mod ml prepd_binds--    stg_binds2-        <- {-# SCC "Stg2Stg" #-}-           stg2stg logger dflags ictxt this_mod stg_binds--    return (stg_binds2, denv, cost_centre_info)--{- **********************************************************************-%*                                                                      *-\subsection{Compiling a do-statement}-%*                                                                      *-%********************************************************************* -}--{--When the UnlinkedBCOExpr is linked you get an HValue of type *IO [HValue]* When-you run it you get a list of HValues that should be the same length as the list-of names; add them to the ClosureEnv.--A naked expression returns a singleton Name [it]. The stmt is lifted into the-IO monad as explained in Note [Interactively-bound Ids in GHCi] in GHC.Runtime.Context--}---- | Compile a stmt all the way to an HValue, but don't run it------ We return Nothing to indicate an empty statement (or comment only), not a--- parse error.-hscStmt :: HscEnv -> String -> IO (Maybe ([Id], ForeignHValue, FixityEnv))-hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "<interactive>" 1---- | Compile a stmt all the way to an HValue, but don't run it------ We return Nothing to indicate an empty statement (or comment only), not a--- parse error.-hscStmtWithLocation :: HscEnv-                    -> String -- ^ The statement-                    -> String -- ^ The source-                    -> Int    -- ^ Starting line-                    -> IO ( Maybe ([Id]-                          , ForeignHValue {- IO [HValue] -}-                          , FixityEnv))-hscStmtWithLocation hsc_env0 stmt source linenumber =-  runInteractiveHsc hsc_env0 $ do-    maybe_stmt <- hscParseStmtWithLocation source linenumber stmt-    case maybe_stmt of-      Nothing -> return Nothing--      Just parsed_stmt -> do-        hsc_env <- getHscEnv-        liftIO $ hscParsedStmt hsc_env parsed_stmt--hscParsedStmt :: HscEnv-              -> GhciLStmt GhcPs  -- ^ The parsed statement-              -> IO ( Maybe ([Id]-                    , ForeignHValue {- IO [HValue] -}-                    , FixityEnv))-hscParsedStmt hsc_env stmt = runInteractiveHsc hsc_env $ do-  -- Rename and typecheck it-  (ids, tc_expr, fix_env) <- ioMsgMaybe $ tcRnStmt hsc_env stmt--  -- Desugar it-  ds_expr <- ioMsgMaybe $ deSugarExpr hsc_env tc_expr-  liftIO (lintInteractiveExpr (text "desugar expression") hsc_env ds_expr)-  handleWarnings--  -- Then code-gen, and link it-  -- It's important NOT to have package 'interactive' as thisUnitId-  -- for linking, else we try to link 'main' and can't find it.-  -- Whereas the linker already knows to ignore 'interactive'-  let src_span = srcLocSpan interactiveSrcLoc-  hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr--  return $ Just (ids, hval, fix_env)---- | Compile a decls-hscDecls :: HscEnv-         -> String -- ^ The statement-         -> IO ([TyThing], InteractiveContext)-hscDecls hsc_env str = hscDeclsWithLocation hsc_env str "<interactive>" 1--hscParseDeclsWithLocation :: HscEnv -> String -> Int -> String -> IO [LHsDecl GhcPs]-hscParseDeclsWithLocation hsc_env source line_num str = do-    L _ (HsModule{ hsmodDecls = decls }) <--      runInteractiveHsc hsc_env $-        hscParseThingWithLocation source line_num parseModule str-    return decls---- | Compile a decls-hscDeclsWithLocation :: HscEnv-                     -> String -- ^ The statement-                     -> String -- ^ The source-                     -> Int    -- ^ Starting line-                     -> IO ([TyThing], InteractiveContext)-hscDeclsWithLocation hsc_env str source linenumber = do-    L _ (HsModule{ hsmodDecls = decls }) <--      runInteractiveHsc hsc_env $-        hscParseThingWithLocation source linenumber parseModule str-    hscParsedDecls hsc_env decls--hscParsedDecls :: HscEnv -> [LHsDecl GhcPs] -> IO ([TyThing], InteractiveContext)-hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do-    hsc_env <- getHscEnv-    let interp = hscInterp hsc_env--    {- Rename and typecheck it -}-    tc_gblenv <- ioMsgMaybe $ tcRnDeclsi hsc_env decls--    {- Grab the new instances -}-    -- We grab the whole environment because of the overlapping that may have-    -- been done. See the notes at the definition of InteractiveContext-    -- (ic_instances) for more details.-    let defaults = tcg_default tc_gblenv--    {- Desugar it -}-    -- We use a basically null location for iNTERACTIVE-    let iNTERACTIVELoc = ModLocation{ ml_hs_file   = Nothing,-                                      ml_hi_file   = panic "hsDeclsWithLocation:ml_hi_file",-                                      ml_obj_file  = panic "hsDeclsWithLocation:ml_obj_file",-                                      ml_hie_file  = panic "hsDeclsWithLocation:ml_hie_file" }-    ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv--    {- Simplify -}-    simpl_mg <- liftIO $ do-      plugins <- readIORef (tcg_th_coreplugins tc_gblenv)-      hscSimplify hsc_env plugins ds_result--    {- Tidy -}-    (tidy_cg, mod_details) <- liftIO $ tidyProgram hsc_env simpl_mg--    let !CgGuts{ cg_module    = this_mod,-                 cg_binds     = core_binds,-                 cg_tycons    = tycons,-                 cg_modBreaks = mod_breaks } = tidy_cg--        !ModDetails { md_insts     = cls_insts-                    , md_fam_insts = fam_insts } = mod_details-            -- Get the *tidied* cls_insts and fam_insts--        data_tycons = filter isDataTyCon tycons--    {- Prepare For Code Generation -}-    -- Do saturation and convert to A-normal form-    (prepd_binds, _) <- {-# SCC "CorePrep" #-}-      liftIO $ corePrepPgm hsc_env this_mod iNTERACTIVELoc core_binds data_tycons--    (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks)-        <- {-# SCC "CoreToStg" #-}-           liftIO $ myCoreToStg (hsc_logger hsc_env)-                                (hsc_dflags hsc_env)-                                (hsc_IC hsc_env)-                                this_mod-                                iNTERACTIVELoc-                                prepd_binds--    {- Generate byte code -}-    cbc <- liftIO $ byteCodeGen hsc_env this_mod-                                stg_binds data_tycons mod_breaks--    let src_span = srcLocSpan interactiveSrcLoc-    _ <- liftIO $ loadDecls interp hsc_env src_span cbc--    {- Load static pointer table entries -}-    liftIO $ hscAddSptEntries hsc_env (cg_spt_entries tidy_cg)--    let tcs = filterOut isImplicitTyCon (mg_tcs simpl_mg)-        patsyns = mg_patsyns simpl_mg--        ext_ids = [ id | id <- bindersOfBinds core_binds-                       , isExternalName (idName id)-                       , not (isDFunId id || isImplicitId id) ]-            -- We only need to keep around the external bindings-            -- (as decided by GHC.Iface.Tidy), since those are the only ones-            -- that might later be looked up by name.  But we can exclude-            --    - DFunIds, which are in 'cls_insts' (see Note [ic_tythings] in GHC.Runtime.Context-            --    - Implicit Ids, which are implicit in tcs-            -- c.f. GHC.Tc.Module.runTcInteractive, which reconstructs the TypeEnv--        new_tythings = map AnId ext_ids ++ map ATyCon tcs ++ map (AConLike . PatSynCon) patsyns-        ictxt        = hsc_IC hsc_env-        -- See Note [Fixity declarations in GHCi]-        fix_env      = tcg_fix_env tc_gblenv-        new_ictxt    = extendInteractiveContext ictxt new_tythings cls_insts-                                                fam_insts defaults fix_env-    return (new_tythings, new_ictxt)---- | Load the given static-pointer table entries into the interpreter.--- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable".-hscAddSptEntries :: HscEnv -> [SptEntry] -> IO ()-hscAddSptEntries hsc_env entries = do-    let interp = hscInterp hsc_env-    let add_spt_entry :: SptEntry -> IO ()-        add_spt_entry (SptEntry i fpr) = do-            val <- loadName interp hsc_env (idName i)-            addSptEntry interp fpr val-    mapM_ add_spt_entry entries--{--  Note [Fixity declarations in GHCi]-  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--  To support fixity declarations on types defined within GHCi (as requested-  in #10018) we record the fixity environment in InteractiveContext.-  When we want to evaluate something GHC.Tc.Module.runTcInteractive pulls out this-  fixity environment and uses it to initialize the global typechecker environment.-  After the typechecker has finished its business, an updated fixity environment-  (reflecting whatever fixity declarations were present in the statements we-  passed it) will be returned from hscParsedStmt. This is passed to-  updateFixityEnv, which will stuff it back into InteractiveContext, to be-  used in evaluating the next statement.---}--hscImport :: HscEnv -> String -> IO (ImportDecl GhcPs)-hscImport hsc_env str = runInteractiveHsc hsc_env $ do-    (L _ (HsModule{hsmodImports=is})) <--       hscParseThing parseModule str-    case is of-        [L _ i] -> return i-        _ -> liftIO $ throwOneError $-                 mkPlainMsgEnvelope noSrcSpan $-                     text "parse error in import declaration"---- | Typecheck an expression (but don't run it)-hscTcExpr :: HscEnv-          -> TcRnExprMode-          -> String -- ^ The expression-          -> IO Type-hscTcExpr hsc_env0 mode expr = runInteractiveHsc hsc_env0 $ do-  hsc_env <- getHscEnv-  parsed_expr <- hscParseExpr expr-  ioMsgMaybe $ tcRnExpr hsc_env mode parsed_expr---- | Find the kind of a type, after generalisation-hscKcType-  :: HscEnv-  -> Bool            -- ^ Normalise the type-  -> String          -- ^ The type as a string-  -> IO (Type, Kind) -- ^ Resulting type (possibly normalised) and kind-hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do-    hsc_env <- getHscEnv-    ty <- hscParseType str-    ioMsgMaybe $ tcRnType hsc_env DefaultFlexi normalise ty--hscParseExpr :: String -> Hsc (LHsExpr GhcPs)-hscParseExpr expr = do-  maybe_stmt <- hscParseStmt expr-  case maybe_stmt of-    Just (L _ (BodyStmt _ expr _ _)) -> return expr-    _ -> throwOneError $ mkPlainMsgEnvelope noSrcSpan-      (text "not an expression:" <+> quotes (text expr))--hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs))-hscParseStmt = hscParseThing parseStmt--hscParseStmtWithLocation :: String -> Int -> String-                         -> Hsc (Maybe (GhciLStmt GhcPs))-hscParseStmtWithLocation source linenumber stmt =-    hscParseThingWithLocation source linenumber parseStmt stmt--hscParseType :: String -> Hsc (LHsType GhcPs)-hscParseType = hscParseThing parseType--hscParseIdentifier :: HscEnv -> String -> IO (LocatedN RdrName)-hscParseIdentifier hsc_env str =-    runInteractiveHsc hsc_env $ hscParseThing parseIdentifier str--hscParseThing :: (Outputable thing, Data thing)-              => Lexer.P thing -> String -> Hsc thing-hscParseThing = hscParseThingWithLocation "<interactive>" 1--hscParseThingWithLocation :: (Outputable thing, Data thing) => String -> Int-                          -> Lexer.P thing -> String -> Hsc thing-hscParseThingWithLocation source linenumber parser str = do-    dflags <- getDynFlags-    logger <- getLogger-    withTiming logger dflags-               (text "Parser [source]")-               (const ()) $ {-# SCC "Parser" #-} do--        let buf = stringToStringBuffer str-            loc = mkRealSrcLoc (fsLit source) linenumber 1--        case unP parser (initParserState (initParserOpts dflags) buf loc) of-            PFailed pst ->-                handleWarningsThrowErrors (getMessages pst)-            POk pst thing -> do-                logWarningsReportErrors (getMessages pst)-                liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed "Parser"-                            FormatHaskell (ppr thing)-                liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed_ast "Parser AST"-                            FormatHaskell (showAstData NoBlankSrcSpan NoBlankEpAnnotations thing)-                return thing---{- **********************************************************************-%*                                                                      *-        Desugar, simplify, convert to bytecode, and link an expression-%*                                                                      *-%********************************************************************* -}--hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue-hscCompileCoreExpr hsc_env loc expr =-  case hscCompileCoreExprHook (hsc_hooks hsc_env) of-      Nothing -> hscCompileCoreExpr' hsc_env loc expr-      Just h  -> h                   hsc_env loc expr--hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue-hscCompileCoreExpr' hsc_env srcspan ds_expr-    = do { {- Simplify it -}-           -- Question: should we call SimpleOpt.simpleOptExpr here instead?-           -- It is, well, simpler, and does less inlining etc.-           simpl_expr <- simplifyExpr hsc_env ds_expr--           {- Tidy it (temporary, until coreSat does cloning) -}-         ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr--           {- Prepare for codegen -}-         ; prepd_expr <- corePrepExpr hsc_env tidy_expr--           {- Lint if necessary -}-         ; lintInteractiveExpr (text "hscCompileExpr") hsc_env prepd_expr-         ; let iNTERACTIVELoc = ModLocation{ ml_hs_file   = Nothing,-                                      ml_hi_file   = panic "hscCompileCoreExpr':ml_hi_file",-                                      ml_obj_file  = panic "hscCompileCoreExpr':ml_obj_file",-                                      ml_hie_file  = panic "hscCompileCoreExpr':ml_hie_file" }--         ; let ictxt = hsc_IC hsc_env-         ; (binding_id, stg_expr, _, _) <--             myCoreToStgExpr (hsc_logger hsc_env)-                             (hsc_dflags hsc_env)-                             ictxt-                             (icInteractiveModule ictxt)-                             iNTERACTIVELoc-                             prepd_expr--           {- Convert to BCOs -}-         ; bcos <- byteCodeGen hsc_env-                     (icInteractiveModule ictxt)-                     stg_expr-                     [] Nothing--           {- load it -}-         ; fv_hvs <- loadDecls (hscInterp hsc_env) hsc_env srcspan bcos-           {- Get the HValue for the root -}-         ; return (expectJust "hscCompileCoreExpr'"-              $ lookup (idName binding_id) fv_hvs) }---{- **********************************************************************-%*                                                                      *-        Statistics on reading interfaces-%*                                                                      *-%********************************************************************* -}--dumpIfaceStats :: HscEnv -> IO ()-dumpIfaceStats hsc_env = do-    eps <- readIORef (hsc_EPS hsc_env)-    dumpIfSet logger dflags (dump_if_trace || dump_rn_stats)-              "Interface statistics"-              (ifaceStats eps)-  where-    dflags = hsc_dflags hsc_env-    logger = hsc_logger hsc_env-    dump_rn_stats = dopt Opt_D_dump_rn_stats dflags-    dump_if_trace = dopt Opt_D_dump_if_trace dflags---{- **********************************************************************-%*                                                                      *-        Progress Messages: Module i of n-%*                                                                      *-%********************************************************************* -}--showModuleIndex :: (Int, Int) -> SDoc-showModuleIndex (i,n) = text "[" <> pad <> int i <> text " of " <> int n <> text "] "-  where-    -- compute the length of x > 0 in base 10-    len x = ceiling (logBase 10 (fromIntegral x+1) :: Float)-    pad = text (replicate (len n - len i) ' ') -- TODO: use GHC.Utils.Ppr.RStr++{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE GADTs #-}++{-# OPTIONS_GHC -fprof-auto-top #-}++-------------------------------------------------------------------------------+--+-- | Main API for compiling plain Haskell source code.+--+-- This module implements compilation of a Haskell source. It is+-- /not/ concerned with preprocessing of source files; this is handled+-- in "GHC.Driver.Pipeline"+--+-- There are various entry points depending on what mode we're in:+-- "batch" mode (@--make@), "one-shot" mode (@-c@, @-S@ etc.), and+-- "interactive" mode (GHCi). There are also entry points for+-- individual passes: parsing, typechecking/renaming, desugaring, and+-- simplification.+--+-- All the functions here take an 'HscEnv' as a parameter, but none of+-- them return a new one: 'HscEnv' is treated as an immutable value+-- from here on in (although it has mutable components, for the+-- caches).+--+-- We use the Hsc monad to deal with warning messages consistently:+-- specifically, while executing within an Hsc monad, warnings are+-- collected. When a Hsc monad returns to an IO monad, the+-- warnings are printed, or compilation aborts if the @-Werror@+-- flag is enabled.+--+-- (c) The GRASP/AQUA Project, Glasgow University, 1993-2000+--+-------------------------------------------------------------------------------++module GHC.Driver.Main+    (+    -- * Making an HscEnv+      newHscEnv+    , newHscEnvWithHUG++    -- * Compiling complete source files+    , Messager, batchMsg, batchMultiMsg+    , HscBackendAction (..), HscRecompStatus (..)+    , initModDetails+    , hscMaybeWriteIface+    , hscCompileCmmFile++    , hscGenHardCode+    , hscInteractive++    -- * Running passes separately+    , hscRecompStatus+    , hscParse+    , hscTypecheckRename+    , hscTypecheckAndGetWarnings+    , hscDesugar+    , makeSimpleDetails+    , hscSimplify -- ToDo, shouldn't really export this+    , hscDesugarAndSimplify++    -- * Safe Haskell+    , hscCheckSafe+    , hscGetSafe++    -- * Support for interactive evaluation+    , hscParseIdentifier+    , hscTcRcLookupName+    , hscTcRnGetInfo+    , hscIsGHCiMonad+    , hscGetModuleInterface+    , hscRnImportDecls+    , hscTcRnLookupRdrName+    , hscStmt, hscParseStmtWithLocation, hscStmtWithLocation, hscParsedStmt+    , hscDecls, hscParseDeclsWithLocation, hscDeclsWithLocation, hscParsedDecls+    , hscParseModuleWithLocation+    , hscTcExpr, TcRnExprMode(..), hscImport, hscKcType+    , hscParseExpr+    , hscParseType+    , hscCompileCoreExpr+    , hscTidy+++    -- * Low-level exports for hooks+    , hscCompileCoreExpr'+      -- We want to make sure that we export enough to be able to redefine+      -- hsc_typecheck in client code+    , hscParse', hscSimplify', hscDesugar', tcRnModule', doCodeGen+    , getHscEnv+    , hscSimpleIface'+    , oneShotMsg+    , dumpIfaceStats+    , ioMsgMaybe+    , showModuleIndex+    , hscAddSptEntries+    , writeInterfaceOnlyMode+    ) where++import GHC.Prelude++import GHC.Driver.Plugins+import GHC.Driver.Session+import GHC.Driver.Backend+import GHC.Driver.Env+import GHC.Driver.Errors+import GHC.Driver.Errors.Types+import GHC.Driver.CodeOutput+import GHC.Driver.Config.Logger   (initLogFlags)+import GHC.Driver.Config.Parser   (initParserOpts)+import GHC.Driver.Config.Stg.Ppr  (initStgPprOpts)+import GHC.Driver.Config.Stg.Pipeline (initStgPipelineOpts)+import GHC.Driver.Config.StgToCmm (initStgToCmmConfig)+import GHC.Driver.Config.Diagnostic+import GHC.Driver.Config.Tidy+import GHC.Driver.Hooks++import GHC.Runtime.Context+import GHC.Runtime.Interpreter ( addSptEntry )+import GHC.Runtime.Loader      ( initializePlugins )+import GHCi.RemoteTypes        ( ForeignHValue )+import GHC.ByteCode.Types++import GHC.Linker.Loader+import GHC.Linker.Types++import GHC.Hs+import GHC.Hs.Dump+import GHC.Hs.Stats         ( ppSourceStats )++import GHC.HsToCore++import GHC.StgToByteCode    ( byteCodeGen )++import GHC.IfaceToCore  ( typecheckIface )++import GHC.Iface.Load   ( ifaceStats, writeIface )+import GHC.Iface.Make+import GHC.Iface.Recomp+import GHC.Iface.Tidy+import GHC.Iface.Ext.Ast    ( mkHieFile )+import GHC.Iface.Ext.Types  ( getAsts, hie_asts, hie_module )+import GHC.Iface.Ext.Binary ( readHieFile, writeHieFile , hie_file_result)+import GHC.Iface.Ext.Debug  ( diffFile, validateScopes )++import GHC.Core+import GHC.Core.Tidy           ( tidyExpr )+import GHC.Core.Type           ( Type, Kind )+import GHC.Core.Lint           ( lintInteractiveExpr, endPassIO )+import GHC.Core.Multiplicity+import GHC.Core.Utils          ( exprType )+import GHC.Core.ConLike+import GHC.Core.Opt.Monad      ( CoreToDo (..))+import GHC.Core.Opt.Pipeline+import GHC.Core.TyCon+import GHC.Core.InstEnv+import GHC.Core.FamInstEnv+import GHC.Core.Rules+import GHC.Core.Stats+import GHC.Core.LateCC (addLateCostCentresPgm)+++import GHC.CoreToStg.Prep+import GHC.CoreToStg    ( coreToStg )++import GHC.Parser.Errors.Types+import GHC.Parser+import GHC.Parser.Lexer as Lexer++import GHC.Tc.Module+import GHC.Tc.Utils.Monad+import GHC.Tc.Utils.Zonk    ( ZonkFlexi (DefaultFlexi) )++import GHC.Stg.Syntax+import GHC.Stg.Pipeline ( stg2stg )+import GHC.Stg.InferTags++import GHC.Builtin.Utils+import GHC.Builtin.Names+import GHC.Builtin.Uniques ( mkPseudoUniqueE )++import qualified GHC.StgToCmm as StgToCmm ( codeGen )+import GHC.StgToCmm.Types (CgInfos (..), ModuleLFInfos)++import GHC.Cmm+import GHC.Cmm.Parser       ( parseCmmFile )+import GHC.Cmm.Info.Build+import GHC.Cmm.Pipeline+import GHC.Cmm.Info++import GHC.Unit+import GHC.Unit.Env+import GHC.Unit.Finder+import GHC.Unit.External+import GHC.Unit.Module.ModDetails+import GHC.Unit.Module.ModGuts+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.ModSummary+import GHC.Unit.Module.Graph+import GHC.Unit.Module.Imported+import GHC.Unit.Module.Deps+import GHC.Unit.Module.Status+import GHC.Unit.Home.ModInfo++import GHC.Types.Id+import GHC.Types.SourceError+import GHC.Types.SafeHaskell+import GHC.Types.ForeignStubs+import GHC.Types.Var.Env       ( emptyTidyEnv )+import GHC.Types.Error+import GHC.Types.Fixity.Env+import GHC.Types.CostCentre+import GHC.Types.IPE+import GHC.Types.SourceFile+import GHC.Types.SrcLoc+import GHC.Types.Name+import GHC.Types.Name.Cache ( initNameCache )+import GHC.Types.Name.Reader+import GHC.Types.Name.Ppr+import GHC.Types.TyThing+import GHC.Types.HpcInfo++import GHC.Utils.Fingerprint ( Fingerprint )+import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Utils.Error+import GHC.Utils.Outputable+import GHC.Utils.Misc+import GHC.Utils.Logger+import GHC.Utils.TmpFs++import GHC.Data.FastString+import GHC.Data.Bag+import GHC.Data.StringBuffer+import qualified GHC.Data.Stream as Stream+import GHC.Data.Stream (Stream)+import qualified GHC.SysTools++import Data.Data hiding (Fixity, TyCon)+import Data.List        ( nub, isPrefixOf, partition )+import Control.Monad+import Data.IORef+import System.FilePath as FilePath+import System.Directory+import System.IO (fixIO)+import qualified Data.Set as S+import Data.Set (Set)+import Data.Functor+import Control.DeepSeq (force)+import Data.Bifunctor (first)+import GHC.Data.Maybe+import GHC.Driver.Env.KnotVars+import GHC.Types.Name.Set (NonCaffySet)+import GHC.Driver.GenerateCgIPEStub (generateCgIPEStub)+import Data.List.NonEmpty (NonEmpty ((:|)))+++{- **********************************************************************+%*                                                                      *+                Initialisation+%*                                                                      *+%********************************************************************* -}++newHscEnv :: DynFlags -> IO HscEnv+newHscEnv dflags = newHscEnvWithHUG dflags (homeUnitId_ dflags) home_unit_graph+  where+    home_unit_graph = unitEnv_singleton+                        (homeUnitId_ dflags)+                        (mkHomeUnitEnv dflags emptyHomePackageTable Nothing)++newHscEnvWithHUG :: DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv+newHscEnvWithHUG top_dynflags cur_unit home_unit_graph = do+    nc_var  <- initNameCache 'r' knownKeyNames+    fc_var  <- initFinderCache+    logger  <- initLogger+    tmpfs   <- initTmpFs+    let dflags = homeUnitEnv_dflags $ unitEnv_lookup cur_unit home_unit_graph+    unit_env <- initUnitEnv cur_unit home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags)+    return HscEnv { hsc_dflags = top_dynflags+                  , hsc_logger         = setLogFlags logger (initLogFlags top_dynflags)+                  ,  hsc_targets        = []+                  ,  hsc_mod_graph      = emptyMG+                  ,  hsc_IC             = emptyInteractiveContext dflags+                  ,  hsc_NC             = nc_var+                  ,  hsc_FC             = fc_var+                  ,  hsc_type_env_vars  = emptyKnotVars+                  ,  hsc_interp         = Nothing+                  ,  hsc_unit_env       = unit_env+                  ,  hsc_plugins        = emptyPlugins+                  ,  hsc_hooks          = emptyHooks+                  ,  hsc_tmpfs          = tmpfs+                  }++-- -----------------------------------------------------------------------------++getDiagnostics :: Hsc (Messages GhcMessage)+getDiagnostics = Hsc $ \_ w -> return (w, w)++clearDiagnostics :: Hsc ()+clearDiagnostics = Hsc $ \_ _ -> return ((), emptyMessages)++logDiagnostics :: Messages GhcMessage -> Hsc ()+logDiagnostics w = Hsc $ \_ w0 -> return ((), w0 `unionMessages` w)++getHscEnv :: Hsc HscEnv+getHscEnv = Hsc $ \e w -> return (e, w)++handleWarnings :: Hsc ()+handleWarnings = do+    diag_opts <- initDiagOpts <$> getDynFlags+    logger <- getLogger+    w <- getDiagnostics+    liftIO $ printOrThrowDiagnostics logger diag_opts w+    clearDiagnostics++-- | log warning in the monad, and if there are errors then+-- throw a SourceError exception.+logWarningsReportErrors :: (Messages PsWarning, Messages PsError) -> Hsc ()+logWarningsReportErrors (warnings,errors) = do+    logDiagnostics (GhcPsMessage <$> warnings)+    when (not $ isEmptyMessages errors) $ throwErrors (GhcPsMessage <$> errors)++-- | Log warnings and throw errors, assuming the messages+-- contain at least one error (e.g. coming from PFailed)+handleWarningsThrowErrors :: (Messages PsWarning, Messages PsError) -> Hsc a+handleWarningsThrowErrors (warnings, errors) = do+    diag_opts <- initDiagOpts <$> getDynFlags+    logDiagnostics (GhcPsMessage <$> warnings)+    logger <- getLogger+    let (wWarns, wErrs) = partitionMessages warnings+    liftIO $ printMessages logger diag_opts wWarns+    throwErrors $ fmap GhcPsMessage $ errors `unionMessages` wErrs++-- | Deal with errors and warnings returned by a compilation step+--+-- In order to reduce dependencies to other parts of the compiler, functions+-- outside the "main" parts of GHC return warnings and errors as a parameter+-- and signal success via by wrapping the result in a 'Maybe' type. This+-- function logs the returned warnings and propagates errors as exceptions+-- (of type 'SourceError').+--+-- This function assumes the following invariants:+--+--  1. If the second result indicates success (is of the form 'Just x'),+--     there must be no error messages in the first result.+--+--  2. If there are no error messages, but the second result indicates failure+--     there should be warnings in the first result. That is, if the action+--     failed, it must have been due to the warnings (i.e., @-Werror@).+ioMsgMaybe :: IO (Messages GhcMessage, Maybe a) -> Hsc a+ioMsgMaybe ioA = do+    (msgs, mb_r) <- liftIO ioA+    let (warns, errs) = partitionMessages msgs+    logDiagnostics warns+    case mb_r of+        Nothing -> throwErrors errs+        Just r  -> assert (isEmptyMessages errs ) return r++-- | like ioMsgMaybe, except that we ignore error messages and return+-- 'Nothing' instead.+ioMsgMaybe' :: IO (Messages GhcMessage, Maybe a) -> Hsc (Maybe a)+ioMsgMaybe' ioA = do+    (msgs, mb_r) <- liftIO $ ioA+    logDiagnostics (mkMessages $ getWarningMessages msgs)+    return mb_r++-- -----------------------------------------------------------------------------+-- | Lookup things in the compiler's environment++hscTcRnLookupRdrName :: HscEnv -> LocatedN RdrName -> IO [Name]+hscTcRnLookupRdrName hsc_env0 rdr_name+  = runInteractiveHsc hsc_env0 $+    do { hsc_env <- getHscEnv+       ; ioMsgMaybe $ hoistTcRnMessage $ tcRnLookupRdrName hsc_env rdr_name }++hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)+hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do+  hsc_env <- getHscEnv+  ioMsgMaybe' $ hoistTcRnMessage $ tcRnLookupName hsc_env name+      -- ignore errors: the only error we're likely to get is+      -- "name not found", and the Maybe in the return type+      -- is used to indicate that.++hscTcRnGetInfo :: HscEnv -> Name+               -> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))+hscTcRnGetInfo hsc_env0 name+  = runInteractiveHsc hsc_env0 $+    do { hsc_env <- getHscEnv+       ; ioMsgMaybe' $ hoistTcRnMessage $ tcRnGetInfo hsc_env name }++hscIsGHCiMonad :: HscEnv -> String -> IO Name+hscIsGHCiMonad hsc_env name+  = runHsc hsc_env $ ioMsgMaybe $ hoistTcRnMessage $ isGHCiMonad hsc_env name++hscGetModuleInterface :: HscEnv -> Module -> IO ModIface+hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do+  hsc_env <- getHscEnv+  ioMsgMaybe $ hoistTcRnMessage $ getModuleInterface hsc_env mod++-- -----------------------------------------------------------------------------+-- | Rename some import declarations+hscRnImportDecls :: HscEnv -> [LImportDecl GhcPs] -> IO GlobalRdrEnv+hscRnImportDecls hsc_env0 import_decls = runInteractiveHsc hsc_env0 $ do+  hsc_env <- getHscEnv+  ioMsgMaybe $ hoistTcRnMessage $ tcRnImportDecls hsc_env import_decls++-- -----------------------------------------------------------------------------+-- | parse a file, returning the abstract syntax++hscParse :: HscEnv -> ModSummary -> IO HsParsedModule+hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary++-- internal version, that doesn't fail due to -Werror+hscParse' :: ModSummary -> Hsc HsParsedModule+hscParse' mod_summary+ | Just r <- ms_parsed_mod mod_summary = return r+ | otherwise = do+    dflags <- getDynFlags+    logger <- getLogger+    {-# SCC "Parser" #-} withTiming logger+                (text "Parser"<+>brackets (ppr $ ms_mod mod_summary))+                (const ()) $ do+    let src_filename  = ms_hspp_file mod_summary+        maybe_src_buf = ms_hspp_buf  mod_summary++    --------------------------  Parser  ----------------+    -- sometimes we already have the buffer in memory, perhaps+    -- because we needed to parse the imports out of it, or get the+    -- module name.+    buf <- case maybe_src_buf of+               Just b  -> return b+               Nothing -> liftIO $ hGetStringBuffer src_filename++    let loc = mkRealSrcLoc (mkFastString src_filename) 1 1++    let diag_opts = initDiagOpts dflags+    when (wopt Opt_WarnUnicodeBidirectionalFormatCharacters dflags) $ do+      case checkBidirectionFormatChars (PsLoc loc (BufPos 0)) buf of+        Nothing -> pure ()+        Just chars@((eloc,chr,_) :| _) ->+          let span = mkSrcSpanPs $ mkPsSpan eloc (advancePsLoc eloc chr)+          in logDiagnostics $ singleMessage $+               mkPlainMsgEnvelope diag_opts span $+               GhcPsMessage $ PsWarnBidirectionalFormatChars chars++    let parseMod | HsigFile == ms_hsc_src mod_summary+                 = parseSignature+                 | otherwise = parseModule++    case unP parseMod (initParserState (initParserOpts dflags) buf loc) of+        PFailed pst ->+            handleWarningsThrowErrors (getPsMessages pst)+        POk pst rdr_module -> do+            liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed "Parser"+                        FormatHaskell (ppr rdr_module)+            liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed_ast "Parser AST"+                        FormatHaskell (showAstData NoBlankSrcSpan+                                                   NoBlankEpAnnotations+                                                   rdr_module)+            liftIO $ putDumpFileMaybe logger Opt_D_source_stats "Source Statistics"+                        FormatText (ppSourceStats False rdr_module)++            -- To get the list of extra source files, we take the list+            -- that the parser gave us,+            --   - eliminate files beginning with '<'.  gcc likes to use+            --     pseudo-filenames like "<built-in>" and "<command-line>"+            --   - normalise them (eliminate differences between ./f and f)+            --   - filter out the preprocessed source file+            --   - filter out anything beginning with tmpdir+            --   - remove duplicates+            --   - filter out the .hs/.lhs source filename if we have one+            --+            let n_hspp  = FilePath.normalise src_filename+                TempDir tmp_dir = tmpDir dflags+                srcs0 = nub $ filter (not . (tmp_dir `isPrefixOf`))+                            $ filter (not . (== n_hspp))+                            $ map FilePath.normalise+                            $ filter (not . isPrefixOf "<")+                            $ map unpackFS+                            $ srcfiles pst+                srcs1 = case ml_hs_file (ms_location mod_summary) of+                          Just f  -> filter (/= FilePath.normalise f) srcs0+                          Nothing -> srcs0++            -- sometimes we see source files from earlier+            -- preprocessing stages that cannot be found, so just+            -- filter them out:+            srcs2 <- liftIO $ filterM doesFileExist srcs1++            let res = HsParsedModule {+                      hpm_module    = rdr_module,+                      hpm_src_files = srcs2+                   }++            -- apply parse transformation of plugins+            let applyPluginAction p opts+                  = parsedResultAction p opts mod_summary+            hsc_env <- getHscEnv+            (ParsedResult transformed (PsMessages warns errs)) <-+              withPlugins (hsc_plugins hsc_env) applyPluginAction+                (ParsedResult res (uncurry PsMessages $ getPsMessages pst))++            logDiagnostics (GhcPsMessage <$> warns)+            unless (isEmptyMessages errs) $ throwErrors (GhcPsMessage <$> errs)++            return transformed++checkBidirectionFormatChars :: PsLoc -> StringBuffer -> Maybe (NonEmpty (PsLoc, Char, String))+checkBidirectionFormatChars start_loc sb+  | containsBidirectionalFormatChar sb = Just $ go start_loc sb+  | otherwise = Nothing+  where+    go :: PsLoc -> StringBuffer -> NonEmpty (PsLoc, Char, String)+    go loc sb+      | atEnd sb = panic "checkBidirectionFormatChars: no char found"+      | otherwise = case nextChar sb of+          (chr, sb)+            | Just desc <- lookup chr bidirectionalFormatChars ->+                (loc, chr, desc) :| go1 (advancePsLoc loc chr) sb+            | otherwise -> go (advancePsLoc loc chr) sb++    go1 :: PsLoc -> StringBuffer -> [(PsLoc, Char, String)]+    go1 loc sb+      | atEnd sb = []+      | otherwise = case nextChar sb of+          (chr, sb)+            | Just desc <- lookup chr bidirectionalFormatChars ->+                (loc, chr, desc) : go1 (advancePsLoc loc chr) sb+            | otherwise -> go1 (advancePsLoc loc chr) sb+++-- -----------------------------------------------------------------------------+-- | If the renamed source has been kept, extract it. Dump it if requested.+++extract_renamed_stuff :: ModSummary -> TcGblEnv -> Hsc RenamedStuff+extract_renamed_stuff mod_summary tc_result = do+    let rn_info = getRenamedStuff tc_result++    dflags <- getDynFlags+    logger <- getLogger+    liftIO $ putDumpFileMaybe logger Opt_D_dump_rn_ast "Renamer"+                FormatHaskell (showAstData NoBlankSrcSpan NoBlankEpAnnotations rn_info)++    -- Create HIE files+    when (gopt Opt_WriteHie dflags) $ do+        -- I assume this fromJust is safe because `-fwrite-hie-file`+        -- enables the option which keeps the renamed source.+        hieFile <- mkHieFile mod_summary tc_result (fromJust rn_info)+        let out_file = ml_hie_file $ ms_location mod_summary+        liftIO $ writeHieFile out_file hieFile+        liftIO $ putDumpFileMaybe logger Opt_D_dump_hie "HIE AST" FormatHaskell (ppr $ hie_asts hieFile)++        -- Validate HIE files+        when (gopt Opt_ValidateHie dflags) $ do+            hs_env <- Hsc $ \e w -> return (e, w)+            liftIO $ do+              -- Validate Scopes+              case validateScopes (hie_module hieFile) $ getAsts $ hie_asts hieFile of+                  [] -> putMsg logger $ text "Got valid scopes"+                  xs -> do+                    putMsg logger $ text "Got invalid scopes"+                    mapM_ (putMsg logger) xs+              -- Roundtrip testing+              file' <- readHieFile (hsc_NC hs_env) out_file+              case diffFile hieFile (hie_file_result file') of+                [] ->+                  putMsg logger $ text "Got no roundtrip errors"+                xs -> do+                  putMsg logger $ text "Got roundtrip errors"+                  let logger' = updateLogFlags logger (log_set_dopt Opt_D_ppr_debug)+                  mapM_ (putMsg logger') xs+    return rn_info+++-- -----------------------------------------------------------------------------+-- | Rename and typecheck a module, additionally returning the renamed syntax+hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule+                   -> IO (TcGblEnv, RenamedStuff)+hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $+    hsc_typecheck True mod_summary (Just rdr_module)++-- | Do Typechecking without throwing SourceError exception with -Werror+hscTypecheckAndGetWarnings :: HscEnv ->  ModSummary -> IO (FrontendResult, WarningMessages)+hscTypecheckAndGetWarnings hsc_env summary = runHsc' hsc_env $ do+  case hscFrontendHook (hsc_hooks hsc_env) of+    Nothing -> FrontendTypecheck . fst <$> hsc_typecheck False summary Nothing+    Just h  -> h summary++-- | A bunch of logic piled around @tcRnModule'@, concerning a) backpack+-- b) concerning dumping rename info and hie files. It would be nice to further+-- separate this stuff out, probably in conjunction better separating renaming+-- and type checking (#17781).+hsc_typecheck :: Bool -- ^ Keep renamed source?+              -> ModSummary -> Maybe HsParsedModule+              -> Hsc (TcGblEnv, RenamedStuff)+hsc_typecheck keep_rn mod_summary mb_rdr_module = do+    hsc_env <- getHscEnv+    let hsc_src = ms_hsc_src mod_summary+        dflags = hsc_dflags hsc_env+        home_unit = hsc_home_unit hsc_env+        outer_mod = ms_mod mod_summary+        mod_name = moduleName outer_mod+        outer_mod' = mkHomeModule home_unit mod_name+        inner_mod = homeModuleNameInstantiation home_unit mod_name+        src_filename  = ms_hspp_file mod_summary+        real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1+        keep_rn' = gopt Opt_WriteHie dflags || keep_rn+    massert (isHomeModule home_unit outer_mod)+    tc_result <- if hsc_src == HsigFile && not (isHoleModule inner_mod)+        then ioMsgMaybe $ hoistTcRnMessage $ tcRnInstantiateSignature hsc_env outer_mod' real_loc+        else+         do hpm <- case mb_rdr_module of+                    Just hpm -> return hpm+                    Nothing -> hscParse' mod_summary+            tc_result0 <- tcRnModule' mod_summary keep_rn' hpm+            if hsc_src == HsigFile+                then do (iface, _) <- liftIO $ hscSimpleIface hsc_env tc_result0 mod_summary+                        ioMsgMaybe $ hoistTcRnMessage $+                            tcRnMergeSignatures hsc_env hpm tc_result0 iface+                else return tc_result0+    -- TODO are we extracting anything when we merely instantiate a signature?+    -- If not, try to move this into the "else" case above.+    rn_info <- extract_renamed_stuff mod_summary tc_result+    return (tc_result, rn_info)++-- wrapper around tcRnModule to handle safe haskell extras+tcRnModule' :: ModSummary -> Bool -> HsParsedModule+            -> Hsc TcGblEnv+tcRnModule' sum save_rn_syntax mod = do+    hsc_env <- getHscEnv+    dflags  <- getDynFlags++    let diag_opts = initDiagOpts dflags+    -- -Wmissing-safe-haskell-mode+    when (not (safeHaskellModeEnabled dflags)+          && wopt Opt_WarnMissingSafeHaskellMode dflags) $+        logDiagnostics $ singleMessage $+        mkPlainMsgEnvelope diag_opts (getLoc (hpm_module mod)) $+        GhcDriverMessage $ DriverMissingSafeHaskellMode (ms_mod sum)++    tcg_res <- {-# SCC "Typecheck-Rename" #-}+               ioMsgMaybe $ hoistTcRnMessage $+                   tcRnModule hsc_env sum+                     save_rn_syntax mod++    -- See Note [Safe Haskell Overlapping Instances Implementation]+    -- although this is used for more than just that failure case.+    tcSafeOK <- liftIO $ readIORef (tcg_safe_infer tcg_res)+    whyUnsafe <- liftIO $ readIORef (tcg_safe_infer_reasons tcg_res)+    let allSafeOK = safeInferred dflags && tcSafeOK++    -- end of the safe haskell line, how to respond to user?+    if not (safeHaskellOn dflags)+         || (safeInferOn dflags && not allSafeOK)+      -- if safe Haskell off or safe infer failed, mark unsafe+      then markUnsafeInfer tcg_res whyUnsafe++      -- module (could be) safe, throw warning if needed+      else do+          tcg_res' <- hscCheckSafeImports tcg_res+          safe <- liftIO $ readIORef (tcg_safe_infer tcg_res')+          when safe $+            case wopt Opt_WarnSafe dflags of+              True+                | safeHaskell dflags == Sf_Safe -> return ()+                | otherwise -> (logDiagnostics $ singleMessage $+                       mkPlainMsgEnvelope diag_opts (warnSafeOnLoc dflags) $+                       GhcDriverMessage $ DriverInferredSafeModule (tcg_mod tcg_res'))+              False | safeHaskell dflags == Sf_Trustworthy &&+                      wopt Opt_WarnTrustworthySafe dflags ->+                      (logDiagnostics $ singleMessage $+                       mkPlainMsgEnvelope diag_opts (trustworthyOnLoc dflags) $+                       GhcDriverMessage $ DriverMarkedTrustworthyButInferredSafe (tcg_mod tcg_res'))+              False -> return ()+          return tcg_res'++-- | Convert a typechecked module to Core+hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts+hscDesugar hsc_env mod_summary tc_result =+    runHsc hsc_env $ hscDesugar' (ms_location mod_summary) tc_result++hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts+hscDesugar' mod_location tc_result = do+    hsc_env <- getHscEnv+    ioMsgMaybe $ hoistDsMessage $+      {-# SCC "deSugar" #-}+      deSugar hsc_env mod_location tc_result++-- | Make a 'ModDetails' from the results of typechecking. Used when+-- typechecking only, as opposed to full compilation.+makeSimpleDetails :: Logger -> TcGblEnv -> IO ModDetails+makeSimpleDetails logger tc_result = mkBootModDetailsTc logger tc_result+++{- **********************************************************************+%*                                                                      *+                The main compiler pipeline+%*                                                                      *+%********************************************************************* -}++{-+                   --------------------------------+                        The compilation proper+                   --------------------------------++It's the task of the compilation proper to compile Haskell, hs-boot and core+files to either byte-code, hard-code (C, asm, LLVM, etc.) or to nothing at all+(the module is still parsed and type-checked. This feature is mostly used by+IDE's and the likes). Compilation can happen in either 'one-shot', 'batch',+'nothing', or 'interactive' mode. 'One-shot' mode targets hard-code, 'batch'+mode targets hard-code, 'nothing' mode targets nothing and 'interactive' mode+targets byte-code.++The modes are kept separate because of their different types and meanings:++ * In 'one-shot' mode, we're only compiling a single file and can therefore+ discard the new ModIface and ModDetails. This is also the reason it only+ targets hard-code; compiling to byte-code or nothing doesn't make sense when+ we discard the result.++ * 'Batch' mode is like 'one-shot' except that we keep the resulting ModIface+ and ModDetails. 'Batch' mode doesn't target byte-code since that require us to+ return the newly compiled byte-code.++ * 'Nothing' mode has exactly the same type as 'batch' mode but they're still+ kept separate. This is because compiling to nothing is fairly special: We+ don't output any interface files, we don't run the simplifier and we don't+ generate any code.++ * 'Interactive' mode is similar to 'batch' mode except that we return the+ compiled byte-code together with the ModIface and ModDetails.++Trying to compile a hs-boot file to byte-code will result in a run-time error.+This is the only thing that isn't caught by the type-system.+-}+++type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModuleGraphNode -> IO ()++-- | Do the recompilation avoidance checks for both one-shot and --make modes+-- This function is the *only* place in the compiler where we decide whether to+-- recompile a module or not!+hscRecompStatus :: Maybe Messager+                -> HscEnv+                -> ModSummary+                -> Maybe ModIface+                -> Maybe Linkable+                -> (Int,Int)+                -> IO HscRecompStatus+hscRecompStatus+    mHscMessage hsc_env mod_summary mb_old_iface old_linkable mod_index+  = do+    let+        msg what = case mHscMessage of+          Just hscMessage -> hscMessage hsc_env mod_index what (ModuleNode [] mod_summary)+          Nothing -> return ()++    -- First check to see if the interface file agrees with the+    -- source file.+    --+    -- Save the interface that comes back from checkOldIface.+    -- In one-shot mode we don't have the old iface until this+    -- point, when checkOldIface reads it from the disk.+    recomp_if_result+          <- {-# SCC "checkOldIface" #-}+             liftIO $ checkOldIface hsc_env mod_summary mb_old_iface+    case recomp_if_result of+      OutOfDateItem reason mb_checked_iface -> do+        msg $ NeedsRecompile reason+        return $ HscRecompNeeded $ fmap (mi_iface_hash . mi_final_exts) mb_checked_iface+      UpToDateItem checked_iface -> do+        let lcl_dflags = ms_hspp_opts mod_summary+        case backend lcl_dflags of+          -- No need for a linkable, we're good to go+          NoBackend -> do+            msg $ UpToDate+            return $ HscUpToDate checked_iface Nothing+          -- Do need linkable+          _ -> do+            -- Check to see whether the expected build products already exist.+            -- If they don't exists then we trigger recompilation.+            recomp_linkable_result <- case () of+               -- Interpreter can use either already loaded bytecode or loaded object code+               _ | Interpreter <- backend lcl_dflags -> do+                     let res = checkByteCode old_linkable+                     case res of+                       UpToDateItem _ -> pure res+                       _ -> liftIO $ checkObjects lcl_dflags old_linkable mod_summary+                 -- Need object files for making object files+                 | backendProducesObject (backend lcl_dflags) -> liftIO $ checkObjects lcl_dflags old_linkable mod_summary+                 | otherwise -> pprPanic "hscRecompStatus" (text $ show $ backend lcl_dflags)+            case recomp_linkable_result of+              UpToDateItem linkable -> do+                msg $ UpToDate+                return $ HscUpToDate checked_iface $ Just linkable+              OutOfDateItem reason _ -> do+                msg $ NeedsRecompile reason+                return $ HscRecompNeeded $ Just $ mi_iface_hash $ mi_final_exts $ checked_iface++-- | Check that the .o files produced by compilation are already up-to-date+-- or not.+checkObjects :: DynFlags -> Maybe Linkable -> ModSummary -> IO (MaybeValidated Linkable)+checkObjects dflags mb_old_linkable summary = do+  let+    dt_enabled  = gopt Opt_BuildDynamicToo dflags+    this_mod    = ms_mod summary+    mb_obj_date = ms_obj_date summary+    mb_dyn_obj_date = ms_dyn_obj_date summary+    mb_if_date  = ms_iface_date summary+    obj_fn      = ml_obj_file (ms_location summary)+    -- dynamic-too *also* produces the dyn_o_file, so have to check+    -- that's there, and if it's not, regenerate both .o and+    -- .dyn_o+    checkDynamicObj k = if dt_enabled+      then case (>=) <$> mb_dyn_obj_date <*> mb_if_date of+        Just True -> k+        _ -> return $ outOfDateItemBecause MissingDynObjectFile Nothing+      -- Not in dynamic-too mode+      else k++  checkDynamicObj $+    case (,) <$> mb_obj_date <*> mb_if_date of+      Just (obj_date, if_date)+        | obj_date >= if_date ->+            case mb_old_linkable of+              Just old_linkable+                | isObjectLinkable old_linkable, linkableTime old_linkable == obj_date+                -> return $ UpToDateItem old_linkable+              _ -> UpToDateItem <$> findObjectLinkable this_mod obj_fn obj_date+      _ -> return $ outOfDateItemBecause MissingObjectFile Nothing++-- | Check to see if we can reuse the old linkable, by this point we will+-- have just checked that the old interface matches up with the source hash, so+-- no need to check that again here+checkByteCode :: Maybe Linkable -> MaybeValidated Linkable+checkByteCode mb_old_linkable =+  case mb_old_linkable of+    Just old_linkable+      | not (isObjectLinkable old_linkable)+      -> UpToDateItem old_linkable+    _ -> outOfDateItemBecause MissingBytecode Nothing++--------------------------------------------------------------+-- Compilers+--------------------------------------------------------------+++-- Knot tying!  See Note [Knot-tying typecheckIface]+-- See Note [ModDetails and --make mode]+initModDetails :: HscEnv -> ModSummary -> ModIface -> IO ModDetails+initModDetails hsc_env mod_summary iface =+  fixIO $ \details' -> do+    let act hpt  = addToHpt hpt (ms_mod_name mod_summary)+                                (HomeModInfo iface details' Nothing)+    let hsc_env' = hscUpdateHPT act hsc_env+    -- NB: This result is actually not that useful+    -- in one-shot mode, since we're not going to do+    -- any further typechecking.  It's much more useful+    -- in make mode, since this HMI will go into the HPT.+    genModDetails hsc_env' iface+++{-+Note [ModDetails and --make mode]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+An interface file consists of two parts++* The `ModIface` which ends up getting written to disk.+  The `ModIface` is a completely acyclic tree, which can be serialised+  and de-serialised completely straightforwardly.  The `ModIface` is+  also the structure that is finger-printed for recompilation control.++* The `ModDetails` which provides a more structured view that is suitable+  for usage during compilation.  The `ModDetails` is heavily cyclic:+  An `Id` contains a `Type`, which mentions a `TyCon` that contains kind+  that mentions other `TyCons`; the `Id` also includes an unfolding that+  in turn mentions more `Id`s;  And so on.++The `ModIface` can be created from the `ModDetails` and the `ModDetails` from+a `ModIface`.++During tidying, just before interfaces are written to disk,+the ModDetails is calculated and then converted into a ModIface (see GHC.Iface.Make.mkIface_).+Then when GHC needs to restart typechecking from a certain point it can read the+interface file, and regenerate the ModDetails from the ModIface (see GHC.IfaceToCore.typecheckIface).+The key part about the loading is that the ModDetails is regenerated lazily+from the ModIface, so that there's only a detailed in-memory representation+for declarations which are actually used from the interface. This mode is+also used when reading interface files from external packages.++In the old --make mode implementation, the interface was written after compiling a module+but the in-memory ModDetails which was used to compute the ModIface was retained.+The result was that --make mode used much more memory than `-c` mode, because a large amount of+information about a module would be kept in the ModDetails but never used.++The new idea is that even in `--make` mode, when there is an in-memory `ModDetails`+at hand, we re-create the `ModDetails` from the `ModIface`. Doing this means that+we only have to keep the `ModIface` decls in memory and then lazily load+detailed representations if needed. It turns out this makes a really big difference+to memory usage, halving maximum memory used in some cases.++See !5492 and #13586+-}++-- Runs the post-typechecking frontend (desugar and simplify). We want to+-- generate most of the interface as late as possible. This gets us up-to-date+-- and good unfoldings and other info in the interface file.+--+-- We might create a interface right away, in which case we also return the+-- updated HomeModInfo. But we might also need to run the backend first. In the+-- later case Status will be HscRecomp and we return a function from ModIface ->+-- HomeModInfo.+--+-- HscRecomp in turn will carry the information required to compute a interface+-- when passed the result of the code generator. So all this can and is done at+-- the call site of the backend code gen if it is run.+hscDesugarAndSimplify :: ModSummary+       -> FrontendResult+       -> Messages GhcMessage+       -> Maybe Fingerprint+       -> Hsc HscBackendAction+hscDesugarAndSimplify summary (FrontendTypecheck tc_result) tc_warnings mb_old_hash = do+  hsc_env <- getHscEnv+  dflags <- getDynFlags+  logger <- getLogger+  let bcknd  = backend dflags+      hsc_src = ms_hsc_src summary+      diag_opts = initDiagOpts dflags++  -- Desugar, if appropriate+  --+  -- We usually desugar even when we are not generating code, otherwise we+  -- would miss errors thrown by the desugaring (see #10600). The only+  -- exceptions are when the Module is Ghc.Prim or when it is not a+  -- HsSrcFile Module.+  mb_desugar <-+      if ms_mod summary /= gHC_PRIM && hsc_src == HsSrcFile+      then Just <$> hscDesugar' (ms_location summary) tc_result+      else pure Nothing++  -- Report the warnings from both typechecking and desugar together+  w <- getDiagnostics+  liftIO $ printOrThrowDiagnostics logger diag_opts (unionMessages tc_warnings w)+  clearDiagnostics++  -- Simplify, if appropriate, and (whether we simplified or not) generate an+  -- interface file.+  case mb_desugar of+      -- Just cause we desugared doesn't mean we are generating code, see above.+      Just desugared_guts | bcknd /= NoBackend -> do+          plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result)+          simplified_guts <- hscSimplify' plugins desugared_guts++          (cg_guts, details) <-+              liftIO $ hscTidy hsc_env simplified_guts++          let !partial_iface =+                {-# SCC "GHC.Driver.Main.mkPartialIface" #-}+                -- This `force` saves 2M residency in test T10370+                -- See Note [Avoiding space leaks in toIface*] for details.+                force (mkPartialIface hsc_env details summary simplified_guts)++          return HscRecomp { hscs_guts = cg_guts,+                             hscs_mod_location = ms_location summary,+                             hscs_partial_iface = partial_iface,+                             hscs_old_iface_hash = mb_old_hash+                           }++      -- We are not generating code, so we can skip simplification+      -- and generate a simple interface.+      _ -> do+        (iface, _details) <- liftIO $+          hscSimpleIface hsc_env tc_result summary++        liftIO $ hscMaybeWriteIface logger dflags True iface mb_old_hash (ms_location summary)++        return $ HscUpdate iface++{-+Note [Writing interface files]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We write one interface file per module and per compilation, except with+-dynamic-too where we write two interface files (non-dynamic and dynamic).++We can write two kinds of interfaces (see Note [Interface file stages] in+"GHC.Driver.Types"):++   * simple interface: interface generated after the core pipeline++   * full interface: simple interface completed with information from the+     backend++Depending on the situation, we write one or the other (using+`hscMaybeWriteIface`). We must be careful with `-dynamic-too` because only the+backend is run twice, so if we write a simple interface we need to write both+the non-dynamic and the dynamic interfaces at the same time (with the same+contents).++Cases for which we generate simple interfaces:++   * GHC.Driver.Main.hscDesugarAndSimplify: when a compilation does NOT require (re)compilation+   of the hard code++   * GHC.Driver.Pipeline.compileOne': when we run in One Shot mode and target+   bytecode (if interface writing is forced).++   * GHC.Driver.Backpack uses simple interfaces for indefinite units+   (units with module holes). It writes them indirectly by forcing the+   -fwrite-interface flag while setting backend to NoBackend.++Cases for which we generate full interfaces:++   * GHC.Driver.Pipeline.runPhase: when we must be compiling to regular hard+   code and/or require recompilation.++By default interface file names are derived from module file names by adding+suffixes. The interface file name can be overloaded with "-ohi", except when+`-dynamic-too` is used.++-}++-- | Write interface files+hscMaybeWriteIface+  :: Logger+  -> DynFlags+  -> Bool+  -- ^ Is this a simple interface generated after the core pipeline, or one+  -- with information from the backend? See: Note [Writing interface files]+  -> ModIface+  -> Maybe Fingerprint+  -- ^ The old interface hash, used to decide if we need to actually write the+  -- new interface.+  -> ModLocation+  -> IO ()+hscMaybeWriteIface logger dflags is_simple iface old_iface mod_location = do+    let force_write_interface = gopt Opt_WriteInterface dflags+        write_interface = case backend dflags of+                            NoBackend    -> False+                            Interpreter  -> False+                            _            -> True++        write_iface dflags' iface =+          let !iface_name = if dynamicNow dflags' then ml_dyn_hi_file mod_location else ml_hi_file mod_location+              profile     = targetProfile dflags'+          in+          {-# SCC "writeIface" #-}+          withTiming logger+              (text "WriteIface"<+>brackets (text iface_name))+              (const ())+              (writeIface logger profile iface_name iface)++    if (write_interface || force_write_interface) then do++      -- FIXME: with -dynamic-too, "change" is only meaningful for the+      -- non-dynamic interface, not for the dynamic one. We should have another+      -- flag for the dynamic interface. In the meantime:+      --+      --    * when we write a single full interface, we check if we are+      --    currently writing the dynamic interface due to -dynamic-too, in+      --    which case we ignore "change".+      --+      --    * when we write two simple interfaces at once because of+      --    dynamic-too, we use "change" both for the non-dynamic and the+      --    dynamic interfaces. Hopefully both the dynamic and the non-dynamic+      --    interfaces stay in sync...+      --+      let change = old_iface /= Just (mi_iface_hash (mi_final_exts iface))++      let dt = dynamicTooState dflags++      when (logHasDumpFlag logger Opt_D_dump_if_trace) $ putMsg logger $+        hang (text "Writing interface(s):") 2 $ vcat+         [ text "Kind:" <+> if is_simple then text "simple" else text "full"+         , text "Hash change:" <+> ppr change+         , text "DynamicToo state:" <+> text (show dt)+         ]++      if is_simple+         then when change $ do -- FIXME: see 'change' comment above+            write_iface dflags iface+            case dt of+               DT_Dont   -> return ()+               DT_Dyn    -> panic "Unexpected DT_Dyn state when writing simple interface"+               DT_OK     -> write_iface (setDynamicNow dflags) iface+         else case dt of+               DT_Dont | change                    -> write_iface dflags iface+               DT_OK   | change                    -> write_iface dflags iface+               -- FIXME: see change' comment above+               DT_Dyn                              -> write_iface dflags iface+               _                                   -> return ()++      when (gopt Opt_WriteHie dflags) $ do+          -- This is slightly hacky. A hie file is considered to be up to date+          -- if its modification time on disk is greater than or equal to that+          -- of the .hi file (since we should always write a .hi file if we are+          -- writing a .hie file). However, with the way this code is+          -- structured at the moment, the .hie file is often written before+          -- the .hi file; by touching the file here, we ensure that it is+          -- correctly considered up-to-date.+          --+          -- The file should exist by the time we get here, but we check for+          -- existence just in case, so that we don't accidentally create empty+          -- .hie files.+          let hie_file = ml_hie_file mod_location+          whenM (doesFileExist hie_file) $+            GHC.SysTools.touch logger dflags "Touching hie file" hie_file+    else+        -- See Note [Strictness in ModIface]+        forceModIface iface++--------------------------------------------------------------+-- NoRecomp handlers+--------------------------------------------------------------+++-- | genModDetails is used to initialise 'ModDetails' at the end of compilation.+-- This has two main effects:+-- 1. Increases memory usage by unloading a lot of the TypeEnv+-- 2. Globalising certain parts (DFunIds) in the TypeEnv (which used to be achieved using UpdateIdInfos)+-- For the second part to work, it's critical that we use 'initIfaceLoadModule' here rather than+-- 'initIfaceCheck' as 'initIfaceLoadModule' removes the module from the KnotVars, otherwise name lookups+-- succeed by hitting the old TypeEnv, which missing out the critical globalisation step for DFuns.++-- After the DFunIds are globalised, it's critical to overwrite the old TypeEnv with the new+-- more compact and more correct version. This reduces memory usage whilst compiling the rest of+-- the module loop.+genModDetails :: HscEnv -> ModIface -> IO ModDetails+genModDetails hsc_env old_iface+  = do+    -- CRITICAL: To use initIfaceLoadModule as that removes the current module from the KnotVars and+    -- hence properly globalises DFunIds.+    new_details <- {-# SCC "tcRnIface" #-}+                  initIfaceLoadModule hsc_env (mi_module old_iface) (typecheckIface old_iface)+    case lookupKnotVars (hsc_type_env_vars hsc_env) (mi_module old_iface) of+      Nothing -> return ()+      Just te_var -> writeIORef te_var (md_types new_details)+    dumpIfaceStats hsc_env+    return new_details++--------------------------------------------------------------+-- Progress displayers.+--------------------------------------------------------------++oneShotMsg :: Logger -> RecompileRequired -> IO ()+oneShotMsg logger recomp =+    case recomp of+        UpToDate -> compilationProgressMsg logger $ text "compilation IS NOT required"+        NeedsRecompile _ -> return ()++batchMsg :: Messager+batchMsg = batchMsgWith (\_ _ _ _ -> empty)+batchMultiMsg :: Messager+batchMultiMsg = batchMsgWith (\_ _ _ node -> brackets (ppr (moduleGraphNodeUnitId node)))++batchMsgWith :: (HscEnv -> (Int, Int) -> RecompileRequired -> ModuleGraphNode -> SDoc) -> Messager+batchMsgWith extra hsc_env_start mod_index recomp node =+      case recomp of+        UpToDate+          | logVerbAtLeast logger 2 -> showMsg (text "Skipping") empty+          | otherwise -> return ()+        NeedsRecompile reason0 -> showMsg (text herald) $ case reason0 of+          MustCompile            -> empty+          (RecompBecause reason) -> text " [" <> pprWithUnitState state (ppr reason) <> text "]"+    where+        herald = case node of+                    LinkNode {} -> "Linking"+                    InstantiationNode {} -> "Instantiating"+                    ModuleNode {} -> "Compiling"+        hsc_env = hscSetActiveUnitId (moduleGraphNodeUnitId node) hsc_env_start+        dflags = hsc_dflags hsc_env+        logger = hsc_logger hsc_env+        state  = hsc_units hsc_env+        showMsg msg reason =+            compilationProgressMsg logger $+            (showModuleIndex mod_index <>+            msg <+> showModMsg dflags (recompileRequired recomp) node)+                <> extra hsc_env mod_index recomp node+                <> reason++--------------------------------------------------------------+-- Safe Haskell+--------------------------------------------------------------++-- Note [Safe Haskell Trust Check]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Safe Haskell checks that an import is trusted according to the following+-- rules for an import of module M that resides in Package P:+--+--   * If M is recorded as Safe and all its trust dependencies are OK+--     then M is considered safe.+--   * If M is recorded as Trustworthy and P is considered trusted and+--     all M's trust dependencies are OK then M is considered safe.+--+-- By trust dependencies we mean that the check is transitive. So if+-- a module M that is Safe relies on a module N that is trustworthy,+-- importing module M will first check (according to the second case)+-- that N is trusted before checking M is trusted.+--+-- This is a minimal description, so please refer to the user guide+-- for more details. The user guide is also considered the authoritative+-- source in this matter, not the comments or code.+++-- Note [Safe Haskell Inference]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Safe Haskell does Safe inference on modules that don't have any specific+-- safe haskell mode flag. The basic approach to this is:+--   * When deciding if we need to do a Safe language check, treat+--     an unmarked module as having -XSafe mode specified.+--   * For checks, don't throw errors but return them to the caller.+--   * Caller checks if there are errors:+--     * For modules explicitly marked -XSafe, we throw the errors.+--     * For unmarked modules (inference mode), we drop the errors+--       and mark the module as being Unsafe.+--+-- It used to be that we only did safe inference on modules that had no Safe+-- Haskell flags, but now we perform safe inference on all modules as we want+-- to allow users to set the `-Wsafe`, `-Wunsafe` and+-- `-Wtrustworthy-safe` flags on Trustworthy and Unsafe modules so that a+-- user can ensure their assumptions are correct and see reasons for why a+-- module is safe or unsafe.+--+-- This is tricky as we must be careful when we should throw an error compared+-- to just warnings. For checking safe imports we manage it as two steps. First+-- we check any imports that are required to be safe, then we check all other+-- imports to see if we can infer them to be safe.+++-- | Check that the safe imports of the module being compiled are valid.+-- If not we either issue a compilation error if the module is explicitly+-- using Safe Haskell, or mark the module as unsafe if we're in safe+-- inference mode.+hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv+hscCheckSafeImports tcg_env = do+    dflags   <- getDynFlags+    tcg_env' <- checkSafeImports tcg_env+    checkRULES dflags tcg_env'++  where+    checkRULES dflags tcg_env' =+      let diag_opts = initDiagOpts dflags+      in case safeLanguageOn dflags of+          True -> do+              -- XSafe: we nuke user written RULES+              logDiagnostics $ fmap GhcDriverMessage $ warns diag_opts (tcg_rules tcg_env')+              return tcg_env' { tcg_rules = [] }+          False+                -- SafeInferred: user defined RULES, so not safe+              | safeInferOn dflags && not (null $ tcg_rules tcg_env')+              -> markUnsafeInfer tcg_env' $ warns diag_opts (tcg_rules tcg_env')++                -- Trustworthy OR SafeInferred: with no RULES+              | otherwise+              -> return tcg_env'++    warns diag_opts rules = mkMessages $ listToBag $ map (warnRules diag_opts) rules++    warnRules :: DiagOpts -> LRuleDecl GhcTc -> MsgEnvelope DriverMessage+    warnRules diag_opts (L loc rule) =+        mkPlainMsgEnvelope diag_opts (locA loc) $ DriverUserDefinedRuleIgnored rule++-- | Validate that safe imported modules are actually safe.  For modules in the+-- HomePackage (the package the module we are compiling in resides) this just+-- involves checking its trust type is 'Safe' or 'Trustworthy'. For modules+-- that reside in another package we also must check that the external package+-- is trusted. See the Note [Safe Haskell Trust Check] above for more+-- information.+--+-- The code for this is quite tricky as the whole algorithm is done in a few+-- distinct phases in different parts of the code base. See+-- 'GHC.Rename.Names.rnImportDecl' for where package trust dependencies for a+-- module are collected and unioned.  Specifically see the Note [Tracking Trust+-- Transitively] in "GHC.Rename.Names" and the Note [Trust Own Package] in+-- "GHC.Rename.Names".+checkSafeImports :: TcGblEnv -> Hsc TcGblEnv+checkSafeImports tcg_env+    = do+        dflags <- getDynFlags+        imps <- mapM condense imports'+        let (safeImps, regImps) = partition (\(_,_,s) -> s) imps++        -- We want to use the warning state specifically for detecting if safe+        -- inference has failed, so store and clear any existing warnings.+        oldErrs <- getDiagnostics+        clearDiagnostics++        -- Check safe imports are correct+        safePkgs <- S.fromList <$> mapMaybeM checkSafe safeImps+        safeErrs <- getDiagnostics+        clearDiagnostics++        -- Check non-safe imports are correct if inferring safety+        -- See the Note [Safe Haskell Inference]+        (infErrs, infPkgs) <- case (safeInferOn dflags) of+          False -> return (emptyMessages, S.empty)+          True -> do infPkgs <- S.fromList <$> mapMaybeM checkSafe regImps+                     infErrs <- getDiagnostics+                     clearDiagnostics+                     return (infErrs, infPkgs)++        -- restore old errors+        logDiagnostics oldErrs++        case (isEmptyMessages safeErrs) of+          -- Failed safe check+          False -> liftIO . throwErrors $ safeErrs++          -- Passed safe check+          True -> do+            let infPassed = isEmptyMessages infErrs+            tcg_env' <- case (not infPassed) of+              True  -> markUnsafeInfer tcg_env infErrs+              False -> return tcg_env+            when (packageTrustOn dflags) $ checkPkgTrust pkgReqs+            let newTrust = pkgTrustReqs dflags safePkgs infPkgs infPassed+            return tcg_env' { tcg_imports = impInfo `plusImportAvails` newTrust }++  where+    impInfo  = tcg_imports tcg_env     -- ImportAvails+    imports  = imp_mods impInfo        -- ImportedMods+    imports1 = moduleEnvToList imports -- (Module, [ImportedBy])+    imports' = map (fmap importedByUser) imports1 -- (Module, [ImportedModsVal])+    pkgReqs  = imp_trust_pkgs impInfo  -- [Unit]++    condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport)+    condense (_, [])   = panic "GHC.Driver.Main.condense: Pattern match failure!"+    condense (m, x:xs) = do imv <- foldlM cond' x xs+                            return (m, imv_span imv, imv_is_safe imv)++    -- ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport)+    cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal+    cond' v1 v2+        | imv_is_safe v1 /= imv_is_safe v2+        = throwOneError $+            mkPlainErrorMsgEnvelope (imv_span v1) $+            GhcDriverMessage $ DriverMixedSafetyImport (imv_name v1)+        | otherwise+        = return v1++    -- easier interface to work with+    checkSafe :: (Module, SrcSpan, a) -> Hsc (Maybe UnitId)+    checkSafe (m, l, _) = fst `fmap` hscCheckSafe' m l++    -- what pkg's to add to our trust requirements+    pkgTrustReqs :: DynFlags -> Set UnitId -> Set UnitId ->+          Bool -> ImportAvails+    pkgTrustReqs dflags req inf infPassed | safeInferOn dflags+                                  && not (safeHaskellModeEnabled dflags) && infPassed+                                   = emptyImportAvails {+                                       imp_trust_pkgs = req `S.union` inf+                                   }+    pkgTrustReqs dflags _   _ _ | safeHaskell dflags == Sf_Unsafe+                         = emptyImportAvails+    pkgTrustReqs _ req _ _ = emptyImportAvails { imp_trust_pkgs = req }++-- | Check that a module is safe to import.+--+-- We return True to indicate the import is safe and False otherwise+-- although in the False case an exception may be thrown first.+hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool+hscCheckSafe hsc_env m l = runHsc hsc_env $ do+    dflags <- getDynFlags+    pkgs <- snd `fmap` hscCheckSafe' m l+    when (packageTrustOn dflags) $ checkPkgTrust pkgs+    errs <- getDiagnostics+    return $ isEmptyMessages errs++-- | Return if a module is trusted and the pkgs it depends on to be trusted.+hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set UnitId)+hscGetSafe hsc_env m l = runHsc hsc_env $ do+    (self, pkgs) <- hscCheckSafe' m l+    good         <- isEmptyMessages `fmap` getDiagnostics+    clearDiagnostics -- don't want them printed...+    let pkgs' | Just p <- self = S.insert p pkgs+              | otherwise      = pkgs+    return (good, pkgs')++-- | Is a module trusted? If not, throw or log errors depending on the type.+-- Return (regardless of trusted or not) if the trust type requires the modules+-- own package be trusted and a list of other packages required to be trusted+-- (these later ones haven't been checked) but the own package trust has been.+hscCheckSafe' :: Module -> SrcSpan+  -> Hsc (Maybe UnitId, Set UnitId)+hscCheckSafe' m l = do+    hsc_env <- getHscEnv+    let home_unit = hsc_home_unit hsc_env+    (tw, pkgs) <- isModSafe home_unit m l+    case tw of+        False                           -> return (Nothing, pkgs)+        True | isHomeModule home_unit m -> return (Nothing, pkgs)+             -- TODO: do we also have to check the trust of the instantiation?+             -- Not necessary if that is reflected in dependencies+             | otherwise   -> return (Just $ toUnitId (moduleUnit m), pkgs)+  where+    isModSafe :: HomeUnit -> Module -> SrcSpan -> Hsc (Bool, Set UnitId)+    isModSafe home_unit m l = do+        hsc_env <- getHscEnv+        dflags <- getDynFlags+        iface <- lookup' m+        let diag_opts = initDiagOpts dflags+        case iface of+            -- can't load iface to check trust!+            Nothing -> throwOneError $+                         mkPlainErrorMsgEnvelope l $+                         GhcDriverMessage $ DriverCannotLoadInterfaceFile m++            -- got iface, check trust+            Just iface' ->+                let trust = getSafeMode $ mi_trust iface'+                    trust_own_pkg = mi_trust_pkg iface'+                    -- check module is trusted+                    safeM = trust `elem` [Sf_Safe, Sf_SafeInferred, Sf_Trustworthy]+                    -- check package is trusted+                    safeP = packageTrusted dflags (hsc_units hsc_env) home_unit trust trust_own_pkg m+                    -- pkg trust reqs+                    pkgRs = dep_trusted_pkgs $ mi_deps iface'+                    -- warn if Safe module imports Safe-Inferred module.+                    warns = if wopt Opt_WarnInferredSafeImports dflags+                                && safeLanguageOn dflags+                                && trust == Sf_SafeInferred+                                then inferredImportWarn diag_opts+                                else emptyMessages+                    -- General errors we throw but Safe errors we log+                    errs = case (safeM, safeP) of+                        (True, True ) -> emptyMessages+                        (True, False) -> pkgTrustErr+                        (False, _   ) -> modTrustErr+                in do+                    logDiagnostics warns+                    logDiagnostics errs+                    return (trust == Sf_Trustworthy, pkgRs)++                where+                    state = hsc_units hsc_env+                    inferredImportWarn diag_opts = singleMessage+                        $ mkMsgEnvelope diag_opts l (pkgQual state)+                        $ GhcDriverMessage $ DriverInferredSafeImport m+                    pkgTrustErr = singleMessage+                      $ mkErrorMsgEnvelope l (pkgQual state)+                      $ GhcDriverMessage $ DriverCannotImportFromUntrustedPackage state m+                    modTrustErr = singleMessage+                      $ mkErrorMsgEnvelope l (pkgQual state)+                      $ GhcDriverMessage $ DriverCannotImportUnsafeModule m++    -- Check the package a module resides in is trusted. Safe compiled+    -- modules are trusted without requiring that their package is trusted. For+    -- trustworthy modules, modules in the home package are trusted but+    -- otherwise we check the package trust flag.+    packageTrusted :: DynFlags -> UnitState -> HomeUnit -> SafeHaskellMode -> Bool -> Module -> Bool+    packageTrusted dflags unit_state home_unit safe_mode trust_own_pkg mod =+        case safe_mode of+            Sf_None      -> False -- shouldn't hit these cases+            Sf_Ignore    -> False -- shouldn't hit these cases+            Sf_Unsafe    -> False -- prefer for completeness.+            _ | not (packageTrustOn dflags)     -> True+            Sf_Safe | not trust_own_pkg         -> True+            Sf_SafeInferred | not trust_own_pkg -> True+            _ | isHomeModule home_unit mod      -> True+            _ -> unitIsTrusted $ unsafeLookupUnit unit_state (moduleUnit m)++    lookup' :: Module -> Hsc (Maybe ModIface)+    lookup' m = do+        hsc_env <- getHscEnv+        hsc_eps <- liftIO $ hscEPS hsc_env+        let pkgIfaceT = eps_PIT hsc_eps+            hug       = hsc_HUG hsc_env+            iface     = lookupIfaceByModule hug pkgIfaceT m+        -- the 'lookupIfaceByModule' method will always fail when calling from GHCi+        -- as the compiler hasn't filled in the various module tables+        -- so we need to call 'getModuleInterface' to load from disk+        case iface of+            Just _  -> return iface+            Nothing -> snd `fmap` (liftIO $ getModuleInterface hsc_env m)+++-- | Check the list of packages are trusted.+checkPkgTrust :: Set UnitId -> Hsc ()+checkPkgTrust pkgs = do+    hsc_env <- getHscEnv+    let errors = S.foldr go emptyBag pkgs+        state  = hsc_units hsc_env+        go pkg acc+            | unitIsTrusted $ unsafeLookupUnitId state pkg+            = acc+            | otherwise+            = (`consBag` acc)+                     $ mkErrorMsgEnvelope noSrcSpan (pkgQual state)+                     $ GhcDriverMessage+                     $ DriverPackageNotTrusted state pkg+    if isEmptyBag errors+      then return ()+      else liftIO $ throwErrors $ mkMessages errors++-- | Set module to unsafe and (potentially) wipe trust information.+--+-- Make sure to call this method to set a module to inferred unsafe, it should+-- be a central and single failure method. We only wipe the trust information+-- when we aren't in a specific Safe Haskell mode.+--+-- While we only use this for recording that a module was inferred unsafe, we+-- may call it on modules using Trustworthy or Unsafe flags so as to allow+-- warning flags for safety to function correctly. See Note [Safe Haskell+-- Inference].+markUnsafeInfer :: Diagnostic e => TcGblEnv -> Messages e -> Hsc TcGblEnv+markUnsafeInfer tcg_env whyUnsafe = do+    dflags <- getDynFlags++    let reason = WarningWithFlag Opt_WarnUnsafe+    let diag_opts = initDiagOpts dflags+    when (diag_wopt Opt_WarnUnsafe diag_opts)+         (logDiagnostics $ singleMessage $+             mkPlainMsgEnvelope diag_opts (warnUnsafeOnLoc dflags) $+             GhcDriverMessage $ DriverUnknownMessage $+             mkPlainDiagnostic reason noHints $+             whyUnsafe' dflags)++    liftIO $ writeIORef (tcg_safe_infer tcg_env) False+    liftIO $ writeIORef (tcg_safe_infer_reasons tcg_env) emptyMessages+    -- NOTE: Only wipe trust when not in an explicitly safe haskell mode. Other+    -- times inference may be on but we are in Trustworthy mode -- so we want+    -- to record safe-inference failed but not wipe the trust dependencies.+    case not (safeHaskellModeEnabled dflags) of+      True  -> return $ tcg_env { tcg_imports = wiped_trust }+      False -> return tcg_env++  where+    wiped_trust   = (tcg_imports tcg_env) { imp_trust_pkgs = S.empty }+    pprMod        = ppr $ moduleName $ tcg_mod tcg_env+    whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!"+                         , text "Reason:"+                         , nest 4 $ (vcat $ badFlags df) $+$+                                    (vcat $ pprMsgEnvelopeBagWithLoc (getMessages whyUnsafe)) $+$+                                    (vcat $ badInsts $ tcg_insts tcg_env)+                         ]+    badFlags df   = concatMap (badFlag df) unsafeFlagsForInfer+    badFlag df (str,loc,on,_)+        | on df     = [mkLocMessage MCOutput (loc df) $+                            text str <+> text "is not allowed in Safe Haskell"]+        | otherwise = []+    badInsts insts = concatMap badInst insts++    checkOverlap (NoOverlap _) = False+    checkOverlap _             = True++    badInst ins | checkOverlap (overlapMode (is_flag ins))+                = [mkLocMessage MCOutput (nameSrcSpan $ getName $ is_dfun ins) $+                      ppr (overlapMode $ is_flag ins) <+>+                      text "overlap mode isn't allowed in Safe Haskell"]+                | otherwise = []++-- | Figure out the final correct safe haskell mode+hscGetSafeMode :: TcGblEnv -> Hsc SafeHaskellMode+hscGetSafeMode tcg_env = do+    dflags  <- getDynFlags+    liftIO $ finalSafeMode dflags tcg_env++--------------------------------------------------------------+-- Simplifiers+--------------------------------------------------------------++-- | Run Core2Core simplifier. The list of String is a list of (Core) plugin+-- module names added via TH (cf 'addCorePlugin').+hscSimplify :: HscEnv -> [String] -> ModGuts -> IO ModGuts+hscSimplify hsc_env plugins modguts =+    runHsc hsc_env $ hscSimplify' plugins modguts++-- | Run Core2Core simplifier. The list of String is a list of (Core) plugin+-- module names added via TH (cf 'addCorePlugin').+hscSimplify' :: [String] -> ModGuts -> Hsc ModGuts+hscSimplify' plugins ds_result = do+    hsc_env <- getHscEnv+    hsc_env_with_plugins <- if null plugins -- fast path+        then return hsc_env+        else liftIO $ initializePlugins+                    $ hscUpdateFlags (\dflags -> foldr addPluginModuleName dflags plugins)+                      hsc_env+    {-# SCC "Core2Core" #-}+      liftIO $ core2core hsc_env_with_plugins ds_result++--------------------------------------------------------------+-- Interface generators+--------------------------------------------------------------++-- | Generate a striped down interface file, e.g. for boot files or when ghci+-- generates interface files. See Note [simpleTidyPgm - mkBootModDetailsTc]+hscSimpleIface :: HscEnv+               -> TcGblEnv+               -> ModSummary+               -> IO (ModIface, ModDetails)+hscSimpleIface hsc_env tc_result summary+    = runHsc hsc_env $ hscSimpleIface' tc_result summary++hscSimpleIface' :: TcGblEnv+                -> ModSummary+                -> Hsc (ModIface, ModDetails)+hscSimpleIface' tc_result summary = do+    hsc_env   <- getHscEnv+    logger    <- getLogger+    details   <- liftIO $ mkBootModDetailsTc logger tc_result+    safe_mode <- hscGetSafeMode tc_result+    new_iface+        <- {-# SCC "MkFinalIface" #-}+           liftIO $+               mkIfaceTc hsc_env safe_mode details summary tc_result+    -- And the answer is ...+    liftIO $ dumpIfaceStats hsc_env+    return (new_iface, details)++--------------------------------------------------------------+-- BackEnd combinators+--------------------------------------------------------------++-- | Compile to hard-code.+hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath+               -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], Maybe CgInfos)+                -- ^ @Just f@ <=> _stub.c is f+hscGenHardCode hsc_env cgguts location output_filename = do+        let CgGuts{ -- This is the last use of the ModGuts in a compilation.+                    -- From now on, we just use the bits we need.+                    cg_module   = this_mod,+                    cg_binds    = core_binds,+                    cg_ccs      = local_ccs,+                    cg_tycons   = tycons,+                    cg_foreign  = foreign_stubs0,+                    cg_foreign_files = foreign_files,+                    cg_dep_pkgs = dependencies,+                    cg_hpc_info = hpc_info } = cgguts+            dflags = hsc_dflags hsc_env+            logger = hsc_logger hsc_env+            hooks  = hsc_hooks hsc_env+            tmpfs  = hsc_tmpfs hsc_env+            profile = targetProfile dflags+            data_tycons = filter isDataTyCon tycons+            -- cg_tycons includes newtypes, for the benefit of External Core,+            -- but we don't generate any code for newtypes++        -------------------+        -- Insert late cost centres if enabled.+        -- If `-fprof-late-inline` is enabled we can skip this, as it will have added+        -- a superset of cost centres we would add here already.++        (late_cc_binds, late_local_ccs) <-+              if gopt Opt_ProfLateCcs dflags && not (gopt Opt_ProfLateInlineCcs dflags)+                  then  {-# SCC lateCC #-} do+                    (binds,late_ccs) <- addLateCostCentresPgm dflags logger this_mod core_binds+                    return ( binds, (S.toList late_ccs `mappend` local_ccs ))+                  else+                    return (core_binds, local_ccs)++++        -------------------+        -- PREPARE FOR CODE GENERATION+        -- Do saturation and convert to A-normal form+        (prepd_binds) <- {-# SCC "CorePrep" #-}+                       corePrepPgm hsc_env this_mod location+                                   late_cc_binds data_tycons++        -----------------  Convert to STG ------------------+        (stg_binds, denv, (caf_ccs, caf_cc_stacks))+            <- {-# SCC "CoreToStg" #-}+               withTiming logger+                   (text "CoreToStg"<+>brackets (ppr this_mod))+                   (\(a, b, (c,d)) -> a `seqList` b `seq` c `seqList` d `seqList` ())+                   (myCoreToStg logger dflags (hsc_IC hsc_env) False this_mod location prepd_binds)++        let cost_centre_info =+              (late_local_ccs ++ caf_ccs, caf_cc_stacks)+            platform = targetPlatform dflags+            prof_init+              | sccProfilingEnabled dflags = profilingInitCode platform this_mod cost_centre_info+              | otherwise = mempty++        ------------------  Code generation ------------------+        -- The back-end is streamed: each top-level function goes+        -- from Stg all the way to asm before dealing with the next+        -- top-level function, so showPass isn't very useful here.+        -- Hence we have one showPass for the whole backend, the+        -- next showPass after this will be "Assembler".+        withTiming logger+                   (text "CodeGen"<+>brackets (ppr this_mod))+                   (const ()) $ do+            cmms <- {-# SCC "StgToCmm" #-}+                            doCodeGen hsc_env this_mod denv data_tycons+                                cost_centre_info+                                stg_binds hpc_info++            ------------------  Code output -----------------------+            rawcmms0 <- {-# SCC "cmmToRawCmm" #-}+                        case cmmToRawCmmHook hooks of+                            Nothing -> cmmToRawCmm logger profile cmms+                            Just h  -> h dflags (Just this_mod) cmms++            let dump a = do+                  unless (null a) $+                    putDumpFileMaybe logger Opt_D_dump_cmm_raw "Raw Cmm" FormatCMM (pdoc platform a)+                  return a+                rawcmms1 = Stream.mapM dump rawcmms0++            let foreign_stubs st = foreign_stubs0 `appendStubC` prof_init+                                                  `appendStubC` cgIPEStub st++            (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cg_infos)+                <- {-# SCC "codeOutput" #-}+                  codeOutput logger tmpfs dflags (hsc_units hsc_env) this_mod output_filename location+                  foreign_stubs foreign_files dependencies rawcmms1+            return (output_filename, stub_c_exists, foreign_fps, Just cg_infos)+++hscInteractive :: HscEnv+               -> CgGuts+               -> ModLocation+               -> IO (Maybe FilePath, CompiledByteCode, [SptEntry])+hscInteractive hsc_env cgguts location = do+    let dflags = hsc_dflags hsc_env+    let logger = hsc_logger hsc_env+    let tmpfs  = hsc_tmpfs hsc_env+    let CgGuts{ -- This is the last use of the ModGuts in a compilation.+                -- From now on, we just use the bits we need.+               cg_module   = this_mod,+               cg_binds    = core_binds,+               cg_tycons   = tycons,+               cg_foreign  = foreign_stubs,+               cg_modBreaks = mod_breaks,+               cg_spt_entries = spt_entries } = cgguts++        data_tycons = filter isDataTyCon tycons+        -- cg_tycons includes newtypes, for the benefit of External Core,+        -- but we don't generate any code for newtypes++    -------------------+    -- PREPARE FOR CODE GENERATION+    -- Do saturation and convert to A-normal form+    prepd_binds <- {-# SCC "CorePrep" #-}+                   corePrepPgm hsc_env this_mod location core_binds data_tycons++    (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks)+      <- {-# SCC "CoreToStg" #-}+          myCoreToStg logger dflags (hsc_IC hsc_env) True this_mod location prepd_binds+    -----------------  Generate byte code ------------------+    comp_bc <- byteCodeGen hsc_env this_mod stg_binds data_tycons mod_breaks+    ------------------ Create f-x-dynamic C-side stuff -----+    (_istub_h_exists, istub_c_exists)+        <- outputForeignStubs logger tmpfs dflags (hsc_units hsc_env) this_mod location foreign_stubs+    return (istub_c_exists, comp_bc, spt_entries)++------------------------------++hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> FilePath -> IO (Maybe FilePath)+hscCompileCmmFile hsc_env original_filename filename output_filename = runHsc hsc_env $ do+    let dflags   = hsc_dflags hsc_env+        logger   = hsc_logger hsc_env+        hooks    = hsc_hooks hsc_env+        tmpfs    = hsc_tmpfs hsc_env+        profile  = targetProfile dflags+        home_unit = hsc_home_unit hsc_env+        platform  = targetPlatform dflags+        do_info_table = gopt Opt_InfoTableMap dflags+        -- Make up a module name to give the NCG. We can't pass bottom here+        -- lest we reproduce #11784.+        mod_name = mkModuleName $ "Cmm$" ++ original_filename+        cmm_mod = mkHomeModule home_unit mod_name+    (cmm, ents) <- ioMsgMaybe+               $ do+                  (warns,errs,cmm) <- withTiming logger (text "ParseCmm"<+>brackets (text filename)) (\_ -> ())+                                       $ parseCmmFile dflags cmm_mod home_unit filename+                  let msgs = warns `unionMessages` errs+                  return (GhcPsMessage <$> msgs, cmm)+    liftIO $ do+        putDumpFileMaybe logger Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform cmm)++        -- Compile decls in Cmm files one decl at a time, to avoid re-ordering+        -- them in SRT analysis.+        --+        -- Re-ordering here causes breakage when booting with C backend because+        -- in C we must declare before use, but SRT algorithm is free to+        -- re-order [A, B] (B refers to A) when A is not CAFFY and return [B, A]+        cmmgroup <-+          concatMapM (\cmm -> snd <$> cmmPipeline hsc_env (emptySRT cmm_mod) [cmm]) cmm++        unless (null cmmgroup) $+          putDumpFileMaybe logger Opt_D_dump_cmm "Output Cmm"+            FormatCMM (pdoc platform cmmgroup)++        rawCmms <- case cmmToRawCmmHook hooks of+          Nothing -> cmmToRawCmm logger profile (Stream.yield cmmgroup)+          Just h  -> h           dflags Nothing (Stream.yield cmmgroup)++        let foreign_stubs _ =+              let ip_init   = ipInitCode do_info_table platform cmm_mod ents+              in NoStubs `appendStubC` ip_init++        (_output_filename, (_stub_h_exists, stub_c_exists), _foreign_fps, _caf_infos)+          <- codeOutput logger tmpfs dflags (hsc_units hsc_env) cmm_mod output_filename no_loc foreign_stubs [] S.empty+             rawCmms+        return stub_c_exists+  where+    no_loc = ModLocation{ ml_hs_file  = Just filename,+                          ml_hi_file  = panic "hscCompileCmmFile: no hi file",+                          ml_obj_file = panic "hscCompileCmmFile: no obj file",+                          ml_dyn_obj_file = panic "hscCompileCmmFile: no dyn obj file",+                          ml_dyn_hi_file  = panic "hscCompileCmmFile: no dyn obj file",+                          ml_hie_file = panic "hscCompileCmmFile: no hie file"}++-------------------- Stuff for new code gen ---------------------++{-+Note [Forcing of stg_binds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+The two last steps in the STG pipeline are:++* Sorting the bindings in dependency order.+* Annotating them with free variables.++We want to make sure we do not keep references to unannotated STG bindings+alive, nor references to bindings which have already been compiled to Cmm.++We explicitly force the bindings to avoid this.++This reduces residency towards the end of the CodeGen phase significantly+(5-10%).+-}++doCodeGen :: HscEnv -> Module -> InfoTableProvMap -> [TyCon]+          -> CollectedCCs+          -> [CgStgTopBinding] -- ^ Bindings come already annotated with fvs+          -> HpcInfo+          -> IO (Stream IO CmmGroupSRTs CgInfos)+         -- Note we produce a 'Stream' of CmmGroups, so that the+         -- backend can be run incrementally.  Otherwise it generates all+         -- the C-- up front, which has a significant space cost.+doCodeGen hsc_env this_mod denv data_tycons+              cost_centre_info stg_binds_w_fvs hpc_info = do+    let dflags     = hsc_dflags hsc_env+        logger     = hsc_logger hsc_env+        hooks      = hsc_hooks  hsc_env+        tmpfs      = hsc_tmpfs  hsc_env+        platform   = targetPlatform dflags++    -- Do tag inference on optimized STG+    (!stg_post_infer,export_tag_info) <-+        {-# SCC "StgTagFields" #-} inferTags dflags logger this_mod stg_binds_w_fvs++    putDumpFileMaybe logger Opt_D_dump_stg_final "Final STG:" FormatSTG+        (pprGenStgTopBindings (initStgPprOpts dflags) stg_post_infer)++    let stg_to_cmm dflags mod = case stgToCmmHook hooks of+                        Nothing -> StgToCmm.codeGen logger tmpfs (initStgToCmmConfig dflags mod)+                        Just h  -> h                             (initStgToCmmConfig dflags mod)++    let cmm_stream :: Stream IO CmmGroup ModuleLFInfos+        -- See Note [Forcing of stg_binds]+        cmm_stream = stg_post_infer `seqList` {-# SCC "StgToCmm" #-}+            stg_to_cmm dflags this_mod denv data_tycons cost_centre_info stg_post_infer hpc_info++        -- codegen consumes a stream of CmmGroup, and produces a new+        -- stream of CmmGroup (not necessarily synchronised: one+        -- CmmGroup on input may produce many CmmGroups on output due+        -- to proc-point splitting).++    let dump1 a = do+          unless (null a) $+            putDumpFileMaybe logger Opt_D_dump_cmm_from_stg+              "Cmm produced by codegen" FormatCMM (pdoc platform a)+          return a++        ppr_stream1 = Stream.mapM dump1 cmm_stream++        pipeline_stream :: Stream IO CmmGroupSRTs (NonCaffySet, ModuleLFInfos)+        pipeline_stream = do+          (non_cafs,  lf_infos) <-+            {-# SCC "cmmPipeline" #-}+            Stream.mapAccumL_ (cmmPipeline hsc_env) (emptySRT this_mod) ppr_stream1+              <&> first (srtMapNonCAFs . moduleSRTMap)++          return (non_cafs, lf_infos)++        dump2 a = do+          unless (null a) $+            putDumpFileMaybe logger Opt_D_dump_cmm "Output Cmm" FormatCMM (pdoc platform a)+          return a++    return $ Stream.mapM dump2 $ generateCgIPEStub hsc_env this_mod denv export_tag_info pipeline_stream++myCoreToStgExpr :: Logger -> DynFlags -> InteractiveContext+                -> Bool+                -> Module -> ModLocation -> CoreExpr+                -> IO ( Id+                      , [CgStgTopBinding]+                      , InfoTableProvMap+                      , CollectedCCs )+myCoreToStgExpr logger dflags ictxt for_bytecode this_mod ml prepd_expr = do+    {- Create a temporary binding (just because myCoreToStg needs a+       binding for the stg2stg step) -}+    let bco_tmp_id = mkSysLocal (fsLit "BCO_toplevel")+                                (mkPseudoUniqueE 0)+                                Many+                                (exprType prepd_expr)+    (stg_binds, prov_map, collected_ccs) <-+       myCoreToStg logger+                   dflags+                   ictxt+                   for_bytecode+                   this_mod+                   ml+                   [NonRec bco_tmp_id prepd_expr]+    return (bco_tmp_id, stg_binds, prov_map, collected_ccs)++myCoreToStg :: Logger -> DynFlags -> InteractiveContext+            -> Bool+            -> Module -> ModLocation -> CoreProgram+            -> IO ( [CgStgTopBinding] -- output program+                  , InfoTableProvMap+                  , CollectedCCs )  -- CAF cost centre info (declared and used)+myCoreToStg logger dflags ictxt for_bytecode this_mod ml prepd_binds = do+    let (stg_binds, denv, cost_centre_info)+         = {-# SCC "Core2Stg" #-}+           coreToStg dflags this_mod ml prepd_binds++    stg_binds_with_fvs+        <- {-# SCC "Stg2Stg" #-}+           stg2stg logger ictxt (initStgPipelineOpts dflags for_bytecode)+                   this_mod stg_binds++    putDumpFileMaybe logger Opt_D_dump_stg_cg "CodeGenInput STG:" FormatSTG+        (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds_with_fvs)++    return (stg_binds_with_fvs, denv, cost_centre_info)++{- **********************************************************************+%*                                                                      *+\subsection{Compiling a do-statement}+%*                                                                      *+%********************************************************************* -}++{-+When the UnlinkedBCOExpr is linked you get an HValue of type *IO [HValue]* When+you run it you get a list of HValues that should be the same length as the list+of names; add them to the ClosureEnv.++A naked expression returns a singleton Name [it]. The stmt is lifted into the+IO monad as explained in Note [Interactively-bound Ids in GHCi] in GHC.Runtime.Context+-}++-- | Compile a stmt all the way to an HValue, but don't run it+--+-- We return Nothing to indicate an empty statement (or comment only), not a+-- parse error.+hscStmt :: HscEnv -> String -> IO (Maybe ([Id], ForeignHValue, FixityEnv))+hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "<interactive>" 1++-- | Compile a stmt all the way to an HValue, but don't run it+--+-- We return Nothing to indicate an empty statement (or comment only), not a+-- parse error.+hscStmtWithLocation :: HscEnv+                    -> String -- ^ The statement+                    -> String -- ^ The source+                    -> Int    -- ^ Starting line+                    -> IO ( Maybe ([Id]+                          , ForeignHValue {- IO [HValue] -}+                          , FixityEnv))+hscStmtWithLocation hsc_env0 stmt source linenumber =+  runInteractiveHsc hsc_env0 $ do+    maybe_stmt <- hscParseStmtWithLocation source linenumber stmt+    case maybe_stmt of+      Nothing -> return Nothing++      Just parsed_stmt -> do+        hsc_env <- getHscEnv+        liftIO $ hscParsedStmt hsc_env parsed_stmt++hscParsedStmt :: HscEnv+              -> GhciLStmt GhcPs  -- ^ The parsed statement+              -> IO ( Maybe ([Id]+                    , ForeignHValue {- IO [HValue] -}+                    , FixityEnv))+hscParsedStmt hsc_env stmt = runInteractiveHsc hsc_env $ do+  -- Rename and typecheck it+  (ids, tc_expr, fix_env) <- ioMsgMaybe $ hoistTcRnMessage $ tcRnStmt hsc_env stmt++  -- Desugar it+  ds_expr <- ioMsgMaybe $ hoistDsMessage $ deSugarExpr hsc_env tc_expr+  liftIO (lintInteractiveExpr (text "desugar expression") hsc_env ds_expr)+  handleWarnings++  -- Then code-gen, and link it+  -- It's important NOT to have package 'interactive' as thisUnitId+  -- for linking, else we try to link 'main' and can't find it.+  -- Whereas the linker already knows to ignore 'interactive'+  let src_span = srcLocSpan interactiveSrcLoc+  (hval,_,_) <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr++  return $ Just (ids, hval, fix_env)++-- | Compile a decls+hscDecls :: HscEnv+         -> String -- ^ The statement+         -> IO ([TyThing], InteractiveContext)+hscDecls hsc_env str = hscDeclsWithLocation hsc_env str "<interactive>" 1++hscParseModuleWithLocation :: HscEnv -> String -> Int -> String -> IO HsModule+hscParseModuleWithLocation hsc_env source line_num str = do+    L _ mod <-+      runInteractiveHsc hsc_env $+        hscParseThingWithLocation source line_num parseModule str+    return mod++hscParseDeclsWithLocation :: HscEnv -> String -> Int -> String -> IO [LHsDecl GhcPs]+hscParseDeclsWithLocation hsc_env source line_num str = do+  HsModule { hsmodDecls = decls } <- hscParseModuleWithLocation hsc_env source line_num str+  return decls++-- | Compile a decls+hscDeclsWithLocation :: HscEnv+                     -> String -- ^ The statement+                     -> String -- ^ The source+                     -> Int    -- ^ Starting line+                     -> IO ([TyThing], InteractiveContext)+hscDeclsWithLocation hsc_env str source linenumber = do+    L _ (HsModule{ hsmodDecls = decls }) <-+      runInteractiveHsc hsc_env $+        hscParseThingWithLocation source linenumber parseModule str+    hscParsedDecls hsc_env decls++hscParsedDecls :: HscEnv -> [LHsDecl GhcPs] -> IO ([TyThing], InteractiveContext)+hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do+    hsc_env <- getHscEnv+    let interp = hscInterp hsc_env++    {- Rename and typecheck it -}+    tc_gblenv <- ioMsgMaybe $ hoistTcRnMessage $ tcRnDeclsi hsc_env decls++    {- Grab the new instances -}+    -- We grab the whole environment because of the overlapping that may have+    -- been done. See the notes at the definition of InteractiveContext+    -- (ic_instances) for more details.+    let defaults = tcg_default tc_gblenv++    {- Desugar it -}+    -- We use a basically null location for iNTERACTIVE+    let iNTERACTIVELoc = ModLocation{ ml_hs_file   = Nothing,+                                      ml_hi_file   = panic "hsDeclsWithLocation:ml_hi_file",+                                      ml_obj_file  = panic "hsDeclsWithLocation:ml_obj_file",+                                      ml_dyn_obj_file = panic "hsDeclsWithLocation:ml_dyn_obj_file",+                                      ml_dyn_hi_file = panic "hsDeclsWithLocation:ml_dyn_hi_file",+                                      ml_hie_file  = panic "hsDeclsWithLocation:ml_hie_file" }+    ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv++    {- Simplify -}+    simpl_mg <- liftIO $ do+      plugins <- readIORef (tcg_th_coreplugins tc_gblenv)+      hscSimplify hsc_env plugins ds_result++    {- Tidy -}+    (tidy_cg, mod_details) <- liftIO $ hscTidy hsc_env simpl_mg++    let !CgGuts{ cg_module    = this_mod,+                 cg_binds     = core_binds,+                 cg_tycons    = tycons,+                 cg_modBreaks = mod_breaks } = tidy_cg++        !ModDetails { md_insts     = cls_insts+                    , md_fam_insts = fam_insts } = mod_details+            -- Get the *tidied* cls_insts and fam_insts++        data_tycons = filter isDataTyCon tycons++    {- Prepare For Code Generation -}+    -- Do saturation and convert to A-normal form+    prepd_binds <- {-# SCC "CorePrep" #-}+      liftIO $ corePrepPgm hsc_env this_mod iNTERACTIVELoc core_binds data_tycons++    (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks)+        <- {-# SCC "CoreToStg" #-}+           liftIO $ myCoreToStg (hsc_logger hsc_env)+                                (hsc_dflags hsc_env)+                                (hsc_IC hsc_env)+                                True+                                this_mod+                                iNTERACTIVELoc+                                prepd_binds++    {- Generate byte code -}+    cbc <- liftIO $ byteCodeGen hsc_env this_mod+                                stg_binds data_tycons mod_breaks++    let src_span = srcLocSpan interactiveSrcLoc+    _ <- liftIO $ loadDecls interp hsc_env src_span cbc++    {- Load static pointer table entries -}+    liftIO $ hscAddSptEntries hsc_env (cg_spt_entries tidy_cg)++    let tcs = filterOut isImplicitTyCon (mg_tcs simpl_mg)+        patsyns = mg_patsyns simpl_mg++        ext_ids = [ id | id <- bindersOfBinds core_binds+                       , isExternalName (idName id)+                       , not (isDFunId id || isImplicitId id) ]+            -- We only need to keep around the external bindings+            -- (as decided by GHC.Iface.Tidy), since those are the only ones+            -- that might later be looked up by name.  But we can exclude+            --    - DFunIds, which are in 'cls_insts' (see Note [ic_tythings] in GHC.Runtime.Context+            --    - Implicit Ids, which are implicit in tcs+            -- c.f. GHC.Tc.Module.runTcInteractive, which reconstructs the TypeEnv++        new_tythings = map AnId ext_ids ++ map ATyCon tcs ++ map (AConLike . PatSynCon) patsyns+        ictxt        = hsc_IC hsc_env+        -- See Note [Fixity declarations in GHCi]+        fix_env      = tcg_fix_env tc_gblenv+        new_ictxt    = extendInteractiveContext ictxt new_tythings cls_insts+                                                fam_insts defaults fix_env+    return (new_tythings, new_ictxt)++-- | Load the given static-pointer table entries into the interpreter.+-- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable".+hscAddSptEntries :: HscEnv -> [SptEntry] -> IO ()+hscAddSptEntries hsc_env entries = do+    let interp = hscInterp hsc_env+    let add_spt_entry :: SptEntry -> IO ()+        add_spt_entry (SptEntry i fpr) = do+            -- These are only names from the current module+            (val, _, _) <- loadName interp hsc_env (idName i)+            addSptEntry interp fpr val+    mapM_ add_spt_entry entries++{-+  Note [Fixity declarations in GHCi]+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+  To support fixity declarations on types defined within GHCi (as requested+  in #10018) we record the fixity environment in InteractiveContext.+  When we want to evaluate something GHC.Tc.Module.runTcInteractive pulls out this+  fixity environment and uses it to initialize the global typechecker environment.+  After the typechecker has finished its business, an updated fixity environment+  (reflecting whatever fixity declarations were present in the statements we+  passed it) will be returned from hscParsedStmt. This is passed to+  updateFixityEnv, which will stuff it back into InteractiveContext, to be+  used in evaluating the next statement.++-}++hscImport :: HscEnv -> String -> IO (ImportDecl GhcPs)+hscImport hsc_env str = runInteractiveHsc hsc_env $ do+    (L _ (HsModule{hsmodImports=is})) <-+       hscParseThing parseModule str+    case is of+        [L _ i] -> return i+        _ -> liftIO $ throwOneError $+                 mkPlainErrorMsgEnvelope noSrcSpan $+                 GhcPsMessage $ PsUnknownMessage $ mkPlainError noHints $+                     text "parse error in import declaration"++-- | Typecheck an expression (but don't run it)+hscTcExpr :: HscEnv+          -> TcRnExprMode+          -> String -- ^ The expression+          -> IO Type+hscTcExpr hsc_env0 mode expr = runInteractiveHsc hsc_env0 $ do+  hsc_env <- getHscEnv+  parsed_expr <- hscParseExpr expr+  ioMsgMaybe $ hoistTcRnMessage $ tcRnExpr hsc_env mode parsed_expr++-- | Find the kind of a type, after generalisation+hscKcType+  :: HscEnv+  -> Bool            -- ^ Normalise the type+  -> String          -- ^ The type as a string+  -> IO (Type, Kind) -- ^ Resulting type (possibly normalised) and kind+hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do+    hsc_env <- getHscEnv+    ty <- hscParseType str+    ioMsgMaybe $ hoistTcRnMessage $ tcRnType hsc_env DefaultFlexi normalise ty++hscParseExpr :: String -> Hsc (LHsExpr GhcPs)+hscParseExpr expr = do+  maybe_stmt <- hscParseStmt expr+  case maybe_stmt of+    Just (L _ (BodyStmt _ expr _ _)) -> return expr+    _ -> throwOneError $+           mkPlainErrorMsgEnvelope noSrcSpan $+           GhcPsMessage $ PsUnknownMessage $ mkPlainError noHints $+             text "not an expression:" <+> quotes (text expr)++hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs))+hscParseStmt = hscParseThing parseStmt++hscParseStmtWithLocation :: String -> Int -> String+                         -> Hsc (Maybe (GhciLStmt GhcPs))+hscParseStmtWithLocation source linenumber stmt =+    hscParseThingWithLocation source linenumber parseStmt stmt++hscParseType :: String -> Hsc (LHsType GhcPs)+hscParseType = hscParseThing parseType++hscParseIdentifier :: HscEnv -> String -> IO (LocatedN RdrName)+hscParseIdentifier hsc_env str =+    runInteractiveHsc hsc_env $ hscParseThing parseIdentifier str++hscParseThing :: (Outputable thing, Data thing)+              => Lexer.P thing -> String -> Hsc thing+hscParseThing = hscParseThingWithLocation "<interactive>" 1++hscParseThingWithLocation :: (Outputable thing, Data thing) => String -> Int+                          -> Lexer.P thing -> String -> Hsc thing+hscParseThingWithLocation source linenumber parser str = do+    dflags <- getDynFlags+    logger <- getLogger+    withTiming logger+               (text "Parser [source]")+               (const ()) $ {-# SCC "Parser" #-} do++        let buf = stringToStringBuffer str+            loc = mkRealSrcLoc (fsLit source) linenumber 1++        case unP parser (initParserState (initParserOpts dflags) buf loc) of+            PFailed pst ->+                handleWarningsThrowErrors (getPsMessages pst)+            POk pst thing -> do+                logWarningsReportErrors (getPsMessages pst)+                liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed "Parser"+                            FormatHaskell (ppr thing)+                liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed_ast "Parser AST"+                            FormatHaskell (showAstData NoBlankSrcSpan NoBlankEpAnnotations thing)+                return thing++hscTidy :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)+hscTidy hsc_env guts = do+  let logger   = hsc_logger hsc_env+  let this_mod = mg_module guts++  opts <- initTidyOpts hsc_env+  (cgguts, details) <- withTiming logger+    (text "CoreTidy"<+>brackets (ppr this_mod))+    (const ())+    $! {-# SCC "CoreTidy" #-} tidyProgram opts guts++  -- post tidy pretty-printing and linting...+  let tidy_rules     = md_rules details+  let all_tidy_binds = cg_binds cgguts+  let print_unqual   = mkPrintUnqualified (hsc_unit_env hsc_env) (mg_rdr_env guts)++  endPassIO hsc_env print_unqual CoreTidy all_tidy_binds tidy_rules++  -- If the endPass didn't print the rules, but ddump-rules is+  -- on, print now+  unless (logHasDumpFlag logger Opt_D_dump_simpl) $+    putDumpFileMaybe logger Opt_D_dump_rules+      (renderWithContext defaultSDocContext (ppr CoreTidy <+> text "rules"))+      FormatText+      (pprRulesForUser tidy_rules)++  -- Print one-line size info+  let cs = coreBindsStats all_tidy_binds+  putDumpFileMaybe logger Opt_D_dump_core_stats "Core Stats"+    FormatText+    (text "Tidy size (terms,types,coercions)"+     <+> ppr (moduleName this_mod) <> colon+     <+> int (cs_tm cs)+     <+> int (cs_ty cs)+     <+> int (cs_co cs))++  pure (cgguts, details)+++{- **********************************************************************+%*                                                                      *+        Desugar, simplify, convert to bytecode, and link an expression+%*                                                                      *+%********************************************************************* -}++hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [Linkable], PkgsLoaded)+hscCompileCoreExpr hsc_env loc expr =+  case hscCompileCoreExprHook (hsc_hooks hsc_env) of+      Nothing -> hscCompileCoreExpr' hsc_env loc expr+      Just h  -> h                   hsc_env loc expr++hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [Linkable], PkgsLoaded)+hscCompileCoreExpr' hsc_env srcspan ds_expr+    = do { {- Simplify it -}+           -- Question: should we call SimpleOpt.simpleOptExpr here instead?+           -- It is, well, simpler, and does less inlining etc.+           simpl_expr <- simplifyExpr hsc_env ds_expr++           {- Tidy it (temporary, until coreSat does cloning) -}+         ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr++           {- Prepare for codegen -}+         ; prepd_expr <- corePrepExpr hsc_env tidy_expr++           {- Lint if necessary -}+         ; lintInteractiveExpr (text "hscCompileExpr") hsc_env prepd_expr+         ; let iNTERACTIVELoc = ModLocation{ ml_hs_file   = Nothing,+                                      ml_hi_file   = panic "hscCompileCoreExpr':ml_hi_file",+                                      ml_obj_file  = panic "hscCompileCoreExpr':ml_obj_file",+                                      ml_dyn_obj_file = panic "hscCompileCoreExpr': ml_obj_file",+                                      ml_dyn_hi_file  = panic "hscCompileCoreExpr': ml_dyn_hi_file",+                                      ml_hie_file  = panic "hscCompileCoreExpr':ml_hie_file" }++         ; let ictxt = hsc_IC hsc_env+         ; (binding_id, stg_expr, _, _) <-+             myCoreToStgExpr (hsc_logger hsc_env)+                             (hsc_dflags hsc_env)+                             ictxt+                             True+                             (icInteractiveModule ictxt)+                             iNTERACTIVELoc+                             prepd_expr++           {- Convert to BCOs -}+         ; bcos <- byteCodeGen hsc_env+                     (icInteractiveModule ictxt)+                     stg_expr+                     [] Nothing++           {- load it -}+         ; (fv_hvs, mods_needed, units_needed) <- loadDecls (hscInterp hsc_env) hsc_env srcspan bcos+           {- Get the HValue for the root -}+         ; return (expectJust "hscCompileCoreExpr'"+              $ lookup (idName binding_id) fv_hvs, mods_needed, units_needed) }+++{- **********************************************************************+%*                                                                      *+        Statistics on reading interfaces+%*                                                                      *+%********************************************************************* -}++dumpIfaceStats :: HscEnv -> IO ()+dumpIfaceStats hsc_env = do+  eps <- hscEPS hsc_env+  let+    logger = hsc_logger hsc_env+    dump_rn_stats = logHasDumpFlag logger Opt_D_dump_rn_stats+    dump_if_trace = logHasDumpFlag logger Opt_D_dump_if_trace+  when (dump_if_trace || dump_rn_stats) $+    logDumpMsg logger "Interface statistics" (ifaceStats eps)+++{- **********************************************************************+%*                                                                      *+        Progress Messages: Module i of n+%*                                                                      *+%********************************************************************* -}++showModuleIndex :: (Int, Int) -> SDoc+showModuleIndex (i,n) = text "[" <> pad <> int i <> text " of " <> int n <> text "] "+  where+    -- compute the length of x > 0 in base 10+    len x = ceiling (logBase 10 (fromIntegral x+1) :: Float)+    pad = text (replicate (len n - len i) ' ') -- TODO: use GHC.Utils.Ppr.RStr++writeInterfaceOnlyMode :: DynFlags -> Bool+writeInterfaceOnlyMode dflags =+ gopt Opt_WriteInterface dflags &&+ NoBackend == backend dflags
compiler/GHC/Driver/Make.hs view
@@ -1,2928 +1,2736 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}---- ----------------------------------------------------------------------------------- (c) The University of Glasgow, 2011------ This module implements multi-module compilation, and is used--- by --make and GHCi.------ ------------------------------------------------------------------------------module GHC.Driver.Make (-        depanal, depanalE, depanalPartial,-        load, load', LoadHowMuch(..),-        instantiationNodes,--        downsweep,--        topSortModuleGraph,--        ms_home_srcimps, ms_home_imps,--        summariseModule,-        hscSourceToIsBoot,-        findExtraSigImports,-        implicitRequirementsShallow,--        noModError, cyclicModuleErr,-        moduleGraphNodes, SummaryNode,-        IsBootInterface(..),--        ModNodeMap(..), emptyModNodeMap, modNodeMapElems, modNodeMapLookup, modNodeMapInsert-    ) where--#include "GhclibHsVersions.h"--import GHC.Prelude--import GHC.Tc.Utils.Backpack-import GHC.Tc.Utils.Monad  ( initIfaceCheck )--import GHC.Runtime.Interpreter-import qualified GHC.Linker.Loader as Linker-import GHC.Linker.Types--import GHC.Runtime.Context--import GHC.Driver.Config-import GHC.Driver.Phases-import GHC.Driver.Pipeline-import GHC.Driver.Session-import GHC.Driver.Backend-import GHC.Driver.Monad-import GHC.Driver.Env-import GHC.Driver.Errors-import GHC.Driver.Main--import GHC.Parser.Header-import GHC.Parser.Errors.Ppr--import GHC.Iface.Load      ( cannotFindModule )-import GHC.IfaceToCore     ( typecheckIface )-import GHC.Iface.Recomp    ( RecompileRequired ( MustCompile ) )--import GHC.Data.Bag        ( unitBag, listToBag, unionManyBags, isEmptyBag )-import GHC.Data.Graph.Directed-import GHC.Data.FastString-import GHC.Data.Maybe      ( expectJust )-import GHC.Data.StringBuffer-import qualified GHC.LanguageExtensions as LangExt--import GHC.Utils.Exception ( tryIO )-import GHC.Utils.Monad     ( allM )-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Utils.Misc-import GHC.Utils.Error-import GHC.Utils.Logger-import GHC.Utils.TmpFs--import GHC.Types.Basic-import GHC.Types.Target-import GHC.Types.SourceFile-import GHC.Types.SourceError-import GHC.Types.SrcLoc-import GHC.Types.Unique.DSet-import GHC.Types.Unique.Set-import GHC.Types.Name-import GHC.Types.Name.Env--import GHC.Unit-import GHC.Unit.State-import GHC.Unit.Finder-import GHC.Unit.Module.ModSummary-import GHC.Unit.Module.ModIface-import GHC.Unit.Module.Graph-import GHC.Unit.Home.ModInfo--import Data.Either ( rights, partitionEithers )-import qualified Data.Map as Map-import Data.Map (Map)-import qualified Data.Set as Set-import qualified GHC.Data.FiniteMap as Map ( insertListWith )--import Control.Concurrent ( forkIOWithUnmask, killThread )-import qualified GHC.Conc as CC-import Control.Concurrent.MVar-import Control.Concurrent.QSem-import Control.Exception-import Control.Monad-import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE )-import qualified Control.Monad.Catch as MC-import Data.IORef-import Data.List (nub, sortBy, partition)-import qualified Data.List as List-import Data.Foldable (toList)-import Data.Maybe-import Data.Ord ( comparing )-import Data.Time-import Data.Bifunctor (first)-import System.Directory-import System.FilePath-import System.IO        ( fixIO )-import System.IO.Error  ( isDoesNotExistError )--import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities )--label_self :: String -> IO ()-label_self thread_name = do-    self_tid <- CC.myThreadId-    CC.labelThread self_tid thread_name---- -------------------------------------------------------------------------------- Loading the program---- | Perform a dependency analysis starting from the current targets--- and update the session with the new module graph.------ Dependency analysis entails parsing the @import@ directives and may--- therefore require running certain preprocessors.------ Note that each 'ModSummary' in the module graph caches its 'DynFlags'.--- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the--- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module.  Thus if you want--- changes to the 'DynFlags' to take effect you need to call this function--- again.--- In case of errors, just throw them.----depanal :: GhcMonad m =>-           [ModuleName]  -- ^ excluded modules-        -> Bool          -- ^ allow duplicate roots-        -> m ModuleGraph-depanal excluded_mods allow_dup_roots = do-    (errs, mod_graph) <- depanalE excluded_mods allow_dup_roots-    if isEmptyBag errs-      then pure mod_graph-      else throwErrors errs---- | Perform dependency analysis like in 'depanal'.--- In case of errors, the errors and an empty module graph are returned.-depanalE :: GhcMonad m =>     -- New for #17459-            [ModuleName]      -- ^ excluded modules-            -> Bool           -- ^ allow duplicate roots-            -> m (ErrorMessages, ModuleGraph)-depanalE excluded_mods allow_dup_roots = do-    hsc_env <- getSession-    (errs, mod_graph) <- depanalPartial excluded_mods allow_dup_roots-    if isEmptyBag errs-      then do-        let unused_home_mod_err = warnMissingHomeModules hsc_env mod_graph-            unused_pkg_err = warnUnusedPackages hsc_env mod_graph-            warns = unused_home_mod_err ++ unused_pkg_err-        when (not $ null warns) $-          logWarnings (listToBag warns)-        setSession hsc_env { hsc_mod_graph = mod_graph }-        pure (errs, mod_graph)-      else do-        -- We don't have a complete module dependency graph,-        -- The graph may be disconnected and is unusable.-        setSession hsc_env { hsc_mod_graph = emptyMG }-        pure (errs, emptyMG)----- | Perform dependency analysis like 'depanal' but return a partial module--- graph even in the face of problems with some modules.------ Modules which have parse errors in the module header, failing--- preprocessors or other issues preventing them from being summarised will--- simply be absent from the returned module graph.------ Unlike 'depanal' this function will not update 'hsc_mod_graph' with the--- new module graph.-depanalPartial-    :: GhcMonad m-    => [ModuleName]  -- ^ excluded modules-    -> Bool          -- ^ allow duplicate roots-    -> m (ErrorMessages, ModuleGraph)-    -- ^ possibly empty 'Bag' of errors and a module graph.-depanalPartial excluded_mods allow_dup_roots = do-  hsc_env <- getSession-  let-         dflags  = hsc_dflags hsc_env-         targets = hsc_targets hsc_env-         old_graph = hsc_mod_graph hsc_env-         logger  = hsc_logger hsc_env--  withTiming logger dflags (text "Chasing dependencies") (const ()) $ do-    liftIO $ debugTraceMsg logger dflags 2 (hcat [-              text "Chasing modules from: ",-              hcat (punctuate comma (map pprTarget targets))])--    -- Home package modules may have been moved or deleted, and new-    -- source files may have appeared in the home package that shadow-    -- external package modules, so we have to discard the existing-    -- cached finder data.-    liftIO $ flushFinderCaches hsc_env--    mod_summariesE <- liftIO $ downsweep-      hsc_env (mgExtendedModSummaries old_graph)-      excluded_mods allow_dup_roots-    let-      (errs, mod_summaries) = partitionEithers mod_summariesE-      mod_graph = mkModuleGraph' $-        fmap ModuleNode mod_summaries ++ instantiationNodes (hsc_units hsc_env)-    return (unionManyBags errs, mod_graph)---- | Collect the instantiations of dependencies to create 'InstantiationNode' work graph nodes.--- These are used to represent the type checking that is done after--- all the free holes (sigs in current package) relevant to that instantiation--- are compiled. This is necessary to catch some instantiation errors.------ In the future, perhaps more of the work of instantiation could be moved here,--- instead of shoved in with the module compilation nodes. That could simplify--- backpack, and maybe hs-boot too.-instantiationNodes :: UnitState -> [ModuleGraphNode]-instantiationNodes unit_state = InstantiationNode <$> iuids_to_check-  where-    iuids_to_check :: [InstantiatedUnit]-    iuids_to_check =-      nubSort $ concatMap goUnitId (explicitUnits unit_state)-     where-      goUnitId uid =-        [ recur-        | VirtUnit indef <- [uid]-        , inst <- instUnitInsts indef-        , recur <- (indef :) $ goUnitId $ moduleUnit $ snd inst-        ]---- Note [Missing home modules]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- Sometimes user doesn't want GHC to pick up modules, not explicitly listed--- in a command line. For example, cabal may want to enable this warning--- when building a library, so that GHC warns user about modules, not listed--- neither in `exposed-modules`, nor in `other-modules`.------ Here "home module" means a module, that doesn't come from an other package.------ For example, if GHC is invoked with modules "A" and "B" as targets,--- but "A" imports some other module "C", then GHC will issue a warning--- about module "C" not being listed in a command line.------ The warning in enabled by `-Wmissing-home-modules`. See #13129-warnMissingHomeModules :: HscEnv -> ModuleGraph -> [MsgEnvelope DecoratedSDoc]-warnMissingHomeModules hsc_env mod_graph =-    if (wopt Opt_WarnMissingHomeModules dflags && not (null missing))-    then [warn]-    else []-  where-    dflags = hsc_dflags hsc_env-    targets = map targetId (hsc_targets hsc_env)--    is_known_module mod = any (is_my_target mod) targets--    -- We need to be careful to handle the case where (possibly-    -- path-qualified) filenames (aka 'TargetFile') rather than module-    -- names are being passed on the GHC command-line.-    ---    -- For instance, `ghc --make src-exe/Main.hs` and-    -- `ghc --make -isrc-exe Main` are supposed to be equivalent.-    -- Note also that we can't always infer the associated module name-    -- directly from the filename argument.  See #13727.-    is_my_target mod (TargetModule name)-      = moduleName (ms_mod mod) == name-    is_my_target mod (TargetFile target_file _)-      | Just mod_file <- ml_hs_file (ms_location mod)-      = target_file == mod_file ||--           --  Don't warn on B.hs-boot if B.hs is specified (#16551)-           addBootSuffix target_file == mod_file ||--           --  We can get a file target even if a module name was-           --  originally specified in a command line because it can-           --  be converted in guessTarget (by appending .hs/.lhs).-           --  So let's convert it back and compare with module name-           mkModuleName (fst $ splitExtension target_file)-            == moduleName (ms_mod mod)-    is_my_target _ _ = False--    missing = map (moduleName . ms_mod) $-      filter (not . is_known_module) (mgModSummaries mod_graph)--    msg-      | gopt Opt_BuildingCabalPackage dflags-      = hang-          (text "These modules are needed for compilation but not listed in your .cabal file's other-modules: ")-          4-          (sep (map ppr missing))-      | otherwise-      =-        hang-          (text "Modules are not listed in command line but needed for compilation: ")-          4-          (sep (map ppr missing))-    warn = makeIntoWarning-      (Reason Opt_WarnMissingHomeModules)-      (mkPlainMsgEnvelope noSrcSpan msg)---- | Describes which modules of the module graph need to be loaded.-data LoadHowMuch-   = LoadAllTargets-     -- ^ Load all targets and its dependencies.-   | LoadUpTo ModuleName-     -- ^ Load only the given module and its dependencies.-   | LoadDependenciesOf ModuleName-     -- ^ Load only the dependencies of the given module, but not the module-     -- itself.---- | Try to load the program.  See 'LoadHowMuch' for the different modes.------ This function implements the core of GHC's @--make@ mode.  It preprocesses,--- compiles and loads the specified modules, avoiding re-compilation wherever--- possible.  Depending on the backend (see 'DynFlags.backend' field) compiling--- and loading may result in files being created on disk.------ Calls the 'defaultWarnErrLogger' after each compiling each module, whether--- successful or not.------ If errors are encountered during dependency analysis, the module `depanalE`--- returns together with the errors an empty ModuleGraph.--- After processing this empty ModuleGraph, the errors of depanalE are thrown.--- All other errors are reported using the 'defaultWarnErrLogger'.----load :: GhcMonad m => LoadHowMuch -> m SuccessFlag-load how_much = do-    (errs, mod_graph) <- depanalE [] False                        -- #17459-    success <- load' how_much (Just batchMsg) mod_graph-    if isEmptyBag errs-      then pure success-      else throwErrors errs---- Note [Unused packages]------ Cabal passes `--package-id` flag for each direct dependency. But GHC--- loads them lazily, so when compilation is done, we have a list of all--- actually loaded packages. All the packages, specified on command line,--- but never loaded, are probably unused dependencies.--warnUnusedPackages :: HscEnv -> ModuleGraph -> [MsgEnvelope DecoratedSDoc]-warnUnusedPackages hsc_env mod_graph =-    let dflags = hsc_dflags hsc_env-        state  = hsc_units hsc_env--    -- Only need non-source imports here because SOURCE imports are always HPT-        loadedPackages = concat $-          mapMaybe (\(fs, mn) -> lookupModulePackage state (unLoc mn) fs)-            $ concatMap ms_imps (mgModSummaries mod_graph)--        requestedArgs = mapMaybe packageArg (packageFlags dflags)--        unusedArgs-          = filter (\arg -> not $ any (matching state arg) loadedPackages)-                   requestedArgs--        warn = makeIntoWarning-          (Reason Opt_WarnUnusedPackages)-          (mkPlainMsgEnvelope noSrcSpan msg)-        msg = vcat [ text "The following packages were specified" <+>-                     text "via -package or -package-id flags,"-                   , text "but were not needed for compilation:"-                   , nest 2 (vcat (map (withDash . pprUnusedArg) unusedArgs)) ]--    in if not (null unusedArgs) && wopt Opt_WarnUnusedPackages dflags-       then [warn]-       else []--    where-        packageArg (ExposePackage _ arg _) = Just arg-        packageArg _ = Nothing--        pprUnusedArg (PackageArg str) = text str-        pprUnusedArg (UnitIdArg uid) = ppr uid--        withDash = (<+>) (text "-")--        matchingStr :: String -> UnitInfo -> Bool-        matchingStr str p-                =  str == unitPackageIdString p-                || str == unitPackageNameString p--        matching :: UnitState -> PackageArg -> UnitInfo -> Bool-        matching _ (PackageArg str) p = matchingStr str p-        matching state (UnitIdArg uid) p = uid == realUnit state p--        -- For wired-in packages, we have to unwire their id,-        -- otherwise they won't match package flags-        realUnit :: UnitState -> UnitInfo -> Unit-        realUnit state-          = unwireUnit state-          . RealUnit-          . Definite-          . unitId---- | Generalized version of 'load' which also supports a custom--- 'Messager' (for reporting progress) and 'ModuleGraph' (generally--- produced by calling 'depanal'.-load' :: GhcMonad m => LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag-load' how_much mHscMessage mod_graph = do-    modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph }-    guessOutputFile-    hsc_env <- getSession--    let hpt1   = hsc_HPT hsc_env-    let dflags = hsc_dflags hsc_env-    let logger = hsc_logger hsc_env-    let interp = hscInterp hsc_env--    -- The "bad" boot modules are the ones for which we have-    -- B.hs-boot in the module graph, but no B.hs-    -- The downsweep should have ensured this does not happen-    -- (see msDeps)-    let all_home_mods =-          mkUniqSet [ ms_mod_name s-                    | s <- mgModSummaries mod_graph, isBootSummary s == NotBoot]-    -- TODO: Figure out what the correct form of this assert is. It's violated-    -- when you have HsBootMerge nodes in the graph: then you'll have hs-boot-    -- files without corresponding hs files.-    --  bad_boot_mods = [s        | s <- mod_graph, isBootSummary s,-    --                              not (ms_mod_name s `elem` all_home_mods)]-    -- ASSERT( null bad_boot_mods ) return ()--    -- check that the module given in HowMuch actually exists, otherwise-    -- topSortModuleGraph will bomb later.-    let checkHowMuch (LoadUpTo m)           = checkMod m-        checkHowMuch (LoadDependenciesOf m) = checkMod m-        checkHowMuch _ = id--        checkMod m and_then-            | m `elementOfUniqSet` all_home_mods = and_then-            | otherwise = do-                    liftIO $ errorMsg logger dflags-                        (text "no such module:" <+> quotes (ppr m))-                    return Failed--    checkHowMuch how_much $ do--    -- mg2_with_srcimps drops the hi-boot nodes, returning a-    -- graph with cycles.  Among other things, it is used for-    -- backing out partially complete cycles following a failed-    -- upsweep, and for removing from hpt all the modules-    -- not in strict downwards closure, during calls to compile.-    let mg2_with_srcimps :: [SCC ModSummary]-        mg2_with_srcimps = filterToposortToModules $-          topSortModuleGraph True mod_graph Nothing--    -- If we can determine that any of the {-# SOURCE #-} imports-    -- are definitely unnecessary, then emit a warning.-    warnUnnecessarySourceImports mg2_with_srcimps--    let-        -- check the stability property for each module.-        stable_mods@(stable_obj,stable_bco)-            = checkStability hpt1 mg2_with_srcimps all_home_mods--        pruned_hpt = hpt1--    _ <- liftIO $ evaluate pruned_hpt--    -- before we unload anything, make sure we don't leave an old-    -- interactive context around pointing to dead bindings.  Also,-    -- write the pruned HPT to allow the old HPT to be GC'd.-    setSession $ discardIC $ hsc_env { hsc_HPT = pruned_hpt }--    liftIO $ debugTraceMsg logger dflags 2 (text "Stable obj:" <+> ppr stable_obj $$-                            text "Stable BCO:" <+> ppr stable_bco)--    -- Unload any modules which are going to be re-linked this time around.-    let stable_linkables = [ linkable-                           | m <- nonDetEltsUniqSet stable_obj ++-                                  nonDetEltsUniqSet stable_bco,-                             -- It's OK to use nonDetEltsUniqSet here-                             -- because it only affects linking. Besides-                             -- this list only serves as a poor man's set.-                             Just hmi <- [lookupHpt pruned_hpt m],-                             Just linkable <- [hm_linkable hmi] ]-    liftIO $ unload interp hsc_env stable_linkables--    -- We could at this point detect cycles which aren't broken by-    -- a source-import, and complain immediately, but it seems better-    -- to let upsweep_mods do this, so at least some useful work gets-    -- done before the upsweep is abandoned.-    --hPutStrLn stderr "after tsort:\n"-    --hPutStrLn stderr (showSDoc (vcat (map ppr mg2)))--    -- Now do the upsweep, calling compile for each module in-    -- turn.  Final result is version 3 of everything.--    -- Topologically sort the module graph, this time including hi-boot-    -- nodes, and possibly just including the portion of the graph-    -- reachable from the module specified in the 2nd argument to load.-    -- This graph should be cycle-free.-    -- If we're restricting the upsweep to a portion of the graph, we-    -- also want to retain everything that is still stable.-    let full_mg, partial_mg0, partial_mg, unstable_mg :: [SCC ModuleGraphNode]-        stable_mg :: [SCC ExtendedModSummary]-        full_mg    = topSortModuleGraph False mod_graph Nothing--        maybe_top_mod = case how_much of-                            LoadUpTo m           -> Just m-                            LoadDependenciesOf m -> Just m-                            _                    -> Nothing--        partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod--        -- LoadDependenciesOf m: we want the upsweep to stop just-        -- short of the specified module (unless the specified module-        -- is stable).-        partial_mg-            | LoadDependenciesOf _mod <- how_much-            = ASSERT( case last partial_mg0 of-                        AcyclicSCC (ModuleNode (ExtendedModSummary ms _)) -> ms_mod_name ms == _mod; _ -> False )-              List.init partial_mg0-            | otherwise-            = partial_mg0--        stable_mg =-            [ AcyclicSCC ems-            | AcyclicSCC (ModuleNode ems@(ExtendedModSummary ms _)) <- full_mg-            , stable_mod_summary ms-            ]--        stable_mod_summary ms =-          ms_mod_name ms `elementOfUniqSet` stable_obj ||-          ms_mod_name ms `elementOfUniqSet` stable_bco--        -- the modules from partial_mg that are not also stable-        -- NB. also keep cycles, we need to emit an error message later-        unstable_mg = filter not_stable partial_mg-          where not_stable (CyclicSCC _) = True-                not_stable (AcyclicSCC (InstantiationNode _)) = True-                not_stable (AcyclicSCC (ModuleNode (ExtendedModSummary ms _)))-                   = not $ stable_mod_summary ms--        -- Load all the stable modules first, before attempting to load-        -- an unstable module (#7231).-        mg = fmap (fmap ModuleNode) stable_mg ++ unstable_mg--    liftIO $ debugTraceMsg logger dflags 2 (hang (text "Ready for upsweep")-                               2 (ppr mg))--    n_jobs <- case parMakeCount dflags of-                    Nothing -> liftIO getNumProcessors-                    Just n  -> return n-    let upsweep_fn | n_jobs > 1 = parUpsweep n_jobs-                   | otherwise  = upsweep--    setSession hsc_env{ hsc_HPT = emptyHomePackageTable }-    (upsweep_ok, modsUpswept) <- withDeferredDiagnostics $-      upsweep_fn mHscMessage pruned_hpt stable_mods mg--    -- Make modsDone be the summaries for each home module now-    -- available; this should equal the domain of hpt3.-    -- Get in in a roughly top .. bottom order (hence reverse).--    let nodesDone = reverse modsUpswept-        (_, modsDone) = partitionNodes nodesDone--    -- Try and do linking in some form, depending on whether the-    -- upsweep was completely or only partially successful.--    if succeeded upsweep_ok--     then-       -- Easy; just relink it all.-       do liftIO $ debugTraceMsg logger dflags 2 (text "Upsweep completely successful.")--          -- Clean up after ourselves-          hsc_env1 <- getSession-          liftIO $ cleanCurrentModuleTempFiles logger (hsc_tmpfs hsc_env1) dflags--          -- Issue a warning for the confusing case where the user-          -- said '-o foo' but we're not going to do any linking.-          -- We attempt linking if either (a) one of the modules is-          -- called Main, or (b) the user said -no-hs-main, indicating-          -- that main() is going to come from somewhere else.-          ---          let ofile = outputFile dflags-          let no_hs_main = gopt Opt_NoHsMain dflags-          let-            main_mod = mainModIs hsc_env-            a_root_is_Main = mgElemModule mod_graph main_mod-            do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib--          -- link everything together-          hsc_env <- getSession-          linkresult <- liftIO $ link (ghcLink dflags)-                                      logger-                                      (hsc_tmpfs hsc_env)-                                      (hsc_hooks hsc_env)-                                      dflags-                                      (hsc_unit_env hsc_env)-                                      do_linking-                                      (hsc_HPT hsc_env1)--          if ghcLink dflags == LinkBinary && isJust ofile && not do_linking-             then do-                liftIO $ errorMsg logger dflags $ text-                   ("output was redirected with -o, " ++-                    "but no output will be generated\n" ++-                    "because there is no " ++-                    moduleNameString (moduleName main_mod) ++ " module.")-                -- This should be an error, not a warning (#10895).-                loadFinish Failed linkresult-             else-                loadFinish Succeeded linkresult--     else-       -- Tricky.  We need to back out the effects of compiling any-       -- half-done cycles, both so as to clean up the top level envs-       -- and to avoid telling the interactive linker to link them.-       do liftIO $ debugTraceMsg logger dflags 2 (text "Upsweep partially successful.")--          let modsDone_names-                 = map (ms_mod . emsModSummary) modsDone-          let mods_to_zap_names-                 = findPartiallyCompletedCycles modsDone_names-                      mg2_with_srcimps-          let (mods_to_clean, mods_to_keep) =-                partition ((`Set.member` mods_to_zap_names).ms_mod) $-                emsModSummary <$> modsDone-          hsc_env1 <- getSession-          let hpt4 = hsc_HPT hsc_env1-              -- We must change the lifetime to TFL_CurrentModule for any temp-              -- file created for an element of mod_to_clean during the upsweep.-              -- These include preprocessed files and object files for loaded-              -- modules.-              unneeded_temps = concat-                [ms_hspp_file : object_files-                | ModSummary{ms_mod, ms_hspp_file} <- mods_to_clean-                , let object_files = maybe [] linkableObjs $-                        lookupHpt hpt4 (moduleName ms_mod)-                        >>= hm_linkable-                ]-          tmpfs <- hsc_tmpfs <$> getSession-          liftIO $ changeTempFilesLifetime tmpfs TFL_CurrentModule unneeded_temps-          liftIO $ cleanCurrentModuleTempFiles logger tmpfs dflags--          let hpt5 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep)-                                          hpt4--          -- Clean up after ourselves--          -- there should be no Nothings where linkables should be, now-          let just_linkables =-                    isNoLink (ghcLink dflags)-                 || allHpt (isJust.hm_linkable)-                        (filterHpt ((== HsSrcFile).mi_hsc_src.hm_iface)-                                hpt5)-          ASSERT( just_linkables ) do--          -- Link everything together-          hsc_env <- getSession-          linkresult <- liftIO $ link (ghcLink dflags)-                                      logger-                                      (hsc_tmpfs hsc_env)-                                      (hsc_hooks hsc_env)-                                      dflags-                                      (hsc_unit_env hsc_env)-                                      False-                                      hpt5--          modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt5 }-          loadFinish Failed linkresult--partitionNodes-  :: [ModuleGraphNode]-  -> ( [InstantiatedUnit]-     , [ExtendedModSummary]-     )-partitionNodes ns = partitionEithers $ flip fmap ns $ \case-  InstantiationNode x -> Left x-  ModuleNode x -> Right x---- | Finish up after a load.-loadFinish :: GhcMonad m => SuccessFlag -> SuccessFlag -> m SuccessFlag---- If the link failed, unload everything and return.-loadFinish _all_ok Failed-  = do hsc_env <- getSession-       let interp = hscInterp hsc_env-       liftIO $ unload interp hsc_env []-       modifySession discardProg-       return Failed---- Empty the interactive context and set the module context to the topmost--- newly loaded module, or the Prelude if none were loaded.-loadFinish all_ok Succeeded-  = do modifySession discardIC-       return all_ok----- | Forget the current program, but retain the persistent info in HscEnv-discardProg :: HscEnv -> HscEnv-discardProg hsc_env-  = discardIC $ hsc_env { hsc_mod_graph = emptyMG-                        , hsc_HPT = emptyHomePackageTable }---- | Discard the contents of the InteractiveContext, but keep the DynFlags and--- the loaded plugins.  It will also keep ic_int_print and ic_monad if their--- names are from external packages.-discardIC :: HscEnv -> HscEnv-discardIC hsc_env-  = hsc_env { hsc_IC = empty_ic { ic_int_print = new_ic_int_print-                                , ic_monad     = new_ic_monad-                                , ic_plugins   = old_plugins-                                } }-  where-  -- Force the new values for ic_int_print and ic_monad to avoid leaking old_ic-  !new_ic_int_print = keep_external_name ic_int_print-  !new_ic_monad = keep_external_name ic_monad-  !old_plugins = ic_plugins old_ic-  dflags = ic_dflags old_ic-  old_ic = hsc_IC hsc_env-  empty_ic = emptyInteractiveContext dflags-  keep_external_name ic_name-    | nameIsFromExternalPackage home_unit old_name = old_name-    | otherwise = ic_name empty_ic-    where-    home_unit = hsc_home_unit hsc_env-    old_name = ic_name old_ic---- | If there is no -o option, guess the name of target executable--- by using top-level source file name as a base.-guessOutputFile :: GhcMonad m => m ()-guessOutputFile = modifySession $ \env ->-    let dflags = hsc_dflags env-        -- Force mod_graph to avoid leaking env-        !mod_graph = hsc_mod_graph env-        mainModuleSrcPath :: Maybe String-        mainModuleSrcPath = do-            ms <- mgLookupModule mod_graph (mainModIs env)-            ml_hs_file (ms_location ms)-        name = fmap dropExtension mainModuleSrcPath--        name_exe = do-#if defined(mingw32_HOST_OS)-          -- we must add the .exe extension unconditionally here, otherwise-          -- when name has an extension of its own, the .exe extension will-          -- not be added by GHC.Driver.Pipeline.exeFileName.  See #2248-          name' <- fmap (<.> "exe") name-#else-          name' <- name-#endif-          mainModuleSrcPath' <- mainModuleSrcPath-          -- #9930: don't clobber input files (unless they ask for it)-          if name' == mainModuleSrcPath'-            then throwGhcException . UsageError $-                 "default output name would overwrite the input file; " ++-                 "must specify -o explicitly"-            else Just name'-    in-    case outputFile_ dflags of-        Just _ -> env-        Nothing -> env { hsc_dflags = dflags { outputFile_ = name_exe } }---- ----------------------------------------------------------------------------------- | Return (names of) all those in modsDone who are part of a cycle as defined--- by theGraph.-findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> Set.Set Module-findPartiallyCompletedCycles modsDone theGraph-   = Set.unions-       [mods_in_this_cycle-       | CyclicSCC vs <- theGraph  -- Acyclic? Not interesting.-       , let names_in_this_cycle = Set.fromList (map ms_mod vs)-             mods_in_this_cycle =-                    Set.intersection (Set.fromList modsDone) names_in_this_cycle-         -- If size mods_in_this_cycle == size names_in_this_cycle,-         -- then this cycle has already been completed and we're not-         -- interested.-       , Set.size mods_in_this_cycle < Set.size names_in_this_cycle]----- --------------------------------------------------------------------------------- | Unloading-unload :: Interp -> HscEnv -> [Linkable] -> IO ()-unload interp hsc_env stable_linkables -- Unload everything *except* 'stable_linkables'-  = case ghcLink (hsc_dflags hsc_env) of-        LinkInMemory -> Linker.unload interp hsc_env stable_linkables-        _other -> return ()---- ------------------------------------------------------------------------------{- |--  Stability tells us which modules definitely do not need to be recompiled.-  There are two main reasons for having stability:--   - avoid doing a complete upsweep of the module graph in GHCi when-     modules near the bottom of the tree have not changed.--   - to tell GHCi when it can load object code: we can only load object code-     for a module when we also load object code fo  all of the imports of the-     module.  So we need to know that we will definitely not be recompiling-     any of these modules, and we can use the object code.--  The stability check is as follows.  Both stableObject and-  stableBCO are used during the upsweep phase later.--@-  stable m = stableObject m || stableBCO m--  stableObject m =-        all stableObject (imports m)-        && old linkable does not exist, or is == on-disk .o-        && date(on-disk .o) > date(.hs)--  stableBCO m =-        all stable (imports m)-        && date(BCO) > date(.hs)-@--  These properties embody the following ideas:--    - if a module is stable, then:--        - if it has been compiled in a previous pass (present in HPT)-          then it does not need to be compiled or re-linked.--        - if it has not been compiled in a previous pass,-          then we only need to read its .hi file from disk and-          link it to produce a 'ModDetails'.--    - if a modules is not stable, we will definitely be at least-      re-linking, and possibly re-compiling it during the 'upsweep'.-      All non-stable modules can (and should) therefore be unlinked-      before the 'upsweep'.--    - Note that objects are only considered stable if they only depend-      on other objects.  We can't link object code against byte code.--    - Note that even if an object is stable, we may end up recompiling-      if the interface is out of date because an *external* interface-      has changed.  The current code in GHC.Driver.Make handles this case-      fairly poorly, so be careful.--}--type StableModules =-  ( UniqSet ModuleName  -- stableObject-  , UniqSet ModuleName  -- stableBCO-  )---checkStability-        :: HomePackageTable   -- HPT from last compilation-        -> [SCC ModSummary]   -- current module graph (cyclic)-        -> UniqSet ModuleName -- all home modules-        -> StableModules--checkStability hpt sccs all_home_mods =-  foldl' checkSCC (emptyUniqSet, emptyUniqSet) sccs-  where-   checkSCC :: StableModules -> SCC ModSummary -> StableModules-   checkSCC (stable_obj, stable_bco) scc0-     | stableObjects = (addListToUniqSet stable_obj scc_mods, stable_bco)-     | stableBCOs    = (stable_obj, addListToUniqSet stable_bco scc_mods)-     | otherwise     = (stable_obj, stable_bco)-     where-        scc = flattenSCC scc0-        scc_mods = map ms_mod_name scc-        home_module m =-          m `elementOfUniqSet` all_home_mods && m `notElem` scc_mods--        scc_allimps = nub (filter home_module (concatMap ms_home_allimps scc))-            -- all imports outside the current SCC, but in the home pkg--        stable_obj_imps = map (`elementOfUniqSet` stable_obj) scc_allimps-        stable_bco_imps = map (`elementOfUniqSet` stable_bco) scc_allimps--        stableObjects =-           and stable_obj_imps-           && all object_ok scc--        stableBCOs =-           and (zipWith (||) stable_obj_imps stable_bco_imps)-           && all bco_ok scc--        object_ok ms-          | gopt Opt_ForceRecomp (ms_hspp_opts ms) = False-          | Just t <- ms_obj_date ms  =  t >= ms_hs_date ms-                                         && same_as_prev t-          | otherwise = False-          where-             same_as_prev t = case lookupHpt hpt (ms_mod_name ms) of-                                Just hmi  | Just l <- hm_linkable hmi-                                 -> isObjectLinkable l && t == linkableTime l-                                _other  -> True-                -- why '>=' rather than '>' above?  If the filesystem stores-                -- times to the nearest second, we may occasionally find that-                -- the object & source have the same modification time,-                -- especially if the source was automatically generated-                -- and compiled.  Using >= is slightly unsafe, but it matches-                -- make's behaviour.-                ---                -- But see #5527, where someone ran into this and it caused-                -- a problem.--        bco_ok ms-          | gopt Opt_ForceRecomp (ms_hspp_opts ms) = False-          | otherwise = case lookupHpt hpt (ms_mod_name ms) of-                Just hmi  | Just l <- hm_linkable hmi ->-                        not (isObjectLinkable l) &&-                        linkableTime l >= ms_hs_date ms-                _other  -> False--{- Parallel Upsweep- -- - The parallel upsweep attempts to concurrently compile the modules in the- - compilation graph using multiple Haskell threads.- -- - The Algorithm- -- - A Haskell thread is spawned for each module in the module graph, waiting for- - its direct dependencies to finish building before it itself begins to build.- -- - Each module is associated with an initially empty MVar that stores the- - result of that particular module's compile. If the compile succeeded, then- - the HscEnv (synchronized by an MVar) is updated with the fresh HMI of that- - module, and the module's HMI is deleted from the old HPT (synchronized by an- - IORef) to save space.- -- - Instead of immediately outputting messages to the standard handles, all- - compilation output is deferred to a per-module TQueue. A QSem is used to- - limit the number of workers that are compiling simultaneously.- -- - Meanwhile, the main thread sequentially loops over all the modules in the- - module graph, outputting the messages stored in each module's TQueue.--}---- | Each module is given a unique 'LogQueue' to redirect compilation messages--- to. A 'Nothing' value contains the result of compilation, and denotes the--- end of the message queue.-data LogQueue = LogQueue !(IORef [Maybe (WarnReason, Severity, SrcSpan, SDoc)])-                         !(MVar ())---- | The graph of modules to compile and their corresponding result 'MVar' and--- 'LogQueue'.-type CompilationGraph = [(ModuleGraphNode, MVar SuccessFlag, LogQueue)]---- | Build a 'CompilationGraph' out of a list of strongly-connected modules,--- also returning the first, if any, encountered module cycle.-buildCompGraph :: [SCC ModuleGraphNode] -> IO (CompilationGraph, Maybe [ModuleGraphNode])-buildCompGraph [] = return ([], Nothing)-buildCompGraph (scc:sccs) = case scc of-    AcyclicSCC ms -> do-        mvar <- newEmptyMVar-        log_queue <- do-            ref <- newIORef []-            sem <- newEmptyMVar-            return (LogQueue ref sem)-        (rest,cycle) <- buildCompGraph sccs-        return ((ms,mvar,log_queue):rest, cycle)-    CyclicSCC mss -> return ([], Just mss)---- | A Module and whether it is a boot module.------ We need to treat boot modules specially when building compilation graphs,--- since they break cycles. Regular source files and signature files are treated--- equivalently.-data BuildModule = BuildModule_Unit {-# UNPACK #-} !InstantiatedUnit | BuildModule_Module {-# UNPACK #-} !ModuleWithIsBoot-  deriving (Eq, Ord)---- | Tests if an 'HscSource' is a boot file, primarily for constructing elements--- of 'BuildModule'. We conflate signatures and modules because they are bound--- in the same namespace; only boot interfaces can be disambiguated with--- `import {-# SOURCE #-}`.-hscSourceToIsBoot :: HscSource -> IsBootInterface-hscSourceToIsBoot HsBootFile = IsBoot-hscSourceToIsBoot _ = NotBoot--mkBuildModule :: ModuleGraphNode -> BuildModule-mkBuildModule = \case-  InstantiationNode x -> BuildModule_Unit x-  ModuleNode ems -> BuildModule_Module $ mkBuildModule0 (emsModSummary ems)--mkHomeBuildModule :: ModuleGraphNode -> NodeKey-mkHomeBuildModule = \case-  InstantiationNode x -> NodeKey_Unit x-  ModuleNode ems -> NodeKey_Module $ mkHomeBuildModule0 (emsModSummary ems)--mkBuildModule0 :: ModSummary -> ModuleWithIsBoot-mkBuildModule0 ms = GWIB-  { gwib_mod = ms_mod ms-  , gwib_isBoot = isBootSummary ms-  }--mkHomeBuildModule0 :: ModSummary -> ModuleNameWithIsBoot-mkHomeBuildModule0 ms = GWIB-  { gwib_mod = moduleName $ ms_mod ms-  , gwib_isBoot = isBootSummary ms-  }---- | The entry point to the parallel upsweep.------ See also the simpler, sequential 'upsweep'.-parUpsweep-    :: GhcMonad m-    => Int-    -- ^ The number of workers we wish to run in parallel-    -> Maybe Messager-    -> HomePackageTable-    -> StableModules-    -> [SCC ModuleGraphNode]-    -> m (SuccessFlag,-          [ModuleGraphNode])-parUpsweep n_jobs mHscMessage old_hpt stable_mods sccs = do-    hsc_env <- getSession-    let dflags = hsc_dflags hsc_env-    let logger = hsc_logger hsc_env-    let tmpfs  = hsc_tmpfs hsc_env--    -- The bits of shared state we'll be using:--    -- The global HscEnv is updated with the module's HMI when a module-    -- successfully compiles.-    hsc_env_var <- liftIO $ newMVar hsc_env--    -- The old HPT is used for recompilation checking in upsweep_mod. When a-    -- module successfully gets compiled, its HMI is pruned from the old HPT.-    old_hpt_var <- liftIO $ newIORef old_hpt--    -- What we use to limit parallelism with.-    par_sem <- liftIO $ newQSem n_jobs---    let updNumCapabilities = liftIO $ do-            n_capabilities <- getNumCapabilities-            n_cpus <- getNumProcessors-            -- Setting number of capabilities more than-            -- CPU count usually leads to high userspace-            -- lock contention. #9221-            let n_caps = min n_jobs n_cpus-            unless (n_capabilities /= 1) $ setNumCapabilities n_caps-            return n_capabilities-    -- Reset the number of capabilities once the upsweep ends.-    let resetNumCapabilities orig_n = liftIO $ setNumCapabilities orig_n--    MC.bracket updNumCapabilities resetNumCapabilities $ \_ -> do--    -- Sync the global session with the latest HscEnv once the upsweep ends.-    let finallySyncSession io = io `MC.finally` do-            hsc_env <- liftIO $ readMVar hsc_env_var-            setSession hsc_env--    finallySyncSession $ do--    -- Build the compilation graph out of the list of SCCs. Module cycles are-    -- handled at the very end, after some useful work gets done. Note that-    -- this list is topologically sorted (by virtue of 'sccs' being sorted so).-    (comp_graph,cycle) <- liftIO $ buildCompGraph sccs-    let comp_graph_w_idx = zip comp_graph [1..]--    -- The list of all loops in the compilation graph.-    -- NB: For convenience, the last module of each loop (aka the module that-    -- finishes the loop) is prepended to the beginning of the loop.-    let graph = map fstOf3 (reverse comp_graph)-        boot_modules = mkModuleSet-          [ms_mod ms | ModuleNode (ExtendedModSummary ms _) <- graph, isBootSummary ms == IsBoot]-        comp_graph_loops = go graph boot_modules-          where-            remove ms bm = case isBootSummary ms of-              IsBoot -> delModuleSet bm (ms_mod ms)-              NotBoot -> bm-            go [] _ = []-            go (InstantiationNode _ : mss) boot_modules-              = go mss boot_modules-            go mg@(mnode@(ModuleNode (ExtendedModSummary ms _)) : mss) boot_modules-              | Just loop <- getModLoop ms mg (`elemModuleSet` boot_modules)-              = map mkBuildModule (mnode : loop) : go mss (remove ms boot_modules)-              | otherwise-              = go mss (remove ms boot_modules)--    -- Build a Map out of the compilation graph with which we can efficiently-    -- look up the result MVar associated with a particular home module.-    let home_mod_map :: Map BuildModule (MVar SuccessFlag, Int)-        home_mod_map =-            Map.fromList [ (mkBuildModule ms, (mvar, idx))-                         | ((ms,mvar,_),idx) <- comp_graph_w_idx ]---    liftIO $ label_self "main --make thread"--    -- Make the logger thread_safe: we only make the "log" action thread-safe in-    -- each worker by setting a LogAction hook, so we need to make the logger-    -- thread-safe for other actions (DumpAction, TraceAction).-    thread_safe_logger <- liftIO $ makeThreadSafe logger--    -- For each module in the module graph, spawn a worker thread that will-    -- compile this module.-    let { spawnWorkers = forM comp_graph_w_idx $ \((mod,!mvar,!log_queue),!mod_idx) ->-            forkIOWithUnmask $ \unmask -> do-                liftIO $ label_self $ unwords $ concat-                    [ [ "worker --make thread" ]-                    , case mod of-                        InstantiationNode iuid ->-                          [ "for instantiation of unit"-                          , show $ VirtUnit iuid-                          ]-                        ModuleNode ems ->-                          [ "for module"-                          , show (moduleNameString (ms_mod_name (emsModSummary ems)))-                          ]-                    , ["number"-                      , show mod_idx-                      ]-                    ]-                -- Replace the default log_action with one that writes each-                -- message to the module's log_queue. The main thread will-                -- deal with synchronously printing these messages.-                let lcl_logger = pushLogHook (const (parLogAction log_queue)) thread_safe_logger--                -- Use a local TmpFs so that we can clean up intermediate files-                -- in a timely fashion (as soon as compilation for that module-                -- is finished) without having to worry about accidentally-                -- deleting a simultaneous compile's important files.-                lcl_tmpfs <- forkTmpFsFrom tmpfs--                -- Unmask asynchronous exceptions and perform the thread-local-                -- work to compile the module (see parUpsweep_one).-                m_res <- MC.try $ unmask $ prettyPrintGhcErrors dflags $-                  case mod of-                    InstantiationNode iuid -> do-                      hsc_env <- readMVar hsc_env_var-                      liftIO $ upsweep_inst hsc_env mHscMessage mod_idx (length sccs) iuid-                      pure Succeeded-                    ModuleNode ems ->-                      parUpsweep_one (emsModSummary ems) home_mod_map comp_graph_loops-                                     lcl_logger lcl_tmpfs dflags (hsc_home_unit hsc_env)-                                     mHscMessage-                                     par_sem hsc_env_var old_hpt_var-                                     stable_mods mod_idx (length sccs)--                res <- case m_res of-                    Right flag -> return flag-                    Left exc -> do-                        -- Don't print ThreadKilled exceptions: they are used-                        -- to kill the worker thread in the event of a user-                        -- interrupt, and the user doesn't have to be informed-                        -- about that.-                        when (fromException exc /= Just ThreadKilled)-                             (errorMsg lcl_logger dflags (text (show exc)))-                        return Failed--                -- Populate the result MVar.-                putMVar mvar res--                -- Write the end marker to the message queue, telling the main-                -- thread that it can stop waiting for messages from this-                -- particular compile.-                writeLogQueue log_queue Nothing--                -- Add the remaining files that weren't cleaned up to the-                -- global TmpFs, for cleanup later.-                mergeTmpFsInto lcl_tmpfs tmpfs--        -- Kill all the workers, masking interrupts (since killThread is-        -- interruptible). XXX: This is not ideal.-        ; killWorkers = MC.uninterruptibleMask_ . mapM_ killThread }---    -- Spawn the workers, making sure to kill them later. Collect the results-    -- of each compile.-    results <- liftIO $ MC.bracket spawnWorkers killWorkers $ \_ ->-        -- Loop over each module in the compilation graph in order, printing-        -- each message from its log_queue.-        forM comp_graph $ \(mod,mvar,log_queue) -> do-            printLogs logger dflags log_queue-            result <- readMVar mvar-            if succeeded result then return (Just mod) else return Nothing---    -- Collect and return the ModSummaries of all the successful compiles.-    -- NB: Reverse this list to maintain output parity with the sequential upsweep.-    let ok_results = reverse (catMaybes results)--    -- Handle any cycle in the original compilation graph and return the result-    -- of the upsweep.-    case cycle of-        Just mss -> do-            liftIO $ fatalErrorMsg logger dflags (cyclicModuleErr mss)-            return (Failed,ok_results)-        Nothing  -> do-            let success_flag = successIf (all isJust results)-            return (success_flag,ok_results)--  where-    writeLogQueue :: LogQueue -> Maybe (WarnReason,Severity,SrcSpan,SDoc) -> IO ()-    writeLogQueue (LogQueue ref sem) msg = do-        atomicModifyIORef' ref $ \msgs -> (msg:msgs,())-        _ <- tryPutMVar sem ()-        return ()--    -- The log_action callback that is used to synchronize messages from a-    -- worker thread.-    parLogAction :: LogQueue -> LogAction-    parLogAction log_queue _dflags !reason !severity !srcSpan !msg =-        writeLogQueue log_queue (Just (reason,severity,srcSpan,msg))--    -- Print each message from the log_queue using the log_action from the-    -- session's DynFlags.-    printLogs :: Logger -> DynFlags -> LogQueue -> IO ()-    printLogs !logger !dflags (LogQueue ref sem) = read_msgs-      where read_msgs = do-                takeMVar sem-                msgs <- atomicModifyIORef' ref $ \xs -> ([], reverse xs)-                print_loop msgs--            print_loop [] = read_msgs-            print_loop (x:xs) = case x of-                Just (reason,severity,srcSpan,msg) -> do-                    putLogMsg logger dflags reason severity srcSpan msg-                    print_loop xs-                -- Exit the loop once we encounter the end marker.-                Nothing -> return ()---- The interruptible subset of the worker threads' work.-parUpsweep_one-    :: ModSummary-    -- ^ The module we wish to compile-    -> Map BuildModule (MVar SuccessFlag, Int)-    -- ^ The map of home modules and their result MVar-    -> [[BuildModule]]-    -- ^ The list of all module loops within the compilation graph.-    -> Logger-    -- ^ The thread-local Logger-    -> TmpFs-    -- ^ The thread-local TmpFs-    -> DynFlags-    -- ^ The thread-local DynFlags-    -> HomeUnit-    -- ^ The home-unit-    -> Maybe Messager-    -- ^ The messager-    -> QSem-    -- ^ The semaphore for limiting the number of simultaneous compiles-    -> MVar HscEnv-    -- ^ The MVar that synchronizes updates to the global HscEnv-    -> IORef HomePackageTable-    -- ^ The old HPT-    -> StableModules-    -- ^ Sets of stable objects and BCOs-    -> Int-    -- ^ The index of this module-    -> Int-    -- ^ The total number of modules-    -> IO SuccessFlag-    -- ^ The result of this compile-parUpsweep_one mod home_mod_map comp_graph_loops lcl_logger lcl_tmpfs lcl_dflags home_unit mHscMessage par_sem-               hsc_env_var old_hpt_var stable_mods mod_index num_mods = do--    let this_build_mod = mkBuildModule0 mod--    let home_imps     = map unLoc $ ms_home_imps mod-    let home_src_imps = map unLoc $ ms_home_srcimps mod--    -- All the textual imports of this module.-    let textual_deps = Set.fromList $-            zipWith f home_imps     (repeat NotBoot) ++-            zipWith f home_src_imps (repeat IsBoot)-          where f mn isBoot = BuildModule_Module $ GWIB-                  { gwib_mod = mkHomeModule home_unit mn-                  , gwib_isBoot = isBoot-                  }--    -- Dealing with module loops-    -- ~~~~~~~~~~~~~~~~~~~~~~~~~-    ---    -- Not only do we have to deal with explicit textual dependencies, we also-    -- have to deal with implicit dependencies introduced by import cycles that-    -- are broken by an hs-boot file. We have to ensure that:-    ---    -- 1. A module that breaks a loop must depend on all the modules in the-    --    loop (transitively or otherwise). This is normally always fulfilled-    --    by the module's textual dependencies except in degenerate loops,-    --    e.g.:-    ---    --    A.hs imports B.hs-boot-    --    B.hs doesn't import A.hs-    --    C.hs imports A.hs, B.hs-    ---    --    In this scenario, getModLoop will detect the module loop [A,B] but-    --    the loop finisher B doesn't depend on A. So we have to explicitly add-    --    A in as a dependency of B when we are compiling B.-    ---    -- 2. A module that depends on a module in an external loop can't proceed-    --    until the entire loop is re-typechecked.-    ---    -- These two invariants have to be maintained to correctly build a-    -- compilation graph with one or more loops.---    -- The loop that this module will finish. After this module successfully-    -- compiles, this loop is going to get re-typechecked.-    let finish_loop :: Maybe [ModuleWithIsBoot]-        finish_loop = listToMaybe-          [ flip mapMaybe (tail loop) $ \case-              BuildModule_Unit _ -> Nothing-              BuildModule_Module ms -> Just ms-          | loop <- comp_graph_loops-          , head loop == BuildModule_Module this_build_mod-          ]--    -- If this module finishes a loop then it must depend on all the other-    -- modules in that loop because the entire module loop is going to be-    -- re-typechecked once this module gets compiled. These extra dependencies-    -- are this module's "internal" loop dependencies, because this module is-    -- inside the loop in question.-    let int_loop_deps :: Set.Set BuildModule-        int_loop_deps = Set.fromList $-            case finish_loop of-                Nothing   -> []-                Just loop -> BuildModule_Module <$> filter (/= this_build_mod) loop--    -- If this module depends on a module within a loop then it must wait for-    -- that loop to get re-typechecked, i.e. it must wait on the module that-    -- finishes that loop. These extra dependencies are this module's-    -- "external" loop dependencies, because this module is outside of the-    -- loop(s) in question.-    let ext_loop_deps :: Set.Set BuildModule-        ext_loop_deps = Set.fromList-            [ head loop | loop <- comp_graph_loops-                        , any (`Set.member` textual_deps) loop-                        , BuildModule_Module this_build_mod `notElem` loop ]---    let all_deps = foldl1 Set.union [textual_deps, int_loop_deps, ext_loop_deps]--    -- All of the module's home-module dependencies.-    let home_deps_with_idx =-            [ home_dep | dep <- Set.toList all_deps-                       , Just home_dep <- [Map.lookup dep home_mod_map]-                       ]--    -- Sort the list of dependencies in reverse-topological order. This way, by-    -- the time we get woken up by the result of an earlier dependency,-    -- subsequent dependencies are more likely to have finished. This step-    -- effectively reduces the number of MVars that each thread blocks on.-    let home_deps = map fst $ sortBy (flip (comparing snd)) home_deps_with_idx--    -- Wait for the all the module's dependencies to finish building.-    deps_ok <- allM (fmap succeeded . readMVar) home_deps--    -- We can't build this module if any of its dependencies failed to build.-    if not deps_ok-      then return Failed-      else do-        -- Any hsc_env at this point is OK to use since we only really require-        -- that the HPT contains the HMIs of our dependencies.-        hsc_env <- readMVar hsc_env_var-        old_hpt <- readIORef old_hpt_var--        let logg err = printBagOfErrors lcl_logger lcl_dflags (srcErrorMessages err)--        -- Limit the number of parallel compiles.-        let withSem sem = MC.bracket_ (waitQSem sem) (signalQSem sem)-        mb_mod_info <- withSem par_sem $-            handleSourceError (\err -> do logg err; return Nothing) $ do-                -- Have the HscEnv point to our local logger and tmpfs.-                let lcl_hsc_env = localize_hsc_env hsc_env--                -- Re-typecheck the loop-                -- This is necessary to make sure the knot is tied when-                -- we close a recursive module loop, see bug #12035.-                type_env_var <- liftIO $ newIORef emptyNameEnv-                let lcl_hsc_env' = lcl_hsc_env { hsc_type_env_var =-                                    Just (ms_mod mod, type_env_var) }-                lcl_hsc_env'' <- case finish_loop of-                    Nothing   -> return lcl_hsc_env'-                    -- In the non-parallel case, the retypecheck prior to-                    -- typechecking the loop closer includes all modules-                    -- EXCEPT the loop closer.  However, our precomputed-                    -- SCCs include the loop closer, so we have to filter-                    -- it out.-                    Just loop -> typecheckLoop lcl_dflags lcl_hsc_env' $-                                 filter (/= moduleName (gwib_mod this_build_mod)) $-                                 map (moduleName . gwib_mod) loop--                -- Compile the module.-                mod_info <- upsweep_mod lcl_hsc_env'' mHscMessage old_hpt stable_mods-                                        mod mod_index num_mods-                return (Just mod_info)--        case mb_mod_info of-            Nothing -> return Failed-            Just mod_info -> do-                let this_mod = ms_mod_name mod--                -- Prune the old HPT unless this is an hs-boot module.-                unless (isBootSummary mod == IsBoot) $-                    atomicModifyIORef' old_hpt_var $ \old_hpt ->-                        (delFromHpt old_hpt this_mod, ())--                -- Update and fetch the global HscEnv.-                lcl_hsc_env' <- modifyMVar hsc_env_var $ \hsc_env -> do-                    let hsc_env' = hsc_env-                                     { hsc_HPT = addToHpt (hsc_HPT hsc_env)-                                                           this_mod mod_info }-                    -- We've finished typechecking the module, now we must-                    -- retypecheck the loop AGAIN to ensure unfoldings are-                    -- updated.  This time, however, we include the loop-                    -- closer!-                    hsc_env'' <- case finish_loop of-                        Nothing   -> return hsc_env'-                        Just loop -> typecheckLoop lcl_dflags hsc_env' $-                                     map (moduleName . gwib_mod) loop-                    return (hsc_env'', localize_hsc_env hsc_env'')--                -- Clean up any intermediate files.-                cleanCurrentModuleTempFiles (hsc_logger lcl_hsc_env')-                                            (hsc_tmpfs  lcl_hsc_env')-                                            (hsc_dflags lcl_hsc_env')-                return Succeeded--  where-    localize_hsc_env hsc_env-        = hsc_env { hsc_logger = lcl_logger-                  , hsc_tmpfs  = lcl_tmpfs-                  }---- ----------------------------------------------------------------------------------- | The upsweep------ This is where we compile each module in the module graph, in a pass--- from the bottom to the top of the graph.------ There better had not be any cyclic groups here -- we check for them.-upsweep-    :: forall m-    .  GhcMonad m-    => Maybe Messager-    -> HomePackageTable            -- ^ HPT from last time round (pruned)-    -> StableModules               -- ^ stable modules (see checkStability)-    -> [SCC ModuleGraphNode]       -- ^ Mods to do (the worklist)-    -> m (SuccessFlag,-          [ModuleGraphNode])-       -- ^ Returns:-       ---       --  1. A flag whether the complete upsweep was successful.-       --  2. The 'HscEnv' in the monad has an updated HPT-       --  3. A list of modules which succeeded loading.--upsweep mHscMessage old_hpt stable_mods sccs = do-   (res, done) <- upsweep' old_hpt emptyMG sccs 1 (length sccs)-   return (res, reverse $ mgModSummaries' done)- where-  keep_going-    :: [NodeKey]-    -> HomePackageTable-    -> ModuleGraph-    -> [SCC ModuleGraphNode]-    -> Int-    -> Int-    -> m (SuccessFlag, ModuleGraph)-  keep_going this_mods old_hpt done mods mod_index nmods = do-    let sum_deps ms (AcyclicSCC iuidOrMod) =-          if any (flip elem $ unfilteredEdges False iuidOrMod) $ ms-          then mkHomeBuildModule iuidOrMod : ms-          else ms-        sum_deps ms _ = ms-        dep_closure = foldl' sum_deps this_mods mods-        dropped_ms = drop (length this_mods) (reverse dep_closure)-        prunable (AcyclicSCC node) = elem (mkHomeBuildModule node) dep_closure-        prunable _ = False-        mods' = filter (not . prunable) mods-        nmods' = nmods - length dropped_ms--    when (not $ null dropped_ms) $ do-        dflags <- getSessionDynFlags-        logger <- getLogger-        liftIO $ fatalErrorMsg logger dflags (keepGoingPruneErr $ dropped_ms)-    (_, done') <- upsweep' old_hpt done mods' (mod_index+1) nmods'-    return (Failed, done')--  upsweep'-    :: HomePackageTable-    -> ModuleGraph-    -> [SCC ModuleGraphNode]-    -> Int-    -> Int-    -> m (SuccessFlag, ModuleGraph)-  upsweep' _old_hpt done-     [] _ _-     = return (Succeeded, done)--  upsweep' _old_hpt done-     (CyclicSCC ms : mods) mod_index nmods-   = do dflags <- getSessionDynFlags-        logger <- getLogger-        liftIO $ fatalErrorMsg logger dflags (cyclicModuleErr ms)-        if gopt Opt_KeepGoing dflags-          then keep_going (mkHomeBuildModule <$> ms) old_hpt done mods mod_index nmods-          else return (Failed, done)--  upsweep' old_hpt done-     (AcyclicSCC (InstantiationNode iuid) : mods) mod_index nmods-   = do hsc_env <- getSession-        liftIO $ upsweep_inst hsc_env mHscMessage mod_index nmods iuid-        upsweep' old_hpt done mods (mod_index+1) nmods--  upsweep' old_hpt done-     (AcyclicSCC (ModuleNode ems@(ExtendedModSummary mod _)) : mods) mod_index nmods-   = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++-        --           show (map (moduleUserString.moduleName.mi_module.hm_iface)-        --                     (moduleEnvElts (hsc_HPT hsc_env)))-        let logg _mod = defaultWarnErrLogger--        hsc_env <- getSession--        -- Remove unwanted tmp files between compilations-        liftIO $ cleanCurrentModuleTempFiles (hsc_logger hsc_env)-                                             (hsc_tmpfs  hsc_env)-                                             (hsc_dflags hsc_env)--        -- Get ready to tie the knot-        type_env_var <- liftIO $ newIORef emptyNameEnv-        let hsc_env1 = hsc_env { hsc_type_env_var =-                                    Just (ms_mod mod, type_env_var) }-        setSession hsc_env1--        -- Lazily reload the HPT modules participating in the loop.-        -- See Note [Tying the knot]--if we don't throw out the old HPT-        -- and reinitalize the knot-tying process, anything that was forced-        -- while we were previously typechecking won't get updated, this-        -- was bug #12035.-        hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done-        setSession hsc_env2--        mb_mod_info-            <- handleSourceError-                   (\err -> do logg mod (Just err); return Nothing) $ do-                 mod_info <- liftIO $ upsweep_mod hsc_env2 mHscMessage old_hpt stable_mods-                                                  mod mod_index nmods-                 logg mod Nothing -- log warnings-                 return (Just mod_info)--        case mb_mod_info of-          Nothing -> do-                dflags <- getSessionDynFlags-                if gopt Opt_KeepGoing dflags-                  then keep_going [NodeKey_Module $ mkHomeBuildModule0 mod] old_hpt done mods mod_index nmods-                  else return (Failed, done)-          Just mod_info -> do-                let this_mod = ms_mod_name mod--                        -- Add new info to hsc_env-                    hpt1     = addToHpt (hsc_HPT hsc_env2) this_mod mod_info-                    hsc_env3 = hsc_env2 { hsc_HPT = hpt1, hsc_type_env_var = Nothing }--                        -- Space-saving: delete the old HPT entry-                        -- for mod BUT if mod is a hs-boot-                        -- node, don't delete it.  For the-                        -- interface, the HPT entry is probably for the-                        -- main Haskell source file.  Deleting it-                        -- would force the real module to be recompiled-                        -- every time.-                    old_hpt1 = case isBootSummary mod of-                      IsBoot -> old_hpt-                      NotBoot -> delFromHpt old_hpt this_mod--                    done' = extendMG done ems--                        -- fixup our HomePackageTable after we've finished compiling-                        -- a mutually-recursive loop.  We have to do this again-                        -- to make sure we have the final unfoldings, which may-                        -- not have been computed accurately in the previous-                        -- retypecheck.-                hsc_env4 <- liftIO $ reTypecheckLoop hsc_env3 mod done'-                setSession hsc_env4--                        -- Add any necessary entries to the static pointer-                        -- table. See Note [Grand plan for static forms] in-                        -- GHC.Iface.Tidy.StaticPtrTable.-                when (backend (hsc_dflags hsc_env4) == Interpreter) $-                    liftIO $ hscAddSptEntries hsc_env4-                                 [ spt-                                 | Just linkable <- pure $ hm_linkable mod_info-                                 , unlinked <- linkableUnlinked linkable-                                 , BCOs _ spts <- pure unlinked-                                 , spt <- spts-                                 ]--                upsweep' old_hpt1 done' mods (mod_index+1) nmods--maybeGetIfaceDate :: DynFlags -> ModLocation -> IO (Maybe UTCTime)-maybeGetIfaceDate dflags location- | writeInterfaceOnlyMode dflags-    -- Minor optimization: it should be harmless to check the hi file location-    -- always, but it's better to avoid hitting the filesystem if possible.-    = modificationTimeIfExists (ml_hi_file location)- | otherwise-    = return Nothing--upsweep_inst :: HscEnv-             -> Maybe Messager-             -> Int  -- index of module-             -> Int  -- total number of modules-             -> InstantiatedUnit-             -> IO ()-upsweep_inst hsc_env mHscMessage mod_index nmods iuid = do-        case mHscMessage of-            Just hscMessage -> hscMessage hsc_env (mod_index, nmods) MustCompile (InstantiationNode iuid)-            Nothing -> return ()-        runHsc hsc_env $ ioMsgMaybe $ tcRnCheckUnit hsc_env $ VirtUnit iuid-        pure ()---- | Compile a single module.  Always produce a Linkable for it if--- successful.  If no compilation happened, return the old Linkable.-upsweep_mod :: HscEnv-            -> Maybe Messager-            -> HomePackageTable-            -> StableModules-            -> ModSummary-            -> Int  -- index of module-            -> Int  -- total number of modules-            -> IO HomeModInfo-upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_index nmods-   =    let-            this_mod_name = ms_mod_name summary-            this_mod    = ms_mod summary-            mb_obj_date = ms_obj_date summary-            mb_if_date  = ms_iface_date summary-            obj_fn      = ml_obj_file (ms_location summary)-            hs_date     = ms_hs_date summary--            is_stable_obj = this_mod_name `elementOfUniqSet` stable_obj-            is_stable_bco = this_mod_name `elementOfUniqSet` stable_bco--            old_hmi = lookupHpt old_hpt this_mod_name--            -- We're using the dflags for this module now, obtained by-            -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas.-            lcl_dflags = ms_hspp_opts summary-            prevailing_backend = backend (hsc_dflags hsc_env)-            local_backend      = backend lcl_dflags--            -- If OPTIONS_GHC contains -fasm or -fllvm, be careful that-            -- we don't do anything dodgy: these should only work to change-            -- from -fllvm to -fasm and vice-versa, or away from -fno-code,-            -- otherwise we could end up trying to link object code to byte-            -- code.-            bcknd = case (prevailing_backend,local_backend) of-               (LLVM,NCG) -> NCG-               (NCG,LLVM) -> LLVM-               (NoBackend,b)-                  | backendProducesObject b -> b-               (Interpreter,b)-                  | backendProducesObject b -> b-               _ -> prevailing_backend--            -- store the corrected backend into the summary-            summary' = summary{ ms_hspp_opts = lcl_dflags { backend = bcknd } }--            -- The old interface is ok if-            --  a) we're compiling a source file, and the old HPT-            --     entry is for a source file-            --  b) we're compiling a hs-boot file-            -- Case (b) allows an hs-boot file to get the interface of its-            -- real source file on the second iteration of the compilation-            -- manager, but that does no harm.  Otherwise the hs-boot file-            -- will always be recompiled--            mb_old_iface-                = case old_hmi of-                     Nothing                                        -> Nothing-                     Just hm_info | isBootSummary summary == IsBoot -> Just iface-                                  | mi_boot iface == NotBoot        -> Just iface-                                  | otherwise                       -> Nothing-                                   where-                                     iface = hm_iface hm_info--            compile_it :: Maybe Linkable -> SourceModified -> IO HomeModInfo-            compile_it  mb_linkable src_modified =-                  compileOne' Nothing mHscMessage hsc_env summary' mod_index nmods-                             mb_old_iface mb_linkable src_modified--            compile_it_discard_iface :: Maybe Linkable -> SourceModified-                                     -> IO HomeModInfo-            compile_it_discard_iface mb_linkable  src_modified =-                  compileOne' Nothing mHscMessage hsc_env summary' mod_index nmods-                             Nothing mb_linkable src_modified--            -- With NoBackend we create empty linkables to avoid recompilation.-            -- We have to detect these to recompile anyway if the backend changed-            -- since the last compile.-            is_fake_linkable-               | Just hmi <- old_hmi, Just l <- hm_linkable hmi =-                  null (linkableUnlinked l)-               | otherwise =-                   -- we have no linkable, so it cannot be fake-                   False--            implies False _ = True-            implies True x  = x--            debug_trace n t = liftIO $ debugTraceMsg (hsc_logger hsc_env) (hsc_dflags hsc_env) n t--        in-        case () of-         _-                -- Regardless of whether we're generating object code or-                -- byte code, we can always use an existing object file-                -- if it is *stable* (see checkStability).-          | is_stable_obj, Just hmi <- old_hmi -> do-                debug_trace 5 (text "skipping stable obj mod:" <+> ppr this_mod_name)-                return hmi-                -- object is stable, and we have an entry in the-                -- old HPT: nothing to do--          | is_stable_obj, isNothing old_hmi -> do-                debug_trace 5 (text "compiling stable on-disk mod:" <+> ppr this_mod_name)-                linkable <- liftIO $ findObjectLinkable this_mod obj_fn-                              (expectJust "upsweep1" mb_obj_date)-                compile_it (Just linkable) SourceUnmodifiedAndStable-                -- object is stable, but we need to load the interface-                -- off disk to make a HMI.--          | not (backendProducesObject bcknd), is_stable_bco,-            (bcknd /= NoBackend) `implies` not is_fake_linkable ->-                ASSERT(isJust old_hmi) -- must be in the old_hpt-                let Just hmi = old_hmi in do-                debug_trace 5 (text "skipping stable BCO mod:" <+> ppr this_mod_name)-                return hmi-                -- BCO is stable: nothing to do--          | not (backendProducesObject bcknd),-            Just hmi <- old_hmi,-            Just l <- hm_linkable hmi,-            not (isObjectLinkable l),-            (bcknd /= NoBackend) `implies` not is_fake_linkable,-            linkableTime l >= ms_hs_date summary -> do-                debug_trace 5 (text "compiling non-stable BCO mod:" <+> ppr this_mod_name)-                compile_it (Just l) SourceUnmodified-                -- we have an old BCO that is up to date with respect-                -- to the source: do a recompilation check as normal.--          -- When generating object code, if there's an up-to-date-          -- object file on the disk, then we can use it.-          -- However, if the object file is new (compared to any-          -- linkable we had from a previous compilation), then we-          -- must discard any in-memory interface, because this-          -- means the user has compiled the source file-          -- separately and generated a new interface, that we must-          -- read from the disk.-          ---          | backendProducesObject bcknd,-            Just obj_date <- mb_obj_date,-            obj_date >= hs_date -> do-                case old_hmi of-                  Just hmi-                    | Just l <- hm_linkable hmi,-                      isObjectLinkable l && linkableTime l == obj_date -> do-                          debug_trace 5 (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name)-                          compile_it (Just l) SourceUnmodified-                  _otherwise -> do-                          debug_trace 5 (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name)-                          linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date-                          compile_it_discard_iface (Just linkable) SourceUnmodified--          -- See Note [Recompilation checking in -fno-code mode]-          | writeInterfaceOnlyMode lcl_dflags,-            Just if_date <- mb_if_date,-            if_date >= hs_date -> do-                debug_trace 5 (text "skipping tc'd mod:" <+> ppr this_mod_name)-                compile_it Nothing SourceUnmodified--         _otherwise -> do-                debug_trace 5 (text "compiling mod:" <+> ppr this_mod_name)-                compile_it Nothing SourceModified---{- Note [-fno-code mode]-~~~~~~~~~~~~~~~~~~~~~~~~-GHC offers the flag -fno-code for the purpose of parsing and typechecking a-program without generating object files. This is intended to be used by tooling-and IDEs to provide quick feedback on any parser or type errors as cheaply as-possible.--When GHC is invoked with -fno-code no object files or linked output will be-generated. As many errors and warnings as possible will be generated, as if--fno-code had not been passed. The session DynFlags will have-backend == NoBackend.---fwrite-interface-~~~~~~~~~~~~~~~~-Whether interface files are generated in -fno-code mode is controlled by the--fwrite-interface flag. The -fwrite-interface flag is a no-op if -fno-code is-not also passed. Recompilation avoidance requires interface files, so passing--fno-code without -fwrite-interface should be avoided. If -fno-code were-re-implemented today, -fwrite-interface would be discarded and it would be-considered always on; this behaviour is as it is for backwards compatibility.--================================================================-IN SUMMARY: ALWAYS PASS -fno-code AND -fwrite-interface TOGETHER-================================================================--Template Haskell-~~~~~~~~~~~~~~~~-A module using template haskell may invoke an imported function from inside a-splice. This will cause the type-checker to attempt to execute that code, which-would fail if no object files had been generated. See #8025. To rectify this,-during the downsweep we patch the DynFlags in the ModSummary of any home module-that is imported by a module that uses template haskell, to generate object-code.--The flavour of generated object code is chosen by defaultObjectTarget for the-target platform. It would likely be faster to generate bytecode, but this is not-supported on all platforms(?Please Confirm?), and does not support the entirety-of GHC haskell. See #1257.--The object files (and interface files if -fwrite-interface is disabled) produced-for template haskell are written to temporary files.--Note that since template haskell can run arbitrary IO actions, -fno-code mode-is no more secure than running without it.--Potential TODOS:-~~~~~-* Remove -fwrite-interface and have interface files always written in -fno-code-  mode-* Both .o and .dyn_o files are generated for template haskell, but we only need-  .dyn_o. Fix it.-* In make mode, a message like-  Compiling A (A.hs, /tmp/ghc_123.o)-  is shown if downsweep enabled object code generation for A. Perhaps we should-  show "nothing" or "temporary object file" instead. Note that one-  can currently use -keep-tmp-files and inspect the generated file with the-  current behaviour.-* Offer a -no-codedir command line option, and write what were temporary-  object files there. This would speed up recompilation.-* Use existing object files (if they are up to date) instead of always-  generating temporary ones.--}---- Note [Recompilation checking in -fno-code mode]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- If we are compiling with -fno-code -fwrite-interface, there won't--- be any object code that we can compare against, nor should there--- be: we're *just* generating interface files.  In this case, we--- want to check if the interface file is new, in lieu of the object--- file.  See also #9243.---- Filter modules in the HPT-retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable-retainInTopLevelEnvs keep_these hpt-   = listToHpt   [ (mod, expectJust "retain" mb_mod_info)-                 | mod <- keep_these-                 , let mb_mod_info = lookupHpt hpt mod-                 , isJust mb_mod_info ]---- ------------------------------------------------------------------------------ Typecheck module loops-{--See bug #930.  This code fixes a long-standing bug in --make.  The-problem is that when compiling the modules *inside* a loop, a data-type that is only defined at the top of the loop looks opaque; but-after the loop is done, the structure of the data type becomes-apparent.--The difficulty is then that two different bits of code have-different notions of what the data type looks like.--The idea is that after we compile a module which also has an .hs-boot-file, we re-generate the ModDetails for each of the modules that-depends on the .hs-boot file, so that everyone points to the proper-TyCons, Ids etc. defined by the real module, not the boot module.-Fortunately re-generating a ModDetails from a ModIface is easy: the-function GHC.IfaceToCore.typecheckIface does exactly that.--Picking the modules to re-typecheck is slightly tricky.  Starting from-the module graph consisting of the modules that have already been-compiled, we reverse the edges (so they point from the imported module-to the importing module), and depth-first-search from the .hs-boot-node.  This gives us all the modules that depend transitively on the-.hs-boot module, and those are exactly the modules that we need to-re-typecheck.--Following this fix, GHC can compile itself with --make -O2.--}--reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv-reTypecheckLoop hsc_env ms graph-  | Just loop <- getModLoop ms mss appearsAsBoot-  -- SOME hs-boot files should still-  -- get used, just not the loop-closer.-  , let non_boot = flip mapMaybe loop $ \case-          InstantiationNode _ -> Nothing-          ModuleNode ems -> do-            let l = emsModSummary ems-            guard $ not $ isBootSummary l == IsBoot && ms_mod l == ms_mod ms-            pure l-  = typecheckLoop (hsc_dflags hsc_env) hsc_env (map ms_mod_name non_boot)-  | otherwise-  = return hsc_env-  where-  mss = mgModSummaries' graph-  appearsAsBoot = (`elemModuleSet` mgBootModules graph)---- | Given a non-boot ModSummary @ms@ of a module, for which there exists a--- corresponding boot file in @graph@, return the set of modules which--- transitively depend on this boot file.  This function is slightly misnamed,--- but its name "getModLoop" alludes to the fact that, when getModLoop is called--- with a graph that does not contain @ms@ (non-parallel case) or is an--- SCC with hs-boot nodes dropped (parallel-case), the modules which--- depend on the hs-boot file are typically (but not always) the--- modules participating in the recursive module loop.  The returned--- list includes the hs-boot file.------ Example:---      let g represent the module graph:---          C.hs---          A.hs-boot imports C.hs---          B.hs imports A.hs-boot---          A.hs imports B.hs---      genModLoop A.hs g == Just [A.hs-boot, B.hs, A.hs]------      It would also be permissible to omit A.hs from the graph,---      in which case the result is [A.hs-boot, B.hs]------ Example:---      A counter-example to the claim that modules returned---      by this function participate in the loop occurs here:------      let g represent the module graph:---          C.hs---          A.hs-boot imports C.hs---          B.hs imports A.hs-boot---          A.hs imports B.hs---          D.hs imports A.hs-boot---      genModLoop A.hs g == Just [A.hs-boot, B.hs, A.hs, D.hs]------      Arguably, D.hs should import A.hs, not A.hs-boot, but---      a dependency on the boot file is not illegal.----getModLoop-  :: ModSummary-  -> [ModuleGraphNode]-  -> (Module -> Bool) -- check if a module appears as a boot module in 'graph'-  -> Maybe [ModuleGraphNode]-getModLoop ms graph appearsAsBoot-  | isBootSummary ms == NotBoot-  , appearsAsBoot this_mod-  , let mss = reachableBackwards (ms_mod_name ms) graph-  = Just mss-  | otherwise-  = Nothing- where-  this_mod = ms_mod ms---- NB: sometimes mods has duplicates; this is harmless because--- any duplicates get clobbered in addListToHpt and never get forced.-typecheckLoop :: DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv-typecheckLoop dflags hsc_env mods = do-  debugTraceMsg logger dflags 2 $-     text "Re-typechecking loop: " <> ppr mods-  new_hpt <--    fixIO $ \new_hpt -> do-      let new_hsc_env = hsc_env{ hsc_HPT = new_hpt }-      mds <- initIfaceCheck (text "typecheckLoop") new_hsc_env $-                mapM (typecheckIface . hm_iface) hmis-      let new_hpt = addListToHpt old_hpt-                        (zip mods [ hmi{ hm_details = details }-                                  | (hmi,details) <- zip hmis mds ])-      return new_hpt-  return hsc_env{ hsc_HPT = new_hpt }-  where-    logger  = hsc_logger hsc_env-    old_hpt = hsc_HPT hsc_env-    hmis    = map (expectJust "typecheckLoop" . lookupHpt old_hpt) mods--reachableBackwards :: ModuleName -> [ModuleGraphNode] -> [ModuleGraphNode]-reachableBackwards mod summaries-  = [ node_payload node | node <- reachableG (transposeG graph) root ]-  where -- the rest just sets up the graph:-        (graph, lookup_node) = moduleGraphNodes False summaries-        root  = expectJust "reachableBackwards" (lookup_node $ NodeKey_Module $ GWIB mod IsBoot)---- --------------------------------------------------------------------------------- | Topological sort of the module graph-topSortModuleGraph-          :: Bool-          -- ^ Drop hi-boot nodes? (see below)-          -> ModuleGraph-          -> Maybe ModuleName-             -- ^ Root module name.  If @Nothing@, use the full graph.-          -> [SCC ModuleGraphNode]--- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes--- The resulting list of strongly-connected-components is in topologically--- sorted order, starting with the module(s) at the bottom of the--- dependency graph (ie compile them first) and ending with the ones at--- the top.------ Drop hi-boot nodes (first boolean arg)?------ - @False@:   treat the hi-boot summaries as nodes of the graph,---              so the graph must be acyclic------ - @True@:    eliminate the hi-boot nodes, and instead pretend---              the a source-import of Foo is an import of Foo---              The resulting graph has no hi-boot nodes, but can be cyclic--topSortModuleGraph drop_hs_boot_nodes module_graph mb_root_mod-  = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph-  where-    summaries = mgModSummaries' module_graph-    -- stronglyConnCompG flips the original order, so if we reverse-    -- the summaries we get a stable topological sort.-    (graph, lookup_node) =-      moduleGraphNodes drop_hs_boot_nodes (reverse summaries)--    initial_graph = case mb_root_mod of-        Nothing -> graph-        Just root_mod ->-            -- restrict the graph to just those modules reachable from-            -- the specified module.  We do this by building a graph with-            -- the full set of nodes, and determining the reachable set from-            -- the specified node.-            let root | Just node <- lookup_node $ NodeKey_Module $ GWIB root_mod NotBoot-                     , graph `hasVertexG` node-                     = node-                     | otherwise-                     = throwGhcException (ProgramError "module does not exist")-            in graphFromEdgedVerticesUniq (seq root (reachableG graph root))--type SummaryNode = Node Int ModuleGraphNode--summaryNodeKey :: SummaryNode -> Int-summaryNodeKey = node_key--summaryNodeSummary :: SummaryNode -> ModuleGraphNode-summaryNodeSummary = node_payload---- | Collect the immediate dependencies of a ModuleGraphNode,--- optionally avoiding hs-boot dependencies.--- If the drop_hs_boot_nodes flag is False, and if this is a .hs and there is--- an equivalent .hs-boot, add a link from the former to the latter.  This--- has the effect of detecting bogus cases where the .hs-boot depends on the--- .hs, by introducing a cycle.  Additionally, it ensures that we will always--- process the .hs-boot before the .hs, and so the HomePackageTable will always--- have the most up to date information.-unfilteredEdges :: Bool -> ModuleGraphNode -> [NodeKey]-unfilteredEdges drop_hs_boot_nodes = \case-    InstantiationNode iuid ->-      NodeKey_Module . flip GWIB NotBoot <$> uniqDSetToList (instUnitHoles iuid)-    ModuleNode (ExtendedModSummary ms bds) ->-      (NodeKey_Module . flip GWIB hs_boot_key . unLoc <$> ms_home_srcimps ms) ++-      (NodeKey_Module . flip GWIB NotBoot     . unLoc <$> ms_home_imps ms) ++-      [ NodeKey_Module $ GWIB (ms_mod_name ms) IsBoot-      | not $ drop_hs_boot_nodes || ms_hsc_src ms == HsBootFile-      ] ++-      [ NodeKey_Unit inst_unit-      | inst_unit <- bds-      ]-  where-    -- Drop hs-boot nodes by using HsSrcFile as the key-    hs_boot_key | drop_hs_boot_nodes = NotBoot -- is regular mod or signature-                | otherwise          = IsBoot--moduleGraphNodes :: Bool -> [ModuleGraphNode]-  -> (Graph SummaryNode, NodeKey -> Maybe SummaryNode)-moduleGraphNodes drop_hs_boot_nodes summaries =-  (graphFromEdgedVerticesUniq nodes, lookup_node)-  where-    numbered_summaries = zip summaries [1..]--    lookup_node :: NodeKey -> Maybe SummaryNode-    lookup_node key = Map.lookup key (unNodeMap node_map)--    lookup_key :: NodeKey -> Maybe Int-    lookup_key = fmap summaryNodeKey . lookup_node--    node_map :: NodeMap SummaryNode-    node_map = NodeMap $-      Map.fromList [ (mkHomeBuildModule s, node)-                   | node <- nodes-                   , let s = summaryNodeSummary node-                   ]--    -- We use integers as the keys for the SCC algorithm-    nodes :: [SummaryNode]-    nodes = [ DigraphNode s key $ out_edge_keys $ unfilteredEdges drop_hs_boot_nodes s-            | (s, key) <- numbered_summaries-             -- Drop the hi-boot ones if told to do so-            , case s of-                InstantiationNode _ -> True-                ModuleNode ems -> not $ isBootSummary (emsModSummary ems) == IsBoot && drop_hs_boot_nodes-            ]--    out_edge_keys :: [NodeKey] -> [Int]-    out_edge_keys = mapMaybe lookup_key-        -- If we want keep_hi_boot_nodes, then we do lookup_key with-        -- IsBoot; else False---- The nodes of the graph are keyed by (mod, is boot?) pairs for the current--- modules, and indefinite unit IDs for dependencies which are instantiated with--- our holes.------ NB: hsig files show up as *normal* nodes (not boot!), since they don't--- participate in cycles (for now)-type ModNodeKey = ModuleNameWithIsBoot-newtype ModNodeMap a = ModNodeMap { unModNodeMap :: Map.Map ModNodeKey a }-  deriving (Functor, Traversable, Foldable)--emptyModNodeMap :: ModNodeMap a-emptyModNodeMap = ModNodeMap Map.empty--modNodeMapInsert :: ModNodeKey -> a -> ModNodeMap a -> ModNodeMap a-modNodeMapInsert k v (ModNodeMap m) = ModNodeMap (Map.insert k v m)--modNodeMapElems :: ModNodeMap a -> [a]-modNodeMapElems (ModNodeMap m) = Map.elems m--modNodeMapLookup :: ModNodeKey -> ModNodeMap a -> Maybe a-modNodeMapLookup k (ModNodeMap m) = Map.lookup k m--data NodeKey = NodeKey_Unit {-# UNPACK #-} !InstantiatedUnit | NodeKey_Module {-# UNPACK #-} !ModNodeKey-  deriving (Eq, Ord)--newtype NodeMap a = NodeMap { unNodeMap :: Map.Map NodeKey a }-  deriving (Functor, Traversable, Foldable)--msKey :: ModSummary -> ModNodeKey-msKey = mkHomeBuildModule0--mkNodeKey :: ModuleGraphNode -> NodeKey-mkNodeKey = \case-  InstantiationNode x -> NodeKey_Unit x-  ModuleNode x -> NodeKey_Module $ mkHomeBuildModule0 (emsModSummary x)--pprNodeKey :: NodeKey -> SDoc-pprNodeKey (NodeKey_Unit iu) = ppr iu-pprNodeKey (NodeKey_Module mk) = ppr mk--mkNodeMap :: [ExtendedModSummary] -> ModNodeMap ExtendedModSummary-mkNodeMap summaries = ModNodeMap $ Map.fromList-  [ (msKey $ emsModSummary s, s) | s <- summaries]---- | If there are {-# SOURCE #-} imports between strongly connected--- components in the topological sort, then those imports can--- definitely be replaced by ordinary non-SOURCE imports: if SOURCE--- were necessary, then the edge would be part of a cycle.-warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()-warnUnnecessarySourceImports sccs = do-  dflags <- getDynFlags-  when (wopt Opt_WarnUnusedImports dflags)-    (logWarnings (listToBag (concatMap (check . flattenSCC) sccs)))-  where check ms =-           let mods_in_this_cycle = map ms_mod_name ms in-           [ warn i | m <- ms, i <- ms_home_srcimps m,-                      unLoc i `notElem`  mods_in_this_cycle ]--        warn :: Located ModuleName -> WarnMsg-        warn (L loc mod) =-           mkPlainMsgEnvelope loc-                (text "Warning: {-# SOURCE #-} unnecessary in import of "-                 <+> quotes (ppr mod))-------------------------------------------------------------------------------------- | Downsweep (dependency analysis)------ Chase downwards from the specified root set, returning summaries--- for all home modules encountered.  Only follow source-import--- links.------ We pass in the previous collection of summaries, which is used as a--- cache to avoid recalculating a module summary if the source is--- unchanged.------ The returned list of [ModSummary] nodes has one node for each home-package--- module, plus one for any hs-boot files.  The imports of these nodes--- are all there, including the imports of non-home-package modules.-downsweep :: HscEnv-          -> [ExtendedModSummary]-          -- ^ Old summaries-          -> [ModuleName]       -- Ignore dependencies on these; treat-                                -- them as if they were package modules-          -> Bool               -- True <=> allow multiple targets to have-                                --          the same module name; this is-                                --          very useful for ghc -M-          -> IO [Either ErrorMessages ExtendedModSummary]-                -- The non-error elements of the returned list all have distinct-                -- (Modules, IsBoot) identifiers, unless the Bool is true in-                -- which case there can be repeats-downsweep hsc_env old_summaries excl_mods allow_dup_roots-   = do-       rootSummaries <- mapM getRootSummary roots-       let (errs, rootSummariesOk) = partitionEithers rootSummaries -- #17549-           root_map = mkRootMap rootSummariesOk-       checkDuplicates root_map-       map0 <- loop (concatMap calcDeps rootSummariesOk) root_map-       -- if we have been passed -fno-code, we enable code generation-       -- for dependencies of modules that have -XTemplateHaskell,-       -- otherwise those modules will fail to compile.-       -- See Note [-fno-code mode] #8025-       let default_backend = platformDefaultBackend (targetPlatform dflags)-       let home_unit       = hsc_home_unit hsc_env-       let tmpfs           = hsc_tmpfs     hsc_env-       map1 <- case backend dflags of-         NoBackend   -> enableCodeGenForTH logger tmpfs home_unit default_backend map0-         _           -> return map0-       if null errs-         then pure $ concat $ modNodeMapElems map1-         else pure $ map Left errs-     where-        -- TODO(@Ericson2314): Probably want to include backpack instantiations-        -- in the map eventually for uniformity-        calcDeps (ExtendedModSummary ms _bkp_deps) = msDeps ms--        dflags = hsc_dflags hsc_env-        logger = hsc_logger hsc_env-        roots = hsc_targets hsc_env--        old_summary_map :: ModNodeMap ExtendedModSummary-        old_summary_map = mkNodeMap old_summaries--        getRootSummary :: Target -> IO (Either ErrorMessages ExtendedModSummary)-        getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf)-           = do exists <- liftIO $ doesFileExist file-                if exists || isJust maybe_buf-                    then summariseFile hsc_env old_summaries file mb_phase-                                       obj_allowed maybe_buf-                    else return $ Left $ unitBag $ mkPlainMsgEnvelope noSrcSpan $-                           text "can't find file:" <+> text file-        getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf)-           = do maybe_summary <- summariseModule hsc_env old_summary_map NotBoot-                                           (L rootLoc modl) obj_allowed-                                           maybe_buf excl_mods-                case maybe_summary of-                   Nothing -> return $ Left $ moduleNotFoundErr modl-                   Just s  -> return s--        rootLoc = mkGeneralSrcSpan (fsLit "<command line>")--        -- In a root module, the filename is allowed to diverge from the module-        -- name, so we have to check that there aren't multiple root files-        -- defining the same module (otherwise the duplicates will be silently-        -- ignored, leading to confusing behaviour).-        checkDuplicates-          :: ModNodeMap-               [Either ErrorMessages-                       ExtendedModSummary]-          -> IO ()-        checkDuplicates root_map-           | allow_dup_roots = return ()-           | null dup_roots  = return ()-           | otherwise       = liftIO $ multiRootsErr (emsModSummary <$> head dup_roots)-           where-             dup_roots :: [[ExtendedModSummary]]        -- Each at least of length 2-             dup_roots = filterOut isSingleton $ map rights $ modNodeMapElems root_map--        loop :: [GenWithIsBoot (Located ModuleName)]-                        -- Work list: process these modules-             -> ModNodeMap [Either ErrorMessages ExtendedModSummary]-                        -- Visited set; the range is a list because-                        -- the roots can have the same module names-                        -- if allow_dup_roots is True-             -> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])-                        -- The result is the completed NodeMap-        loop [] done = return done-        loop (s : ss) done-          | Just summs <- modNodeMapLookup key done-          = if isSingleton summs then-                loop ss done-            else-                do { multiRootsErr (emsModSummary <$> rights summs)-                   ; return (ModNodeMap Map.empty)-                   }-          | otherwise-          = do mb_s <- summariseModule hsc_env old_summary_map-                                       is_boot wanted_mod True-                                       Nothing excl_mods-               case mb_s of-                   Nothing -> loop ss done-                   Just (Left e) -> loop ss (modNodeMapInsert key [Left e] done)-                   Just (Right s)-> do-                     new_map <--                       loop (calcDeps s) (modNodeMapInsert key [Right s] done)-                     loop ss new_map-          where-            GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = s-            wanted_mod = L loc mod-            key = GWIB-                    { gwib_mod = unLoc wanted_mod-                    , gwib_isBoot = is_boot-                    }---- | Update the every ModSummary that is depended on--- by a module that needs template haskell. We enable codegen to--- the specified target, disable optimization and change the .hi--- and .o file locations to be temporary files.--- See Note [-fno-code mode]-enableCodeGenForTH-  :: Logger-  -> TmpFs-  -> HomeUnit-  -> Backend-  -> ModNodeMap [Either ErrorMessages ExtendedModSummary]-  -> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])-enableCodeGenForTH logger tmpfs home_unit =-  enableCodeGenWhen logger tmpfs condition should_modify TFL_CurrentModule TFL_GhcSession-  where-    condition = isTemplateHaskellOrQQNonBoot-    should_modify (ModSummary { ms_hspp_opts = dflags }) =-      backend dflags == NoBackend &&-      -- Don't enable codegen for TH on indefinite packages; we-      -- can't compile anything anyway! See #16219.-      isHomeUnitDefinite home_unit---- | Helper used to implement 'enableCodeGenForTH'.--- In particular, this enables--- unoptimized code generation for all modules that meet some--- condition (first parameter), or are dependencies of those--- modules. The second parameter is a condition to check before--- marking modules for code generation.-enableCodeGenWhen-  :: Logger-  -> TmpFs-  -> (ModSummary -> Bool)-  -> (ModSummary -> Bool)-  -> TempFileLifetime-  -> TempFileLifetime-  -> Backend-  -> ModNodeMap [Either ErrorMessages ExtendedModSummary]-  -> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])-enableCodeGenWhen logger tmpfs condition should_modify staticLife dynLife bcknd nodemap =-  traverse (traverse (traverse enable_code_gen)) nodemap-  where-    enable_code_gen :: ExtendedModSummary -> IO ExtendedModSummary-    enable_code_gen (ExtendedModSummary ms bkp_deps)-      | ModSummary-        { ms_mod = ms_mod-        , ms_location = ms_location-        , ms_hsc_src = HsSrcFile-        , ms_hspp_opts = dflags-        } <- ms-      , should_modify ms-      , ms_mod `Set.member` needs_codegen_set-      = do-        let new_temp_file suf dynsuf = do-              tn <- newTempName logger tmpfs dflags staticLife suf-              let dyn_tn = tn -<.> dynsuf-              addFilesToClean tmpfs dynLife [dyn_tn]-              return tn-          -- We don't want to create .o or .hi files unless we have been asked-          -- to by the user. But we need them, so we patch their locations in-          -- the ModSummary with temporary files.-          ---        (hi_file, o_file) <--          -- If ``-fwrite-interface` is specified, then the .o and .hi files-          -- are written into `-odir` and `-hidir` respectively.  #16670-          if gopt Opt_WriteInterface dflags-            then return (ml_hi_file ms_location, ml_obj_file ms_location)-            else (,) <$> (new_temp_file (hiSuf_ dflags) (dynHiSuf_ dflags))-                     <*> (new_temp_file (objectSuf_ dflags) (dynObjectSuf_ dflags))-        let ms' = ms-              { ms_location =-                  ms_location {ml_hi_file = hi_file, ml_obj_file = o_file}-              , ms_hspp_opts = updOptLevel 0 $ dflags {backend = bcknd}-              }-        pure (ExtendedModSummary ms' bkp_deps)-      | otherwise = return (ExtendedModSummary ms bkp_deps)--    needs_codegen_set = transitive_deps_set-      [ ms-      | mss <- modNodeMapElems nodemap-      , Right (ExtendedModSummary { emsModSummary = ms }) <- mss-      , condition ms-      ]--    -- find the set of all transitive dependencies of a list of modules.-    transitive_deps_set :: [ModSummary] -> Set.Set Module-    transitive_deps_set modSums = foldl' go Set.empty modSums-      where-        go marked_mods ms@ModSummary{ms_mod}-          | ms_mod `Set.member` marked_mods = marked_mods-          | otherwise =-            let deps =-                  [ dep_ms-                  -- If a module imports a boot module, msDeps helpfully adds a-                  -- dependency to that non-boot module in it's result. This-                  -- means we don't have to think about boot modules here.-                  | dep <- msDeps ms-                  , NotBoot == gwib_isBoot dep-                  , dep_ms_0 <- toList $ modNodeMapLookup (unLoc <$> dep) nodemap-                  , dep_ms_1 <- toList $ dep_ms_0-                  , (ExtendedModSummary { emsModSummary = dep_ms }) <- toList $ dep_ms_1-                  ]-                new_marked_mods = Set.insert ms_mod marked_mods-            in foldl' go new_marked_mods deps--mkRootMap-  :: [ExtendedModSummary]-  -> ModNodeMap [Either ErrorMessages ExtendedModSummary]-mkRootMap summaries = ModNodeMap $ Map.insertListWith-  (flip (++))-  [ (msKey $ emsModSummary s, [Right s]) | s <- summaries ]-  Map.empty---- | Returns the dependencies of the ModSummary s.--- A wrinkle is that for a {-# SOURCE #-} import we return---      *both* the hs-boot file---      *and* the source file--- as "dependencies".  That ensures that the list of all relevant--- modules always contains B.hs if it contains B.hs-boot.--- Remember, this pass isn't doing the topological sort.  It's--- just gathering the list of all relevant ModSummaries-msDeps :: ModSummary -> [GenWithIsBoot (Located ModuleName)]-msDeps s = [ d-           | m <- ms_home_srcimps s-           , d <- [ GWIB { gwib_mod = m, gwib_isBoot = IsBoot }-                  , GWIB { gwib_mod = m, gwib_isBoot = NotBoot }-                  ]-           ]-        ++ [ GWIB { gwib_mod = m, gwib_isBoot = NotBoot }-           | m <- ms_home_imps s-           ]---------------------------------------------------------------------------------- Summarising modules---- We have two types of summarisation:------    * Summarise a file.  This is used for the root module(s) passed to---      cmLoadModules.  The file is read, and used to determine the root---      module name.  The module name may differ from the filename.------    * Summarise a module.  We are given a module name, and must provide---      a summary.  The finder is used to locate the file in which the module---      resides.--summariseFile-        :: HscEnv-        -> [ExtendedModSummary]         -- old summaries-        -> FilePath                     -- source file name-        -> Maybe Phase                  -- start phase-        -> Bool                         -- object code allowed?-        -> Maybe (StringBuffer,UTCTime)-        -> IO (Either ErrorMessages ExtendedModSummary)--summariseFile hsc_env old_summaries src_fn mb_phase obj_allowed maybe_buf-        -- we can use a cached summary if one is available and the-        -- source file hasn't changed,  But we have to look up the summary-        -- by source file, rather than module name as we do in summarise.-   | Just old_summary <- findSummaryBySourceFile old_summaries src_fn-   = do-        let location = ms_location $ emsModSummary old_summary-            dflags = hsc_dflags hsc_env--        src_timestamp <- get_src_timestamp-                -- The file exists; we checked in getRootSummary above.-                -- If it gets removed subsequently, then this-                -- getModificationUTCTime may fail, but that's the right-                -- behaviour.--                -- return the cached summary if the source didn't change-        checkSummaryTimestamp-            hsc_env dflags obj_allowed NotBoot (new_summary src_fn)-            old_summary location src_timestamp--   | otherwise-   = do src_timestamp <- get_src_timestamp-        new_summary src_fn src_timestamp-  where-    get_src_timestamp = case maybe_buf of-                           Just (_,t) -> return t-                           Nothing    -> liftIO $ getModificationUTCTime src_fn-                        -- getModificationUTCTime may fail--    new_summary src_fn src_timestamp = runExceptT $ do-        preimps@PreprocessedImports {..}-            <- getPreprocessedImports hsc_env src_fn mb_phase maybe_buf---        -- Make a ModLocation for this file-        location <- liftIO $ mkHomeModLocation (hsc_dflags hsc_env) pi_mod_name src_fn--        -- Tell the Finder cache where it is, so that subsequent calls-        -- to findModule will find it, even if it's not on any search path-        mod <- liftIO $ addHomeModuleToFinder hsc_env pi_mod_name location--        liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary-            { nms_src_fn = src_fn-            , nms_src_timestamp = src_timestamp-            , nms_is_boot = NotBoot-            , nms_hsc_src =-                if isHaskellSigFilename src_fn-                   then HsigFile-                   else HsSrcFile-            , nms_location = location-            , nms_mod = mod-            , nms_obj_allowed = obj_allowed-            , nms_preimps = preimps-            }--findSummaryBySourceFile :: [ExtendedModSummary] -> FilePath -> Maybe ExtendedModSummary-findSummaryBySourceFile summaries file = case-    [ ms-    | ms <- summaries-    , HsSrcFile <- [ms_hsc_src $ emsModSummary ms]-    , let derived_file = ml_hs_file $ ms_location $ emsModSummary ms-    , expectJust "findSummaryBySourceFile" derived_file == file-    ]-  of-    [] -> Nothing-    (x:_) -> Just x--checkSummaryTimestamp-    :: HscEnv -> DynFlags -> Bool -> IsBootInterface-    -> (UTCTime -> IO (Either e ExtendedModSummary))-    -> ExtendedModSummary -> ModLocation -> UTCTime-    -> IO (Either e ExtendedModSummary)-checkSummaryTimestamp-  hsc_env dflags obj_allowed is_boot new_summary-  (ExtendedModSummary { emsModSummary = old_summary, emsInstantiatedUnits = bkp_deps})-  location src_timestamp-  | ms_hs_date old_summary == src_timestamp &&-      not (gopt Opt_ForceRecomp (hsc_dflags hsc_env)) = do-           -- update the object-file timestamp-           obj_timestamp <--             if backendProducesObject (backend (hsc_dflags hsc_env))-                 || obj_allowed -- bug #1205-                 then liftIO $ getObjTimestamp location is_boot-                 else return Nothing--           -- We have to repopulate the Finder's cache for file targets-           -- because the file might not even be on the regular search path-           -- and it was likely flushed in depanal. This is not technically-           -- needed when we're called from sumariseModule but it shouldn't-           -- hurt.-           _ <- addHomeModuleToFinder hsc_env-                  (moduleName (ms_mod old_summary)) location--           hi_timestamp <- maybeGetIfaceDate dflags location-           hie_timestamp <- modificationTimeIfExists (ml_hie_file location)--           return $ Right-             ( ExtendedModSummary { emsModSummary = old_summary-                     { ms_obj_date = obj_timestamp-                     , ms_iface_date = hi_timestamp-                     , ms_hie_date = hie_timestamp-                     }-                   , emsInstantiatedUnits = bkp_deps-                   }-             )--   | otherwise =-           -- source changed: re-summarise.-           new_summary src_timestamp---- Summarise a module, and pick up source and timestamp.-summariseModule-          :: HscEnv-          -> ModNodeMap ExtendedModSummary-          -- ^ Map of old summaries-          -> IsBootInterface    -- True <=> a {-# SOURCE #-} import-          -> Located ModuleName -- Imported module to be summarised-          -> Bool               -- object code allowed?-          -> Maybe (StringBuffer, UTCTime)-          -> [ModuleName]               -- Modules to exclude-          -> IO (Maybe (Either ErrorMessages ExtendedModSummary))      -- Its new summary--summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)-                obj_allowed maybe_buf excl_mods-  | wanted_mod `elem` excl_mods-  = return Nothing--  | Just old_summary <- modNodeMapLookup-      (GWIB { gwib_mod = wanted_mod, gwib_isBoot = is_boot })-      old_summary_map-  = do          -- Find its new timestamp; all the-                -- ModSummaries in the old map have valid ml_hs_files-        let location = ms_location $ emsModSummary old_summary-            src_fn = expectJust "summariseModule" (ml_hs_file location)--                -- check the modification time on the source file, and-                -- return the cached summary if it hasn't changed.  If the-                -- file has disappeared, we need to call the Finder again.-        case maybe_buf of-           Just (_,t) ->-               Just <$> check_timestamp old_summary location src_fn t-           Nothing    -> do-                m <- tryIO (getModificationUTCTime src_fn)-                case m of-                   Right t ->-                       Just <$> check_timestamp old_summary location src_fn t-                   Left e | isDoesNotExistError e -> find_it-                          | otherwise             -> ioError e--  | otherwise  = find_it-  where-    dflags = hsc_dflags hsc_env-    home_unit = hsc_home_unit hsc_env--    check_timestamp old_summary location src_fn =-        checkSummaryTimestamp-          hsc_env dflags obj_allowed is_boot-          (new_summary location (ms_mod $ emsModSummary old_summary) src_fn)-          old_summary location--    find_it = do-        found <- findImportedModule hsc_env wanted_mod Nothing-        case found of-             Found location mod-                | isJust (ml_hs_file location) ->-                        -- Home package-                         Just <$> just_found location mod--             _ -> return Nothing-                        -- Not found-                        -- (If it is TRULY not found at all, we'll-                        -- error when we actually try to compile)--    just_found location mod = do-                -- Adjust location to point to the hs-boot source file,-                -- hi file, object file, when is_boot says so-        let location' = case is_boot of-              IsBoot -> addBootSuffixLocn location-              NotBoot -> location-            src_fn = expectJust "summarise2" (ml_hs_file location')--                -- Check that it exists-                -- It might have been deleted since the Finder last found it-        maybe_t <- modificationTimeIfExists src_fn-        case maybe_t of-          Nothing -> return $ Left $ noHsFileErr loc src_fn-          Just t  -> new_summary location' mod src_fn t--    new_summary location mod src_fn src_timestamp-      = runExceptT $ do-        preimps@PreprocessedImports {..}-            <- getPreprocessedImports hsc_env src_fn Nothing maybe_buf--        -- NB: Despite the fact that is_boot is a top-level parameter, we-        -- don't actually know coming into this function what the HscSource-        -- of the module in question is.  This is because we may be processing-        -- this module because another module in the graph imported it: in this-        -- case, we know if it's a boot or not because of the {-# SOURCE #-}-        -- annotation, but we don't know if it's a signature or a regular-        -- module until we actually look it up on the filesystem.-        let hsc_src-              | is_boot == IsBoot = HsBootFile-              | isHaskellSigFilename src_fn = HsigFile-              | otherwise = HsSrcFile--        when (pi_mod_name /= wanted_mod) $-                throwE $ unitBag $ mkPlainMsgEnvelope pi_mod_name_loc $-                              text "File name does not match module name:"-                              $$ text "Saw:" <+> quotes (ppr pi_mod_name)-                              $$ text "Expected:" <+> quotes (ppr wanted_mod)--        when (hsc_src == HsigFile && isNothing (lookup pi_mod_name (homeUnitInstantiations home_unit))) $-            let suggested_instantiated_with =-                    hcat (punctuate comma $-                        [ ppr k <> text "=" <> ppr v-                        | (k,v) <- ((pi_mod_name, mkHoleModule pi_mod_name)-                                : homeUnitInstantiations home_unit)-                        ])-            in throwE $ unitBag $ mkPlainMsgEnvelope pi_mod_name_loc $-                text "Unexpected signature:" <+> quotes (ppr pi_mod_name)-                $$ if gopt Opt_BuildingCabalPackage dflags-                    then parens (text "Try adding" <+> quotes (ppr pi_mod_name)-                            <+> text "to the"-                            <+> quotes (text "signatures")-                            <+> text "field in your Cabal file.")-                    else parens (text "Try passing -instantiated-with=\"" <>-                                 suggested_instantiated_with <> text "\"" $$-                                text "replacing <" <> ppr pi_mod_name <> text "> as necessary.")--        liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary-            { nms_src_fn = src_fn-            , nms_src_timestamp = src_timestamp-            , nms_is_boot = is_boot-            , nms_hsc_src = hsc_src-            , nms_location = location-            , nms_mod = mod-            , nms_obj_allowed = obj_allowed-            , nms_preimps = preimps-            }---- | Convenience named arguments for 'makeNewModSummary' only used to make--- code more readable, not exported.-data MakeNewModSummary-  = MakeNewModSummary-      { nms_src_fn :: FilePath-      , nms_src_timestamp :: UTCTime-      , nms_is_boot :: IsBootInterface-      , nms_hsc_src :: HscSource-      , nms_location :: ModLocation-      , nms_mod :: Module-      , nms_obj_allowed :: Bool-      , nms_preimps :: PreprocessedImports-      }--makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ExtendedModSummary-makeNewModSummary hsc_env MakeNewModSummary{..} = do-  let PreprocessedImports{..} = nms_preimps-  let dflags = hsc_dflags hsc_env--  -- when the user asks to load a source file by name, we only-  -- use an object file if -fobject-code is on.  See #1205.-  obj_timestamp <- liftIO $-      if backendProducesObject (backend dflags)-         || nms_obj_allowed -- bug #1205-          then getObjTimestamp nms_location nms_is_boot-          else return Nothing--  hi_timestamp <- maybeGetIfaceDate dflags nms_location-  hie_timestamp <- modificationTimeIfExists (ml_hie_file nms_location)--  extra_sig_imports <- findExtraSigImports hsc_env nms_hsc_src pi_mod_name-  (implicit_sigs, inst_deps) <- implicitRequirementsShallow hsc_env pi_theimps--  return $ ExtendedModSummary-    { emsModSummary =-        ModSummary-        { ms_mod = nms_mod-        , ms_hsc_src = nms_hsc_src-        , ms_location = nms_location-        , ms_hspp_file = pi_hspp_fn-        , ms_hspp_opts = pi_local_dflags-        , ms_hspp_buf  = Just pi_hspp_buf-        , ms_parsed_mod = Nothing-        , ms_srcimps = pi_srcimps-        , ms_textual_imps =-            pi_theimps ++-            extra_sig_imports ++-            ((,) Nothing . noLoc <$> implicit_sigs)-        , ms_hs_date = nms_src_timestamp-        , ms_iface_date = hi_timestamp-        , ms_hie_date = hie_timestamp-        , ms_obj_date = obj_timestamp-        }-    , emsInstantiatedUnits = inst_deps-    }--getObjTimestamp :: ModLocation -> IsBootInterface -> IO (Maybe UTCTime)-getObjTimestamp location is_boot-  = case is_boot of-      IsBoot -> return Nothing-      NotBoot -> modificationTimeIfExists (ml_obj_file location)--data PreprocessedImports-  = PreprocessedImports-      { pi_local_dflags :: DynFlags-      , pi_srcimps  :: [(Maybe FastString, Located ModuleName)]-      , pi_theimps  :: [(Maybe FastString, Located ModuleName)]-      , pi_hspp_fn  :: FilePath-      , pi_hspp_buf :: StringBuffer-      , pi_mod_name_loc :: SrcSpan-      , pi_mod_name :: ModuleName-      }---- Preprocess the source file and get its imports--- The pi_local_dflags contains the OPTIONS pragmas-getPreprocessedImports-    :: HscEnv-    -> FilePath-    -> Maybe Phase-    -> Maybe (StringBuffer, UTCTime)-    -- ^ optional source code buffer and modification time-    -> ExceptT ErrorMessages IO PreprocessedImports-getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do-  (pi_local_dflags, pi_hspp_fn)-      <- ExceptT $ preprocess hsc_env src_fn (fst <$> maybe_buf) mb_phase-  pi_hspp_buf <- liftIO $ hGetStringBuffer pi_hspp_fn-  (pi_srcimps, pi_theimps, L pi_mod_name_loc pi_mod_name)-      <- ExceptT $ do-          let imp_prelude = xopt LangExt.ImplicitPrelude pi_local_dflags-              popts = initParserOpts pi_local_dflags-          mimps <- getImports popts imp_prelude pi_hspp_buf pi_hspp_fn src_fn-          return (first (fmap pprError) mimps)-  return PreprocessedImports {..}-----------------------------------------------------------------------------------                      Error messages---------------------------------------------------------------------------------- Defer and group warning, error and fatal messages so they will not get lost--- in the regular output.-withDeferredDiagnostics :: GhcMonad m => m a -> m a-withDeferredDiagnostics f = do-  dflags <- getDynFlags-  if not $ gopt Opt_DeferDiagnostics dflags-  then f-  else do-    warnings <- liftIO $ newIORef []-    errors <- liftIO $ newIORef []-    fatals <- liftIO $ newIORef []-    logger <- getLogger--    let deferDiagnostics _dflags !reason !severity !srcSpan !msg = do-          let action = putLogMsg logger dflags reason severity srcSpan msg-          case severity of-            SevWarning -> atomicModifyIORef' warnings $ \i -> (action: i, ())-            SevError -> atomicModifyIORef' errors $ \i -> (action: i, ())-            SevFatal -> atomicModifyIORef' fatals $ \i -> (action: i, ())-            _ -> action--        printDeferredDiagnostics = liftIO $-          forM_ [warnings, errors, fatals] $ \ref -> do-            -- This IORef can leak when the dflags leaks, so let us always-            -- reset the content.-            actions <- atomicModifyIORef' ref $ \i -> ([], i)-            sequence_ $ reverse actions--    MC.bracket-      (pushLogHookM (const deferDiagnostics))-      (\_ -> popLogHookM >> printDeferredDiagnostics)-      (\_ -> f)--noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope DecoratedSDoc--- ToDo: we don't have a proper line number for this error-noModError hsc_env loc wanted_mod err-  = mkPlainMsgEnvelope loc $ cannotFindModule hsc_env wanted_mod err--noHsFileErr :: SrcSpan -> String -> ErrorMessages-noHsFileErr loc path-  = unitBag $ mkPlainMsgEnvelope loc $ text "Can't find" <+> text path--moduleNotFoundErr :: ModuleName -> ErrorMessages-moduleNotFoundErr mod-  = unitBag $ mkPlainMsgEnvelope noSrcSpan $-        text "module" <+> quotes (ppr mod) <+> text "cannot be found locally"--multiRootsErr :: [ModSummary] -> IO ()-multiRootsErr [] = panic "multiRootsErr"-multiRootsErr summs@(summ1:_)-  = throwOneError $ mkPlainMsgEnvelope noSrcSpan $-        text "module" <+> quotes (ppr mod) <+>-        text "is defined in multiple files:" <+>-        sep (map text files)-  where-    mod = ms_mod summ1-    files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs--keepGoingPruneErr :: [NodeKey] -> SDoc-keepGoingPruneErr ms-  = vcat (( text "-fkeep-going in use, removing the following" <+>-            text "dependencies and continuing:"):-          map (nest 6 . pprNodeKey) ms )--cyclicModuleErr :: [ModuleGraphNode] -> SDoc--- From a strongly connected component we find--- a single cycle to report-cyclicModuleErr mss-  = ASSERT( not (null mss) )-    case findCycle graph of-       Nothing   -> text "Unexpected non-cycle" <+> ppr mss-       Just path0 -> vcat-        [ case partitionNodes path0 of-            ([],_) -> text "Module imports form a cycle:"-            (_,[]) -> text "Module instantiations form a cycle:"-            _ -> text "Module imports and instantiations form a cycle:"-        , nest 2 (show_path path0)]-  where-    graph :: [Node NodeKey ModuleGraphNode]-    graph =-      [ DigraphNode-        { node_payload = ms-        , node_key = mkNodeKey ms-        , node_dependencies = get_deps ms-        }-      | ms <- mss-      ]--    get_deps :: ModuleGraphNode -> [NodeKey]-    get_deps = \case-      InstantiationNode iuid ->-        [ NodeKey_Module $ GWIB { gwib_mod = hole, gwib_isBoot = NotBoot }-        | hole <- uniqDSetToList $ instUnitHoles iuid-        ]-      ModuleNode (ExtendedModSummary ms bds) ->-        [ NodeKey_Module $ GWIB { gwib_mod = unLoc m, gwib_isBoot = IsBoot }-        | m <- ms_home_srcimps ms ] ++-        [ NodeKey_Module $ GWIB { gwib_mod = unLoc m, gwib_isBoot = NotBoot }-        | m <- ms_home_imps    ms ] ++-        [ NodeKey_Unit inst_unit-        | inst_unit <- bds-        ]--    show_path :: [ModuleGraphNode] -> SDoc-    show_path []  = panic "show_path"-    show_path [m] = ppr_node m <+> text "imports itself"-    show_path (m1:m2:ms) = vcat ( nest 6 (ppr_node m1)-                                : nest 6 (text "imports" <+> ppr_node m2)-                                : go ms )-       where-         go []     = [text "which imports" <+> ppr_node m1]-         go (m:ms) = (text "which imports" <+> ppr_node m) : go ms--    ppr_node :: ModuleGraphNode -> SDoc-    ppr_node (ModuleNode m) = text "module" <+> ppr_ms (emsModSummary m)-    ppr_node (InstantiationNode u) = text "instantiated unit" <+> ppr u--    ppr_ms :: ModSummary -> SDoc-    ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+>-                (parens (text (msHsFilePath ms)))+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralisedNewtypeDeriving #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RecordWildCards #-}++-- -----------------------------------------------------------------------------+--+-- (c) The University of Glasgow, 2011+--+-- This module implements multi-module compilation, and is used+-- by --make and GHCi.+--+-- -----------------------------------------------------------------------------+module GHC.Driver.Make (+        depanal, depanalE, depanalPartial, checkHomeUnitsClosed,+        load, loadWithCache, load', LoadHowMuch(..), ModIfaceCache(..), noIfaceCache, newIfaceCache,+        instantiationNodes,++        downsweep,++        topSortModuleGraph,++        ms_home_srcimps, ms_home_imps,++        summariseModule,+        SummariseResult(..),+        summariseFile,+        hscSourceToIsBoot,+        findExtraSigImports,+        implicitRequirementsShallow,++        noModError, cyclicModuleErr,+        SummaryNode,+        IsBootInterface(..), mkNodeKey,++        ModNodeKey, ModNodeKeyWithUid(..),+        ModNodeMap(..), emptyModNodeMap, modNodeMapElems, modNodeMapLookup, modNodeMapInsert, modNodeMapSingleton, modNodeMapUnionWith+        ) where++import GHC.Prelude+import GHC.Platform++import GHC.Tc.Utils.Backpack+import GHC.Tc.Utils.Monad  ( initIfaceCheck )++import GHC.Runtime.Interpreter+import qualified GHC.Linker.Loader as Linker+import GHC.Linker.Types++import GHC.Platform.Ways++import GHC.Driver.Config.Finder (initFinderOpts)+import GHC.Driver.Config.Parser (initParserOpts)+import GHC.Driver.Config.Diagnostic+import GHC.Driver.Phases+import GHC.Driver.Pipeline+import GHC.Driver.Session+import GHC.Driver.Backend+import GHC.Driver.Monad+import GHC.Driver.Env+import GHC.Driver.Errors+import GHC.Driver.Errors.Types+import GHC.Driver.Main++import GHC.Parser.Header++import GHC.Iface.Load      ( cannotFindModule )+import GHC.IfaceToCore     ( typecheckIface )+import GHC.Iface.Recomp    ( RecompileRequired(..), CompileReason(..) )++import GHC.Data.Bag        ( listToBag )+import GHC.Data.Graph.Directed+import GHC.Data.FastString+import GHC.Data.Maybe      ( expectJust )+import GHC.Data.StringBuffer+import qualified GHC.LanguageExtensions as LangExt++import GHC.Utils.Exception ( throwIO, SomeAsyncException )+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Utils.Misc+import GHC.Utils.Error+import GHC.Utils.Logger+import GHC.Utils.Fingerprint+import GHC.Utils.TmpFs++import GHC.Types.Basic+import GHC.Types.Error+import GHC.Types.Target+import GHC.Types.SourceFile+import GHC.Types.SourceError+import GHC.Types.SrcLoc+import GHC.Types.Unique.FM+import GHC.Types.PkgQual++import GHC.Unit+import GHC.Unit.Env+import GHC.Unit.Finder+import GHC.Unit.Module.ModSummary+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.Graph+import GHC.Unit.Home.ModInfo+import GHC.Unit.Module.ModDetails++import Data.Either ( rights, partitionEithers, lefts )+import qualified Data.Map as Map+import qualified Data.Set as Set++import Control.Concurrent ( newQSem, waitQSem, signalQSem, ThreadId, killThread, forkIOWithUnmask )+import qualified GHC.Conc as CC+import Control.Concurrent.MVar+import Control.Monad+import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE )+import qualified Control.Monad.Catch as MC+import Data.IORef+import Data.Maybe+import Data.Time+import Data.Bifunctor (first)+import System.Directory+import System.FilePath+import System.IO        ( fixIO )++import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities )+import Control.Monad.IO.Class+import Control.Monad.Trans.Reader+import GHC.Driver.Pipeline.LogQueue+import qualified Data.Map.Strict as M+import GHC.Types.TypeEnv+import Control.Monad.Trans.State.Lazy+import Control.Monad.Trans.Class+import GHC.Driver.Env.KnotVars+import Control.Concurrent.STM+import Control.Monad.Trans.Maybe+import GHC.Runtime.Loader+import GHC.Rename.Names+import GHC.Utils.Constants++-- -----------------------------------------------------------------------------+-- Loading the program++-- | Perform a dependency analysis starting from the current targets+-- and update the session with the new module graph.+--+-- Dependency analysis entails parsing the @import@ directives and may+-- therefore require running certain preprocessors.+--+-- Note that each 'ModSummary' in the module graph caches its 'DynFlags'.+-- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the+-- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module.  Thus if you want+-- changes to the 'DynFlags' to take effect you need to call this function+-- again.+-- In case of errors, just throw them.+--+depanal :: GhcMonad m =>+           [ModuleName]  -- ^ excluded modules+        -> Bool          -- ^ allow duplicate roots+        -> m ModuleGraph+depanal excluded_mods allow_dup_roots = do+    (errs, mod_graph) <- depanalE excluded_mods allow_dup_roots+    if isEmptyMessages errs+      then pure mod_graph+      else throwErrors (fmap GhcDriverMessage errs)++-- | Perform dependency analysis like in 'depanal'.+-- In case of errors, the errors and an empty module graph are returned.+depanalE :: GhcMonad m =>     -- New for #17459+            [ModuleName]      -- ^ excluded modules+            -> Bool           -- ^ allow duplicate roots+            -> m (DriverMessages, ModuleGraph)+depanalE excluded_mods allow_dup_roots = do+    hsc_env <- getSession+    (errs, mod_graph) <- depanalPartial excluded_mods allow_dup_roots+    if isEmptyMessages errs+      then do+        hsc_env <- getSession+        let one_unit_messages get_mod_errs k hue = do+              errs <- get_mod_errs+              unknown_module_err <- warnUnknownModules (hscSetActiveUnitId k hsc_env) (homeUnitEnv_dflags hue) mod_graph++              let unused_home_mod_err = warnMissingHomeModules (homeUnitEnv_dflags hue) (hsc_targets hsc_env) mod_graph+                  unused_pkg_err = warnUnusedPackages (homeUnitEnv_units hue) (homeUnitEnv_dflags hue) mod_graph+++              return $ errs `unionMessages` unused_home_mod_err+                          `unionMessages` unused_pkg_err+                          `unionMessages` unknown_module_err++        all_errs <- liftIO $ unitEnv_foldWithKey one_unit_messages (return emptyMessages) (hsc_HUG hsc_env)+        logDiagnostics (GhcDriverMessage <$> all_errs)+        setSession hsc_env { hsc_mod_graph = mod_graph }+        pure (emptyMessages, mod_graph)+      else do+        -- We don't have a complete module dependency graph,+        -- The graph may be disconnected and is unusable.+        setSession hsc_env { hsc_mod_graph = emptyMG }+        pure (errs, emptyMG)+++-- | Perform dependency analysis like 'depanal' but return a partial module+-- graph even in the face of problems with some modules.+--+-- Modules which have parse errors in the module header, failing+-- preprocessors or other issues preventing them from being summarised will+-- simply be absent from the returned module graph.+--+-- Unlike 'depanal' this function will not update 'hsc_mod_graph' with the+-- new module graph.+depanalPartial+    :: GhcMonad m+    => [ModuleName]  -- ^ excluded modules+    -> Bool          -- ^ allow duplicate roots+    -> m (DriverMessages, ModuleGraph)+    -- ^ possibly empty 'Bag' of errors and a module graph.+depanalPartial excluded_mods allow_dup_roots = do+  hsc_env <- getSession+  let+         targets = hsc_targets hsc_env+         old_graph = hsc_mod_graph hsc_env+         logger  = hsc_logger hsc_env++  withTiming logger (text "Chasing dependencies") (const ()) $ do+    liftIO $ debugTraceMsg logger 2 (hcat [+              text "Chasing modules from: ",+              hcat (punctuate comma (map pprTarget targets))])++    -- Home package modules may have been moved or deleted, and new+    -- source files may have appeared in the home package that shadow+    -- external package modules, so we have to discard the existing+    -- cached finder data.+    liftIO $ flushFinderCaches (hsc_FC hsc_env) (hsc_unit_env hsc_env)++    (errs, graph_nodes) <- liftIO $ downsweep+      hsc_env (mgModSummaries old_graph)+      excluded_mods allow_dup_roots+    let+      mod_graph = mkModuleGraph graph_nodes+    return (unionManyMessages errs, mod_graph)++-- | Collect the instantiations of dependencies to create 'InstantiationNode' work graph nodes.+-- These are used to represent the type checking that is done after+-- all the free holes (sigs in current package) relevant to that instantiation+-- are compiled. This is necessary to catch some instantiation errors.+--+-- In the future, perhaps more of the work of instantiation could be moved here,+-- instead of shoved in with the module compilation nodes. That could simplify+-- backpack, and maybe hs-boot too.+instantiationNodes :: UnitId -> UnitState -> [ModuleGraphNode]+instantiationNodes uid unit_state = InstantiationNode uid <$> iuids_to_check+  where+    iuids_to_check :: [InstantiatedUnit]+    iuids_to_check =+      nubSort $ concatMap (goUnitId . fst) (explicitUnits unit_state)+     where+      goUnitId uid =+        [ recur+        | VirtUnit indef <- [uid]+        , inst <- instUnitInsts indef+        , recur <- (indef :) $ goUnitId $ moduleUnit $ snd inst+        ]++-- The linking plan for each module. If we need to do linking for a home unit+-- then this function returns a graph node which depends on all the modules in the home unit.++-- At the moment nothing can depend on these LinkNodes.+linkNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> Maybe (Either (Messages DriverMessage) ModuleGraphNode)+linkNodes summaries uid hue =+  let dflags = homeUnitEnv_dflags hue+      ofile = outputFile_ dflags++      unit_nodes :: [NodeKey]+      unit_nodes = map mkNodeKey (filter ((== uid) . moduleGraphNodeUnitId) summaries)+  -- Issue a warning for the confusing case where the user+  -- said '-o foo' but we're not going to do any linking.+  -- We attempt linking if either (a) one of the modules is+  -- called Main, or (b) the user said -no-hs-main, indicating+  -- that main() is going to come from somewhere else.+  --+      no_hs_main = gopt Opt_NoHsMain dflags++      main_sum = any (== NodeKey_Module (ModNodeKeyWithUid (GWIB (mainModuleNameIs dflags) NotBoot) uid)) unit_nodes++      do_linking =  main_sum || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib++  in if | ghcLink dflags == LinkBinary && isJust ofile && not do_linking ->+            Just (Left $ singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverRedirectedNoMain $ mainModuleNameIs dflags))+        -- This should be an error, not a warning (#10895).+        | do_linking -> Just (Right (LinkNode unit_nodes uid))+        | otherwise  -> Nothing++-- Note [Missing home modules]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Sometimes user doesn't want GHC to pick up modules, not explicitly listed+-- in a command line. For example, cabal may want to enable this warning+-- when building a library, so that GHC warns user about modules, not listed+-- neither in `exposed-modules`, nor in `other-modules`.+--+-- Here "home module" means a module, that doesn't come from an other package.+--+-- For example, if GHC is invoked with modules "A" and "B" as targets,+-- but "A" imports some other module "C", then GHC will issue a warning+-- about module "C" not being listed in a command line.+--+-- The warning in enabled by `-Wmissing-home-modules`. See #13129+warnMissingHomeModules ::  DynFlags -> [Target] -> ModuleGraph -> DriverMessages+warnMissingHomeModules dflags targets mod_graph =+    if null missing+      then emptyMessages+      else warn+  where+    diag_opts = initDiagOpts dflags++    is_known_module mod = any (is_my_target mod) targets++    -- We need to be careful to handle the case where (possibly+    -- path-qualified) filenames (aka 'TargetFile') rather than module+    -- names are being passed on the GHC command-line.+    --+    -- For instance, `ghc --make src-exe/Main.hs` and+    -- `ghc --make -isrc-exe Main` are supposed to be equivalent.+    -- Note also that we can't always infer the associated module name+    -- directly from the filename argument.  See #13727.+    is_my_target mod target =+      let tuid = targetUnitId target+      in case targetId target of+          TargetModule name+            -> moduleName (ms_mod mod) == name+                && tuid == ms_unitid mod+          TargetFile target_file _+            | Just mod_file <- ml_hs_file (ms_location mod)+            ->+             target_file == mod_file ||++             --  Don't warn on B.hs-boot if B.hs is specified (#16551)+             addBootSuffix target_file == mod_file ||++             --  We can get a file target even if a module name was+             --  originally specified in a command line because it can+             --  be converted in guessTarget (by appending .hs/.lhs).+             --  So let's convert it back and compare with module name+             mkModuleName (fst $ splitExtension target_file)+              == moduleName (ms_mod mod)+          _ -> False++    missing = map (moduleName . ms_mod) $+      filter (not . is_known_module) $+        (filter (\ms -> ms_unitid ms == homeUnitId_ dflags)+                (mgModSummaries mod_graph))++    warn = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan+                         $ DriverMissingHomeModules missing (checkBuildingCabalPackage dflags)++-- Check that any modules we want to reexport or hide are actually in the package.+warnUnknownModules :: HscEnv -> DynFlags -> ModuleGraph -> IO DriverMessages+warnUnknownModules hsc_env dflags mod_graph = do+  reexported_warns <- filterM check_reexport (Set.toList reexported_mods)+  return $ final_msgs hidden_warns reexported_warns+  where+    diag_opts = initDiagOpts dflags++    unit_mods = Set.fromList (map ms_mod_name+                  (filter (\ms -> ms_unitid ms == homeUnitId_ dflags)+                       (mgModSummaries mod_graph)))++    reexported_mods = reexportedModules dflags+    hidden_mods     = hiddenModules dflags++    hidden_warns = hidden_mods `Set.difference` unit_mods++    lookupModule mn = findImportedModule hsc_env mn NoPkgQual++    check_reexport mn = do+      fr <- lookupModule mn+      case fr of+        Found _ m -> return (moduleUnitId m == homeUnitId_ dflags)+        _ -> return True+++    warn flag mod = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan+                         $ flag mod++    final_msgs hidden_warns reexported_warns+          =+        unionManyMessages $+          [warn DriverUnknownHiddenModules (Set.toList hidden_warns) | not (Set.null hidden_warns)]+          ++ [warn DriverUnknownReexportedModules reexported_warns | not (null reexported_warns)]++-- | Describes which modules of the module graph need to be loaded.+data LoadHowMuch+   = LoadAllTargets+     -- ^ Load all targets and its dependencies.+   | LoadUpTo HomeUnitModule+     -- ^ Load only the given module and its dependencies.+   | LoadDependenciesOf HomeUnitModule+     -- ^ Load only the dependencies of the given module, but not the module+     -- itself.++{-+Note [Caching HomeModInfo]+~~~~~~~~~~~~~~~~~~~~~~~~~~++API clients who call `load` like to cache the HomeModInfo in memory between+calls to this function. In the old days, this cache was a simple MVar which stored+a HomePackageTable. This was insufficient, as the interface files for boot modules+were not recorded in the cache. In the less old days, the cache was returned at the+end of load, and supplied at the start of load, however, this was not sufficient+because it didn't account for the possibility of exceptions such as SIGINT (#20780).++So now, in the current day, we have this ModIfaceCache abstraction which+can incrementally be updated during the process of upsweep. This allows us+to store interface files for boot modules in an exception-safe way.++When the final version of an interface file is completed then it is placed into+the cache. The contents of the cache is retrieved, and the cache cleared, by iface_clearCache.++Note that because we only store the ModIface and Linkable in the ModIfaceCache,+hydration and rehydration is totally irrelevant, and we just store the CachedIface as+soon as it is completed.++-}+++-- Abstract interface to a cache of HomeModInfo+-- See Note [Caching HomeModInfo]+data ModIfaceCache = ModIfaceCache { iface_clearCache :: IO [CachedIface]+                                   , iface_addToCache :: CachedIface -> IO () }++addHmiToCache :: ModIfaceCache -> HomeModInfo -> IO ()+addHmiToCache c (HomeModInfo i _ l) = iface_addToCache c (CachedIface i l)++data CachedIface = CachedIface { cached_modiface :: !ModIface+                               , cached_linkable :: !(Maybe Linkable) }++noIfaceCache :: Maybe ModIfaceCache+noIfaceCache = Nothing++newIfaceCache :: IO ModIfaceCache+newIfaceCache = do+  ioref <- newIORef []+  return $+    ModIfaceCache+      { iface_clearCache = atomicModifyIORef' ioref (\c -> ([], c))+      , iface_addToCache = \hmi -> atomicModifyIORef' ioref (\c -> (hmi:c, ()))+      }+++++-- | Try to load the program.  See 'LoadHowMuch' for the different modes.+--+-- This function implements the core of GHC's @--make@ mode.  It preprocesses,+-- compiles and loads the specified modules, avoiding re-compilation wherever+-- possible.  Depending on the backend (see 'DynFlags.backend' field) compiling+-- and loading may result in files being created on disk.+--+-- Calls the 'defaultWarnErrLogger' after each compiling each module, whether+-- successful or not.+--+-- If errors are encountered during dependency analysis, the module `depanalE`+-- returns together with the errors an empty ModuleGraph.+-- After processing this empty ModuleGraph, the errors of depanalE are thrown.+-- All other errors are reported using the 'defaultWarnErrLogger'.++load :: GhcMonad f => LoadHowMuch -> f SuccessFlag+load how_much = loadWithCache noIfaceCache how_much++mkBatchMsg :: HscEnv -> Messager+mkBatchMsg hsc_env =+  if length (hsc_all_home_unit_ids hsc_env) > 1+    -- This also displays what unit each module is from.+    then batchMultiMsg+    else batchMsg+++loadWithCache :: GhcMonad m => Maybe ModIfaceCache -> LoadHowMuch -> m SuccessFlag+loadWithCache cache how_much = do+    (errs, mod_graph) <- depanalE [] False                        -- #17459+    msg <- mkBatchMsg <$> getSession+    success <- load' cache how_much (Just msg) mod_graph+    if isEmptyMessages errs+      then pure success+      else throwErrors (fmap GhcDriverMessage errs)++-- Note [Unused packages]+-- ~~~~~~~~~~~~~~~~~~~~~~+-- Cabal passes `--package-id` flag for each direct dependency. But GHC+-- loads them lazily, so when compilation is done, we have a list of all+-- actually loaded packages. All the packages, specified on command line,+-- but never loaded, are probably unused dependencies.++warnUnusedPackages :: UnitState -> DynFlags -> ModuleGraph -> DriverMessages+warnUnusedPackages us dflags mod_graph =+    let diag_opts = initDiagOpts dflags++    -- Only need non-source imports here because SOURCE imports are always HPT+        loadedPackages = concat $+          mapMaybe (\(fs, mn) -> lookupModulePackage us (unLoc mn) fs)+            $ concatMap ms_imps (+              filter (\ms -> homeUnitId_ dflags == ms_unitid ms) (mgModSummaries mod_graph))++        used_args = Set.fromList $ map unitId loadedPackages++        resolve (u,mflag) = do+                  -- The units which we depend on via the command line explicitly+                  flag <- mflag+                  -- Which we can find the UnitInfo for (should be all of them)+                  ui <- lookupUnit us u+                  -- Which are not explicitly used+                  guard (Set.notMember (unitId ui) used_args)+                  return (unitId ui, unitPackageName ui, unitPackageVersion ui, flag)++        unusedArgs = mapMaybe resolve (explicitUnits us)++        warn = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan (DriverUnusedPackages unusedArgs)++    in if null unusedArgs+        then emptyMessages+        else warn+++-- | A ModuleGraphNode which also has a hs-boot file, and the list of nodes on any+-- path from module to its boot file.+data ModuleGraphNodeWithBootFile+  = ModuleGraphNodeWithBootFile ModuleGraphNode [ModuleGraphNode]++instance Outputable ModuleGraphNodeWithBootFile where+  ppr (ModuleGraphNodeWithBootFile mgn deps) = text "ModeGraphNodeWithBootFile: " <+> ppr mgn $$ ppr deps++getNode :: ModuleGraphNodeWithBootFile -> ModuleGraphNode+getNode (ModuleGraphNodeWithBootFile mgn _) = mgn+data BuildPlan = SingleModule ModuleGraphNode  -- A simple, single module all alone but *might* have an hs-boot file which isn't part of a cycle+               | ResolvedCycle [Either ModuleGraphNode ModuleGraphNodeWithBootFile]   -- A resolved cycle, linearised by hs-boot files+               | UnresolvedCycle [ModuleGraphNode] -- An actual cycle, which wasn't resolved by hs-boot files++instance Outputable BuildPlan where+  ppr (SingleModule mgn) = text "SingleModule" <> parens (ppr mgn)+  ppr (ResolvedCycle mgn)   = text "ResolvedCycle:" <+> ppr mgn+  ppr (UnresolvedCycle mgn) = text "UnresolvedCycle:" <+> ppr mgn+++-- Just used for an assertion+countMods :: BuildPlan -> Int+countMods (SingleModule _) = 1+countMods (ResolvedCycle ns) = length ns+countMods (UnresolvedCycle ns) = length ns++-- See Note [Upsweep] for a high-level description.+createBuildPlan :: ModuleGraph -> Maybe HomeUnitModule -> [BuildPlan]+createBuildPlan mod_graph maybe_top_mod =+    let -- Step 1: Compute SCCs without .hi-boot files, to find the cycles+        cycle_mod_graph = topSortModuleGraph True mod_graph maybe_top_mod++        -- Step 2: Reanalyse loops, with relevant boot modules, to solve the cycles.+        build_plan :: [BuildPlan]+        build_plan+          -- Fast path, if there are no boot modules just do a normal toposort+          | isEmptyModuleEnv boot_modules = collapseAcyclic $ topSortModuleGraph False mod_graph maybe_top_mod+          | otherwise = toBuildPlan cycle_mod_graph []++        toBuildPlan :: [SCC ModuleGraphNode] -> [ModuleGraphNode] -> [BuildPlan]+        toBuildPlan [] mgn = collapseAcyclic (topSortWithBoot mgn)+        toBuildPlan ((AcyclicSCC node):sccs) mgn = toBuildPlan sccs (node:mgn)+        -- Interesting case+        toBuildPlan ((CyclicSCC nodes):sccs) mgn =+          let acyclic = collapseAcyclic (topSortWithBoot mgn)+              -- Now perform another toposort but just with these nodes and relevant hs-boot files.+              -- The result should be acyclic, if it's not, then there's an unresolved cycle in the graph.+              mresolved_cycle = collapseSCC (topSortWithBoot nodes)+          in acyclic ++ [maybe (UnresolvedCycle nodes) ResolvedCycle mresolved_cycle] ++ toBuildPlan sccs []++        (mg, lookup_node) = moduleGraphNodes False (mgModSummaries' mod_graph)+        trans_deps_map = allReachable mg (mkNodeKey . node_payload)+        -- Compute the intermediate modules between a file and its hs-boot file.+        -- See Step 2a in Note [Upsweep]+        boot_path mn uid =+          map (summaryNodeSummary . expectJust "toNode" . lookup_node) $ Set.toList $+          -- Don't include the boot module itself+          Set.delete (NodeKey_Module (key IsBoot))  $+          -- Keep intermediate dependencies: as per Step 2a in Note [Upsweep], these are+          -- the transitive dependencies of the non-boot file which transitively depend+          -- on the boot file.+          Set.filter (\nk -> nodeKeyUnitId nk == uid  -- Cheap test+                              && (NodeKey_Module (key IsBoot)) `Set.member` expectJust "dep_on_boot" (M.lookup nk trans_deps_map)) $+          expectJust "not_boot_dep" (M.lookup (NodeKey_Module (key NotBoot)) trans_deps_map)+          where+            key ib = ModNodeKeyWithUid (GWIB mn ib) uid+++        -- An environment mapping a module to its hs-boot file and all nodes on the path between the two, if one exists+        boot_modules = mkModuleEnv+          [ (ms_mod ms, (m, boot_path (ms_mod_name ms) (ms_unitid ms))) | m@(ModuleNode _ ms) <- (mgModSummaries' mod_graph), isBootSummary ms == IsBoot]++        select_boot_modules :: [ModuleGraphNode] -> [ModuleGraphNode]+        select_boot_modules = mapMaybe (fmap fst . get_boot_module)++        get_boot_module :: (ModuleGraphNode -> Maybe (ModuleGraphNode, [ModuleGraphNode]))+        get_boot_module m = case m of ModuleNode _ ms | HsSrcFile <- ms_hsc_src ms -> lookupModuleEnv boot_modules (ms_mod ms); _ -> Nothing++        -- Any cycles should be resolved now+        collapseSCC :: [SCC ModuleGraphNode] -> Maybe [(Either ModuleGraphNode ModuleGraphNodeWithBootFile)]+        -- Must be at least two nodes, as we were in a cycle+        collapseSCC [AcyclicSCC node1, AcyclicSCC node2] = Just [toNodeWithBoot node1, toNodeWithBoot node2]+        collapseSCC (AcyclicSCC node : nodes) = (toNodeWithBoot node :) <$> collapseSCC nodes+        -- Cyclic+        collapseSCC _ = Nothing++        toNodeWithBoot :: (ModuleGraphNode -> Either ModuleGraphNode ModuleGraphNodeWithBootFile)+        toNodeWithBoot mn =+          case get_boot_module mn of+            -- The node doesn't have a boot file+            Nothing -> Left mn+            -- The node does have a boot file+            Just path -> Right (ModuleGraphNodeWithBootFile mn (snd path))++        -- The toposort and accumulation of acyclic modules is solely to pick-up+        -- hs-boot files which are **not** part of cycles.+        collapseAcyclic :: [SCC ModuleGraphNode] -> [BuildPlan]+        collapseAcyclic (AcyclicSCC node : nodes) = SingleModule node : collapseAcyclic nodes+        collapseAcyclic (CyclicSCC cy_nodes : nodes) = (UnresolvedCycle cy_nodes) : collapseAcyclic nodes+        collapseAcyclic [] = []++        topSortWithBoot nodes = topSortModules False (select_boot_modules nodes ++ nodes) Nothing+++  in++    assertPpr (sum (map countMods build_plan) == length (mgModSummaries' mod_graph))+              (vcat [text "Build plan missing nodes:", (text "PLAN:" <+> ppr (sum (map countMods build_plan))), (text "GRAPH:" <+> ppr (length (mgModSummaries' mod_graph )))])+              build_plan++-- | Generalized version of 'load' which also supports a custom+-- 'Messager' (for reporting progress) and 'ModuleGraph' (generally+-- produced by calling 'depanal'.+load' :: GhcMonad m => Maybe ModIfaceCache -> LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag+load' mhmi_cache how_much mHscMessage mod_graph = do+    modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph }+    guessOutputFile+    hsc_env <- getSession++    let dflags = hsc_dflags hsc_env+    let logger = hsc_logger hsc_env+    let interp = hscInterp hsc_env++    -- The "bad" boot modules are the ones for which we have+    -- B.hs-boot in the module graph, but no B.hs+    -- The downsweep should have ensured this does not happen+    -- (see msDeps)+    let all_home_mods =+          Set.fromList [ Module (ms_unitid s) (ms_mod_name s)+                    | s <- mgModSummaries mod_graph, isBootSummary s == NotBoot]+    -- TODO: Figure out what the correct form of this assert is. It's violated+    -- when you have HsBootMerge nodes in the graph: then you'll have hs-boot+    -- files without corresponding hs files.+    --  bad_boot_mods = [s        | s <- mod_graph, isBootSummary s,+    --                              not (ms_mod_name s `elem` all_home_mods)]+    -- assert (null bad_boot_mods ) return ()++    -- check that the module given in HowMuch actually exists, otherwise+    -- topSortModuleGraph will bomb later.+    let checkHowMuch (LoadUpTo m)           = checkMod m+        checkHowMuch (LoadDependenciesOf m) = checkMod m+        checkHowMuch _ = id++        checkMod m and_then+            | m `Set.member` all_home_mods = and_then+            | otherwise = do+                    liftIO $ errorMsg logger+                        (text "no such module:" <+> quotes (ppr (moduleUnit m) <> colon <> ppr (moduleName m)))+                    return Failed++    checkHowMuch how_much $ do++    -- mg2_with_srcimps drops the hi-boot nodes, returning a+    -- graph with cycles. It is just used for warning about unecessary source imports.+    let mg2_with_srcimps :: [SCC ModuleGraphNode]+        mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing++    -- If we can determine that any of the {-# SOURCE #-} imports+    -- are definitely unnecessary, then emit a warning.+    warnUnnecessarySourceImports (filterToposortToModules mg2_with_srcimps)++    let maybe_top_mod = case how_much of+                          LoadUpTo m           -> Just m+                          LoadDependenciesOf m -> Just m+                          _                    -> Nothing++        build_plan = createBuildPlan mod_graph maybe_top_mod+++    cache <- liftIO $ maybe (return []) iface_clearCache mhmi_cache+    let+        -- prune the HPT so everything is not retained when doing an+        -- upsweep.+        !pruned_cache = pruneCache cache+                            (flattenSCCs (filterToposortToModules  mg2_with_srcimps))+++    -- before we unload anything, make sure we don't leave an old+    -- interactive context around pointing to dead bindings.  Also,+    -- write an empty HPT to allow the old HPT to be GC'd.++    let pruneHomeUnitEnv hme = hme { homeUnitEnv_hpt = emptyHomePackageTable }+    setSession $ discardIC $ hscUpdateHUG (unitEnv_map pruneHomeUnitEnv) hsc_env++    -- Unload everything+    liftIO $ unload interp hsc_env++    liftIO $ debugTraceMsg logger 2 (hang (text "Ready for upsweep")+                                    2 (ppr build_plan))++    n_jobs <- case parMakeCount (hsc_dflags hsc_env) of+                    Nothing -> liftIO getNumProcessors+                    Just n  -> return n++    setSession $ hscUpdateHUG (unitEnv_map pruneHomeUnitEnv) hsc_env+    hsc_env <- getSession+    (upsweep_ok, hsc_env1) <- withDeferredDiagnostics $+      liftIO $ upsweep n_jobs hsc_env mhmi_cache mHscMessage (toCache pruned_cache) build_plan+    setSession hsc_env1+    case upsweep_ok of+      Failed -> loadFinish upsweep_ok+      Succeeded -> do+          liftIO $ debugTraceMsg logger 2 (text "Upsweep completely successful.")+          -- Clean up after ourselves+          liftIO $ cleanCurrentModuleTempFilesMaybe logger (hsc_tmpfs hsc_env1) dflags+          loadFinish upsweep_ok++++-- | Finish up after a load.+loadFinish :: GhcMonad m => SuccessFlag -> m SuccessFlag+-- Empty the interactive context and set the module context to the topmost+-- newly loaded module, or the Prelude if none were loaded.+loadFinish all_ok+  = do modifySession discardIC+       return all_ok+++-- | If there is no -o option, guess the name of target executable+-- by using top-level source file name as a base.+guessOutputFile :: GhcMonad m => m ()+guessOutputFile = modifySession $ \env ->+    -- Force mod_graph to avoid leaking env+    let !mod_graph = hsc_mod_graph env+        new_home_graph =+          flip unitEnv_map (hsc_HUG env) $ \hue ->+            let dflags = homeUnitEnv_dflags hue+                platform = targetPlatform dflags+                mainModuleSrcPath :: Maybe String+                mainModuleSrcPath = do+                  ms <- mgLookupModule mod_graph (mainModIs hue)+                  ml_hs_file (ms_location ms)+                name = fmap dropExtension mainModuleSrcPath++                -- MP: This exception is quite sensitive to being forced, if you+                -- force it here then the error message is different because it gets+                -- caught by a different error handler than the test (T9930fail) expects.+                -- Putting an exception into DynFlags is probably not a great design but+                -- I'll write this comment rather than more eagerly force the exception.+                name_exe = do+                  -- we must add the .exe extension unconditionally here, otherwise+                  -- when name has an extension of its own, the .exe extension will+                 -- not be added by GHC.Driver.Pipeline.exeFileName.  See #2248+                 !name' <- if platformOS platform == OSMinGW32+                           then fmap (<.> "exe") name+                           else name+                 mainModuleSrcPath' <- mainModuleSrcPath+                 -- #9930: don't clobber input files (unless they ask for it)+                 if name' == mainModuleSrcPath'+                   then throwGhcException . UsageError $+                        "default output name would overwrite the input file; " +++                        "must specify -o explicitly"+                   else Just name'+            in+              case outputFile_ dflags of+                Just _ -> hue+                Nothing -> hue {homeUnitEnv_dflags = dflags { outputFile_ = name_exe } }+    in env { hsc_unit_env = (hsc_unit_env env) { ue_home_unit_graph = new_home_graph } }++-- -----------------------------------------------------------------------------+--+-- | Prune the HomePackageTable+--+-- Before doing an upsweep, we can throw away:+--+--   - all ModDetails, all linked code+--   - all unlinked code that is out of date with respect to+--     the source file+--+-- This is VERY IMPORTANT otherwise we'll end up requiring 2x the+-- space at the end of the upsweep, because the topmost ModDetails of the+-- old HPT holds on to the entire type environment from the previous+-- compilation.+-- Note [GHC Heap Invariants]+pruneCache :: [CachedIface]+                      -> [ModSummary]+                      -> [HomeModInfo]+pruneCache hpt summ+  = strictMap prune hpt+  where prune (CachedIface { cached_modiface = iface+                           , cached_linkable = linkable+                           }) = HomeModInfo iface emptyModDetails linkable'+          where+           modl = moduleName (mi_module iface)+           linkable'+                | Just ms <- lookupUFM ms_map modl+                , mi_src_hash iface /= ms_hs_hash ms+                = Nothing+                | otherwise+                = linkable++        ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ]++-- ---------------------------------------------------------------------------+--+-- | Unloading+unload :: Interp -> HscEnv -> IO ()+unload interp hsc_env+  = case ghcLink (hsc_dflags hsc_env) of+        LinkInMemory -> Linker.unload interp hsc_env []+        _other -> return ()+++{- Parallel Upsweep++The parallel upsweep attempts to concurrently compile the modules in the+compilation graph using multiple Haskell threads.++The Algorithm++* The list of `MakeAction`s are created by `interpretBuildPlan`. A `MakeAction` is+a pair of an `IO a` action and a `MVar a`, where to place the result.+  The list is sorted topologically, so can be executed in order without fear of+  blocking.+* runPipelines takes this list and eventually passes it to runLoop which executes+  each action and places the result into the right MVar.+* The amount of parrelism is controlled by a semaphore. This is just used around the+  module compilation step, so that only the right number of modules are compiled at+  the same time which reduces overal memory usage and allocations.+* Each proper node has a LogQueue, which dictates where to send it's output.+* The LogQueue is placed into the LogQueueQueue when the action starts and a worker+  thread processes the LogQueueQueue printing logs for each module in a stable order.+* The result variable for an action producing `a` is of type `Maybe a`, therefore+  it is still filled on a failure. If a module fails to compile, the+  failure is propagated through the whole module graph and any modules which didn't+  depend on the failure can still be compiled. This behaviour also makes the code+  quite a bit cleaner.+-}+++{-++Note [--make mode]+~~~~~~~~~~~~~~~~~+There are two main parts to `--make` mode.++1. `downsweep`: Starts from the top of the module graph and computes dependencies.+2. `upsweep`: Starts from the bottom of the module graph and compiles modules.++The result of the downsweep is a 'ModuleGraph', which is then passed to 'upsweep' which+computers how to build this ModuleGraph.++Note [Upsweep]+~~~~~~~~~~~~~~+Upsweep takes a 'ModuleGraph' as input, computes a build plan and then executes+the plan in order to compile the project.++The first step is computing the build plan from a 'ModuleGraph'.++The output of this step is a `[BuildPlan]`, which is a topologically sorted plan for+how to build all the modules.++```+data BuildPlan = SingleModule ModuleGraphNode  -- A simple, single module all alone but *might* have an hs-boot file which isn't part of a cycle+               | ResolvedCycle [Either ModuleGraphNode ModuleGraphNodeWithBoot]   -- A resolved cycle, linearised by hs-boot files+               | UnresolvedCycle [ModuleGraphNode] -- An actual cycle, which wasn't resolved by hs-boot files+```++The plan is computed in two steps:++Step 1:  Topologically sort the module graph without hs-boot files. This returns a [SCC ModuleGraphNode] which contains+         cycles.+Step 2:  For each cycle, topologically sort the modules in the cycle *with* the relevant hs-boot files. This should+         result in an acyclic build plan if the hs-boot files are sufficient to resolve the cycle.+Step 2a: For each module in the cycle, if the module has a boot file then compute the+         modules on the path between it and the hs-boot file.+         These are the intermediate modules which:+            (1) are (transitive) dependencies of the non-boot module, and+            (2) have the boot module as a (transitive) dependency.+         In particular, all such intermediate modules must appear in the same unit as+         the module under consideration, as module cycles cannot cross unit boundaries.+         This information is stored in ModuleGraphNodeWithBoot.++The `[BuildPlan]` is then interpreted by the `interpretBuildPlan` function.++* SingleModule nodes are compiled normally by either the upsweep_inst or upsweep_mod functions.+* ResolvedCycles need to compiled "together" so that modules outside the cycle are presented+  with a consistent knot-tied version of modules at the end.+    - When the ModuleGraphNodeWithBoot nodes are compiled then suitable rehydration+      is performed both before and after the module in question is compiled.+      See Note [Hydrating Modules] for more information.+* UnresolvedCycles are indicative of a proper cycle, unresolved by hs-boot files+  and are reported as an error to the user.++The main trickiness of `interpretBuildPlan` is deciding which version of a dependency+is visible from each module. For modules which are not in a cycle, there is just+one version of a module, so that is always used. For modules in a cycle, there are two versions of+'HomeModInfo'.++1. Internal to loop: The version created whilst compiling the loop by upsweep_mod.+2. External to loop: The knot-tied version created by typecheckLoop.++Whilst compiling a module inside the loop, we need to use the (1). For a module which+is outside of the loop which depends on something from in the loop, the (2) version+is used.++As the plan is interpreted, which version of a HomeModInfo is visible is updated+by updating a map held in a state monad. So after a loop has finished being compiled,+the visible module is the one created by typecheckLoop and the internal version is not+used again.++This plan also ensures the most important invariant to do with module loops:++> If you depend on anything within a module loop, before you can use the dependency,+  the whole loop has to finish compiling.++The end result of `interpretBuildPlan` is a `[MakeAction]`, which are pairs+of `IO a` actions and a `MVar (Maybe a)`, somewhere to put the result of running+the action. This list is topologically sorted, so can be run in order to compute+the whole graph.++As well as this `interpretBuildPlan` also outputs an `IO [Maybe (Maybe HomeModInfo)]` which+can be queried at the end to get the result of all modules at the end, with their proper+visibility. For example, if any module in a loop fails then all modules in that loop will+report as failed because the visible node at the end will be the result of checking+these modules together.++-}++-- | Simple wrapper around MVar which allows a functor instance.+data ResultVar b = forall a . ResultVar (a -> b) (MVar (Maybe a))++instance Functor ResultVar where+  fmap f (ResultVar g var) = ResultVar (f . g) var++mkResultVar :: MVar (Maybe a) -> ResultVar a+mkResultVar = ResultVar id++-- | Block until the result is ready.+waitResult :: ResultVar a -> MaybeT IO a+waitResult (ResultVar f var) = MaybeT (fmap f <$> readMVar var)+++data BuildLoopState = BuildLoopState { buildDep :: M.Map NodeKey (SDoc, ResultVar (Maybe HomeModInfo))+                                          -- The current way to build a specific TNodeKey, without cycles this just points to+                                          -- the appropiate result of compiling a module  but with+                                          -- cycles there can be additional indirection and can point to the result of typechecking a loop+                                     , nNODE :: Int+                                     , hug_var :: MVar HomeUnitGraph+                                     -- A global variable which is incrementally updated with the result+                                     -- of compiling modules.+                                     }++nodeId :: BuildM Int+nodeId = do+  n <- gets nNODE+  modify (\m -> m { nNODE = n + 1 })+  return n++setModulePipeline :: NodeKey -> SDoc -> ResultVar (Maybe HomeModInfo) -> BuildM ()+setModulePipeline mgn doc wrapped_pipeline = do+  modify (\m -> m { buildDep = M.insert mgn (doc, wrapped_pipeline) (buildDep m) })++getBuildMap :: BuildM (M.Map+                    NodeKey (SDoc, ResultVar (Maybe HomeModInfo)))+getBuildMap = gets buildDep++type BuildM a = StateT BuildLoopState IO a+++-- | Abstraction over the operations of a semaphore which allows usage with the+--  -j1 case+data AbstractSem = AbstractSem { acquireSem :: IO ()+                               , releaseSem :: IO () }++withAbstractSem :: AbstractSem -> IO b -> IO b+withAbstractSem sem = MC.bracket_ (acquireSem sem) (releaseSem sem)++-- | Environment used when compiling a module+data MakeEnv = MakeEnv { hsc_env :: !HscEnv -- The basic HscEnv which will be augmented for each module+                       , compile_sem :: !AbstractSem+                       -- Modify the environment for module k, with the supplied logger modification function.+                       -- For -j1, this wrapper doesn't do anything+                       -- For -jn, the wrapper initialised a log queue and then modifies the logger to pipe its output+                       --          into the log queue.+                       , withLogger :: forall a . Int -> ((Logger -> Logger) -> IO a) -> IO a+                       , env_messager :: !(Maybe Messager)+                       }++type RunMakeM a = ReaderT MakeEnv (MaybeT IO) a++-- | Given the build plan, creates a graph which indicates where each NodeKey should+-- get its direct dependencies from. This might not be the corresponding build action+-- if the module participates in a loop. This step also labels each node with a number for the output.+-- See Note [Upsweep] for a high-level description.+interpretBuildPlan :: HomeUnitGraph+                   -> Maybe ModIfaceCache+                   -> M.Map ModNodeKeyWithUid HomeModInfo+                   -> [BuildPlan]+                   -> IO ( Maybe [ModuleGraphNode] -- Is there an unresolved cycle+                         , [MakeAction] -- Actions we need to run in order to build everything+                         , IO [Maybe (Maybe HomeModInfo)]) -- An action to query to get all the built modules at the end.+interpretBuildPlan hug mhmi_cache old_hpt plan = do+  hug_var <- newMVar hug+  ((mcycle, plans), build_map) <- runStateT (buildLoop plan) (BuildLoopState M.empty 1 hug_var)+  let wait = collect_results (buildDep build_map)+  return (mcycle, plans, wait)++  where+    collect_results build_map =+      sequence (map (\(_doc, res_var) -> collect_result res_var) (M.elems build_map))+      where+        collect_result res_var = runMaybeT (waitResult res_var)++    n_mods = sum (map countMods plan)++    buildLoop :: [BuildPlan]+              -> BuildM (Maybe [ModuleGraphNode], [MakeAction])+    -- Build the abstract pipeline which we can execute+    -- Building finished+    buildLoop []           = return (Nothing, [])+    buildLoop (plan:plans) =+      case plan of+        -- If there was no cycle, then typecheckLoop is not necessary+        SingleModule m -> do+          (one_plan, _) <- buildSingleModule Nothing m+          (cycle, all_plans) <- buildLoop plans+          return (cycle, one_plan : all_plans)++        -- For a resolved cycle, depend on everything in the loop, then update+        -- the cache to point to this node rather than directly to the module build+        -- nodes+        ResolvedCycle ms -> do+          pipes <- buildModuleLoop ms+          (cycle, graph) <- buildLoop plans+          return (cycle, pipes ++ graph)++        -- Can't continue past this point as the cycle is unresolved.+        UnresolvedCycle ns -> return (Just ns, [])++    buildSingleModule :: Maybe [ModuleGraphNode]  -- Modules we need to rehydrate before compiling this module+                      -> ModuleGraphNode          -- The node we are compiling+                      -> BuildM (MakeAction, ResultVar (Maybe HomeModInfo))+    buildSingleModule rehydrate_nodes mod = do+      mod_idx <- nodeId+      home_mod_map <- getBuildMap+      hug_var <- gets hug_var+      -- 1. Get the transitive dependencies of this module, by looking up in the dependency map+      let direct_deps = nodeDependencies False mod+          doc_build_deps = map (expectJust "dep_map" . flip M.lookup home_mod_map) direct_deps+          build_deps = map snd doc_build_deps+      -- 2. Set the default way to build this node, not in a loop here+      let build_action = withCurrentUnit (moduleGraphNodeUnitId mod) $+            case mod of+              InstantiationNode uid iu ->+                const Nothing <$> executeInstantiationNode mod_idx n_mods (wait_deps_hug hug_var build_deps) uid iu+              ModuleNode _build_deps ms -> do+                  let !old_hmi = M.lookup (msKey ms) old_hpt+                      rehydrate_mods = mapMaybe moduleGraphNodeModule <$> rehydrate_nodes+                  hmi <- executeCompileNode mod_idx n_mods old_hmi (wait_deps_hug hug_var build_deps) rehydrate_mods ms++                  -- Write the HMI to an external cache (if one exists)+                  -- See Note [Caching HomeModInfo]+                  liftIO $ forM mhmi_cache $ \hmi_cache -> addHmiToCache hmi_cache hmi+                  -- This global MVar is incrementally modified in order to avoid having to+                  -- recreate the HPT before compiling each module which leads to a quadratic amount of work.+                  hsc_env <- asks hsc_env+                  hmi' <- liftIO $ modifyMVar hug_var (\hug -> do+                    let new_hpt = addHomeModInfoToHug hmi hug+                        new_hsc = setHUG new_hpt hsc_env+                    maybeRehydrateAfter hmi new_hsc rehydrate_mods+                      )+                  return (Just hmi')+              LinkNode _nks uid -> do+                  executeLinkNode (wait_deps_hug hug_var build_deps) (mod_idx, n_mods) uid direct_deps+                  return Nothing+++      res_var <- liftIO newEmptyMVar+      let result_var = mkResultVar res_var+      setModulePipeline (mkNodeKey mod) (text "N") result_var+      return $ (MakeAction build_action res_var, result_var)+++    buildOneLoopyModule ::  ModuleGraphNodeWithBootFile -> BuildM (MakeAction, (ResultVar (Maybe HomeModInfo)))+    buildOneLoopyModule (ModuleGraphNodeWithBootFile mn deps) =+      buildSingleModule (Just deps) mn++    buildModuleLoop :: [Either ModuleGraphNode ModuleGraphNodeWithBootFile] ->  BuildM [MakeAction]+    buildModuleLoop ms = do+      (build_modules, wait_modules) <- mapAndUnzipM (either (buildSingleModule Nothing) buildOneLoopyModule) ms+      res_var <- liftIO newEmptyMVar+      let loop_action = wait_deps wait_modules+      let fanout i = Just . (!! i) <$> mkResultVar res_var+      -- From outside the module loop, anyone must wait for the loop to finish and then+      -- use the result of the rehydrated iface. This makes sure that things not in the+      -- module loop will see the updated interfaces for all the identifiers in the loop.+      let update_module_pipeline (m, i) = setModulePipeline (NodeKey_Module m) (text "T") (fanout i)++      let ms_i = zip (mapMaybe (fmap msKey . moduleGraphNodeModSum . either id getNode) ms) [0..]+      mapM update_module_pipeline ms_i+      return $ build_modules ++ [MakeAction loop_action res_var]+++withCurrentUnit :: UnitId -> RunMakeM a -> RunMakeM a+withCurrentUnit uid = do+  local (\env -> env { hsc_env = hscSetActiveUnitId uid (hsc_env env)})+++upsweep+    :: Int -- ^ The number of workers we wish to run in parallel+    -> HscEnv -- ^ The base HscEnv, which is augmented for each module+    -> Maybe ModIfaceCache -- ^ A cache to incrementally write final interface files to+    -> Maybe Messager+    -> M.Map ModNodeKeyWithUid HomeModInfo+    -> [BuildPlan]+    -> IO (SuccessFlag, HscEnv)+upsweep n_jobs hsc_env hmi_cache mHscMessage old_hpt build_plan = do+    (cycle, pipelines, collect_result) <- interpretBuildPlan (hsc_HUG hsc_env) hmi_cache old_hpt build_plan+    runPipelines n_jobs hsc_env mHscMessage pipelines+    res <- collect_result++    let completed = [m | Just (Just m) <- res]+    let hsc_env' = addDepsToHscEnv completed hsc_env++    -- Handle any cycle in the original compilation graph and return the result+    -- of the upsweep.+    case cycle of+        Just mss -> do+          let logger = hsc_logger hsc_env+          liftIO $ fatalErrorMsg logger (cyclicModuleErr mss)+          return (Failed, hsc_env)+        Nothing  -> do+          let success_flag = successIf (all isJust res)+          return (success_flag, hsc_env')++toCache :: [HomeModInfo] -> M.Map (ModNodeKeyWithUid) HomeModInfo+toCache hmis = M.fromList ([(miKey $ hm_iface hmi, hmi) | hmi <- hmis])++miKey :: ModIface -> ModNodeKeyWithUid+miKey hmi = ModNodeKeyWithUid (mi_mnwib hmi) ((toUnitId $ moduleUnit (mi_module hmi)))++upsweep_inst :: HscEnv+             -> Maybe Messager+             -> Int  -- index of module+             -> Int  -- total number of modules+             -> UnitId+             -> InstantiatedUnit+             -> IO ()+upsweep_inst hsc_env mHscMessage mod_index nmods uid iuid = do+        case mHscMessage of+            Just hscMessage -> hscMessage hsc_env (mod_index, nmods) (NeedsRecompile MustCompile) (InstantiationNode uid iuid)+            Nothing -> return ()+        runHsc hsc_env $ ioMsgMaybe $ hoistTcRnMessage $ tcRnCheckUnit hsc_env $ VirtUnit iuid+        pure ()++-- | Compile a single module.  Always produce a Linkable for it if+-- successful.  If no compilation happened, return the old Linkable.+upsweep_mod :: HscEnv+            -> Maybe Messager+            -> Maybe HomeModInfo+            -> ModSummary+            -> Int  -- index of module+            -> Int  -- total number of modules+            -> IO HomeModInfo+upsweep_mod hsc_env mHscMessage old_hmi summary mod_index nmods =  do+  hmi <- compileOne' mHscMessage hsc_env summary+          mod_index nmods (hm_iface <$> old_hmi) (old_hmi >>= hm_linkable)++  -- MP: This is a bit janky, because before you add the entries you have to extend the HPT with the module+  -- you just compiled. Another option, would be delay adding anything until after upsweep has finished, but I+  -- am unsure if this is sound (wrt running TH splices for example).+  -- This function only does anything if the linkable produced is a BCO, which only happens with the+  -- bytecode backend, no need to guard against the backend type additionally.+  addSptEntries (hscUpdateHPT (\hpt -> addToHpt hpt (ms_mod_name summary) hmi) hsc_env)+                (hm_linkable hmi)++  return hmi++-- | Add the entries from a BCO linkable to the SPT table, see+-- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.+addSptEntries :: HscEnv -> Maybe Linkable -> IO ()+addSptEntries hsc_env mlinkable =+  hscAddSptEntries hsc_env+     [ spt+     | Just linkable <- [mlinkable]+     , unlinked <- linkableUnlinked linkable+     , BCOs _ spts <- pure unlinked+     , spt <- spts+     ]++{- Note [-fno-code mode]+~~~~~~~~~~~~~~~~~~~~~~~~+GHC offers the flag -fno-code for the purpose of parsing and typechecking a+program without generating object files. This is intended to be used by tooling+and IDEs to provide quick feedback on any parser or type errors as cheaply as+possible.++When GHC is invoked with -fno-code no object files or linked output will be+generated. As many errors and warnings as possible will be generated, as if+-fno-code had not been passed. The session DynFlags will have+backend == NoBackend.++-fwrite-interface+~~~~~~~~~~~~~~~~+Whether interface files are generated in -fno-code mode is controlled by the+-fwrite-interface flag. The -fwrite-interface flag is a no-op if -fno-code is+not also passed. Recompilation avoidance requires interface files, so passing+-fno-code without -fwrite-interface should be avoided. If -fno-code were+re-implemented today, -fwrite-interface would be discarded and it would be+considered always on; this behaviour is as it is for backwards compatibility.++================================================================+IN SUMMARY: ALWAYS PASS -fno-code AND -fwrite-interface TOGETHER+================================================================++Template Haskell+~~~~~~~~~~~~~~~~+A module using template haskell may invoke an imported function from inside a+splice. This will cause the type-checker to attempt to execute that code, which+would fail if no object files had been generated. See #8025. To rectify this,+during the downsweep we patch the DynFlags in the ModSummary of any home module+that is imported by a module that uses template haskell, to generate object+code.++The flavour of generated object code is chosen by defaultObjectTarget for the+target platform. It would likely be faster to generate bytecode, but this is not+supported on all platforms(?Please Confirm?), and does not support the entirety+of GHC haskell. See #1257.++The object files (and interface files if -fwrite-interface is disabled) produced+for template haskell are written to temporary files.++Note that since template haskell can run arbitrary IO actions, -fno-code mode+is no more secure than running without it.++Potential TODOS:+~~~~~+* Remove -fwrite-interface and have interface files always written in -fno-code+  mode+* Both .o and .dyn_o files are generated for template haskell, but we only need+  .dyn_o. Fix it.+* In make mode, a message like+  Compiling A (A.hs, /tmp/ghc_123.o)+  is shown if downsweep enabled object code generation for A. Perhaps we should+  show "nothing" or "temporary object file" instead. Note that one+  can currently use -keep-tmp-files and inspect the generated file with the+  current behaviour.+* Offer a -no-codedir command line option, and write what were temporary+  object files there. This would speed up recompilation.+* Use existing object files (if they are up to date) instead of always+  generating temporary ones.+-}++-- Note [When source is considered modified]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- A number of functions in GHC.Driver accept a SourceModified argument, which+-- is part of how GHC determines whether recompilation may be avoided (see the+-- definition of the SourceModified data type for details).+--+-- Determining whether or not a source file is considered modified depends not+-- only on the source file itself, but also on the output files which compiling+-- that module would produce. This is done because GHC supports a number of+-- flags which control which output files should be produced, e.g. -fno-code+-- -fwrite-interface and -fwrite-ide-file; we must check not only whether the+-- source file has been modified since the last compile, but also whether the+-- source file has been modified since the last compile which produced all of+-- the output files which have been requested.+--+-- Specifically, a source file is considered unmodified if it is up-to-date+-- relative to all of the output files which have been requested. Whether or+-- not an output file is up-to-date depends on what kind of file it is:+--+-- * iface (.hi) files are considered up-to-date if (and only if) their+--   mi_src_hash field matches the hash of the source file,+--+-- * all other output files (.o, .dyn_o, .hie, etc) are considered up-to-date+--   if (and only if) their modification times on the filesystem are greater+--   than or equal to the modification time of the corresponding .hi file.+--+-- Why do we use '>=' rather than '>' for output files other than the .hi file?+-- If the filesystem has poor resolution for timestamps (e.g. FAT32 has a+-- resolution of 2 seconds), we may often find that the .hi and .o files have+-- the same modification time. Using >= is slightly unsafe, but it matches+-- make's behaviour.+--+-- This strategy allows us to do the minimum work necessary in order to ensure+-- that all the files the user cares about are up-to-date; e.g. we should not+-- worry about .o files if the user has indicated that they are not interested+-- in them via -fno-code. See also #9243.+--+-- Note that recompilation avoidance is dependent on .hi files being produced,+-- which does not happen if -fno-write-interface -fno-code is passed. That is,+-- passing -fno-write-interface -fno-code means that you cannot benefit from+-- recompilation avoidance. See also Note [-fno-code mode].+--+-- The correctness of this strategy depends on an assumption that whenever we+-- are producing multiple output files, the .hi file is always written first.+-- If this assumption is violated, we risk recompiling unnecessarily by+-- incorrectly regarding non-.hi files as outdated.+--++-- ---------------------------------------------------------------------------+--+-- | Topological sort of the module graph+topSortModuleGraph+          :: Bool+          -- ^ Drop hi-boot nodes? (see below)+          -> ModuleGraph+          -> Maybe HomeUnitModule+             -- ^ Root module name.  If @Nothing@, use the full graph.+          -> [SCC ModuleGraphNode]+-- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes+-- The resulting list of strongly-connected-components is in topologically+-- sorted order, starting with the module(s) at the bottom of the+-- dependency graph (ie compile them first) and ending with the ones at+-- the top.+--+-- Drop hi-boot nodes (first boolean arg)?+--+-- - @False@:   treat the hi-boot summaries as nodes of the graph,+--              so the graph must be acyclic+--+-- - @True@:    eliminate the hi-boot nodes, and instead pretend+--              the a source-import of Foo is an import of Foo+--              The resulting graph has no hi-boot nodes, but can be cyclic+topSortModuleGraph drop_hs_boot_nodes module_graph mb_root_mod =+    -- stronglyConnCompG flips the original order, so if we reverse+    -- the summaries we get a stable topological sort.+  topSortModules drop_hs_boot_nodes (reverse $ mgModSummaries' module_graph) mb_root_mod++topSortModules :: Bool -> [ModuleGraphNode] -> Maybe HomeUnitModule -> [SCC ModuleGraphNode]+topSortModules drop_hs_boot_nodes summaries mb_root_mod+  = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph+  where+    (graph, lookup_node) =+      moduleGraphNodes drop_hs_boot_nodes summaries++    initial_graph = case mb_root_mod of+        Nothing -> graph+        Just (Module uid root_mod) ->+            -- restrict the graph to just those modules reachable from+            -- the specified module.  We do this by building a graph with+            -- the full set of nodes, and determining the reachable set from+            -- the specified node.+            let root | Just node <- lookup_node $ NodeKey_Module $ ModNodeKeyWithUid (GWIB root_mod NotBoot) uid+                     , graph `hasVertexG` node+                     = node+                     | otherwise+                     = throwGhcException (ProgramError "module does not exist")+            in graphFromEdgedVerticesUniq (seq root (reachableG graph root))++newtype ModNodeMap a = ModNodeMap { unModNodeMap :: Map.Map ModNodeKey a }+  deriving (Functor, Traversable, Foldable)++emptyModNodeMap :: ModNodeMap a+emptyModNodeMap = ModNodeMap Map.empty++modNodeMapInsert :: ModNodeKey -> a -> ModNodeMap a -> ModNodeMap a+modNodeMapInsert k v (ModNodeMap m) = ModNodeMap (Map.insert k v m)++modNodeMapElems :: ModNodeMap a -> [a]+modNodeMapElems (ModNodeMap m) = Map.elems m++modNodeMapLookup :: ModNodeKey -> ModNodeMap a -> Maybe a+modNodeMapLookup k (ModNodeMap m) = Map.lookup k m++modNodeMapSingleton :: ModNodeKey -> a -> ModNodeMap a+modNodeMapSingleton k v = ModNodeMap (M.singleton k v)++modNodeMapUnionWith :: (a -> a -> a) -> ModNodeMap a -> ModNodeMap a -> ModNodeMap a+modNodeMapUnionWith f (ModNodeMap m) (ModNodeMap n) = ModNodeMap (M.unionWith f m n)++-- | If there are {-# SOURCE #-} imports between strongly connected+-- components in the topological sort, then those imports can+-- definitely be replaced by ordinary non-SOURCE imports: if SOURCE+-- were necessary, then the edge would be part of a cycle.+warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()+warnUnnecessarySourceImports sccs = do+  diag_opts <- initDiagOpts <$> getDynFlags+  when (diag_wopt Opt_WarnUnusedImports diag_opts) $ do+    let check ms =+           let mods_in_this_cycle = map ms_mod_name ms in+           [ warn i | m <- ms, i <- ms_home_srcimps m,+                      unLoc i `notElem`  mods_in_this_cycle ]++        warn :: Located ModuleName -> MsgEnvelope GhcMessage+        warn (L loc mod) = GhcDriverMessage <$> mkPlainMsgEnvelope diag_opts+                                                  loc (DriverUnnecessarySourceImports mod)+    logDiagnostics (mkMessages $ listToBag (concatMap (check . flattenSCC) sccs))+++-- This caches the answer to the question, if we are in this unit, what does+-- an import of this module mean.+type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either DriverMessages ModSummary]++-----------------------------------------------------------------------------+--+-- | Downsweep (dependency analysis)+--+-- Chase downwards from the specified root set, returning summaries+-- for all home modules encountered.  Only follow source-import+-- links.+--+-- We pass in the previous collection of summaries, which is used as a+-- cache to avoid recalculating a module summary if the source is+-- unchanged.+--+-- The returned list of [ModSummary] nodes has one node for each home-package+-- module, plus one for any hs-boot files.  The imports of these nodes+-- are all there, including the imports of non-home-package modules.+downsweep :: HscEnv+          -> [ModSummary]+          -- ^ Old summaries+          -> [ModuleName]       -- Ignore dependencies on these; treat+                                -- them as if they were package modules+          -> Bool               -- True <=> allow multiple targets to have+                                --          the same module name; this is+                                --          very useful for ghc -M+          -> IO ([DriverMessages], [ModuleGraphNode])+                -- The non-error elements of the returned list all have distinct+                -- (Modules, IsBoot) identifiers, unless the Bool is true in+                -- which case there can be repeats+downsweep hsc_env old_summaries excl_mods allow_dup_roots+   = do+       rootSummaries <- mapM getRootSummary roots+       let (root_errs, rootSummariesOk) = partitionEithers rootSummaries -- #17549+           root_map = mkRootMap rootSummariesOk+       checkDuplicates root_map+       (deps, pkg_deps, map0) <- loopSummaries rootSummariesOk (M.empty, Set.empty, root_map)+       let closure_errs = checkHomeUnitsClosed (hsc_unit_env hsc_env) (hsc_all_home_unit_ids hsc_env) (Set.toList pkg_deps)+       let unit_env = hsc_unit_env hsc_env+       let tmpfs    = hsc_tmpfs    hsc_env++       let downsweep_errs = lefts $ concat $ M.elems map0+           downsweep_nodes = M.elems deps++           (other_errs, unit_nodes) = partitionEithers $ unitEnv_foldWithKey (\nodes uid hue -> nodes ++ unitModuleNodes downsweep_nodes uid hue) [] (hsc_HUG hsc_env)+           all_nodes = downsweep_nodes ++ unit_nodes+           all_errs  = all_root_errs ++  downsweep_errs ++ other_errs+           all_root_errs =  closure_errs ++ map snd root_errs++       -- if we have been passed -fno-code, we enable code generation+       -- for dependencies of modules that have -XTemplateHaskell,+       -- otherwise those modules will fail to compile.+       -- See Note [-fno-code mode] #8025+       th_enabled_nodes <- enableCodeGenForTH logger tmpfs unit_env all_nodes+       if null all_root_errs+         then return (all_errs, th_enabled_nodes)+         else pure $ (all_root_errs, [])+     where+        -- Dependencies arising on a unit (backpack and module linking deps)+        unitModuleNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> [Either (Messages DriverMessage) ModuleGraphNode]+        unitModuleNodes summaries uid hue =+          let instantiation_nodes = instantiationNodes uid (homeUnitEnv_units hue)+          in map Right instantiation_nodes+              ++ maybeToList (linkNodes (instantiation_nodes ++ summaries) uid hue)++        calcDeps ms =+          -- Add a dependency on the HsBoot file if it exists+          -- This gets passed to the loopImports function which just ignores it if it+          -- can't be found.+          [(ms_unitid ms, NoPkgQual, GWIB (noLoc $ ms_mod_name ms) IsBoot) | NotBoot <- [isBootSummary ms] ] +++          [(ms_unitid ms, b, c) | (b, c) <- msDeps ms ]++        logger = hsc_logger hsc_env+        roots  = hsc_targets hsc_env++        -- A cache from file paths to the already summarised modules.+        -- Reuse these if we can because the most expensive part of downsweep is+        -- reading the headers.+        old_summary_map :: M.Map FilePath ModSummary+        old_summary_map = M.fromList [(msHsFilePath ms, ms) | ms <- old_summaries]++        getRootSummary :: Target -> IO (Either (UnitId, DriverMessages) ModSummary)+        getRootSummary Target { targetId = TargetFile file mb_phase+                              , targetContents = maybe_buf+                              , targetUnitId = uid+                              }+           = do let offset_file = augmentByWorkingDirectory dflags file+                exists <- liftIO $ doesFileExist offset_file+                if exists || isJust maybe_buf+                    then first (uid,) <$>+                        summariseFile hsc_env home_unit old_summary_map offset_file mb_phase+                                       maybe_buf+                    else return $ Left $ (uid,) $ singleMessage+                                $ mkPlainErrorMsgEnvelope noSrcSpan (DriverFileNotFound offset_file)+            where+              dflags = homeUnitEnv_dflags (ue_findHomeUnitEnv uid (hsc_unit_env hsc_env))+              home_unit = ue_unitHomeUnit uid (hsc_unit_env hsc_env)+        getRootSummary Target { targetId = TargetModule modl+                              , targetContents = maybe_buf+                              , targetUnitId = uid+                              }+           = do maybe_summary <- summariseModule hsc_env home_unit old_summary_map NotBoot+                                           (L rootLoc modl) (ThisPkg (homeUnitId home_unit))+                                           maybe_buf excl_mods+                case maybe_summary of+                   FoundHome s  -> return (Right s)+                   FoundHomeWithError err -> return (Left err)+                   _ -> return $ Left $ (uid, moduleNotFoundErr modl)+            where+              home_unit = ue_unitHomeUnit uid (hsc_unit_env hsc_env)+        rootLoc = mkGeneralSrcSpan (fsLit "<command line>")++        -- In a root module, the filename is allowed to diverge from the module+        -- name, so we have to check that there aren't multiple root files+        -- defining the same module (otherwise the duplicates will be silently+        -- ignored, leading to confusing behaviour).+        checkDuplicates+          :: DownsweepCache+          -> IO ()+        checkDuplicates root_map+           | allow_dup_roots = return ()+           | null dup_roots  = return ()+           | otherwise       = liftIO $ multiRootsErr (head dup_roots)+           where+             dup_roots :: [[ModSummary]]        -- Each at least of length 2+             dup_roots = filterOut isSingleton $ map rights (M.elems root_map)++        -- This loops over all the mod summaries in the dependency graph, accumulates the actual dependencies for each module/unit+        loopSummaries :: [ModSummary]+              -> (M.Map NodeKey ModuleGraphNode, Set.Set (UnitId, UnitId),+                    DownsweepCache)+              -> IO ((M.Map NodeKey ModuleGraphNode), Set.Set (UnitId, UnitId), DownsweepCache)+        loopSummaries [] done = return done+        loopSummaries (ms:next) (done, pkgs, summarised)+          | Just {} <- M.lookup k done+          = loopSummaries next (done, pkgs, summarised)+          -- Didn't work out what the imports mean yet, now do that.+          | otherwise = do+             (final_deps, pkgs1, done', summarised') <- loopImports (calcDeps ms) done summarised+             -- This has the effect of finding a .hs file if we are looking at the .hs-boot file.+             (_, _, done'', summarised'') <- loopImports (maybeToList hs_file_for_boot) done' summarised'+             loopSummaries next (M.insert k (ModuleNode final_deps ms) done'', pkgs1 `Set.union` pkgs, summarised'')+          where+            k = NodeKey_Module (msKey ms)++            hs_file_for_boot+              | HsBootFile <- ms_hsc_src ms = Just $ ((ms_unitid ms), NoPkgQual, (GWIB (noLoc $ ms_mod_name ms) NotBoot))+              | otherwise = Nothing+++        -- This loops over each import in each summary. It is mutually recursive with loopSummaries if we discover+        -- a new module by doing this.+        loopImports :: [(UnitId, PkgQual, GenWithIsBoot (Located ModuleName))]+                        -- Work list: process these modules+             -> M.Map NodeKey ModuleGraphNode+             -> DownsweepCache+                        -- Visited set; the range is a list because+                        -- the roots can have the same module names+                        -- if allow_dup_roots is True+             -> IO ([NodeKey], Set.Set (UnitId, UnitId),++                  M.Map NodeKey ModuleGraphNode, DownsweepCache)+                        -- The result is the completed NodeMap+        loopImports [] done summarised = return ([], Set.empty, done, summarised)+        loopImports ((home_uid,mb_pkg, gwib) : ss) done summarised+          | Just summs <- M.lookup cache_key summarised+          = case summs of+              [Right ms] -> do+                let nk = NodeKey_Module (msKey ms)+                (rest, pkgs, summarised', done') <- loopImports ss done summarised+                return (nk: rest, pkgs, summarised', done')+              [Left _err] ->+                loopImports ss done summarised+              _errs ->  do+                loopImports ss done summarised+          | otherwise+          = do+               mb_s <- summariseModule hsc_env home_unit old_summary_map+                                       is_boot wanted_mod mb_pkg+                                       Nothing excl_mods+               case mb_s of+                   NotThere -> loopImports ss done summarised+                   External uid -> do+                    (other_deps, pkgs, done', summarised') <- loopImports ss done summarised+                    return (other_deps, Set.insert (homeUnitId home_unit, uid) pkgs, done', summarised')+                   FoundInstantiation iud -> do+                    (other_deps, pkgs, done', summarised') <- loopImports ss done summarised+                    return (NodeKey_Unit iud : other_deps, pkgs, done', summarised')+                   FoundHomeWithError (_uid, e) ->  loopImports ss done (Map.insert cache_key [(Left e)] summarised)+                   FoundHome s -> do+                     (done', pkgs1, summarised') <-+                       loopSummaries [s] (done, Set.empty, Map.insert cache_key [Right s] summarised)+                     (other_deps, pkgs2, final_done, final_summarised) <- loopImports ss done' summarised'++                     -- MP: This assumes that we can only instantiate non home units, which is probably fair enough for now.+                     return (NodeKey_Module (msKey s) : other_deps, pkgs1 `Set.union` pkgs2, final_done, final_summarised)+          where+            cache_key = (home_uid, mb_pkg, unLoc <$> gwib)+            home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env)+            GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib+            wanted_mod = L loc mod++-- This function checks then important property that if both p and q are home units+-- then any dependency of p, which transitively depends on q is also a home unit.+checkHomeUnitsClosed ::  UnitEnv -> Set.Set UnitId -> [(UnitId, UnitId)] -> [DriverMessages]+-- Fast path, trivially closed.+checkHomeUnitsClosed ue home_id_set home_imp_ids+  | Set.size home_id_set == 1 = []+  | otherwise =+  let res = foldMap loop home_imp_ids+  -- Now check whether everything which transitively depends on a home_unit is actually a home_unit+  -- These units are the ones which we need to load as home packages but failed to do for some reason,+  -- it's a bug in the tool invoking GHC.+      bad_unit_ids = Set.difference res home_id_set+  in if Set.null bad_unit_ids+        then []+        else [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (Set.toList bad_unit_ids)]++  where+    rootLoc = mkGeneralSrcSpan (fsLit "<command line>")+    -- TODO: This could repeat quite a bit of work but I struggled to write this function.+    -- Which units transitively depend on a home unit+    loop :: (UnitId, UnitId) -> Set.Set UnitId -- The units which transitively depend on a home unit+    loop (from_uid, uid) =+      let us = ue_findHomeUnitEnv from_uid ue in+      let um = unitInfoMap (homeUnitEnv_units us) in+      case Map.lookup uid um of+        Nothing -> pprPanic "uid not found" (ppr uid)+        Just ui ->+          let depends = unitDepends ui+              home_depends = Set.fromList depends `Set.intersection` home_id_set+              other_depends = Set.fromList depends `Set.difference` home_id_set+          in+            -- Case 1: The unit directly depends on a home_id+            if not (null home_depends)+              then+                let res = foldMap (loop . (from_uid,)) other_depends+                in Set.insert uid res+             -- Case 2: Check the rest of the dependencies, and then see if any of them depended on+              else+                let res = foldMap (loop . (from_uid,)) other_depends+                in+                  if not (Set.null res)+                    then Set.insert uid res+                    else res++-- | Update the every ModSummary that is depended on+-- by a module that needs template haskell. We enable codegen to+-- the specified target, disable optimization and change the .hi+-- and .o file locations to be temporary files.+-- See Note [-fno-code mode]+enableCodeGenForTH+  :: Logger+  -> TmpFs+  -> UnitEnv+  -> [ModuleGraphNode]+  -> IO [ModuleGraphNode]+enableCodeGenForTH logger tmpfs unit_env =+  enableCodeGenWhen logger tmpfs TFL_CurrentModule TFL_GhcSession unit_env++-- | Helper used to implement 'enableCodeGenForTH'.+-- In particular, this enables+-- unoptimized code generation for all modules that meet some+-- condition (first parameter), or are dependencies of those+-- modules. The second parameter is a condition to check before+-- marking modules for code generation.+enableCodeGenWhen+  :: Logger+  -> TmpFs+  -> TempFileLifetime+  -> TempFileLifetime+  -> UnitEnv+  -> [ModuleGraphNode]+  -> IO [ModuleGraphNode]+enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph =+  mapM enable_code_gen mod_graph+  where+    defaultBackendOf ms = platformDefaultBackend (targetPlatform $ ue_unitFlags (ms_unitid ms) unit_env)+    enable_code_gen :: ModuleGraphNode -> IO ModuleGraphNode+    enable_code_gen n@(ModuleNode deps ms)+      | ModSummary+        { ms_location = ms_location+        , ms_hsc_src = HsSrcFile+        , ms_hspp_opts = dflags+        } <- ms+      , mkNodeKey n `Set.member` needs_codegen_set =+      if | nocode_enable ms -> do+               let new_temp_file suf dynsuf = do+                     tn <- newTempName logger tmpfs (tmpDir dflags) staticLife suf+                     let dyn_tn = tn -<.> dynsuf+                     addFilesToClean tmpfs dynLife [dyn_tn]+                     return (tn, dyn_tn)+                 -- We don't want to create .o or .hi files unless we have been asked+                 -- to by the user. But we need them, so we patch their locations in+                 -- the ModSummary with temporary files.+                 --+               ((hi_file, dyn_hi_file), (o_file, dyn_o_file)) <-+                 -- If ``-fwrite-interface` is specified, then the .o and .hi files+                 -- are written into `-odir` and `-hidir` respectively.  #16670+                 if gopt Opt_WriteInterface dflags+                   then return ((ml_hi_file ms_location, ml_dyn_hi_file ms_location)+                               , (ml_obj_file ms_location, ml_dyn_obj_file ms_location))+                   else (,) <$> (new_temp_file (hiSuf_ dflags) (dynHiSuf_ dflags))+                            <*> (new_temp_file (objectSuf_ dflags) (dynObjectSuf_ dflags))+               let ms' = ms+                     { ms_location =+                         ms_location { ml_hi_file = hi_file+                                     , ml_obj_file = o_file+                                     , ml_dyn_hi_file = dyn_hi_file+                                     , ml_dyn_obj_file = dyn_o_file }+                     , ms_hspp_opts = updOptLevel 0 $ dflags {backend = defaultBackendOf ms}+                     }+               -- Recursive call to catch the other cases+               enable_code_gen (ModuleNode deps ms')+         | dynamic_too_enable ms -> do+               let ms' = ms+                     { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_BuildDynamicToo+                     }+               -- Recursive call to catch the other cases+               enable_code_gen (ModuleNode deps ms')+         | ext_interp_enable ms -> do+               let ms' = ms+                     { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_ExternalInterpreter+                     }+               -- Recursive call to catch the other cases+               enable_code_gen (ModuleNode deps ms')++         | otherwise -> return n++    enable_code_gen ms = return ms++    nocode_enable ms@(ModSummary { ms_hspp_opts = dflags }) =+      backend dflags == NoBackend &&+      -- Don't enable codegen for TH on indefinite packages; we+      -- can't compile anything anyway! See #16219.+      isHomeUnitDefinite (ue_unitHomeUnit (ms_unitid ms) unit_env)++    -- #8180 - when using TemplateHaskell, switch on -dynamic-too so+    -- the linker can correctly load the object files.  This isn't necessary+    -- when using -fexternal-interpreter.+    dynamic_too_enable ms+      = hostIsDynamic && internalInterpreter &&+            not isDynWay && not isProfWay &&  not dyn_too_enabled+      where+       lcl_dflags   = ms_hspp_opts ms+       internalInterpreter = not (gopt Opt_ExternalInterpreter lcl_dflags)+       dyn_too_enabled =  (gopt Opt_BuildDynamicToo lcl_dflags)+       isDynWay    = hasWay (ways lcl_dflags) WayDyn+       isProfWay   = hasWay (ways lcl_dflags) WayProf++    -- #16331 - when no "internal interpreter" is available but we+    -- need to process some TemplateHaskell or QuasiQuotes, we automatically+    -- turn on -fexternal-interpreter.+    ext_interp_enable ms = not ghciSupported && internalInterpreter+      where+       lcl_dflags   = ms_hspp_opts ms+       internalInterpreter = not (gopt Opt_ExternalInterpreter lcl_dflags)+++++    (mg, lookup_node) = moduleGraphNodes False mod_graph+    needs_codegen_set = Set.fromList $ map (mkNodeKey . node_payload) $ reachablesG mg (map (expectJust "needs_th" . lookup_node) has_th_set)+++    has_th_set =+      [ mkNodeKey mn+      | mn@(ModuleNode _ ms) <- mod_graph+      , isTemplateHaskellOrQQNonBoot ms+      ]++-- | Populate the Downsweep cache with the root modules.+mkRootMap+  :: [ModSummary]+  -> DownsweepCache+mkRootMap summaries = Map.fromListWith (flip (++))+  [ ((ms_unitid s, NoPkgQual, ms_mnwib s), [Right s]) | s <- summaries ]++-----------------------------------------------------------------------------+-- Summarising modules++-- We have two types of summarisation:+--+--    * Summarise a file.  This is used for the root module(s) passed to+--      cmLoadModules.  The file is read, and used to determine the root+--      module name.  The module name may differ from the filename.+--+--    * Summarise a module.  We are given a module name, and must provide+--      a summary.  The finder is used to locate the file in which the module+--      resides.++summariseFile+        :: HscEnv+        -> HomeUnit+        -> M.Map FilePath ModSummary    -- old summaries+        -> FilePath                     -- source file name+        -> Maybe Phase                  -- start phase+        -> Maybe (StringBuffer,UTCTime)+        -> IO (Either DriverMessages ModSummary)++summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf+        -- we can use a cached summary if one is available and the+        -- source file hasn't changed,  But we have to look up the summary+        -- by source file, rather than module name as we do in summarise.+   | Just old_summary <- M.lookup src_fn old_summaries+   = do+        let location = ms_location $ old_summary++        src_hash <- get_src_hash+                -- The file exists; we checked in getRootSummary above.+                -- If it gets removed subsequently, then this+                -- getFileHash may fail, but that's the right+                -- behaviour.++                -- return the cached summary if the source didn't change+        checkSummaryHash+            hsc_env (new_summary src_fn)+            old_summary location src_hash++   | otherwise+   = do src_hash <- get_src_hash+        new_summary src_fn src_hash+  where+    -- change the main active unit so all operations happen relative to the given unit+    hsc_env = hscSetActiveHomeUnit home_unit hsc_env'+    -- src_fn does not necessarily exist on the filesystem, so we need to+    -- check what kind of target we are dealing with+    get_src_hash = case maybe_buf of+                      Just (buf,_) -> return $ fingerprintStringBuffer buf+                      Nothing -> liftIO $ getFileHash src_fn++    new_summary src_fn src_hash = runExceptT $ do+        preimps@PreprocessedImports {..}+            <- getPreprocessedImports hsc_env src_fn mb_phase maybe_buf++        let fopts = initFinderOpts (hsc_dflags hsc_env)++        -- Make a ModLocation for this file+        let location = mkHomeModLocation fopts pi_mod_name src_fn++        -- Tell the Finder cache where it is, so that subsequent calls+        -- to findModule will find it, even if it's not on any search path+        mod <- liftIO $ do+          let home_unit = hsc_home_unit hsc_env+          let fc        = hsc_FC hsc_env+          addHomeModuleToFinder fc home_unit pi_mod_name location++        liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary+            { nms_src_fn = src_fn+            , nms_src_hash = src_hash+            , nms_is_boot = NotBoot+            , nms_hsc_src =+                if isHaskellSigFilename src_fn+                   then HsigFile+                   else HsSrcFile+            , nms_location = location+            , nms_mod = mod+            , nms_preimps = preimps+            }++checkSummaryHash+    :: HscEnv+    -> (Fingerprint -> IO (Either e ModSummary))+    -> ModSummary -> ModLocation -> Fingerprint+    -> IO (Either e ModSummary)+checkSummaryHash+  hsc_env new_summary+  old_summary+  location src_hash+  | ms_hs_hash old_summary == src_hash &&+      not (gopt Opt_ForceRecomp (hsc_dflags hsc_env)) = do+           -- update the object-file timestamp+           obj_timestamp <- modificationTimeIfExists (ml_obj_file location)++           -- We have to repopulate the Finder's cache for file targets+           -- because the file might not even be on the regular search path+           -- and it was likely flushed in depanal. This is not technically+           -- needed when we're called from sumariseModule but it shouldn't+           -- hurt.+           -- Also, only add to finder cache for non-boot modules as the finder cache+           -- makes sure to add a boot suffix for boot files.+           _ <- do+              let fc        = hsc_FC hsc_env+              case ms_hsc_src old_summary of+                HsSrcFile -> addModuleToFinder fc (ms_mod old_summary) location+                _ -> return ()++           hi_timestamp <- modificationTimeIfExists (ml_hi_file location)+           hie_timestamp <- modificationTimeIfExists (ml_hie_file location)++           return $ Right+             ( old_summary+                     { ms_obj_date = obj_timestamp+                     , ms_iface_date = hi_timestamp+                     , ms_hie_date = hie_timestamp+                     }+             )++   | otherwise =+           -- source changed: re-summarise.+           new_summary src_hash++data SummariseResult =+        FoundInstantiation InstantiatedUnit+      | FoundHomeWithError (UnitId, DriverMessages)+      | FoundHome ModSummary+      | External UnitId+      | NotThere++-- Summarise a module, and pick up source and timestamp.+summariseModule+          :: HscEnv+          -> HomeUnit+          -> M.Map FilePath ModSummary+          -- ^ Map of old summaries+          -> IsBootInterface    -- True <=> a {-# SOURCE #-} import+          -> Located ModuleName -- Imported module to be summarised+          -> PkgQual+          -> Maybe (StringBuffer, UTCTime)+          -> [ModuleName]               -- Modules to exclude+          -> IO SummariseResult+++summariseModule hsc_env' home_unit old_summary_map is_boot (L _ wanted_mod) mb_pkg+                maybe_buf excl_mods+  | wanted_mod `elem` excl_mods+  = return NotThere+  | otherwise  = find_it+  where+    -- Temporarily change the currently active home unit so all operations+    -- happen relative to it+    hsc_env   = hscSetActiveHomeUnit home_unit hsc_env'+    dflags    = hsc_dflags hsc_env++    find_it :: IO SummariseResult++    find_it = do+        found <- findImportedModule hsc_env wanted_mod mb_pkg+        case found of+             Found location mod+                | isJust (ml_hs_file location) ->+                        -- Home package+                         just_found location mod+                | VirtUnit iud <- moduleUnit mod+                , not (isHomeModule home_unit mod)+                  -> return $ FoundInstantiation iud+                | otherwise -> return $ External (moduleUnitId mod)+             _ -> return NotThere+                        -- Not found+                        -- (If it is TRULY not found at all, we'll+                        -- error when we actually try to compile)++    just_found location mod = do+                -- Adjust location to point to the hs-boot source file,+                -- hi file, object file, when is_boot says so+        let location' = case is_boot of+              IsBoot -> addBootSuffixLocn location+              NotBoot -> location+            src_fn = expectJust "summarise2" (ml_hs_file location')++                -- Check that it exists+                -- It might have been deleted since the Finder last found it+        maybe_h <- fileHashIfExists src_fn+        case maybe_h of+          -- This situation can also happen if we have found the .hs file but the+          -- .hs-boot file doesn't exist.+          Nothing -> return NotThere+          Just h  -> do+            fresult <- new_summary_cache_check location' mod src_fn h+            return $ case fresult of+              Left err -> FoundHomeWithError (moduleUnitId mod, err)+              Right ms -> FoundHome ms++    new_summary_cache_check loc mod src_fn h+      | Just old_summary <- Map.lookup src_fn old_summary_map =++         -- check the hash on the source file, and+         -- return the cached summary if it hasn't changed.  If the+         -- file has changed then need to resummarise.+        case maybe_buf of+           Just (buf,_) ->+               checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc (fingerprintStringBuffer buf)+           Nothing    ->+               checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc h+      | otherwise = new_summary loc mod src_fn h++    new_summary :: ModLocation+                  -> Module+                  -> FilePath+                  -> Fingerprint+                  -> IO (Either DriverMessages ModSummary)+    new_summary location mod src_fn src_hash+      = runExceptT $ do+        preimps@PreprocessedImports {..}+            -- Remember to set the active unit here, otherwise the wrong include paths are passed to CPP+            -- See multiHomeUnits_cpp2 test+            <- getPreprocessedImports (hscSetActiveUnitId (moduleUnitId mod) hsc_env) src_fn Nothing maybe_buf++        -- NB: Despite the fact that is_boot is a top-level parameter, we+        -- don't actually know coming into this function what the HscSource+        -- of the module in question is.  This is because we may be processing+        -- this module because another module in the graph imported it: in this+        -- case, we know if it's a boot or not because of the {-# SOURCE #-}+        -- annotation, but we don't know if it's a signature or a regular+        -- module until we actually look it up on the filesystem.+        let hsc_src+              | is_boot == IsBoot = HsBootFile+              | isHaskellSigFilename src_fn = HsigFile+              | otherwise = HsSrcFile++        when (pi_mod_name /= wanted_mod) $+                throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc+                       $ DriverFileModuleNameMismatch pi_mod_name wanted_mod++        let instantiations = homeUnitInstantiations home_unit+        when (hsc_src == HsigFile && isNothing (lookup pi_mod_name instantiations)) $+            throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc+                   $ DriverUnexpectedSignature pi_mod_name (checkBuildingCabalPackage dflags) instantiations++        liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary+            { nms_src_fn = src_fn+            , nms_src_hash = src_hash+            , nms_is_boot = is_boot+            , nms_hsc_src = hsc_src+            , nms_location = location+            , nms_mod = mod+            , nms_preimps = preimps+            }++-- | Convenience named arguments for 'makeNewModSummary' only used to make+-- code more readable, not exported.+data MakeNewModSummary+  = MakeNewModSummary+      { nms_src_fn :: FilePath+      , nms_src_hash :: Fingerprint+      , nms_is_boot :: IsBootInterface+      , nms_hsc_src :: HscSource+      , nms_location :: ModLocation+      , nms_mod :: Module+      , nms_preimps :: PreprocessedImports+      }++makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ModSummary+makeNewModSummary hsc_env MakeNewModSummary{..} = do+  let PreprocessedImports{..} = nms_preimps+  obj_timestamp <- modificationTimeIfExists (ml_obj_file nms_location)+  dyn_obj_timestamp <- modificationTimeIfExists (ml_dyn_obj_file nms_location)+  hi_timestamp <- modificationTimeIfExists (ml_hi_file nms_location)+  hie_timestamp <- modificationTimeIfExists (ml_hie_file nms_location)++  extra_sig_imports <- findExtraSigImports hsc_env nms_hsc_src pi_mod_name+  (implicit_sigs, _inst_deps) <- implicitRequirementsShallow (hscSetActiveUnitId (moduleUnitId nms_mod) hsc_env) pi_theimps++  return $+        ModSummary+        { ms_mod = nms_mod+        , ms_hsc_src = nms_hsc_src+        , ms_location = nms_location+        , ms_hspp_file = pi_hspp_fn+        , ms_hspp_opts = pi_local_dflags+        , ms_hspp_buf  = Just pi_hspp_buf+        , ms_parsed_mod = Nothing+        , ms_srcimps = pi_srcimps+        , ms_ghc_prim_import = pi_ghc_prim_import+        , ms_textual_imps =+            ((,) NoPkgQual . noLoc <$> extra_sig_imports) +++            ((,) NoPkgQual . noLoc <$> implicit_sigs) +++            pi_theimps+        , ms_hs_hash = nms_src_hash+        , ms_iface_date = hi_timestamp+        , ms_hie_date = hie_timestamp+        , ms_obj_date = obj_timestamp+        , ms_dyn_obj_date = dyn_obj_timestamp+        }++data PreprocessedImports+  = PreprocessedImports+      { pi_local_dflags :: DynFlags+      , pi_srcimps  :: [(PkgQual, Located ModuleName)]+      , pi_theimps  :: [(PkgQual, Located ModuleName)]+      , pi_ghc_prim_import :: Bool+      , pi_hspp_fn  :: FilePath+      , pi_hspp_buf :: StringBuffer+      , pi_mod_name_loc :: SrcSpan+      , pi_mod_name :: ModuleName+      }++-- Preprocess the source file and get its imports+-- The pi_local_dflags contains the OPTIONS pragmas+getPreprocessedImports+    :: HscEnv+    -> FilePath+    -> Maybe Phase+    -> Maybe (StringBuffer, UTCTime)+    -- ^ optional source code buffer and modification time+    -> ExceptT DriverMessages IO PreprocessedImports+getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do+  (pi_local_dflags, pi_hspp_fn)+      <- ExceptT $ preprocess hsc_env src_fn (fst <$> maybe_buf) mb_phase+  pi_hspp_buf <- liftIO $ hGetStringBuffer pi_hspp_fn+  (pi_srcimps', pi_theimps', pi_ghc_prim_import, L pi_mod_name_loc pi_mod_name)+      <- ExceptT $ do+          let imp_prelude = xopt LangExt.ImplicitPrelude pi_local_dflags+              popts = initParserOpts pi_local_dflags+          mimps <- getImports popts imp_prelude pi_hspp_buf pi_hspp_fn src_fn+          return (first (mkMessages . fmap mkDriverPsHeaderMessage . getMessages) mimps)+  let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)+  let rn_imps = fmap (\(pk, lmn@(L _ mn)) -> (rn_pkg_qual mn pk, lmn))+  let pi_srcimps = rn_imps pi_srcimps'+  let pi_theimps = rn_imps pi_theimps'+  return PreprocessedImports {..}+++-----------------------------------------------------------------------------+--                      Error messages+-----------------------------------------------------------------------------++-- Defer and group warning, error and fatal messages so they will not get lost+-- in the regular output.+withDeferredDiagnostics :: GhcMonad m => m a -> m a+withDeferredDiagnostics f = do+  dflags <- getDynFlags+  if not $ gopt Opt_DeferDiagnostics dflags+  then f+  else do+    warnings <- liftIO $ newIORef []+    errors <- liftIO $ newIORef []+    fatals <- liftIO $ newIORef []+    logger <- getLogger++    let deferDiagnostics _dflags !msgClass !srcSpan !msg = do+          let action = logMsg logger msgClass srcSpan msg+          case msgClass of+            MCDiagnostic SevWarning _reason+              -> atomicModifyIORef' warnings $ \i -> (action: i, ())+            MCDiagnostic SevError _reason+              -> atomicModifyIORef' errors   $ \i -> (action: i, ())+            MCFatal+              -> atomicModifyIORef' fatals   $ \i -> (action: i, ())+            _ -> action++        printDeferredDiagnostics = liftIO $+          forM_ [warnings, errors, fatals] $ \ref -> do+            -- This IORef can leak when the dflags leaks, so let us always+            -- reset the content.+            actions <- atomicModifyIORef' ref $ \i -> ([], i)+            sequence_ $ reverse actions++    MC.bracket+      (pushLogHookM (const deferDiagnostics))+      (\_ -> popLogHookM >> printDeferredDiagnostics)+      (\_ -> f)++noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope GhcMessage+-- ToDo: we don't have a proper line number for this error+noModError hsc_env loc wanted_mod err+  = mkPlainErrorMsgEnvelope loc $ GhcDriverMessage $ DriverUnknownMessage $ mkPlainError noHints $+    cannotFindModule hsc_env wanted_mod err++{-+noHsFileErr :: SrcSpan -> String -> DriverMessages+noHsFileErr loc path+  = singleMessage $ mkPlainErrorMsgEnvelope loc (DriverFileNotFound path)+  -}++moduleNotFoundErr :: ModuleName -> DriverMessages+moduleNotFoundErr mod = singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverModuleNotFound mod)++multiRootsErr :: [ModSummary] -> IO ()+multiRootsErr [] = panic "multiRootsErr"+multiRootsErr summs@(summ1:_)+  = throwOneError $ fmap GhcDriverMessage $+    mkPlainErrorMsgEnvelope noSrcSpan $ DriverDuplicatedModuleDeclaration mod files+  where+    mod = ms_mod summ1+    files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs++cyclicModuleErr :: [ModuleGraphNode] -> SDoc+-- From a strongly connected component we find+-- a single cycle to report+cyclicModuleErr mss+  = assert (not (null mss)) $+    case findCycle graph of+       Nothing   -> text "Unexpected non-cycle" <+> ppr mss+       Just path0 -> vcat+        [ text "Module graph contains a cycle:"+        , nest 2 (show_path path0)]+  where+    graph :: [Node NodeKey ModuleGraphNode]+    graph =+      [ DigraphNode+        { node_payload = ms+        , node_key = mkNodeKey ms+        , node_dependencies = nodeDependencies False ms+        }+      | ms <- mss+      ]++    show_path :: [ModuleGraphNode] -> SDoc+    show_path []  = panic "show_path"+    show_path [m] = ppr_node m <+> text "imports itself"+    show_path (m1:m2:ms) = vcat ( nest 6 (ppr_node m1)+                                : nest 6 (text "imports" <+> ppr_node m2)+                                : go ms )+       where+         go []     = [text "which imports" <+> ppr_node m1]+         go (m:ms) = (text "which imports" <+> ppr_node m) : go ms++    ppr_node :: ModuleGraphNode -> SDoc+    ppr_node (ModuleNode _deps m) = text "module" <+> ppr_ms m+    ppr_node (InstantiationNode _uid u) = text "instantiated unit" <+> ppr u+    ppr_node (LinkNode uid _) = pprPanic "LinkNode should not be in a cycle" (ppr uid)++    ppr_ms :: ModSummary -> SDoc+    ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+>+                (parens (text (msHsFilePath ms)))+++cleanCurrentModuleTempFilesMaybe :: MonadIO m => Logger -> TmpFs -> DynFlags -> m ()+cleanCurrentModuleTempFilesMaybe logger tmpfs dflags =+  unless (gopt Opt_KeepTmpFiles dflags) $+    liftIO $ cleanCurrentModuleTempFiles logger tmpfs+++addDepsToHscEnv ::  [HomeModInfo] -> HscEnv -> HscEnv+addDepsToHscEnv deps hsc_env =+  hscUpdateHUG (\hug -> foldr addHomeModInfoToHug hug deps) hsc_env++setHPT ::  HomePackageTable -> HscEnv -> HscEnv+setHPT deps hsc_env =+  hscUpdateHPT (const $ deps) hsc_env++setHUG ::  HomeUnitGraph -> HscEnv -> HscEnv+setHUG deps hsc_env =+  hscUpdateHUG (const $ deps) hsc_env++-- | Wrap an action to catch and handle exceptions.+wrapAction :: HscEnv -> IO a -> IO (Maybe a)+wrapAction hsc_env k = do+  let lcl_logger = hsc_logger hsc_env+      lcl_dynflags = hsc_dflags hsc_env+  let logg err = printMessages lcl_logger (initDiagOpts lcl_dynflags) (srcErrorMessages err)+  -- MP: It is a bit strange how prettyPrintGhcErrors handles some errors but then we handle+  -- SourceError and ThreadKilled differently directly below. TODO: Refactor to use `catches`+  -- directly. MP should probably use safeTry here to not catch async exceptions but that will regress performance due to+  -- internally using forkIO.+  mres <- MC.try $ liftIO $ prettyPrintGhcErrors lcl_logger $ k+  case mres of+    Right res -> return $ Just res+    Left exc -> do+        case fromException exc of+          Just (err :: SourceError)+            -> logg err+          Nothing -> case fromException exc of+                        -- ThreadKilled in particular needs to actually kill the thread.+                        -- So rethrow that and the other async exceptions+                        Just (err :: SomeAsyncException) -> throwIO err+                        _ -> errorMsg lcl_logger (text (show exc))+        return Nothing++withParLog :: TVar LogQueueQueue -> Int -> ((Logger -> Logger) -> IO b) -> IO b+withParLog lqq_var k cont = do+  let init_log = do+        -- Make a new log queue+        lq <- newLogQueue k+        -- Add it into the LogQueueQueue+        atomically $ initLogQueue lqq_var lq+        return lq+      finish_log lq = liftIO (finishLogQueue lq)+  MC.bracket init_log finish_log $ \lq -> cont (pushLogHook (const (parLogAction lq)))++withLoggerHsc :: Int -> MakeEnv -> (HscEnv -> IO a) -> IO a+withLoggerHsc k MakeEnv{withLogger, hsc_env} cont = do+  withLogger k $ \modifyLogger -> do+    let lcl_logger = modifyLogger (hsc_logger hsc_env)+        hsc_env' = hsc_env { hsc_logger = lcl_logger }+    -- Run continuation with modified logger+    cont hsc_env'+++executeInstantiationNode :: Int+  -> Int+  -> RunMakeM HomeUnitGraph+  -> UnitId+  -> InstantiatedUnit+  -> RunMakeM ()+executeInstantiationNode k n wait_deps uid iu = do+        -- Wait for the dependencies of this node+        deps <- wait_deps+        env <- ask+        -- Output of the logger is mediated by a central worker to+        -- avoid output interleaving+        msg <- asks env_messager+        lift $ MaybeT $ withLoggerHsc k env $ \hsc_env ->+          let lcl_hsc_env = setHUG deps hsc_env+          in wrapAction lcl_hsc_env $ do+            res <- upsweep_inst lcl_hsc_env msg k n uid iu+            cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (hsc_dflags hsc_env)+            return res+++executeCompileNode :: Int+  -> Int+  -> Maybe HomeModInfo+  -> RunMakeM HomeUnitGraph+  -> Maybe [ModuleName] -- List of modules we need to rehydrate before compiling+  -> ModSummary+  -> RunMakeM HomeModInfo+executeCompileNode k n !old_hmi wait_deps mrehydrate_mods mod = do+  me@MakeEnv{..} <- ask+  deps <- wait_deps+  -- Rehydrate any dependencies if this module had a boot file or is a signature file.+  lift $ MaybeT (withAbstractSem compile_sem $ withLoggerHsc k me $ \hsc_env -> do+     hydrated_hsc_env <- liftIO $ maybeRehydrateBefore (setHUG deps hsc_env) mod fixed_mrehydrate_mods+     let -- Use the cached DynFlags which includes OPTIONS_GHC pragmas+         lcl_dynflags = ms_hspp_opts mod+     let lcl_hsc_env =+             -- Localise the hsc_env to use the cached flags+             hscSetFlags lcl_dynflags $+             hydrated_hsc_env+     -- Compile the module, locking with a semphore to avoid too many modules+     -- being compiled at the same time leading to high memory usage.+     wrapAction lcl_hsc_env $ do+      res <- upsweep_mod lcl_hsc_env env_messager old_hmi mod k n+      cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) lcl_dynflags+      return res)++  where+    fixed_mrehydrate_mods =+      case ms_hsc_src mod of+        -- MP: It is probably a bit of a misimplementation in backpack that+        -- compiling a signature requires an knot_var for that unit.+        -- If you remove this then a lot of backpack tests fail.+        HsigFile -> Just []+        _ -> mrehydrate_mods++{- Rehydration, see Note [Rehydrating Modules] -}++rehydrate :: HscEnv        -- ^ The HPT in this HscEnv needs rehydrating.+          -> [HomeModInfo] -- ^ These are the modules we want to rehydrate.+          -> IO HscEnv+rehydrate hsc_env hmis = do+  debugTraceMsg logger 2 $+     text "Re-hydrating loop: "+  new_mods <- fixIO $ \new_mods -> do+      let new_hpt = addListToHpt old_hpt new_mods+      let new_hsc_env = hscUpdateHPT (const new_hpt) hsc_env+      mds <- initIfaceCheck (text "rehydrate") new_hsc_env $+                mapM (typecheckIface . hm_iface) hmis+      let new_mods = [ (mn,hmi{ hm_details = details })+                     | (hmi,details) <- zip hmis mds+                     , let mn = moduleName (mi_module (hm_iface hmi)) ]+      return new_mods+  return $ setHPT (foldl' (\old (mn, hmi) -> addToHpt old mn hmi) old_hpt new_mods) hsc_env++  where+    logger  = hsc_logger hsc_env+    to_delete =  (map (moduleName . mi_module . hm_iface) hmis)+    -- Filter out old modules before tying the knot, otherwise we can end+    -- up with a thunk which keeps reference to the old HomeModInfo.+    !old_hpt = foldl' delFromHpt (hsc_HPT hsc_env) to_delete++-- If needed, then rehydrate the necessary modules with a suitable KnotVars for the+-- module currently being compiled.+maybeRehydrateBefore :: HscEnv -> ModSummary -> Maybe [ModuleName] -> IO HscEnv+maybeRehydrateBefore hsc_env _ Nothing = return hsc_env+maybeRehydrateBefore hsc_env mod (Just mns) = do+  knot_var <- initialise_knot_var hsc_env+  let hmis = map (expectJust "mr" . lookupHpt (hsc_HPT hsc_env)) mns+  rehydrate (hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv knot_var }) hmis++  where+   initialise_knot_var hsc_env = liftIO $+    let mod_name = homeModuleInstantiation (hsc_home_unit_maybe hsc_env) (ms_mod mod)+    in mkModuleEnv . (:[]) . (mod_name,) <$> newIORef emptyTypeEnv++maybeRehydrateAfter :: HomeModInfo+  -> HscEnv+  -> Maybe [ModuleName]+  -> IO (HomeUnitGraph, HomeModInfo)+maybeRehydrateAfter hmi new_hsc Nothing = return (hsc_HUG new_hsc, hmi)+maybeRehydrateAfter hmi new_hsc (Just mns) = do+  let new_hpt = hsc_HPT new_hsc+      hmis = map (expectJust "mrAfter" . lookupHpt new_hpt) mns+      new_mod_name = moduleName (mi_module (hm_iface hmi))+  hsc_env <- rehydrate (new_hsc { hsc_type_env_vars = emptyKnotVars }) (hmi : hmis)+  return (hsc_HUG hsc_env, expectJust "rehydrate" $ lookupHpt (hsc_HPT hsc_env) new_mod_name)++{-+Note [Hydrating Modules]+~~~~~~~~~~~~~~~~~~~~~~~~+There are at least 4 different representations of an interface file as described+by this diagram.++------------------------------+|       On-disk M.hi         |+------------------------------+    |             ^+    | Read file   | Write file+    V             |+-------------------------------+|      ByteString             |+-------------------------------+    |             ^+    | Binary.get  | Binary.put+    V             |+--------------------------------+|    ModIface (an acyclic AST) |+--------------------------------+    |           ^+    | hydrate   | mkIfaceTc+    V           |+---------------------------------+|  ModDetails (lots of cycles)  |+---------------------------------++The last step, converting a ModIface into a ModDetails is known as "hydration".++Hydration happens in three different places++* When an interface file is initially loaded from disk, it has to be hydrated.+* When a module is finished compiling, we hydrate the ModIface in order to generate+  the version of ModDetails which exists in memory (see Note [ModDetails and --make mode])+* When dealing with boot files and module loops (see Note [Rehydrating Modules])++Note [Rehydrating Modules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+If a module has a boot file then it is critical to rehydrate the modules on+the path between the two (see #20561).++Suppose we have ("R" for "recursive"):+```+R.hs-boot:   module R where+               data T+               g :: T -> T++A.hs:        module A( f, T, g ) where+                import {-# SOURCE #-} R+                data S = MkS T+                f :: T -> S = ...g...++R.hs:        module R where+                import A+                data T = T1 | T2 S+                g = ...f...+```++== Why we need to rehydrate A's ModIface before compiling R.hs++After compiling A.hs we'll have a TypeEnv in which the Id for `f` has a type+type uses the AbstractTyCon T; and a TyCon for `S` that also mentions that same+AbstractTyCon. (Abstract because it came from R.hs-boot; we know nothing about+it.)++When compiling R.hs, we build a TyCon for `T`.  But that TyCon mentions `S`, and+it currently has an AbstractTyCon for `T` inside it.  But we want to build a+fully cyclic structure, in which `S` refers to `T` and `T` refers to `S`.++Solution: **rehydration**.  *Before compiling `R.hs`*, rehydrate all the+ModIfaces below it that depend on R.hs-boot.  To rehydrate a ModIface, call+`typecheckIface` to convert it to a ModDetails.  It's just a de-serialisation+step, no type inference, just lookups.++Now `S` will be bound to a thunk that, when forced, will "see" the final binding+for `T`; see [Tying the knot](https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/tying-the-knot).+But note that this must be done *before* compiling R.hs.++== Why we need to rehydrate A's ModIface after compiling R.hs++When compiling R.hs, the knot-tying stuff above will ensure that `f`'s unfolding+mentions the `LocalId` for `g`.  But when we finish R, we carefully ensure that+all those `LocalIds` are turned into completed `GlobalIds`, replete with+unfoldings etc.   Alas, that will not apply to the occurrences of `g` in `f`'s+unfolding. And if we leave matters like that, they will stay that way, and *all*+subsequent modules that import A will see a crippled unfolding for `f`.++Solution: rehydrate both R and A's ModIface together, right after completing R.hs.++~~ Which modules to rehydrate++We only need rehydrate modules that are+* Below R.hs+* Above R.hs-boot++There might be many unrelated modules (in the home package) that don't need to be+rehydrated.++== Modules "above" the loop++This dark corner is the subject of #14092.++Suppose we add to our example+```+X.hs     module X where+           import A+           data XT = MkX T+           fx = ...g...+```+If in `--make` we compile R.hs-boot, then A.hs, then X.hs, we'll get a `ModDetails` for `X` that has an AbstractTyCon for `T` in the the argument type of `MkX`.  So:++* Either we should delay compiling X until after R has beeen compiled. (This is what we do)+* Or we should rehydrate X after compiling R -- because it transitively depends on R.hs-boot.++Ticket #20200 has exposed some issues to do with the knot-tying logic in GHC.Make, in `--make` mode.+#20200 has lots of issues, many of them now fixed;+this particular issue starts [here](https://gitlab.haskell.org/ghc/ghc/-/issues/20200#note_385758).++The wiki page [Tying the knot](https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/tying-the-knot) is helpful.+Also closely related are+    * #14092+    * #14103++-}++executeLinkNode :: RunMakeM HomeUnitGraph -> (Int, Int) -> UnitId -> [NodeKey] -> RunMakeM ()+executeLinkNode wait_deps kn uid deps = do+  withCurrentUnit uid $ do+    MakeEnv{..} <- ask+    hug <- wait_deps+    let dflags = hsc_dflags hsc_env+    let hsc_env' = setHUG hug hsc_env+        msg' = (\messager -> \recomp -> messager hsc_env kn recomp (LinkNode deps uid)) <$> env_messager++    linkresult <- liftIO $ withAbstractSem compile_sem $ do+                            link (ghcLink dflags)+                                (hsc_logger hsc_env')+                                (hsc_tmpfs hsc_env')+                                (hsc_hooks hsc_env')+                                dflags+                                (hsc_unit_env hsc_env')+                                True -- We already decided to link+                                msg'+                                (hsc_HPT hsc_env')+    case linkresult of+      Failed -> fail "Link Failed"+      Succeeded -> return ()+++-- | Wait for some dependencies to finish and then read from the given MVar.+wait_deps_hug :: MVar b -> [ResultVar (Maybe HomeModInfo)] -> ReaderT MakeEnv (MaybeT IO) b+wait_deps_hug hug_var deps = do+  _ <- wait_deps deps+  liftIO $ readMVar hug_var+++-- | Wait for dependencies to finish, and then return their results.+wait_deps :: [ResultVar (Maybe HomeModInfo)] -> RunMakeM [HomeModInfo]+wait_deps [] = return []+wait_deps (x:xs) = do+  res <- lift $ waitResult x+  case res of+    Nothing -> wait_deps xs+    Just hmi -> (hmi:) <$> wait_deps xs+++-- Executing the pipelines++-- | Start a thread which reads from the LogQueueQueue+++label_self :: String -> IO ()+label_self thread_name = do+    self_tid <- CC.myThreadId+    CC.labelThread self_tid thread_name+++runPipelines :: Int -> HscEnv -> Maybe Messager -> [MakeAction] -> IO ()+-- Don't even initialise plugins if there are no pipelines+runPipelines _ _ _ [] = return ()+runPipelines n_job orig_hsc_env mHscMessager all_pipelines = do+  liftIO $ label_self "main --make thread"++  plugins_hsc_env <- initializePlugins orig_hsc_env+  case n_job of+    1 -> runSeqPipelines plugins_hsc_env mHscMessager all_pipelines+    _n -> runParPipelines n_job plugins_hsc_env mHscMessager all_pipelines++runSeqPipelines :: HscEnv -> Maybe Messager -> [MakeAction] -> IO ()+runSeqPipelines plugin_hsc_env mHscMessager all_pipelines =+  let env = MakeEnv { hsc_env = plugin_hsc_env+                    , withLogger = \_ k -> k id+                    , compile_sem = AbstractSem (return ()) (return ())+                    , env_messager = mHscMessager+                    }+  in runAllPipelines 1 env all_pipelines+++-- | Build and run a pipeline+runParPipelines :: Int              -- ^ How many capabilities to use+             -> HscEnv           -- ^ The basic HscEnv which is augmented with specific info for each module+             -> Maybe Messager   -- ^ Optional custom messager to use to report progress+             -> [MakeAction]  -- ^ The build plan for all the module nodes+             -> IO ()+runParPipelines n_jobs plugin_hsc_env mHscMessager all_pipelines = do+++  -- A variable which we write to when an error has happened and we have to tell the+  -- logging thread to gracefully shut down.+  stopped_var <- newTVarIO False+  -- The queue of LogQueues which actions are able to write to. When an action starts it+  -- will add it's LogQueue into this queue.+  log_queue_queue_var <- newTVarIO newLogQueueQueue+  -- Thread which coordinates the printing of logs+  wait_log_thread <- logThread n_jobs (length all_pipelines) (hsc_logger plugin_hsc_env) stopped_var log_queue_queue_var+++  -- Make the logger thread-safe, in case there is some output which isn't sent via the LogQueue.+  thread_safe_logger <- liftIO $ makeThreadSafe (hsc_logger plugin_hsc_env)+  let thread_safe_hsc_env = plugin_hsc_env { hsc_logger = thread_safe_logger }++  let updNumCapabilities = liftIO $ do+          n_capabilities <- getNumCapabilities+          n_cpus <- getNumProcessors+          -- Setting number of capabilities more than+          -- CPU count usually leads to high userspace+          -- lock contention. #9221+          let n_caps = min n_jobs n_cpus+          unless (n_capabilities /= 1) $ setNumCapabilities n_caps+          return n_capabilities++  let resetNumCapabilities orig_n = do+          liftIO $ setNumCapabilities orig_n+          atomically $ writeTVar stopped_var True+          wait_log_thread++  compile_sem <- newQSem n_jobs+  let abstract_sem = AbstractSem (waitQSem compile_sem) (signalQSem compile_sem)+    -- Reset the number of capabilities once the upsweep ends.+  let env = MakeEnv { hsc_env = thread_safe_hsc_env+                    , withLogger = withParLog log_queue_queue_var+                    , compile_sem = abstract_sem+                    , env_messager = mHscMessager+                    }++  MC.bracket updNumCapabilities resetNumCapabilities $ \_ ->+    runAllPipelines n_jobs env all_pipelines++withLocalTmpFS :: RunMakeM a -> RunMakeM a+withLocalTmpFS act = do+  let initialiser = do+        MakeEnv{..} <- ask+        lcl_tmpfs <- liftIO $ forkTmpFsFrom (hsc_tmpfs hsc_env)+        return $ hsc_env { hsc_tmpfs  = lcl_tmpfs }+      finaliser lcl_env = do+        gbl_env <- ask+        liftIO $ mergeTmpFsInto (hsc_tmpfs lcl_env) (hsc_tmpfs (hsc_env gbl_env))+       -- Add remaining files which weren't cleaned up into local tmp fs for+       -- clean-up later.+       -- Clear the logQueue if this node had it's own log queue+  MC.bracket initialiser finaliser $ \lcl_hsc_env -> local (\env -> env { hsc_env = lcl_hsc_env}) act++-- | Run the given actions and then wait for them all to finish.+runAllPipelines :: Int -> MakeEnv -> [MakeAction] -> IO ()+runAllPipelines n_jobs env acts = do+  let spawn_actions :: IO [ThreadId]+      spawn_actions = if n_jobs == 1+        then (:[]) <$> (forkIOWithUnmask $ \unmask -> void $ runLoop (\io -> io unmask) env acts)+        else runLoop forkIOWithUnmask env acts++      kill_actions :: [ThreadId] -> IO ()+      kill_actions tids = mapM_ killThread tids++  MC.bracket spawn_actions kill_actions $ \_ -> do+    mapM_ waitMakeAction acts++-- | Execute each action in order, limiting the amount of parrelism by the given+-- semaphore.+runLoop :: (((forall a. IO a -> IO a) -> IO ()) -> IO a) -> MakeEnv -> [MakeAction] -> IO [a]+runLoop _ _env [] = return []+runLoop fork_thread env (MakeAction act res_var :acts) = do+  new_thread <-+    fork_thread $ \unmask -> (do+            mres <- (unmask $ run_pipeline (withLocalTmpFS act))+                      `MC.onException` (putMVar res_var Nothing) -- Defensive: If there's an unhandled exception then still signal the failure.+            putMVar res_var mres)+  threads <- runLoop fork_thread env acts+  return (new_thread : threads)+  where+      run_pipeline :: RunMakeM a -> IO (Maybe a)+      run_pipeline p = runMaybeT (runReaderT p env)++data MakeAction = forall a . MakeAction (RunMakeM a) (MVar (Maybe a))++waitMakeAction :: MakeAction -> IO ()+waitMakeAction (MakeAction _ mvar) = () <$ readMVar mvar++{- Note [GHC Heap Invariants]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~+This note is a general place to explain some of the heap invariants which should+hold for a program compiled with --make mode. These invariants are all things+which can be checked easily using ghc-debug.++1. No HomeModInfo are reachable via the EPS.+   Why? Interfaces are lazily loaded into the EPS and the lazy thunk retains+        a reference to the entire HscEnv, if we are not careful the HscEnv will+        contain the HomePackageTable at the time the interface was loaded and+        it will never be released.+   Where? dontLeakTheHPT in GHC.Iface.Load++2. No KnotVars are live at the end of upsweep (#20491)+   Why? KnotVars contains an old stale reference to the TypeEnv for modules+        which participate in a loop. At the end of a loop all the KnotVars references+        should be removed by the call to typecheckLoop.+   Where? typecheckLoop in GHC.Driver.Make.++3. Immediately after a reload, no ModDetails are live.+   Why? During the upsweep all old ModDetails are replaced with a new ModDetails+        generated from a ModIface. If we don't clear the ModDetails before the+        reload takes place then memory usage during the reload is twice as much+        as it should be as we retain a copy of the ModDetails for too long.+   Where? pruneCache in GHC.Driver.Make++4. No TcGblEnv or TcLclEnv are live after typechecking is completed.+   Why? By the time we get to simplification all the data structures from typechecking+        should be eliminated.+   Where? No one place in the compiler. These leaks can be introduced by not suitable+          forcing functions which take a TcLclEnv as an argument.++-}
+ compiler/GHC/Driver/MakeFile.hs view
@@ -0,0 +1,452 @@+++-----------------------------------------------------------------------------+--+-- Makefile Dependency Generation+--+-- (c) The University of Glasgow 2005+--+-----------------------------------------------------------------------------++module GHC.Driver.MakeFile+   ( doMkDependHS+   )+where++import GHC.Prelude++import qualified GHC+import GHC.Driver.Monad+import GHC.Driver.Session+import GHC.Driver.Ppr+import GHC.Utils.Misc+import GHC.Driver.Env+import GHC.Driver.Errors.Types+import qualified GHC.SysTools as SysTools+import GHC.Data.Graph.Directed ( SCC(..) )+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Types.SourceError+import GHC.Types.SrcLoc+import GHC.Types.PkgQual+import Data.List (partition)+import GHC.Utils.TmpFs++import GHC.Iface.Load (cannotFindModule)++import GHC.Unit.Module+import GHC.Unit.Module.ModSummary+import GHC.Unit.Module.Graph+import GHC.Unit.Finder++import GHC.Utils.Exception+import GHC.Utils.Error+import GHC.Utils.Logger++import System.Directory+import System.FilePath+import System.IO+import System.IO.Error  ( isEOFError )+import Control.Monad    ( when, forM_ )+import Data.Maybe       ( isJust )+import Data.IORef+import qualified Data.Set as Set++-----------------------------------------------------------------+--+--              The main function+--+-----------------------------------------------------------------++doMkDependHS :: GhcMonad m => [FilePath] -> m ()+doMkDependHS srcs = do+    logger <- getLogger++    -- Initialisation+    dflags0 <- GHC.getSessionDynFlags++    -- We kludge things a bit for dependency generation. Rather than+    -- generating dependencies for each way separately, we generate+    -- them once and then duplicate them for each way's osuf/hisuf.+    -- We therefore do the initial dependency generation with an empty+    -- way and .o/.hi extensions, regardless of any flags that might+    -- be specified.+    let dflags1 = dflags0+            { targetWays_ = Set.empty+            , hiSuf_      = "hi"+            , objectSuf_  = "o"+            }+    GHC.setSessionDynFlags dflags1++    -- If no suffix is provided, use the default -- the empty one+    let dflags = if null (depSuffixes dflags1)+                 then dflags1 { depSuffixes = [""] }+                 else dflags1++    tmpfs <- hsc_tmpfs <$> getSession+    files <- liftIO $ beginMkDependHS logger tmpfs dflags++    -- Do the downsweep to find all the modules+    targets <- mapM (\s -> GHC.guessTarget s Nothing Nothing) srcs+    GHC.setTargets targets+    let excl_mods = depExcludeMods dflags+    module_graph <- GHC.depanal excl_mods True {- Allow dup roots -}++    -- Sort into dependency order+    -- There should be no cycles+    let sorted = GHC.topSortModuleGraph False module_graph Nothing++    -- Print out the dependencies if wanted+    liftIO $ debugTraceMsg logger 2 (text "Module dependencies" $$ ppr sorted)++    -- Process them one by one, dumping results into makefile+    -- and complaining about cycles+    hsc_env <- getSession+    root <- liftIO getCurrentDirectory+    mapM_ (liftIO . processDeps dflags hsc_env excl_mods root (mkd_tmp_hdl files)) sorted++    -- If -ddump-mod-cycles, show cycles in the module graph+    liftIO $ dumpModCycles logger module_graph++    -- Tidy up+    liftIO $ endMkDependHS logger files++    -- Unconditional exiting is a bad idea.  If an error occurs we'll get an+    --exception; if that is not caught it's fine, but at least we have a+    --chance to find out exactly what went wrong.  Uncomment the following+    --line if you disagree.++    --`GHC.ghcCatch` \_ -> io $ exitWith (ExitFailure 1)++-----------------------------------------------------------------+--+--              beginMkDependHs+--      Create a temporary file,+--      find the Makefile,+--      slurp through it, etc+--+-----------------------------------------------------------------++data MkDepFiles+  = MkDep { mkd_make_file :: FilePath,          -- Name of the makefile+            mkd_make_hdl  :: Maybe Handle,      -- Handle for the open makefile+            mkd_tmp_file  :: FilePath,          -- Name of the temporary file+            mkd_tmp_hdl   :: Handle }           -- Handle of the open temporary file++beginMkDependHS :: Logger -> TmpFs -> DynFlags -> IO MkDepFiles+beginMkDependHS logger tmpfs dflags = do+        -- open a new temp file in which to stuff the dependency info+        -- as we go along.+  tmp_file <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "dep"+  tmp_hdl <- openFile tmp_file WriteMode++        -- open the makefile+  let makefile = depMakefile dflags+  exists <- doesFileExist makefile+  mb_make_hdl <-+        if not exists+        then return Nothing+        else do+           makefile_hdl <- openFile makefile ReadMode++                -- slurp through until we get the magic start string,+                -- copying the contents into dep_makefile+           let slurp = do+                l <- hGetLine makefile_hdl+                if (l == depStartMarker)+                        then return ()+                        else do hPutStrLn tmp_hdl l; slurp++                -- slurp through until we get the magic end marker,+                -- throwing away the contents+           let chuck = do+                l <- hGetLine makefile_hdl+                if (l == depEndMarker)+                        then return ()+                        else chuck++           catchIO slurp+                (\e -> if isEOFError e then return () else ioError e)+           catchIO chuck+                (\e -> if isEOFError e then return () else ioError e)++           return (Just makefile_hdl)+++        -- write the magic marker into the tmp file+  hPutStrLn tmp_hdl depStartMarker++  return (MkDep { mkd_make_file = makefile, mkd_make_hdl = mb_make_hdl,+                  mkd_tmp_file  = tmp_file, mkd_tmp_hdl  = tmp_hdl})+++-----------------------------------------------------------------+--+--              processDeps+--+-----------------------------------------------------------------++processDeps :: DynFlags+            -> HscEnv+            -> [ModuleName]+            -> FilePath+            -> Handle           -- Write dependencies to here+            -> SCC ModuleGraphNode+            -> IO ()+-- Write suitable dependencies to handle+-- Always:+--                      this.o : this.hs+--+-- If the dependency is on something other than a .hi file:+--                      this.o this.p_o ... : dep+-- otherwise+--                      this.o ...   : dep.hi+--                      this.p_o ... : dep.p_hi+--                      ...+-- (where .o is $osuf, and the other suffixes come from+-- the cmdline -s options).+--+-- For {-# SOURCE #-} imports the "hi" will be "hi-boot".++processDeps dflags _ _ _ _ (CyclicSCC nodes)+  =     -- There shouldn't be any cycles; report them+    throwGhcExceptionIO $ ProgramError $+      showSDoc dflags $ GHC.cyclicModuleErr nodes++processDeps dflags _ _ _ _ (AcyclicSCC (InstantiationNode _uid node))+  =     -- There shouldn't be any backpack instantiations; report them as well+    throwGhcExceptionIO $ ProgramError $+      showSDoc dflags $+        vcat [ text "Unexpected backpack instantiation in dependency graph while constructing Makefile:"+             , nest 2 $ ppr node ]+processDeps _dflags _ _ _ _ (AcyclicSCC (LinkNode {})) = return ()++processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC (ModuleNode _ node))+  = do  { let extra_suffixes = depSuffixes dflags+              include_pkg_deps = depIncludePkgDeps dflags+              src_file  = msHsFilePath node+              obj_file  = msObjFilePath node+              obj_files = insertSuffixes obj_file extra_suffixes++              do_imp loc is_boot pkg_qual imp_mod+                = do { mb_hi <- findDependency hsc_env loc pkg_qual imp_mod+                                               is_boot include_pkg_deps+                     ; case mb_hi of {+                           Nothing      -> return () ;+                           Just hi_file -> do+                     { let hi_files = insertSuffixes hi_file extra_suffixes+                           write_dep (obj,hi) = writeDependency root hdl [obj] hi++                        -- Add one dependency for each suffix;+                        -- e.g.         A.o   : B.hi+                        --              A.x_o : B.x_hi+                     ; mapM_ write_dep (obj_files `zip` hi_files) }}}+++                -- Emit std dependency of the object(s) on the source file+                -- Something like       A.o : A.hs+        ; writeDependency root hdl obj_files src_file++          -- add dependency between objects and their corresponding .hi-boot+          -- files if the module has a corresponding .hs-boot file (#14482)+        ; when (isBootSummary node == IsBoot) $ do+            let hi_boot = msHiFilePath node+            let obj     = removeBootSuffix (msObjFilePath node)+            forM_ extra_suffixes $ \suff -> do+               let way_obj     = insertSuffixes obj     [suff]+               let way_hi_boot = insertSuffixes hi_boot [suff]+               mapM_ (writeDependency root hdl way_obj) way_hi_boot++                -- Emit a dependency for each CPP import+        ; when (depIncludeCppDeps dflags) $ do+            -- CPP deps are descovered in the module parsing phase by parsing+            -- comment lines left by the preprocessor.+            -- Note that GHC.parseModule may throw an exception if the module+            -- fails to parse, which may not be desirable (see #16616).+          { session <- Session <$> newIORef hsc_env+          ; parsedMod <- reflectGhc (GHC.parseModule node) session+          ; mapM_ (writeDependency root hdl obj_files)+                  (GHC.pm_extra_src_files parsedMod)+          }++                -- Emit a dependency for each import++        ; let do_imps is_boot idecls = sequence_+                    [ do_imp loc is_boot mb_pkg mod+                    | (mb_pkg, L loc mod) <- idecls,+                      mod `notElem` excl_mods ]++        ; do_imps IsBoot (ms_srcimps node)+        ; do_imps NotBoot (ms_imps node)+        }+++findDependency  :: HscEnv+                -> SrcSpan+                -> PkgQual              -- package qualifier, if any+                -> ModuleName           -- Imported module+                -> IsBootInterface      -- Source import+                -> Bool                 -- Record dependency on package modules+                -> IO (Maybe FilePath)  -- Interface file+findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps = do+  -- Find the module; this will be fast because+  -- we've done it once during downsweep+  r <- findImportedModule hsc_env imp pkg+  case r of+    Found loc _+        -- Home package: just depend on the .hi or hi-boot file+        | isJust (ml_hs_file loc) || include_pkg_deps+        -> return (Just (addBootSuffix_maybe is_boot (ml_hi_file loc)))++        -- Not in this package: we don't need a dependency+        | otherwise+        -> return Nothing++    fail ->+        throwOneError $+          mkPlainErrorMsgEnvelope srcloc $+          GhcDriverMessage $ DriverUnknownMessage $ mkPlainError noHints $+             cannotFindModule hsc_env imp fail++-----------------------------+writeDependency :: FilePath -> Handle -> [FilePath] -> FilePath -> IO ()+-- (writeDependency r h [t1,t2] dep) writes to handle h the dependency+--      t1 t2 : dep+writeDependency root hdl targets dep+  = do let -- We need to avoid making deps on+           --     c:/foo/...+           -- on cygwin as make gets confused by the :+           -- Making relative deps avoids some instances of this.+           dep' = makeRelative root dep+           forOutput = escapeSpaces . reslash Forwards . normalise+           output = unwords (map forOutput targets) ++ " : " ++ forOutput dep'+       hPutStrLn hdl output++-----------------------------+insertSuffixes+        :: FilePath     -- Original filename;   e.g. "foo.o"+        -> [String]     -- Suffix prefixes      e.g. ["x_", "y_"]+        -> [FilePath]   -- Zapped filenames     e.g. ["foo.x_o", "foo.y_o"]+        -- Note that the extra bit gets inserted *before* the old suffix+        -- We assume the old suffix contains no dots, so we know where to+        -- split it+insertSuffixes file_name extras+  = [ basename <.> (extra ++ suffix) | extra <- extras ]+  where+    (basename, suffix) = case splitExtension file_name of+                         -- Drop the "." from the extension+                         (b, s) -> (b, drop 1 s)+++-----------------------------------------------------------------+--+--              endMkDependHs+--      Complete the makefile, close the tmp file etc+--+-----------------------------------------------------------------++endMkDependHS :: Logger -> MkDepFiles -> IO ()++endMkDependHS logger+   (MkDep { mkd_make_file = makefile, mkd_make_hdl =  makefile_hdl,+            mkd_tmp_file  = tmp_file, mkd_tmp_hdl  =  tmp_hdl })+  = do+  -- write the magic marker into the tmp file+  hPutStrLn tmp_hdl depEndMarker++  case makefile_hdl of+     Nothing  -> return ()+     Just hdl -> do+        -- slurp the rest of the original makefile and copy it into the output+        SysTools.copyHandle hdl tmp_hdl+        hClose hdl++  hClose tmp_hdl  -- make sure it's flushed++        -- Create a backup of the original makefile+  when (isJust makefile_hdl) $ do+    showPass logger ("Backing up " ++ makefile)+    SysTools.copyFile makefile (makefile++".bak")++        -- Copy the new makefile in place+  showPass logger "Installing new makefile"+  SysTools.copyFile tmp_file makefile+++-----------------------------------------------------------------+--              Module cycles+-----------------------------------------------------------------++dumpModCycles :: Logger -> ModuleGraph -> IO ()+dumpModCycles logger module_graph+  | not (logHasDumpFlag logger Opt_D_dump_mod_cycles)+  = return ()++  | null cycles+  = putMsg logger (text "No module cycles")++  | otherwise+  = putMsg logger (hang (text "Module cycles found:") 2 pp_cycles)+  where+    topoSort = GHC.topSortModuleGraph True module_graph Nothing++    cycles :: [[ModuleGraphNode]]+    cycles =+      [ c | CyclicSCC c <- topoSort ]++    pp_cycles = vcat [ (text "---------- Cycle" <+> int n <+> text "----------")+                        $$ pprCycle c $$ blankLine+                     | (n,c) <- [1..] `zip` cycles ]++pprCycle :: [ModuleGraphNode] -> SDoc+-- Print a cycle, but show only the imports within the cycle+pprCycle summaries = pp_group (CyclicSCC summaries)+  where+    cycle_mods :: [ModuleName]  -- The modules in this cycle+    cycle_mods = map (moduleName . ms_mod) [ms | ModuleNode _ ms <- summaries]++    pp_group :: SCC ModuleGraphNode -> SDoc+    pp_group (AcyclicSCC (ModuleNode _ ms)) = pp_ms ms+    pp_group (AcyclicSCC _) = empty+    pp_group (CyclicSCC mss)+        = assert (not (null boot_only)) $+                -- The boot-only list must be non-empty, else there would+                -- be an infinite chain of non-boot imports, and we've+                -- already checked for that in processModDeps+          pp_ms loop_breaker $$ vcat (map pp_group groups)+        where+          (boot_only, others) = partition is_boot_only mss+          is_boot_only (ModuleNode _ ms) = not (any in_group (map snd (ms_imps ms)))+          is_boot_only  _ = False+          in_group (L _ m) = m `elem` group_mods+          group_mods = map (moduleName . ms_mod) [ms | ModuleNode _ ms <- mss]++          loop_breaker = head ([ms | ModuleNode _ ms  <- boot_only])+          all_others   = tail boot_only ++ others+          groups =+            GHC.topSortModuleGraph True (mkModuleGraph all_others) Nothing++    pp_ms summary = text mod_str <> text (take (20 - length mod_str) (repeat ' '))+                       <+> (pp_imps empty (map snd (ms_imps summary)) $$+                            pp_imps (text "{-# SOURCE #-}") (map snd (ms_srcimps summary)))+        where+          mod_str = moduleNameString (moduleName (ms_mod summary))++    pp_imps :: SDoc -> [Located ModuleName] -> SDoc+    pp_imps _    [] = empty+    pp_imps what lms+        = case [m | L _ m <- lms, m `elem` cycle_mods] of+            [] -> empty+            ms -> what <+> text "imports" <+>+                                pprWithCommas ppr ms++-----------------------------------------------------------------+--+--              Flags+--+-----------------------------------------------------------------++depStartMarker, depEndMarker :: String+depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies"+depEndMarker   = "# DO NOT DELETE: End of Haskell dependencies"
compiler/GHC/Driver/Pipeline.hs view
@@ -1,2251 +1,909 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE LambdaCase #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}------------------------------------------------------------------------------------- GHC Driver------ (c) The University of Glasgow 2005-----------------------------------------------------------------------------------module GHC.Driver.Pipeline (-        -- Run a series of compilation steps in a pipeline, for a-        -- collection of source files.-   oneShot, compileFile,--        -- Interfaces for the compilation manager (interpreted/batch-mode)-   preprocess,-   compileOne, compileOne',-   link,--        -- Exports for hooks to override runPhase and link-   PhasePlus(..), CompPipeline(..), PipeEnv(..), PipeState(..),-   phaseOutputFilename, getOutputFilename, getPipeState, getPipeEnv,-   hscPostBackendPhase, getLocation, setModLocation, setDynFlags,-   runPhase,-   doCpp,-   linkingNeeded, checkLinkInfo, writeInterfaceOnlyMode-  ) where--#include <ghcplatform.h>-#include "GhclibHsVersions.h"--import GHC.Prelude--import GHC.Platform--import GHC.Tc.Types--import GHC.Driver.Main-import GHC.Driver.Env hiding ( Hsc )-import GHC.Driver.Errors-import GHC.Driver.Pipeline.Monad-import GHC.Driver.Config-import GHC.Driver.Phases-import GHC.Driver.Session-import GHC.Driver.Backend-import GHC.Driver.Ppr-import GHC.Driver.Hooks--import GHC.Platform.Ways-import GHC.Platform.ArchOS--import GHC.Parser.Header-import GHC.Parser.Errors.Ppr--import GHC.SysTools-import GHC.Utils.TmpFs--import GHC.Linker.ExtraObj-import GHC.Linker.Dynamic-import GHC.Linker.Static-import GHC.Linker.Types--import GHC.Utils.Outputable-import GHC.Utils.Error-import GHC.Utils.Panic-import GHC.Utils.Misc-import GHC.Utils.Monad-import GHC.Utils.Exception as Exception-import GHC.Utils.Logger--import GHC.CmmToLlvm         ( llvmFixupAsm, llvmVersionList )-import qualified GHC.LanguageExtensions as LangExt-import GHC.Settings--import GHC.Data.Bag            ( unitBag )-import GHC.Data.FastString     ( mkFastString )-import GHC.Data.StringBuffer   ( hGetStringBuffer, hPutStringBuffer )-import GHC.Data.Maybe          ( expectJust )--import GHC.Iface.Make          ( mkFullIface )--import GHC.Types.Basic       ( SuccessFlag(..) )-import GHC.Types.Target-import GHC.Types.SrcLoc-import GHC.Types.SourceFile-import GHC.Types.SourceError--import GHC.Unit-import GHC.Unit.Env-import GHC.Unit.State-import GHC.Unit.Finder-import GHC.Unit.Module.ModSummary-import GHC.Unit.Module.ModIface-import GHC.Unit.Module.Graph (needsTemplateHaskellOrQQ)-import GHC.Unit.Module.Deps-import GHC.Unit.Home.ModInfo--import System.Directory-import System.FilePath-import System.IO-import Control.Monad-import qualified Control.Monad.Catch as MC (handle)-import Data.List        ( isInfixOf, intercalate )-import Data.Maybe-import Data.Version-import Data.Either      ( partitionEithers )--import Data.Time        ( UTCTime )---- ------------------------------------------------------------------------------ Pre-process---- | Just preprocess a file, put the result in a temp. file (used by the--- compilation manager during the summary phase).------ We return the augmented DynFlags, because they contain the result--- of slurping in the OPTIONS pragmas--preprocess :: HscEnv-           -> FilePath -- ^ input filename-           -> Maybe InputFileBuffer-           -- ^ optional buffer to use instead of reading the input file-           -> Maybe Phase -- ^ starting phase-           -> IO (Either ErrorMessages (DynFlags, FilePath))-preprocess hsc_env input_fn mb_input_buf mb_phase =-  handleSourceError (\err -> return (Left (srcErrorMessages err))) $-  MC.handle handler $-  fmap Right $ do-  MASSERT2(isJust mb_phase || isHaskellSrcFilename input_fn, text input_fn)-  (dflags, fp, mb_iface) <- runPipeline anyHsc hsc_env (input_fn, mb_input_buf, fmap RealPhase mb_phase)-        Nothing-        -- We keep the processed file for the whole session to save on-        -- duplicated work in ghci.-        (Temporary TFL_GhcSession)-        Nothing{-no ModLocation-}-        []{-no foreign objects-}-  -- We stop before Hsc phase so we shouldn't generate an interface-  MASSERT(isNothing mb_iface)-  return (dflags, fp)-  where-    srcspan = srcLocSpan $ mkSrcLoc (mkFastString input_fn) 1 1-    handler (ProgramError msg) = return $ Left $ unitBag $-        mkPlainMsgEnvelope srcspan $ text msg-    handler ex = throwGhcExceptionIO ex---- ------------------------------------------------------------------------------- | Compile------ Compile a single module, under the control of the compilation manager.------ This is the interface between the compilation manager and the--- compiler proper (hsc), where we deal with tedious details like--- reading the OPTIONS pragma from the source file, converting the--- C or assembly that GHC produces into an object file, and compiling--- FFI stub files.------ NB.  No old interface can also mean that the source has changed.--compileOne :: HscEnv-           -> ModSummary      -- ^ summary for module being compiled-           -> Int             -- ^ module N ...-           -> Int             -- ^ ... of M-           -> Maybe ModIface  -- ^ old interface, if we have one-           -> Maybe Linkable  -- ^ old linkable, if we have one-           -> SourceModified-           -> IO HomeModInfo   -- ^ the complete HomeModInfo, if successful--compileOne = compileOne' Nothing (Just batchMsg)--compileOne' :: Maybe TcGblEnv-            -> Maybe Messager-            -> HscEnv-            -> ModSummary      -- ^ summary for module being compiled-            -> Int             -- ^ module N ...-            -> Int             -- ^ ... of M-            -> Maybe ModIface  -- ^ old interface, if we have one-            -> Maybe Linkable  -- ^ old linkable, if we have one-            -> SourceModified-            -> IO HomeModInfo   -- ^ the complete HomeModInfo, if successful--compileOne' m_tc_result mHscMessage-            hsc_env0 summary mod_index nmods mb_old_iface mb_old_linkable-            source_modified0- = do--   let logger = hsc_logger hsc_env0-   let tmpfs  = hsc_tmpfs hsc_env0-   debugTraceMsg logger dflags1 2 (text "compile: input file" <+> text input_fnpp)--   -- Run the pipeline up to codeGen (so everything up to, but not including, STG)-   (status, plugin_hsc_env) <- hscIncrementalCompile-                        always_do_basic_recompilation_check-                        m_tc_result mHscMessage-                        hsc_env summary source_modified mb_old_iface (mod_index, nmods)-   -- Use an HscEnv updated with the plugin info-   let hsc_env' = plugin_hsc_env--   let flags = hsc_dflags hsc_env0-     in do unless (gopt Opt_KeepHiFiles flags) $-               addFilesToClean tmpfs TFL_CurrentModule $-                   [ml_hi_file $ ms_location summary]-           unless (gopt Opt_KeepOFiles flags) $-               addFilesToClean tmpfs TFL_GhcSession $-                   [ml_obj_file $ ms_location summary]--   case (status, bcknd) of-        (HscUpToDate iface hmi_details, _) ->-            -- TODO recomp014 triggers this assert. What's going on?!-            -- ASSERT( isJust mb_old_linkable || isNoLink (ghcLink dflags) )-            return $! HomeModInfo iface hmi_details mb_old_linkable-        (HscNotGeneratingCode iface hmi_details, NoBackend) ->-            let mb_linkable = if isHsBootOrSig src_flavour-                                then Nothing-                                -- TODO: Questionable.-                                else Just (LM (ms_hs_date summary) this_mod [])-            in return $! HomeModInfo iface hmi_details mb_linkable-        (HscNotGeneratingCode _ _, _) -> panic "compileOne HscNotGeneratingCode"-        (_, NoBackend) -> panic "compileOne NoBackend"-        (HscUpdateBoot iface hmi_details, Interpreter) ->-            return $! HomeModInfo iface hmi_details Nothing-        (HscUpdateBoot iface hmi_details, _) -> do-            touchObjectFile logger dflags object_filename-            return $! HomeModInfo iface hmi_details Nothing-        (HscUpdateSig iface hmi_details, Interpreter) -> do-            let !linkable = LM (ms_hs_date summary) this_mod []-            return $! HomeModInfo iface hmi_details (Just linkable)-        (HscUpdateSig iface hmi_details, _) -> do-            output_fn <- getOutputFilename logger tmpfs next_phase-                            (Temporary TFL_CurrentModule) basename dflags-                            next_phase (Just location)--            -- #10660: Use the pipeline instead of calling-            -- compileEmptyStub directly, so -dynamic-too gets-            -- handled properly-            _ <- runPipeline StopLn hsc_env'-                              (output_fn,-                               Nothing,-                               Just (HscOut src_flavour-                                            mod_name (HscUpdateSig iface hmi_details)))-                              (Just basename)-                              Persistent-                              (Just location)-                              []-            o_time <- getModificationUTCTime object_filename-            let !linkable = LM o_time this_mod [DotO object_filename]-            return $! HomeModInfo iface hmi_details (Just linkable)-        (HscRecomp { hscs_guts = cgguts,-                     hscs_mod_location = mod_location,-                     hscs_partial_iface = partial_iface,-                     hscs_old_iface_hash = mb_old_iface_hash-                   }, Interpreter) -> do-            -- In interpreted mode the regular codeGen backend is not run so we-            -- generate a interface without codeGen info.-            final_iface <- mkFullIface hsc_env' partial_iface Nothing-            -- Reconstruct the `ModDetails` from the just-constructed `ModIface`-            -- See Note [ModDetails and --make mode]-            hmi_details <- liftIO $ initModDetails hsc_env' summary final_iface-            liftIO $ hscMaybeWriteIface logger dflags True final_iface mb_old_iface_hash (ms_location summary)--            (hasStub, comp_bc, spt_entries) <- hscInteractive hsc_env' cgguts mod_location--            stub_o <- case hasStub of-                      Nothing -> return []-                      Just stub_c -> do-                          stub_o <- compileStub hsc_env' stub_c-                          return [DotO stub_o]--            let hs_unlinked = [BCOs comp_bc spt_entries]-                unlinked_time = ms_hs_date summary-              -- Why do we use the timestamp of the source file here,-              -- rather than the current time?  This works better in-              -- the case where the local clock is out of sync-              -- with the filesystem's clock.  It's just as accurate:-              -- if the source is modified, then the linkable will-              -- be out of date.-            let !linkable = LM unlinked_time (ms_mod summary)-                           (hs_unlinked ++ stub_o)-            return $! HomeModInfo final_iface hmi_details (Just linkable)-        (HscRecomp{}, _) -> do-            output_fn <- getOutputFilename logger tmpfs next_phase-                            (Temporary TFL_CurrentModule)-                            basename dflags next_phase (Just location)-            -- We're in --make mode: finish the compilation pipeline.-            (_, _, Just iface) <- runPipeline StopLn hsc_env'-                              (output_fn,-                               Nothing,-                               Just (HscOut src_flavour mod_name status))-                              (Just basename)-                              Persistent-                              (Just location)-                              []-                  -- The object filename comes from the ModLocation-            o_time <- getModificationUTCTime object_filename-            let !linkable = LM o_time this_mod [DotO object_filename]-            -- See Note [ModDetails and --make mode]-            details <- initModDetails hsc_env' summary iface-            return $! HomeModInfo iface details (Just linkable)-- where dflags0     = ms_hspp_opts summary-       this_mod    = ms_mod summary-       location    = ms_location summary-       input_fn    = expectJust "compile:hs" (ml_hs_file location)-       input_fnpp  = ms_hspp_file summary-       mod_graph   = hsc_mod_graph hsc_env0-       needsLinker = needsTemplateHaskellOrQQ mod_graph-       isDynWay    = any (== WayDyn) (ways dflags0)-       isProfWay   = any (== WayProf) (ways dflags0)-       internalInterpreter = not (gopt Opt_ExternalInterpreter dflags0)--       src_flavour = ms_hsc_src summary-       mod_name = ms_mod_name summary-       next_phase = hscPostBackendPhase src_flavour bcknd-       object_filename = ml_obj_file location--       -- #8180 - when using TemplateHaskell, switch on -dynamic-too so-       -- the linker can correctly load the object files.  This isn't necessary-       -- when using -fexternal-interpreter.-       dflags1 = if hostIsDynamic && internalInterpreter &&-                    not isDynWay && not isProfWay && needsLinker-                  then gopt_set dflags0 Opt_BuildDynamicToo-                  else dflags0--       -- #16331 - when no "internal interpreter" is available but we-       -- need to process some TemplateHaskell or QuasiQuotes, we automatically-       -- turn on -fexternal-interpreter.-       dflags2 = if not internalInterpreter && needsLinker-                 then gopt_set dflags1 Opt_ExternalInterpreter-                 else dflags1--       basename = dropExtension input_fn--       -- We add the directory in which the .hs files resides) to the import-       -- path.  This is needed when we try to compile the .hc file later, if it-       -- imports a _stub.h file that we created here.-       current_dir = takeDirectory basename-       old_paths   = includePaths dflags2-       loadAsByteCode-         | Just (Target _ obj _) <- findTarget summary (hsc_targets hsc_env0)-         , not obj-         = True-         | otherwise = False-       -- Figure out which backend we're using-       (bcknd, dflags3)-         -- #8042: When module was loaded with `*` prefix in ghci, but DynFlags-         -- suggest to generate object code (which may happen in case -fobject-code-         -- was set), force it to generate byte-code. This is NOT transitive and-         -- only applies to direct targets.-         | loadAsByteCode-         = (Interpreter, dflags2 { backend = Interpreter })-         | otherwise-         = (backend dflags, dflags2)-       dflags  = dflags3 { includePaths = addImplicitQuoteInclude old_paths [current_dir] }-       hsc_env = hsc_env0 {hsc_dflags = dflags}--       -- -fforce-recomp should also work with --make-       force_recomp = gopt Opt_ForceRecomp dflags-       source_modified-         -- #8042: Usually pre-compiled code is preferred to be loaded in ghci-         -- if available. So, if the "*" prefix was used, force recompilation-         -- to make sure byte-code is loaded.-         | force_recomp || loadAsByteCode = SourceModified-         | otherwise = source_modified0--       always_do_basic_recompilation_check = case bcknd of-                                             Interpreter -> True-                                             _ -> False---------------------------------------------------------------------------------- stub .h and .c files (for foreign export support), and cc files.---- The _stub.c file is derived from the haskell source file, possibly taking--- into account the -stubdir option.------ The object file created by compiling the _stub.c file is put into a--- temporary file, which will be later combined with the main .o file--- (see the MergeForeigns phase).------ Moreover, we also let the user emit arbitrary C/C++/ObjC/ObjC++ files--- from TH, that are then compiled and linked to the module. This is--- useful to implement facilities such as inline-c.--compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath-compileForeign _ RawObject object_file = return object_file-compileForeign hsc_env lang stub_c = do-        let phase = case lang of-              LangC      -> Cc-              LangCxx    -> Ccxx-              LangObjc   -> Cobjc-              LangObjcxx -> Cobjcxx-              LangAsm    -> As True -- allow CPP-#if __GLASGOW_HASKELL__ < 811-              RawObject  -> panic "compileForeign: should be unreachable"-#endif-        (_, stub_o, _) <- runPipeline StopLn hsc_env-                       (stub_c, Nothing, Just (RealPhase phase))-                       Nothing (Temporary TFL_GhcSession)-                       Nothing{-no ModLocation-}-                       []-        return stub_o--compileStub :: HscEnv -> FilePath -> IO FilePath-compileStub hsc_env stub_c = compileForeign hsc_env LangC stub_c--compileEmptyStub :: DynFlags -> HscEnv -> FilePath -> ModLocation -> ModuleName -> IO ()-compileEmptyStub dflags hsc_env basename location mod_name = do-  -- To maintain the invariant that every Haskell file-  -- compiles to object code, we make an empty (but-  -- valid) stub object file for signatures.  However,-  -- we make sure this object file has a unique symbol,-  -- so that ranlib on OS X doesn't complain, see-  -- https://gitlab.haskell.org/ghc/ghc/issues/12673-  -- and https://github.com/haskell/cabal/issues/2257-  let logger = hsc_logger hsc_env-  let tmpfs  = hsc_tmpfs hsc_env-  empty_stub <- newTempName logger tmpfs dflags TFL_CurrentModule "c"-  let home_unit = hsc_home_unit hsc_env-      src = text "int" <+> ppr (mkHomeModule home_unit mod_name) <+> text "= 0;"-  writeFile empty_stub (showSDoc dflags (pprCode CStyle src))-  _ <- runPipeline StopLn hsc_env-                  (empty_stub, Nothing, Nothing)-                  (Just basename)-                  Persistent-                  (Just location)-                  []-  return ()---- ------------------------------------------------------------------------------ Link------ Note [Dynamic linking on macOS]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ Since macOS Sierra (10.14), the dynamic system linker enforces--- a limit on the Load Commands.  Specifically the Load Command Size--- Limit is at 32K (32768).  The Load Commands contain the install--- name, dependencies, runpaths, and a few other commands.  We however--- only have control over the install name, dependencies and runpaths.------ The install name is the name by which this library will be--- referenced.  This is such that we do not need to bake in the full--- absolute location of the library, and can move the library around.------ The dependency commands contain the install names from of referenced--- libraries.  Thus if a libraries install name is @rpath/libHS...dylib,--- that will end up as the dependency.------ Finally we have the runpaths, which informs the linker about the--- directories to search for the referenced dependencies.------ The system linker can do recursive linking, however using only the--- direct dependencies conflicts with ghc's ability to inline across--- packages, and as such would end up with unresolved symbols.------ Thus we will pass the full dependency closure to the linker, and then--- ask the linker to remove any unused dynamic libraries (-dead_strip_dylibs).------ We still need to add the relevant runpaths, for the dynamic linker to--- lookup the referenced libraries though.  The linker (ld64) does not--- have any option to dead strip runpaths; which makes sense as runpaths--- can be used for dependencies of dependencies as well.------ The solution we then take in GHC is to not pass any runpaths to the--- linker at link time, but inject them after the linking.  For this to--- work we'll need to ask the linker to create enough space in the header--- to add more runpaths after the linking (-headerpad 8000).------ After the library has been linked by $LD (usually ld64), we will use--- otool to inspect the libraries left over after dead stripping, compute--- the relevant runpaths, and inject them into the linked product using--- the install_name_tool command.------ This strategy should produce the smallest possible set of load commands--- while still retaining some form of relocatability via runpaths.------ The only way I can see to reduce the load command size further would be--- by shortening the library names, or start putting libraries into the same--- folders, such that one runpath would be sufficient for multiple/all--- libraries.-link :: GhcLink                 -- ^ interactive or batch-     -> Logger                  -- ^ Logger-     -> TmpFs-     -> Hooks-     -> DynFlags                -- ^ dynamic flags-     -> UnitEnv                 -- ^ unit environment-     -> Bool                    -- ^ attempt linking in batch mode?-     -> HomePackageTable        -- ^ what to link-     -> IO SuccessFlag---- For the moment, in the batch linker, we don't bother to tell doLink--- which packages to link -- it just tries all that are available.--- batch_attempt_linking should only be *looked at* in batch mode.  It--- should only be True if the upsweep was successful and someone--- exports main, i.e., we have good reason to believe that linking--- will succeed.--link ghcLink logger tmpfs hooks dflags unit_env batch_attempt_linking hpt =-  case linkHook hooks of-      Nothing -> case ghcLink of-          NoLink        -> return Succeeded-          LinkBinary    -> link' logger tmpfs dflags unit_env batch_attempt_linking hpt-          LinkStaticLib -> link' logger tmpfs dflags unit_env batch_attempt_linking hpt-          LinkDynLib    -> link' logger tmpfs dflags unit_env batch_attempt_linking hpt-          LinkInMemory-              | platformMisc_ghcWithInterpreter $ platformMisc dflags-              -> -- Not Linking...(demand linker will do the job)-                 return Succeeded-              | otherwise-              -> panicBadLink LinkInMemory-      Just h  -> h ghcLink dflags batch_attempt_linking hpt---panicBadLink :: GhcLink -> a-panicBadLink other = panic ("link: GHC not built to link this way: " ++-                            show other)--link' :: Logger-      -> TmpFs-      -> DynFlags                -- ^ dynamic flags-      -> UnitEnv                 -- ^ unit environment-      -> Bool                    -- ^ attempt linking in batch mode?-      -> HomePackageTable        -- ^ what to link-      -> IO SuccessFlag--link' logger tmpfs dflags unit_env batch_attempt_linking hpt-   | batch_attempt_linking-   = do-        let-            staticLink = case ghcLink dflags of-                          LinkStaticLib -> True-                          _ -> False--            home_mod_infos = eltsHpt hpt--            -- the packages we depend on-            pkg_deps  = concatMap (map fst . dep_pkgs . mi_deps . hm_iface) home_mod_infos--            -- the linkables to link-            linkables = map (expectJust "link".hm_linkable) home_mod_infos--        debugTraceMsg logger dflags 3 (text "link: linkables are ..." $$ vcat (map ppr linkables))--        -- check for the -no-link flag-        if isNoLink (ghcLink dflags)-          then do debugTraceMsg logger dflags 3 (text "link(batch): linking omitted (-c flag given).")-                  return Succeeded-          else do--        let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)-            obj_files = concatMap getOfiles linkables-            platform  = targetPlatform dflags-            exe_file  = exeFileName platform staticLink (outputFile dflags)--        linking_needed <- linkingNeeded logger dflags unit_env staticLink linkables pkg_deps--        if not (gopt Opt_ForceRecomp dflags) && not linking_needed-           then do debugTraceMsg logger dflags 2 (text exe_file <+> text "is up to date, linking not required.")-                   return Succeeded-           else do--        compilationProgressMsg logger dflags (text "Linking " <> text exe_file <> text " ...")--        -- Don't showPass in Batch mode; doLink will do that for us.-        let link = case ghcLink dflags of-                LinkBinary    -> linkBinary logger tmpfs-                LinkStaticLib -> linkStaticLib logger-                LinkDynLib    -> linkDynLibCheck logger tmpfs-                other         -> panicBadLink other-        link dflags unit_env obj_files pkg_deps--        debugTraceMsg logger dflags 3 (text "link: done")--        -- linkBinary only returns if it succeeds-        return Succeeded--   | otherwise-   = do debugTraceMsg logger dflags 3 (text "link(batch): upsweep (partially) failed OR" $$-                                text "   Main.main not exported; not linking.")-        return Succeeded---linkingNeeded :: Logger -> DynFlags -> UnitEnv -> Bool -> [Linkable] -> [UnitId] -> IO Bool-linkingNeeded logger dflags unit_env staticLink linkables pkg_deps = do-        -- if the modification time on the executable is later than the-        -- modification times on all of the objects and libraries, then omit-        -- linking (unless the -fforce-recomp flag was given).-  let platform   = ue_platform unit_env-      unit_state = ue_units unit_env-      exe_file   = exeFileName platform staticLink (outputFile dflags)-  e_exe_time <- tryIO $ getModificationUTCTime exe_file-  case e_exe_time of-    Left _  -> return True-    Right t -> do-        -- first check object files and extra_ld_inputs-        let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ]-        e_extra_times <- mapM (tryIO . getModificationUTCTime) extra_ld_inputs-        let (errs,extra_times) = partitionEithers e_extra_times-        let obj_times =  map linkableTime linkables ++ extra_times-        if not (null errs) || any (t <) obj_times-            then return True-            else do--        -- next, check libraries. XXX this only checks Haskell libraries,-        -- not extra_libraries or -l things from the command line.-        let pkg_hslibs  = [ (collectLibraryDirs (ways dflags) [c], lib)-                          | Just c <- map (lookupUnitId unit_state) pkg_deps,-                            lib <- unitHsLibs (ghcNameVersion dflags) (ways dflags) c ]--        pkg_libfiles <- mapM (uncurry (findHSLib platform (ways dflags))) pkg_hslibs-        if any isNothing pkg_libfiles then return True else do-        e_lib_times <- mapM (tryIO . getModificationUTCTime)-                          (catMaybes pkg_libfiles)-        let (lib_errs,lib_times) = partitionEithers e_lib_times-        if not (null lib_errs) || any (t <) lib_times-           then return True-           else checkLinkInfo logger dflags unit_env pkg_deps exe_file--findHSLib :: Platform -> Ways -> [String] -> String -> IO (Maybe FilePath)-findHSLib platform ws dirs lib = do-  let batch_lib_file = if WayDyn `notElem` ws-                      then "lib" ++ lib <.> "a"-                      else platformSOName platform lib-  found <- filterM doesFileExist (map (</> batch_lib_file) dirs)-  case found of-    [] -> return Nothing-    (x:_) -> return (Just x)---- -------------------------------------------------------------------------------- Compile files in one-shot mode.--oneShot :: HscEnv -> Phase -> [(String, Maybe Phase)] -> IO ()-oneShot hsc_env stop_phase srcs = do-  o_files <- mapM (compileFile hsc_env stop_phase) srcs-  doLink hsc_env stop_phase o_files--compileFile :: HscEnv -> Phase -> (FilePath, Maybe Phase) -> IO FilePath-compileFile hsc_env stop_phase (src, mb_phase) = do-   exists <- doesFileExist src-   when (not exists) $-        throwGhcExceptionIO (CmdLineError ("does not exist: " ++ src))--   let-        dflags    = hsc_dflags hsc_env-        mb_o_file = outputFile dflags-        ghc_link  = ghcLink dflags      -- Set by -c or -no-link--        -- When linking, the -o argument refers to the linker's output.-        -- otherwise, we use it as the name for the pipeline's output.-        output-         -- If we are doing -fno-code, then act as if the output is-         -- 'Temporary'. This stops GHC trying to copy files to their-         -- final location.-         | NoBackend <- backend dflags = Temporary TFL_CurrentModule-         | StopLn <- stop_phase, not (isNoLink ghc_link) = Persistent-                -- -o foo applies to linker-         | isJust mb_o_file = SpecificFile-                -- -o foo applies to the file we are compiling now-         | otherwise = Persistent--   ( _, out_file, _) <- runPipeline stop_phase hsc_env-                            (src, Nothing, fmap RealPhase mb_phase)-                            Nothing-                            output-                            Nothing{-no ModLocation-} []-   return out_file---doLink :: HscEnv -> Phase -> [FilePath] -> IO ()-doLink hsc_env stop_phase o_files-  | not (isStopLn stop_phase)-  = return ()           -- We stopped before the linking phase--  | otherwise-  = let-        dflags   = hsc_dflags   hsc_env-        logger   = hsc_logger   hsc_env-        unit_env = hsc_unit_env hsc_env-        tmpfs    = hsc_tmpfs    hsc_env-    in case ghcLink dflags of-        NoLink        -> return ()-        LinkBinary    -> linkBinary         logger tmpfs dflags unit_env o_files []-        LinkStaticLib -> linkStaticLib      logger       dflags unit_env o_files []-        LinkDynLib    -> linkDynLibCheck    logger tmpfs dflags unit_env o_files []-        other         -> panicBadLink other----- ------------------------------------------------------------------------------- | Run a compilation pipeline, consisting of multiple phases.------ This is the interface to the compilation pipeline, which runs--- a series of compilation steps on a single source file, specifying--- at which stage to stop.------ The DynFlags can be modified by phases in the pipeline (eg. by--- OPTIONS_GHC pragmas), and the changes affect later phases in the--- pipeline.-runPipeline-  :: Phase                      -- ^ When to stop-  -> HscEnv                     -- ^ Compilation environment-  -> (FilePath, Maybe InputFileBuffer, Maybe PhasePlus)-                                -- ^ Pipeline input file name, optional-                                -- buffer and maybe -x suffix-  -> Maybe FilePath             -- ^ original basename (if different from ^^^)-  -> PipelineOutput             -- ^ Output filename-  -> Maybe ModLocation          -- ^ A ModLocation, if this is a Haskell module-  -> [FilePath]                 -- ^ foreign objects-  -> IO (DynFlags, FilePath, Maybe ModIface)-                                -- ^ (final flags, output filename, interface)-runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase)-             mb_basename output maybe_loc foreign_os--    = do let-             dflags0 = hsc_dflags hsc_env0--             -- Decide where dump files should go based on the pipeline output-             dflags = dflags0 { dumpPrefix = Just (basename ++ ".") }-             hsc_env = hsc_env0 {hsc_dflags = dflags}-             logger = hsc_logger hsc_env-             tmpfs  = hsc_tmpfs  hsc_env--             (input_basename, suffix) = splitExtension input_fn-             suffix' = drop 1 suffix -- strip off the .-             basename | Just b <- mb_basename = b-                      | otherwise             = input_basename--             -- If we were given a -x flag, then use that phase to start from-             start_phase = fromMaybe (RealPhase (startPhase suffix')) mb_phase--             isHaskell (RealPhase (Unlit _)) = True-             isHaskell (RealPhase (Cpp   _)) = True-             isHaskell (RealPhase (HsPp  _)) = True-             isHaskell (RealPhase (Hsc   _)) = True-             isHaskell (HscOut {})           = True-             isHaskell _                     = False--             isHaskellishFile = isHaskell start_phase--             env = PipeEnv{ stop_phase,-                            src_filename = input_fn,-                            src_basename = basename,-                            src_suffix = suffix',-                            output_spec = output }--         when (isBackpackishSuffix suffix') $-           throwGhcExceptionIO (UsageError-                       ("use --backpack to process " ++ input_fn))--         -- We want to catch cases of "you can't get there from here" before-         -- we start the pipeline, because otherwise it will just run off the-         -- end.-         let happensBefore' = happensBefore (targetPlatform dflags)-         case start_phase of-             RealPhase start_phase' ->-                 -- See Note [Partial ordering on phases]-                 -- Not the same as: (stop_phase `happensBefore` start_phase')-                 when (not (start_phase' `happensBefore'` stop_phase ||-                            start_phase' `eqPhase` stop_phase)) $-                       throwGhcExceptionIO (UsageError-                                   ("cannot compile this file to desired target: "-                                      ++ input_fn))-             HscOut {} -> return ()--         -- Write input buffer to temp file if requested-         input_fn' <- case (start_phase, mb_input_buf) of-             (RealPhase real_start_phase, Just input_buf) -> do-                 let suffix = phaseInputExt real_start_phase-                 fn <- newTempName logger tmpfs dflags TFL_CurrentModule suffix-                 hdl <- openBinaryFile fn WriteMode-                 -- Add a LINE pragma so reported source locations will-                 -- mention the real input file, not this temp file.-                 hPutStrLn hdl $ "{-# LINE 1 \""++ input_fn ++ "\"#-}"-                 hPutStringBuffer hdl input_buf-                 hClose hdl-                 return fn-             (_, _) -> return input_fn--         debugTraceMsg logger dflags 4 (text "Running the pipeline")-         r <- runPipeline' start_phase hsc_env env input_fn'-                           maybe_loc foreign_os--         let dflags = hsc_dflags hsc_env-         when isHaskellishFile $-           dynamicTooState dflags >>= \case-               DT_Dont   -> return ()-               DT_Dyn    -> return ()-               DT_OK     -> return ()-               -- If we are compiling a Haskell module with -dynamic-too, we-               -- first try the "fast path": that is we compile the non-dynamic-               -- version and at the same time we check that interfaces depended-               -- on exist both for the non-dynamic AND the dynamic way. We also-               -- check that they have the same hash.-               --    If they don't, dynamicTooState is set to DT_Failed.-               --       See GHC.Iface.Load.checkBuildDynamicToo-               --    If they do, in the end we produce both the non-dynamic and-               --    dynamic outputs.-               ---               -- If this "fast path" failed, we execute the whole pipeline-               -- again, this time for the dynamic way *only*. To do that we-               -- just set the dynamicNow bit from the start to ensure that the-               -- dynamic DynFlags fields are used and we disable -dynamic-too-               -- (its state is already set to DT_Failed so it wouldn't do much-               -- anyway).-               DT_Failed-                   -- NB: Currently disabled on Windows (ref #7134, #8228, and #5987)-                   | OSMinGW32 <- platformOS (targetPlatform dflags) -> return ()-                   | otherwise -> do-                       debugTraceMsg logger dflags 4-                           (text "Running the full pipeline again for -dynamic-too")-                       let dflags0 = flip gopt_unset Opt_BuildDynamicToo-                                      $ setDynamicNow-                                      $ dflags-                       hsc_env' <- newHscEnv dflags0-                       (dbs,unit_state,home_unit,mconstants) <- initUnits logger dflags0 Nothing-                       dflags1 <- updatePlatformConstants dflags0 mconstants-                       let unit_env = UnitEnv-                             { ue_platform  = targetPlatform dflags1-                             , ue_namever   = ghcNameVersion dflags1-                             , ue_home_unit = home_unit-                             , ue_units     = unit_state-                             }-                       let hsc_env'' = hsc_env'-                            { hsc_dflags   = dflags1-                            , hsc_unit_env = unit_env-                            , hsc_unit_dbs = Just dbs-                            }-                       _ <- runPipeline' start_phase hsc_env'' env input_fn'-                                         maybe_loc foreign_os-                       return ()-         return r--runPipeline'-  :: PhasePlus                  -- ^ When to start-  -> HscEnv                     -- ^ Compilation environment-  -> PipeEnv-  -> FilePath                   -- ^ Input filename-  -> Maybe ModLocation          -- ^ A ModLocation, if this is a Haskell module-  -> [FilePath]                 -- ^ foreign objects, if we have one-  -> IO (DynFlags, FilePath, Maybe ModIface)-                                -- ^ (final flags, output filename, interface)-runPipeline' start_phase hsc_env env input_fn-             maybe_loc foreign_os-  = do-  -- Execute the pipeline...-  let state = PipeState{ hsc_env, maybe_loc, foreign_os = foreign_os, iface = Nothing }-  (pipe_state, fp) <- evalP (pipeLoop start_phase input_fn) env state-  return (pipeStateDynFlags pipe_state, fp, pipeStateModIface pipe_state)---- ------------------------------------------------------------------------------ outer pipeline loop---- | pipeLoop runs phases until we reach the stop phase-pipeLoop :: PhasePlus -> FilePath -> CompPipeline FilePath-pipeLoop phase input_fn = do-  env <- getPipeEnv-  dflags <- getDynFlags-  logger <- getLogger-  -- See Note [Partial ordering on phases]-  let happensBefore' = happensBefore (targetPlatform dflags)-      stopPhase = stop_phase env-  case phase of-   RealPhase realPhase | realPhase `eqPhase` stopPhase            -- All done-     -> -- Sometimes, a compilation phase doesn't actually generate any output-        -- (eg. the CPP phase when -fcpp is not turned on).  If we end on this-        -- stage, but we wanted to keep the output, then we have to explicitly-        -- copy the file, remembering to prepend a {-# LINE #-} pragma so that-        -- further compilation stages can tell what the original filename was.-        case output_spec env of-        Temporary _ ->-            return input_fn-        output ->-            do pst <- getPipeState-               tmpfs <- hsc_tmpfs <$> getPipeSession-               final_fn <- liftIO $ getOutputFilename logger tmpfs-                                        stopPhase output (src_basename env)-                                        dflags stopPhase (maybe_loc pst)-               when (final_fn /= input_fn) $ do-                  let msg = ("Copying `" ++ input_fn ++"' to `" ++ final_fn ++ "'")-                      line_prag = Just ("{-# LINE 1 \"" ++ src_filename env ++ "\" #-}\n")-                  liftIO $ copyWithHeader logger dflags msg line_prag input_fn final_fn-               return final_fn---     | not (realPhase `happensBefore'` stopPhase)-        -- Something has gone wrong.  We'll try to cover all the cases when-        -- this could happen, so if we reach here it is a panic.-        -- eg. it might happen if the -C flag is used on a source file that-        -- has {-# OPTIONS -fasm #-}.-     -> panic ("pipeLoop: at phase " ++ show realPhase ++-           " but I wanted to stop at phase " ++ show stopPhase)--   _-     -> do liftIO $ debugTraceMsg logger dflags 4-                                  (text "Running phase" <+> ppr phase)--           case phase of-               HscOut {} -> do-                   -- Depending on the dynamic-too state, we first run the-                   -- backend to generate the non-dynamic objects and then-                   -- re-run it to generate the dynamic ones.-                   let noDynToo = do-                        (next_phase, output_fn) <- runHookedPhase phase input_fn-                        pipeLoop next_phase output_fn-                   let dynToo = do-                          -- we must run the non-dynamic way before the dynamic-                          -- one because there may be interfaces loaded only in-                          -- the backend (e.g., in CorePrep). See #19264-                          r <- noDynToo--                          -- we must check the dynamic-too state again, because-                          -- we may have failed to load a dynamic interface in-                          -- the backend.-                          dynamicTooState dflags >>= \case-                            DT_OK -> do-                                let dflags' = setDynamicNow dflags -- set "dynamicNow"-                                setDynFlags dflags'-                                (next_phase, output_fn) <- runHookedPhase phase input_fn-                                _ <- pipeLoop next_phase output_fn-                                -- TODO: we probably shouldn't ignore the result of-                                -- the dynamic compilation-                                setDynFlags dflags -- restore flags without "dynamicNow" set-                                return r-                            _ -> return r--                   dynamicTooState dflags >>= \case-                     DT_Dont   -> noDynToo-                     DT_Failed -> noDynToo-                     DT_OK     -> dynToo-                     DT_Dyn    -> noDynToo-                        -- it shouldn't be possible to be in this last case-                        -- here. It would mean that we executed the whole-                        -- pipeline with DynamicNow and Opt_BuildDynamicToo set.-                        ---                        -- When we restart the whole pipeline for -dynamic-too-                        -- we set DynamicNow but we unset Opt_BuildDynamicToo so-                        -- it's weird.-               _ -> do-                  (next_phase, output_fn) <- runHookedPhase phase input_fn-                  pipeLoop next_phase output_fn--runHookedPhase :: PhasePlus -> FilePath -> CompPipeline (PhasePlus, FilePath)-runHookedPhase pp input = do-  hooks <- hsc_hooks <$> getPipeSession-  case runPhaseHook hooks of-    Nothing -> runPhase pp input-    Just h  -> h pp input---- -------------------------------------------------------------------------------- In each phase, we need to know into what filename to generate the--- output.  All the logic about which filenames we generate output--- into is embodied in the following function.---- | Computes the next output filename after we run @next_phase@.--- Like 'getOutputFilename', but it operates in the 'CompPipeline' monad--- (which specifies all of the ambient information.)-phaseOutputFilename :: Phase{-next phase-} -> CompPipeline FilePath-phaseOutputFilename next_phase = do-  PipeEnv{stop_phase, src_basename, output_spec} <- getPipeEnv-  PipeState{maybe_loc,hsc_env} <- getPipeState-  dflags <- getDynFlags-  logger <- getLogger-  let tmpfs = hsc_tmpfs hsc_env-  liftIO $ getOutputFilename logger tmpfs stop_phase output_spec-                             src_basename dflags next_phase maybe_loc---- | Computes the next output filename for something in the compilation--- pipeline.  This is controlled by several variables:------      1. 'Phase': the last phase to be run (e.g. 'stopPhase').  This---         is used to tell if we're in the last phase or not, because---         in that case flags like @-o@ may be important.---      2. 'PipelineOutput': is this intended to be a 'Temporary' or---         'Persistent' build output?  Temporary files just go in---         a fresh temporary name.---      3. 'String': what was the basename of the original input file?---      4. 'DynFlags': the obvious thing---      5. 'Phase': the phase we want to determine the output filename of.---      6. @Maybe ModLocation@: the 'ModLocation' of the module we're---         compiling; this can be used to override the default output---         of an object file.  (TODO: do we actually need this?)-getOutputFilename-  :: Logger-  -> TmpFs-  -> Phase-  -> PipelineOutput-  -> String-  -> DynFlags-  -> Phase -- next phase-  -> Maybe ModLocation-  -> IO FilePath-getOutputFilename logger tmpfs stop_phase output basename dflags next_phase maybe_location- | is_last_phase, Persistent   <- output = persistent_fn- | is_last_phase, SpecificFile <- output = case outputFile dflags of-                                           Just f -> return f-                                           Nothing ->-                                               panic "SpecificFile: No filename"- | keep_this_output                      = persistent_fn- | Temporary lifetime <- output          = newTempName logger tmpfs dflags lifetime suffix- | otherwise                             = newTempName logger tmpfs dflags TFL_CurrentModule-   suffix-    where-          hcsuf      = hcSuf dflags-          odir       = objectDir dflags-          osuf       = objectSuf dflags-          keep_hc    = gopt Opt_KeepHcFiles dflags-          keep_hscpp = gopt Opt_KeepHscppFiles dflags-          keep_s     = gopt Opt_KeepSFiles dflags-          keep_bc    = gopt Opt_KeepLlvmFiles dflags--          myPhaseInputExt HCc       = hcsuf-          myPhaseInputExt MergeForeign = osuf-          myPhaseInputExt StopLn    = osuf-          myPhaseInputExt other     = phaseInputExt other--          is_last_phase = next_phase `eqPhase` stop_phase--          -- sometimes, we keep output from intermediate stages-          keep_this_output =-               case next_phase of-                       As _    | keep_s     -> True-                       LlvmOpt | keep_bc    -> True-                       HCc     | keep_hc    -> True-                       HsPp _  | keep_hscpp -> True   -- See #10869-                       _other               -> False--          suffix = myPhaseInputExt next_phase--          -- persistent object files get put in odir-          persistent_fn-             | StopLn <- next_phase = return odir_persistent-             | otherwise            = return persistent--          persistent = basename <.> suffix--          odir_persistent-             | Just loc <- maybe_location = ml_obj_file loc-             | Just d <- odir = d </> persistent-             | otherwise      = persistent----- | LLVM Options. These are flags to be passed to opt and llc, to ensure--- consistency we list them in pairs, so that they form groups.-llvmOptions :: DynFlags-            -> [(String, String)]  -- ^ pairs of (opt, llc) arguments-llvmOptions dflags =-       [("-enable-tbaa -tbaa",  "-enable-tbaa") | gopt Opt_LlvmTBAA dflags ]-    ++ [("-relocation-model=" ++ rmodel-        ,"-relocation-model=" ++ rmodel) | not (null rmodel)]-    ++ [("-stack-alignment=" ++ (show align)-        ,"-stack-alignment=" ++ (show align)) | align > 0 ]--    -- Additional llc flags-    ++ [("", "-mcpu=" ++ mcpu)   | not (null mcpu)-                                 , not (any (isInfixOf "-mcpu") (getOpts dflags opt_lc)) ]-    ++ [("", "-mattr=" ++ attrs) | not (null attrs) ]-    ++ [("", "-target-abi=" ++ abi) | not (null abi) ]--  where target = platformMisc_llvmTarget $ platformMisc dflags-        Just (LlvmTarget _ mcpu mattr) = lookup target (llvmTargets $ llvmConfig dflags)--        -- Relocation models-        rmodel | gopt Opt_PIC dflags        = "pic"-               | positionIndependent dflags = "pic"-               | WayDyn `elem` ways dflags  = "dynamic-no-pic"-               | otherwise                  = "static"--        platform = targetPlatform dflags--        align :: Int-        align = case platformArch platform of-                  ArchX86_64 | isAvxEnabled dflags -> 32-                  _                                -> 0--        attrs :: String-        attrs = intercalate "," $ mattr-              ++ ["+sse42"   | isSse4_2Enabled dflags   ]-              ++ ["+sse2"    | isSse2Enabled platform   ]-              ++ ["+sse"     | isSseEnabled platform    ]-              ++ ["+avx512f" | isAvx512fEnabled dflags  ]-              ++ ["+avx2"    | isAvx2Enabled dflags     ]-              ++ ["+avx"     | isAvxEnabled dflags      ]-              ++ ["+avx512cd"| isAvx512cdEnabled dflags ]-              ++ ["+avx512er"| isAvx512erEnabled dflags ]-              ++ ["+avx512pf"| isAvx512pfEnabled dflags ]-              ++ ["+bmi"     | isBmiEnabled dflags      ]-              ++ ["+bmi2"    | isBmi2Enabled dflags     ]--        abi :: String-        abi = case platformArch (targetPlatform dflags) of-                ArchRISCV64 -> "lp64d"-                _           -> ""---- -------------------------------------------------------------------------------- | Each phase in the pipeline returns the next phase to execute, and the--- name of the file in which the output was placed.------ We must do things dynamically this way, because we often don't know--- what the rest of the phases will be until part-way through the--- compilation: for example, an {-# OPTIONS -fasm #-} at the beginning--- of a source file can change the latter stages of the pipeline from--- taking the LLVM route to using the native code generator.----runPhase :: PhasePlus   -- ^ Run this phase-         -> FilePath    -- ^ name of the input file-         -> CompPipeline (PhasePlus,           -- next phase to run-                          FilePath)            -- output filename--        -- Invariant: the output filename always contains the output-        -- Interesting case: Hsc when there is no recompilation to do-        --                   Then the output filename is still a .o file------------------------------------------------------------------------------------- Unlit phase--runPhase (RealPhase (Unlit sf)) input_fn = do-    let-       -- escape the characters \, ", and ', but don't try to escape-       -- Unicode or anything else (so we don't use Util.charToC-       -- here).  If we get this wrong, then in-       -- GHC.HsToCore.Coverage.isGoodTickSrcSpan where we check that the filename in-       -- a SrcLoc is the same as the source filenaame, the two will-       -- look bogusly different. See test:-       -- libraries/hpc/tests/function/subdir/tough2.hs-       escape ('\\':cs) = '\\':'\\': escape cs-       escape ('\"':cs) = '\\':'\"': escape cs-       escape ('\'':cs) = '\\':'\'': escape cs-       escape (c:cs)    = c : escape cs-       escape []        = []--    output_fn <- phaseOutputFilename (Cpp sf)--    let flags = [ -- The -h option passes the file name for unlit to-                  -- put in a #line directive-                  GHC.SysTools.Option     "-h"-                  -- See Note [Don't normalise input filenames].-                , GHC.SysTools.Option $ escape input_fn-                , GHC.SysTools.FileOption "" input_fn-                , GHC.SysTools.FileOption "" output_fn-                ]--    dflags <- getDynFlags-    logger <- getLogger-    liftIO $ GHC.SysTools.runUnlit logger dflags flags--    return (RealPhase (Cpp sf), output_fn)------------------------------------------------------------------------------------ Cpp phase : (a) gets OPTIONS out of file---             (b) runs cpp if necessary--runPhase (RealPhase (Cpp sf)) input_fn-  = do-       dflags0 <- getDynFlags-       logger <- getLogger-       src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn-       (dflags1, unhandled_flags, warns)-           <- liftIO $ parseDynamicFilePragma dflags0 src_opts-       setDynFlags dflags1-       liftIO $ checkProcessArgsResult unhandled_flags--       if not (xopt LangExt.Cpp dflags1) then do-           -- we have to be careful to emit warnings only once.-           unless (gopt Opt_Pp dflags1) $-               liftIO $ handleFlagWarnings logger dflags1 warns--           -- no need to preprocess CPP, just pass input file along-           -- to the next phase of the pipeline.-           return (RealPhase (HsPp sf), input_fn)-        else do-            output_fn <- phaseOutputFilename (HsPp sf)-            hsc_env <- getPipeSession-            liftIO $ doCpp logger-                           (hsc_tmpfs hsc_env)-                           (hsc_dflags hsc_env)-                           (hsc_unit_env hsc_env)-                           True{-raw-}-                           input_fn output_fn-            -- re-read the pragmas now that we've preprocessed the file-            -- See #2464,#3457-            src_opts <- liftIO $ getOptionsFromFile dflags0 output_fn-            (dflags2, unhandled_flags, warns)-                <- liftIO $ parseDynamicFilePragma dflags0 src_opts-            liftIO $ checkProcessArgsResult unhandled_flags-            unless (gopt Opt_Pp dflags2) $-                liftIO $ handleFlagWarnings logger dflags2 warns-            -- the HsPp pass below will emit warnings--            setDynFlags dflags2--            return (RealPhase (HsPp sf), output_fn)------------------------------------------------------------------------------------ HsPp phase--runPhase (RealPhase (HsPp sf)) input_fn = do-    dflags <- getDynFlags-    logger <- getLogger-    if not (gopt Opt_Pp dflags) then-      -- no need to preprocess, just pass input file along-      -- to the next phase of the pipeline.-       return (RealPhase (Hsc sf), input_fn)-    else do-        PipeEnv{src_basename, src_suffix} <- getPipeEnv-        let orig_fn = src_basename <.> src_suffix-        output_fn <- phaseOutputFilename (Hsc sf)-        liftIO $ GHC.SysTools.runPp logger dflags-                       ( [ GHC.SysTools.Option     orig_fn-                         , GHC.SysTools.Option     input_fn-                         , GHC.SysTools.FileOption "" output_fn-                         ]-                       )--        -- re-read pragmas now that we've parsed the file (see #3674)-        src_opts <- liftIO $ getOptionsFromFile dflags output_fn-        (dflags1, unhandled_flags, warns)-            <- liftIO $ parseDynamicFilePragma dflags src_opts-        setDynFlags dflags1-        liftIO $ checkProcessArgsResult unhandled_flags-        liftIO $ handleFlagWarnings logger dflags1 warns--        return (RealPhase (Hsc sf), output_fn)---------------------------------------------------------------------------------- Hsc phase---- Compilation of a single module, in "legacy" mode (_not_ under--- the direction of the compilation manager).-runPhase (RealPhase (Hsc src_flavour)) input_fn- = do   -- normal Hsc mode, not mkdependHS-        dflags0 <- getDynFlags--        PipeEnv{ stop_phase=stop,-                 src_basename=basename,-                 src_suffix=suff } <- getPipeEnv--  -- we add the current directory (i.e. the directory in which-  -- the .hs files resides) to the include path, since this is-  -- what gcc does, and it's probably what you want.-        let current_dir = takeDirectory basename-            new_includes = addImplicitQuoteInclude paths [current_dir]-            paths = includePaths dflags0-            dflags = dflags0 { includePaths = new_includes }--        setDynFlags dflags--  -- gather the imports and module name-        (hspp_buf,mod_name,imps,src_imps) <- liftIO $ do-            buf <- hGetStringBuffer input_fn-            let imp_prelude = xopt LangExt.ImplicitPrelude dflags-                popts = initParserOpts dflags-            eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff)-            case eimps of-              Left errs -> throwErrors (fmap pprError errs)-              Right (src_imps,imps,L _ mod_name) -> return-                  (Just buf, mod_name, imps, src_imps)--  -- Take -o into account if present-  -- Very like -ohi, but we must *only* do this if we aren't linking-  -- (If we're linking then the -o applies to the linked thing, not to-  -- the object file for one module.)-  -- Note the nasty duplication with the same computation in compileFile above-        location <- getLocation src_flavour mod_name--        let o_file = ml_obj_file location -- The real object file-            hi_file = ml_hi_file location-            hie_file = ml_hie_file location-            dest_file | writeInterfaceOnlyMode dflags-                            = hi_file-                      | otherwise-                            = o_file--  -- Figure out if the source has changed, for recompilation avoidance.-  ---  -- Setting source_unchanged to True means that M.o (or M.hie) seems-  -- to be up to date wrt M.hs; so no need to recompile unless imports have-  -- changed (which the compiler itself figures out).-  -- Setting source_unchanged to False tells the compiler that M.o is out of-  -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.-        src_timestamp <- liftIO $ getModificationUTCTime (basename <.> suff)--        source_unchanged <- liftIO $-          if not (isStopLn stop)-                -- SourceModified unconditionally if-                --      (a) recompilation checker is off, or-                --      (b) we aren't going all the way to .o file (e.g. ghc -S)-             then return SourceModified-                -- Otherwise look at file modification dates-             else do dest_file_mod <- sourceModified dest_file src_timestamp-                     hie_file_mod <- if gopt Opt_WriteHie dflags-                                        then sourceModified hie_file-                                                            src_timestamp-                                        else pure False-                     if dest_file_mod || hie_file_mod-                        then return SourceModified-                        else return SourceUnmodified--        PipeState{hsc_env=hsc_env'} <- getPipeState--  -- Tell the finder cache about this module-        mod <- liftIO $ addHomeModuleToFinder hsc_env' mod_name location--  -- Make the ModSummary to hand to hscMain-        let-            mod_summary = ModSummary {  ms_mod       = mod,-                                        ms_hsc_src   = src_flavour,-                                        ms_hspp_file = input_fn,-                                        ms_hspp_opts = dflags,-                                        ms_hspp_buf  = hspp_buf,-                                        ms_location  = location,-                                        ms_hs_date   = src_timestamp,-                                        ms_obj_date  = Nothing,-                                        ms_parsed_mod   = Nothing,-                                        ms_iface_date   = Nothing,-                                        ms_hie_date     = Nothing,-                                        ms_textual_imps = imps,-                                        ms_srcimps      = src_imps }--  -- run the compiler!-        let msg hsc_env _ what _ = oneShotMsg hsc_env what-        (result, plugin_hsc_env) <--          liftIO $ hscIncrementalCompile True Nothing (Just msg) hsc_env'-                            mod_summary source_unchanged Nothing (1,1)--        -- In the rest of the pipeline use the loaded plugins-        setPlugins (hsc_plugins        plugin_hsc_env)-                   (hsc_static_plugins plugin_hsc_env)-        -- "driver" plugins may have modified the DynFlags so we update them-        setDynFlags (hsc_dflags plugin_hsc_env)--        return (HscOut src_flavour mod_name result,-                panic "HscOut doesn't have an input filename")--runPhase (HscOut src_flavour mod_name result) _ = do-        dflags <- getDynFlags-        logger <- getLogger-        location <- getLocation src_flavour mod_name-        setModLocation location--        let o_file = ml_obj_file location -- The real object file-            next_phase = hscPostBackendPhase src_flavour (backend dflags)--        case result of-            HscNotGeneratingCode _ _ ->-                return (RealPhase StopLn,-                        panic "No output filename from Hsc when no-code")-            HscUpToDate _ _ ->-                do liftIO $ touchObjectFile logger dflags o_file-                   -- The .o file must have a later modification date-                   -- than the source file (else we wouldn't get Nothing)-                   -- but we touch it anyway, to keep 'make' happy (we think).-                   return (RealPhase StopLn, o_file)-            HscUpdateBoot _ _ ->-                do -- In the case of hs-boot files, generate a dummy .o-boot-                   -- stamp file for the benefit of Make-                   liftIO $ touchObjectFile logger dflags o_file-                   return (RealPhase StopLn, o_file)-            HscUpdateSig _ _ ->-                do -- We need to create a REAL but empty .o file-                   -- because we are going to attempt to put it in a library-                   PipeState{hsc_env=hsc_env'} <- getPipeState-                   let input_fn = expectJust "runPhase" (ml_hs_file location)-                       basename = dropExtension input_fn-                   liftIO $ compileEmptyStub dflags hsc_env' basename location mod_name-                   return (RealPhase StopLn, o_file)-            HscRecomp { hscs_guts = cgguts,-                        hscs_mod_location = mod_location,-                        hscs_partial_iface = partial_iface,-                        hscs_old_iface_hash = mb_old_iface_hash-                      }-              -> do output_fn <- phaseOutputFilename next_phase--                    PipeState{hsc_env=hsc_env'} <- getPipeState--                    (outputFilename, mStub, foreign_files, cg_infos) <- liftIO $-                      hscGenHardCode hsc_env' cgguts mod_location output_fn--                    let dflags = hsc_dflags hsc_env'-                    final_iface <- liftIO (mkFullIface hsc_env' partial_iface (Just cg_infos))-                    setIface final_iface--                    -- See Note [Writing interface files]-                    liftIO $ hscMaybeWriteIface logger dflags False final_iface mb_old_iface_hash mod_location--                    stub_o <- liftIO (mapM (compileStub hsc_env') mStub)-                    foreign_os <- liftIO $-                      mapM (uncurry (compileForeign hsc_env')) foreign_files-                    setForeignOs (maybe [] return stub_o ++ foreign_os)--                    return (RealPhase next_phase, outputFilename)---------------------------------------------------------------------------------- Cmm phase--runPhase (RealPhase CmmCpp) input_fn = do-       hsc_env <- getPipeSession-       logger <- getLogger-       output_fn <- phaseOutputFilename Cmm-       liftIO $ doCpp logger-                      (hsc_tmpfs hsc_env)-                      (hsc_dflags hsc_env)-                      (hsc_unit_env hsc_env)-                      False{-not raw-}-                      input_fn output_fn-       return (RealPhase Cmm, output_fn)--runPhase (RealPhase Cmm) input_fn = do-       hsc_env <- getPipeSession-       let dflags = hsc_dflags hsc_env-       let next_phase = hscPostBackendPhase HsSrcFile (backend dflags)-       output_fn <- phaseOutputFilename next_phase-       PipeState{hsc_env} <- getPipeState-       mstub <- liftIO $ hscCompileCmmFile hsc_env input_fn output_fn-       stub_o <- liftIO (mapM (compileStub hsc_env) mstub)-       setForeignOs (maybeToList stub_o)-       return (RealPhase next_phase, output_fn)---------------------------------------------------------------------------------- Cc phase--runPhase (RealPhase cc_phase) input_fn-   | any (cc_phase `eqPhase`) [Cc, Ccxx, HCc, Cobjc, Cobjcxx]-   = do-        hsc_env <- getPipeSession-        let dflags    = hsc_dflags hsc_env-        let unit_env  = hsc_unit_env hsc_env-        let home_unit = hsc_home_unit hsc_env-        let tmpfs     = hsc_tmpfs hsc_env-        let platform  = ue_platform unit_env-        let hcc       = cc_phase `eqPhase` HCc--        let cmdline_include_paths = includePaths dflags--        -- HC files have the dependent packages stamped into them-        pkgs <- if hcc then liftIO $ getHCFilePackages input_fn else return []--        -- add package include paths even if we're just compiling .c-        -- files; this is the Value Add(TM) that using ghc instead of-        -- gcc gives you :)-        ps <- liftIO $ mayThrowUnitErr (preloadUnitsInfo' unit_env pkgs)-        let pkg_include_dirs     = collectIncludeDirs ps-        let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []-              (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)-        let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []-              (includePathsQuote cmdline_include_paths ++-               includePathsQuoteImplicit cmdline_include_paths)-        let include_paths = include_paths_quote ++ include_paths_global--        -- pass -D or -optP to preprocessor when compiling foreign C files-        -- (#16737). Doing it in this way is simpler and also enable the C-        -- compiler to perform preprocessing and parsing in a single pass,-        -- but it may introduce inconsistency if a different pgm_P is specified.-        let more_preprocessor_opts = concat-              [ ["-Xpreprocessor", i]-              | not hcc-              , i <- getOpts dflags opt_P-              ]--        let gcc_extra_viac_flags = extraGccViaCFlags dflags-        let pic_c_flags = picCCOpts dflags--        let verbFlags = getVerbFlags dflags--        -- cc-options are not passed when compiling .hc files.  Our-        -- hc code doesn't not #include any header files anyway, so these-        -- options aren't necessary.-        let pkg_extra_cc_opts-                | hcc       = []-                | otherwise = collectExtraCcOpts ps--        let framework_paths-                | platformUsesFrameworks platform-                = let pkgFrameworkPaths     = collectFrameworksDirs ps-                      cmdlineFrameworkPaths = frameworkPaths dflags-                  in map ("-F"++) (cmdlineFrameworkPaths ++ pkgFrameworkPaths)-                | otherwise-                = []--        let cc_opt | optLevel dflags >= 2 = [ "-O2" ]-                   | optLevel dflags >= 1 = [ "-O" ]-                   | otherwise            = []--        -- Decide next phase-        let next_phase = As False-        output_fn <- phaseOutputFilename next_phase--        let-          more_hcc_opts =-                -- on x86 the floating point regs have greater precision-                -- than a double, which leads to unpredictable results.-                -- By default, we turn this off with -ffloat-store unless-                -- the user specified -fexcess-precision.-                (if platformArch platform == ArchX86 &&-                    not (gopt Opt_ExcessPrecision dflags)-                        then [ "-ffloat-store" ]-                        else []) ++--                -- gcc's -fstrict-aliasing allows two accesses to memory-                -- to be considered non-aliasing if they have different types.-                -- This interacts badly with the C code we generate, which is-                -- very weakly typed, being derived from C--.-                ["-fno-strict-aliasing"]--        ghcVersionH <- liftIO $ getGhcVersionPathName dflags unit_env--        logger <- getLogger-        liftIO $ GHC.SysTools.runCc (phaseForeignLanguage cc_phase) logger tmpfs dflags (-                        [ GHC.SysTools.FileOption "" input_fn-                        , GHC.SysTools.Option "-o"-                        , GHC.SysTools.FileOption "" output_fn-                        ]-                       ++ map GHC.SysTools.Option (-                          pic_c_flags--                -- Stub files generated for foreign exports references the runIO_closure-                -- and runNonIO_closure symbols, which are defined in the base package.-                -- These symbols are imported into the stub.c file via RtsAPI.h, and the-                -- way we do the import depends on whether we're currently compiling-                -- the base package or not.-                       ++ (if platformOS platform == OSMinGW32 &&-                              isHomeUnitId home_unit baseUnitId-                                then [ "-DCOMPILING_BASE_PACKAGE" ]-                                else [])--        -- We only support SparcV9 and better because V8 lacks an atomic CAS-        -- instruction. Note that the user can still override this-        -- (e.g., -mcpu=ultrasparc) as GCC picks the "best" -mcpu flag-        -- regardless of the ordering.-        ---        -- This is a temporary hack. See #2872, commit-        -- 5bd3072ac30216a505151601884ac88bf404c9f2-                       ++ (if platformArch platform == ArchSPARC-                           then ["-mcpu=v9"]-                           else [])--                       -- GCC 4.6+ doesn't like -Wimplicit when compiling C++.-                       ++ (if (cc_phase /= Ccxx && cc_phase /= Cobjcxx)-                             then ["-Wimplicit"]-                             else [])--                       ++ (if hcc-                             then gcc_extra_viac_flags ++ more_hcc_opts-                             else [])-                       ++ verbFlags-                       ++ [ "-S" ]-                       ++ cc_opt-                       ++ [ "-include", ghcVersionH ]-                       ++ framework_paths-                       ++ include_paths-                       ++ more_preprocessor_opts-                       ++ pkg_extra_cc_opts-                       ))--        return (RealPhase next_phase, output_fn)---------------------------------------------------------------------------------- As, SpitAs phase : Assembler---- This is for calling the assembler on a regular assembly file-runPhase (RealPhase (As with_cpp)) input_fn-  = do-        hsc_env <- getPipeSession-        let dflags     = hsc_dflags   hsc_env-        let logger     = hsc_logger   hsc_env-        let unit_env   = hsc_unit_env hsc_env-        let platform   = ue_platform unit_env--        -- LLVM from version 3.0 onwards doesn't support the OS X system-        -- assembler, so we use clang as the assembler instead. (#5636)-        let as_prog | backend dflags == LLVM-                    , platformOS platform == OSDarwin-                    = GHC.SysTools.runClang-                    | otherwise-                    = GHC.SysTools.runAs--        let cmdline_include_paths = includePaths dflags-        let pic_c_flags = picCCOpts dflags--        next_phase <- maybeMergeForeign-        output_fn <- phaseOutputFilename next_phase--        -- we create directories for the object file, because it-        -- might be a hierarchical module.-        liftIO $ createDirectoryIfMissing True (takeDirectory output_fn)--        ccInfo <- liftIO $ getCompilerInfo logger dflags-        let global_includes = [ GHC.SysTools.Option ("-I" ++ p)-                              | p <- includePathsGlobal cmdline_include_paths ]-        let local_includes = [ GHC.SysTools.Option ("-iquote" ++ p)-                             | p <- includePathsQuote cmdline_include_paths ++-                                includePathsQuoteImplicit cmdline_include_paths]-        let runAssembler inputFilename outputFilename-              = liftIO $-                  withAtomicRename outputFilename $ \temp_outputFilename ->-                    as_prog-                       logger dflags-                       (local_includes ++ global_includes-                       -- See Note [-fPIC for assembler]-                       ++ map GHC.SysTools.Option pic_c_flags-                       -- See Note [Produce big objects on Windows]-                       ++ [ GHC.SysTools.Option "-Wa,-mbig-obj"-                          | platformOS (targetPlatform dflags) == OSMinGW32-                          , not $ target32Bit (targetPlatform dflags)-                          ]--        -- We only support SparcV9 and better because V8 lacks an atomic CAS-        -- instruction so we have to make sure that the assembler accepts the-        -- instruction set. Note that the user can still override this-        -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag-        -- regardless of the ordering.-        ---        -- This is a temporary hack.-                       ++ (if platformArch (targetPlatform dflags) == ArchSPARC-                           then [GHC.SysTools.Option "-mcpu=v9"]-                           else [])-                       ++ (if any (ccInfo ==) [Clang, AppleClang, AppleClang51]-                            then [GHC.SysTools.Option "-Qunused-arguments"]-                            else [])-                       ++ [ GHC.SysTools.Option "-x"-                          , if with_cpp-                              then GHC.SysTools.Option "assembler-with-cpp"-                              else GHC.SysTools.Option "assembler"-                          , GHC.SysTools.Option "-c"-                          , GHC.SysTools.FileOption "" inputFilename-                          , GHC.SysTools.Option "-o"-                          , GHC.SysTools.FileOption "" temp_outputFilename-                          ])--        liftIO $ debugTraceMsg logger dflags 4 (text "Running the assembler")-        runAssembler input_fn output_fn--        return (RealPhase next_phase, output_fn)----------------------------------------------------------------------------------- LlvmOpt phase-runPhase (RealPhase LlvmOpt) input_fn = do-    dflags <- getDynFlags-    logger <- getLogger-    let -- we always (unless -optlo specified) run Opt since we rely on it to-        -- fix up some pretty big deficiencies in the code we generate-        optIdx = max 0 $ min 2 $ optLevel dflags  -- ensure we're in [0,2]-        llvmOpts = case lookup optIdx $ llvmPasses $ llvmConfig dflags of-                    Just passes -> passes-                    Nothing -> panic ("runPhase LlvmOpt: llvm-passes file "-                                      ++ "is missing passes for level "-                                      ++ show optIdx)-        defaultOptions = map GHC.SysTools.Option . concat . fmap words . fst-                         $ unzip (llvmOptions dflags)--        -- don't specify anything if user has specified commands. We do this-        -- for opt but not llc since opt is very specifically for optimisation-        -- passes only, so if the user is passing us extra options we assume-        -- they know what they are doing and don't get in the way.-        optFlag = if null (getOpts dflags opt_lo)-                  then map GHC.SysTools.Option $ words llvmOpts-                  else []--    output_fn <- phaseOutputFilename LlvmLlc--    liftIO $ GHC.SysTools.runLlvmOpt logger dflags-               (   optFlag-                ++ defaultOptions ++-                [ GHC.SysTools.FileOption "" input_fn-                , GHC.SysTools.Option "-o"-                , GHC.SysTools.FileOption "" output_fn]-                )--    return (RealPhase LlvmLlc, output_fn)----------------------------------------------------------------------------------- LlvmLlc phase--runPhase (RealPhase LlvmLlc) input_fn = do-    -- Note [Clamping of llc optimizations]-    ---    -- See #13724-    ---    -- we clamp the llc optimization between [1,2]. This is because passing -O0-    -- to llc 3.9 or llc 4.0, the naive register allocator can fail with-    ---    --   Error while trying to spill R1 from class GPR: Cannot scavenge register-    --   without an emergency spill slot!-    ---    -- Observed at least with target 'arm-unknown-linux-gnueabihf'.-    ---    ---    -- With LLVM4, llc -O3 crashes when ghc-stage1 tries to compile-    --   rts/HeapStackCheck.cmm-    ---    -- llc -O3 '-mtriple=arm-unknown-linux-gnueabihf' -enable-tbaa /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc -o /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_7.lm_s-    -- 0  llc                      0x0000000102ae63e8 llvm::sys::PrintStackTrace(llvm::raw_ostream&) + 40-    -- 1  llc                      0x0000000102ae69a6 SignalHandler(int) + 358-    -- 2  libsystem_platform.dylib 0x00007fffc23f4b3a _sigtramp + 26-    -- 3  libsystem_c.dylib        0x00007fffc226498b __vfprintf + 17876-    -- 4  llc                      0x00000001029d5123 llvm::SelectionDAGISel::LowerArguments(llvm::Function const&) + 5699-    -- 5  llc                      0x0000000102a21a35 llvm::SelectionDAGISel::SelectAllBasicBlocks(llvm::Function const&) + 3381-    -- 6  llc                      0x0000000102a202b1 llvm::SelectionDAGISel::runOnMachineFunction(llvm::MachineFunction&) + 1457-    -- 7  llc                      0x0000000101bdc474 (anonymous namespace)::ARMDAGToDAGISel::runOnMachineFunction(llvm::MachineFunction&) + 20-    -- 8  llc                      0x00000001025573a6 llvm::MachineFunctionPass::runOnFunction(llvm::Function&) + 134-    -- 9  llc                      0x000000010274fb12 llvm::FPPassManager::runOnFunction(llvm::Function&) + 498-    -- 10 llc                      0x000000010274fd23 llvm::FPPassManager::runOnModule(llvm::Module&) + 67-    -- 11 llc                      0x00000001027501b8 llvm::legacy::PassManagerImpl::run(llvm::Module&) + 920-    -- 12 llc                      0x000000010195f075 compileModule(char**, llvm::LLVMContext&) + 12133-    -- 13 llc                      0x000000010195bf0b main + 491-    -- 14 libdyld.dylib            0x00007fffc21e5235 start + 1-    -- Stack dump:-    -- 0.  Program arguments: llc -O3 -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc -o /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_7.lm_s-    -- 1.  Running pass 'Function Pass Manager' on module '/var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc'.-    -- 2.  Running pass 'ARM Instruction Selection' on function '@"stg_gc_f1$def"'-    ---    -- Observed at least with -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa-    ---    dflags <- getDynFlags-    logger <- getLogger-    let-        llvmOpts = case optLevel dflags of-          0 -> "-O1" -- required to get the non-naive reg allocator. Passing -regalloc=greedy is not sufficient.-          1 -> "-O1"-          _ -> "-O2"--        defaultOptions = map GHC.SysTools.Option . concatMap words . snd-                         $ unzip (llvmOptions dflags)-        optFlag = if null (getOpts dflags opt_lc)-                  then map GHC.SysTools.Option $ words llvmOpts-                  else []--    next_phase <- if -- hidden debugging flag '-dno-llvm-mangler' to skip mangling-                     | gopt Opt_NoLlvmMangler dflags -> return (As False)-                     | otherwise -> return LlvmMangle--    output_fn <- phaseOutputFilename next_phase--    liftIO $ GHC.SysTools.runLlvmLlc logger dflags-                (  optFlag-                ++ defaultOptions-                ++ [ GHC.SysTools.FileOption "" input_fn-                   , GHC.SysTools.Option "-o"-                   , GHC.SysTools.FileOption "" output_fn-                   ]-                )--    return (RealPhase next_phase, output_fn)------------------------------------------------------------------------------------ LlvmMangle phase--runPhase (RealPhase LlvmMangle) input_fn = do-      let next_phase = As False-      output_fn <- phaseOutputFilename next_phase-      dflags <- getDynFlags-      logger <- getLogger-      liftIO $ llvmFixupAsm logger dflags input_fn output_fn-      return (RealPhase next_phase, output_fn)---------------------------------------------------------------------------------- merge in stub objects--runPhase (RealPhase MergeForeign) input_fn = do-     PipeState{foreign_os,hsc_env} <- getPipeState-     output_fn <- phaseOutputFilename StopLn-     liftIO $ createDirectoryIfMissing True (takeDirectory output_fn)-     if null foreign_os-       then panic "runPhase(MergeForeign): no foreign objects"-       else do-         dflags <- getDynFlags-         logger <- getLogger-         let tmpfs = hsc_tmpfs hsc_env-         liftIO $ joinObjectFiles logger tmpfs dflags (input_fn : foreign_os) output_fn-         return (RealPhase StopLn, output_fn)---- warning suppression-runPhase (RealPhase other) _input_fn =-   panic ("runPhase: don't know how to run phase " ++ show other)--maybeMergeForeign :: CompPipeline Phase-maybeMergeForeign- = do-     PipeState{foreign_os} <- getPipeState-     if null foreign_os then return StopLn else return MergeForeign--getLocation :: HscSource -> ModuleName -> CompPipeline ModLocation-getLocation src_flavour mod_name = do-    dflags <- getDynFlags--    PipeEnv{ src_basename=basename,-             src_suffix=suff } <- getPipeEnv-    PipeState { maybe_loc=maybe_loc} <- getPipeState-    case maybe_loc of-        -- Build a ModLocation to pass to hscMain.-        -- The source filename is rather irrelevant by now, but it's used-        -- by hscMain for messages.  hscMain also needs-        -- the .hi and .o filenames. If we already have a ModLocation-        -- then simply update the extensions of the interface and object-        -- files to match the DynFlags, otherwise use the logic in Finder.-      Just l -> return $ l-        { ml_hs_file = Just $ basename <.> suff-        , ml_hi_file = ml_hi_file l -<.> hiSuf dflags-        , ml_obj_file = ml_obj_file l -<.> objectSuf dflags-        }-      _ -> do-        location1 <- liftIO $ mkHomeModLocation2 dflags mod_name basename suff--        -- Boot-ify it if necessary-        let location2-              | HsBootFile <- src_flavour = addBootSuffixLocnOut location1-              | otherwise                 = location1---        -- Take -ohi into account if present-        -- This can't be done in mkHomeModuleLocation because-        -- it only applies to the module being compiles-        let ohi = outputHi dflags-            location3 | Just fn <- ohi = location2{ ml_hi_file = fn }-                      | otherwise      = location2--        -- Take -o into account if present-        -- Very like -ohi, but we must *only* do this if we aren't linking-        -- (If we're linking then the -o applies to the linked thing, not to-        -- the object file for one module.)-        -- Note the nasty duplication with the same computation in compileFile-        -- above-        let expl_o_file = outputFile dflags-            location4 | Just ofile <- expl_o_file-                      , isNoLink (ghcLink dflags)-                      = location3 { ml_obj_file = ofile }-                      | otherwise = location3-        return location4---------------------------------------------------------------------------------- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file--getHCFilePackages :: FilePath -> IO [UnitId]-getHCFilePackages filename =-  Exception.bracket (openFile filename ReadMode) hClose $ \h -> do-    l <- hGetLine h-    case l of-      '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest ->-          return (map stringToUnitId (words rest))-      _other ->-          return []---linkDynLibCheck :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO ()-linkDynLibCheck logger tmpfs dflags unit_env o_files dep_units = do-  when (haveRtsOptsFlags dflags) $-    putLogMsg logger dflags NoReason SevInfo noSrcSpan-      $ withPprStyle defaultUserStyle-      (text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$-      text "    Call hs_init_ghc() from your main() function to set these options.")-  linkDynLib logger tmpfs dflags unit_env o_files dep_units----- -------------------------------------------------------------------------------- Running CPP---- | Run CPP------ UnitState is needed to compute MIN_VERSION macros-doCpp :: Logger -> TmpFs -> DynFlags -> UnitEnv -> Bool -> FilePath -> FilePath -> IO ()-doCpp logger tmpfs dflags unit_env raw input_fn output_fn = do-    let hscpp_opts = picPOpts dflags-    let cmdline_include_paths = includePaths dflags-    let unit_state = ue_units unit_env-    pkg_include_dirs <- mayThrowUnitErr-                        (collectIncludeDirs <$> preloadUnitsInfo unit_env)-    let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []-          (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)-    let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []-          (includePathsQuote cmdline_include_paths ++-           includePathsQuoteImplicit cmdline_include_paths)-    let include_paths = include_paths_quote ++ include_paths_global--    let verbFlags = getVerbFlags dflags--    let cpp_prog args | raw       = GHC.SysTools.runCpp logger dflags args-                      | otherwise = GHC.SysTools.runCc Nothing logger tmpfs dflags-                                        (GHC.SysTools.Option "-E" : args)--    let platform   = targetPlatform dflags-        targetArch = stringEncodeArch $ platformArch platform-        targetOS = stringEncodeOS $ platformOS platform-        isWindows = platformOS platform == OSMinGW32-    let target_defs =-          [ "-D" ++ HOST_OS     ++ "_BUILD_OS",-            "-D" ++ HOST_ARCH   ++ "_BUILD_ARCH",-            "-D" ++ targetOS    ++ "_HOST_OS",-            "-D" ++ targetArch  ++ "_HOST_ARCH" ]-        -- remember, in code we *compile*, the HOST is the same our TARGET,-        -- and BUILD is the same as our HOST.--    let io_manager_defs =-          [ "-D__IO_MANAGER_WINIO__=1" | isWindows ] ++-          [ "-D__IO_MANAGER_MIO__=1"               ]--    let sse_defs =-          [ "-D__SSE__"      | isSseEnabled      platform ] ++-          [ "-D__SSE2__"     | isSse2Enabled     platform ] ++-          [ "-D__SSE4_2__"   | isSse4_2Enabled   dflags ]--    let avx_defs =-          [ "-D__AVX__"      | isAvxEnabled      dflags ] ++-          [ "-D__AVX2__"     | isAvx2Enabled     dflags ] ++-          [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++-          [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++-          [ "-D__AVX512F__"  | isAvx512fEnabled  dflags ] ++-          [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ]--    backend_defs <- getBackendDefs logger dflags--    let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ]-    -- Default CPP defines in Haskell source-    ghcVersionH <- getGhcVersionPathName dflags unit_env-    let hsSourceCppOpts = [ "-include", ghcVersionH ]--    -- MIN_VERSION macros-    let uids = explicitUnits unit_state-        pkgs = catMaybes (map (lookupUnit unit_state) uids)-    mb_macro_include <--        if not (null pkgs) && gopt Opt_VersionMacros dflags-            then do macro_stub <- newTempName logger tmpfs dflags TFL_CurrentModule "h"-                    writeFile macro_stub (generatePackageVersionMacros pkgs)-                    -- Include version macros for every *exposed* package.-                    -- Without -hide-all-packages and with a package database-                    -- size of 1000 packages, it takes cpp an estimated 2-                    -- milliseconds to process this file. See #10970-                    -- comment 8.-                    return [GHC.SysTools.FileOption "-include" macro_stub]-            else return []--    cpp_prog       (   map GHC.SysTools.Option verbFlags-                    ++ map GHC.SysTools.Option include_paths-                    ++ map GHC.SysTools.Option hsSourceCppOpts-                    ++ map GHC.SysTools.Option target_defs-                    ++ map GHC.SysTools.Option backend_defs-                    ++ map GHC.SysTools.Option th_defs-                    ++ map GHC.SysTools.Option hscpp_opts-                    ++ map GHC.SysTools.Option sse_defs-                    ++ map GHC.SysTools.Option avx_defs-                    ++ map GHC.SysTools.Option io_manager_defs-                    ++ mb_macro_include-        -- Set the language mode to assembler-with-cpp when preprocessing. This-        -- alleviates some of the C99 macro rules relating to whitespace and the hash-        -- operator, which we tend to abuse. Clang in particular is not very happy-        -- about this.-                    ++ [ GHC.SysTools.Option     "-x"-                       , GHC.SysTools.Option     "assembler-with-cpp"-                       , GHC.SysTools.Option     input_fn-        -- We hackily use Option instead of FileOption here, so that the file-        -- name is not back-slashed on Windows.  cpp is capable of-        -- dealing with / in filenames, so it works fine.  Furthermore-        -- if we put in backslashes, cpp outputs #line directives-        -- with *double* backslashes.   And that in turn means that-        -- our error messages get double backslashes in them.-        -- In due course we should arrange that the lexer deals-        -- with these \\ escapes properly.-                       , GHC.SysTools.Option     "-o"-                       , GHC.SysTools.FileOption "" output_fn-                       ])--getBackendDefs :: Logger -> DynFlags -> IO [String]-getBackendDefs logger dflags | backend dflags == LLVM = do-    llvmVer <- figureLlvmVersion logger dflags-    return $ case fmap llvmVersionList llvmVer of-               Just [m] -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,0) ]-               Just (m:n:_) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]-               _ -> []-  where-    format (major, minor)-      | minor >= 100 = error "getBackendDefs: Unsupported minor version"-      | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int--getBackendDefs _ _ =-    return []---- ------------------------------------------------------------------------------ Macros (cribbed from Cabal)--generatePackageVersionMacros :: [UnitInfo] -> String-generatePackageVersionMacros pkgs = concat-  -- Do not add any C-style comments. See #3389.-  [ generateMacros "" pkgname version-  | pkg <- pkgs-  , let version = unitPackageVersion pkg-        pkgname = map fixchar (unitPackageNameString pkg)-  ]--fixchar :: Char -> Char-fixchar '-' = '_'-fixchar c   = c--generateMacros :: String -> String -> Version -> String-generateMacros prefix name version =-  concat-  ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n"-  ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n"-  ,"  (major1) <  ",major1," || \\\n"-  ,"  (major1) == ",major1," && (major2) <  ",major2," || \\\n"-  ,"  (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"-  ,"\n\n"-  ]-  where-    (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)---- ------------------------------------------------------------------------------ join object files into a single relocatable object file, using ld -r--{--Note [Produce big objects on Windows]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--The Windows Portable Executable object format has a limit of 32k sections, which-we tend to blow through pretty easily. Thankfully, there is a "big object"-extension, which raises this limit to 2^32. However, it must be explicitly-enabled in the toolchain:-- * the assembler accepts the -mbig-obj flag, which causes it to produce a-   bigobj-enabled COFF object.-- * the linker accepts the --oformat pe-bigobj-x86-64 flag. Despite what the name-   suggests, this tells the linker to produce a bigobj-enabled COFF object, no a-   PE executable.--We must enable bigobj output in a few places:-- * When merging object files (GHC.Driver.Pipeline.joinObjectFiles)-- * When assembling (GHC.Driver.Pipeline.runPhase (RealPhase As ...))--Unfortunately the big object format is not supported on 32-bit targets so-none of this can be used in that case.---Note [Merging object files for GHCi]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-GHCi can usually loads standard linkable object files using GHC's linker-implementation. However, most users build their projects with -split-sections,-meaning that such object files can have an extremely high number of sections.-As the linker must map each of these sections individually, loading such object-files is very inefficient.--To avoid this inefficiency, we use the linker's `-r` flag and a linker script-to produce a merged relocatable object file. This file will contain a singe-text section section and can consequently be mapped far more efficiently. As-gcc tends to do unpredictable things to our linker command line, we opt to-invoke ld directly in this case, in contrast to our usual strategy of linking-via gcc.---}--joinObjectFiles :: Logger -> TmpFs -> DynFlags -> [FilePath] -> FilePath -> IO ()-joinObjectFiles logger tmpfs dflags o_files output_fn = do-  let toolSettings' = toolSettings dflags-      ldIsGnuLd = toolSettings_ldIsGnuLd toolSettings'-      osInfo = platformOS (targetPlatform dflags)-      ld_r args = GHC.SysTools.runMergeObjects logger tmpfs dflags (-                        -- See Note [Produce big objects on Windows]-                        concat-                          [ [GHC.SysTools.Option "--oformat", GHC.SysTools.Option "pe-bigobj-x86-64"]-                          | OSMinGW32 == osInfo-                          , not $ target32Bit (targetPlatform dflags)-                          ]-                     ++ map GHC.SysTools.Option ld_build_id-                     ++ [ GHC.SysTools.Option "-o",-                          GHC.SysTools.FileOption "" output_fn ]-                     ++ args)--      -- suppress the generation of the .note.gnu.build-id section,-      -- which we don't need and sometimes causes ld to emit a-      -- warning:-      ld_build_id | toolSettings_ldSupportsBuildId toolSettings' = ["--build-id=none"]-                  | otherwise                     = []--  if ldIsGnuLd-     then do-          script <- newTempName logger tmpfs dflags TFL_CurrentModule "ldscript"-          cwd <- getCurrentDirectory-          let o_files_abs = map (\x -> "\"" ++ (cwd </> x) ++ "\"") o_files-          writeFile script $ "INPUT(" ++ unwords o_files_abs ++ ")"-          ld_r [GHC.SysTools.FileOption "" script]-     else if toolSettings_ldSupportsFilelist toolSettings'-     then do-          filelist <- newTempName logger tmpfs dflags TFL_CurrentModule "filelist"-          writeFile filelist $ unlines o_files-          ld_r [GHC.SysTools.Option "-filelist",-                GHC.SysTools.FileOption "" filelist]-     else-          ld_r (map (GHC.SysTools.FileOption "") o_files)---- -------------------------------------------------------------------------------- Misc.--writeInterfaceOnlyMode :: DynFlags -> Bool-writeInterfaceOnlyMode dflags =- gopt Opt_WriteInterface dflags &&- NoBackend == backend dflags---- | Figure out if a source file was modified after an output file (or if we--- anyways need to consider the source file modified since the output is gone).-sourceModified :: FilePath -- ^ destination file we are looking for-               -> UTCTime  -- ^ last time of modification of source file-               -> IO Bool  -- ^ do we need to regenerate the output?-sourceModified dest_file src_timestamp = do-  dest_file_exists <- doesFileExist dest_file-  if not dest_file_exists-    then return True       -- Need to recompile-     else do t2 <- getModificationUTCTime dest_file-             return (t2 <= src_timestamp)---- | What phase to run after one of the backend code generators has run-hscPostBackendPhase :: HscSource -> Backend -> Phase-hscPostBackendPhase HsBootFile _    =  StopLn-hscPostBackendPhase HsigFile _      =  StopLn-hscPostBackendPhase _ bcknd =-  case bcknd of-        ViaC        -> HCc-        NCG         -> As False-        LLVM        -> LlvmOpt-        NoBackend   -> StopLn-        Interpreter -> StopLn--touchObjectFile :: Logger -> DynFlags -> FilePath -> IO ()-touchObjectFile logger dflags path = do-  createDirectoryIfMissing True $ takeDirectory path-  GHC.SysTools.touch logger dflags "Touching object file" path---- | Find out path to @ghcversion.h@ file-getGhcVersionPathName :: DynFlags -> UnitEnv -> IO FilePath-getGhcVersionPathName dflags unit_env = do-  candidates <- case ghcVersionFile dflags of-    Just path -> return [path]-    Nothing -> do-        ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env [rtsUnitId])-        return ((</> "ghcversion.h") <$> collectIncludeDirs ps)--  found <- filterM doesFileExist candidates-  case found of-      []    -> throwGhcExceptionIO (InstallationError-                                    ("ghcversion.h missing; tried: "-                                      ++ intercalate ", " candidates))-      (x:_) -> return x---- Note [-fPIC for assembler]--- When compiling .c source file GHC's driver pipeline basically--- does the following two things:---   1. ${CC}              -S 'PIC_CFLAGS' source.c---   2. ${CC} -x assembler -c 'PIC_CFLAGS' source.S------ Why do we need to pass 'PIC_CFLAGS' both to C compiler and assembler?--- Because on some architectures (at least sparc32) assembler also chooses--- the relocation type!--- Consider the following C module:------     /* pic-sample.c */---     int v;---     void set_v (int n) { v = n; }---     int  get_v (void)  { return v; }------     $ gcc -S -fPIC pic-sample.c---     $ gcc -c       pic-sample.s -o pic-sample.no-pic.o # incorrect binary---     $ gcc -c -fPIC pic-sample.s -o pic-sample.pic.o    # correct binary------     $ objdump -r -d pic-sample.pic.o    > pic-sample.pic.o.od---     $ objdump -r -d pic-sample.no-pic.o > pic-sample.no-pic.o.od---     $ diff -u pic-sample.pic.o.od pic-sample.no-pic.o.od------ Most of architectures won't show any difference in this test, but on sparc32--- the following assembly snippet:------    sethi   %hi(_GLOBAL_OFFSET_TABLE_-8), %l7------ generates two kinds or relocations, only 'R_SPARC_PC22' is correct:------       3c:  2f 00 00 00     sethi  %hi(0), %l7---    -                       3c: R_SPARC_PC22        _GLOBAL_OFFSET_TABLE_-0x8---    +                       3c: R_SPARC_HI22        _GLOBAL_OFFSET_TABLE_-0x8--{- Note [Don't normalise input filenames]--Summary-  We used to normalise input filenames when starting the unlit phase. This-  broke hpc in `--make` mode with imported literate modules (#2991).--Introduction-  1) --main-  When compiling a module with --main, GHC scans its imports to find out which-  other modules it needs to compile too. It turns out that there is a small-  difference between saying `ghc --make A.hs`, when `A` imports `B`, and-  specifying both modules on the command line with `ghc --make A.hs B.hs`. In-  the former case, the filename for B is inferred to be './B.hs' instead of-  'B.hs'.--  2) unlit-  When GHC compiles a literate haskell file, the source code first needs to go-  through unlit, which turns it into normal Haskell source code. At the start-  of the unlit phase, in `Driver.Pipeline.runPhase`, we call unlit with the-  option `-h` and the name of the original file. We used to normalise this-  filename using System.FilePath.normalise, which among other things removes-  an initial './'. unlit then uses that filename in #line directives that it-  inserts in the transformed source code.--  3) SrcSpan-  A SrcSpan represents a portion of a source code file. It has fields-  linenumber, start column, end column, and also a reference to the file it-  originated from. The SrcSpans for a literate haskell file refer to the-  filename that was passed to unlit -h.--  4) -fhpc-  At some point during compilation with -fhpc, in the function-  `GHC.HsToCore.Coverage.isGoodTickSrcSpan`, we compare the filename that a-  `SrcSpan` refers to with the name of the file we are currently compiling.-  For some reason I don't yet understand, they can sometimes legitimally be-  different, and then hpc ignores that SrcSpan.--Problem-  When running `ghc --make -fhpc A.hs`, where `A.hs` imports the literate-  module `B.lhs`, `B` is inferred to be in the file `./B.lhs` (1). At the-  start of the unlit phase, the name `./B.lhs` is normalised to `B.lhs` (2).-  Therefore the SrcSpans of `B` refer to the file `B.lhs` (3), but we are-  still compiling `./B.lhs`. Hpc thinks these two filenames are different (4),-  doesn't include ticks for B, and we have unhappy customers (#2991).--Solution-  Do not normalise `input_fn` when starting the unlit phase.--Alternative solution-  Another option would be to not compare the two filenames on equality, but to-  use System.FilePath.equalFilePath. That function first normalises its-  arguments. The problem is that by the time we need to do the comparison, the-  filenames have been turned into FastStrings, probably for performance-  reasons, so System.FilePath.equalFilePath can not be used directly.--Archeology-  The call to `normalise` was added in a commit called "Fix slash-  direction on Windows with the new filePath code" (c9b6b5e8). The problem-  that commit was addressing has since been solved in a different manner, in a-  commit called "Fix the filename passed to unlit" (1eedbc6b). So the-  `normalise` is no longer necessary.+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}++{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}++-----------------------------------------------------------------------------+--+-- GHC Driver+--+-- (c) The University of Glasgow 2005+--+-----------------------------------------------------------------------------++module GHC.Driver.Pipeline (+   -- * Run a series of compilation steps in a pipeline, for a+   -- collection of source files.+   oneShot, compileFile,++   -- * Interfaces for the compilation manager (interpreted/batch-mode)+   preprocess,+   compileOne, compileOne',+   compileForeign, compileEmptyStub,++   -- * Linking+   link, linkingNeeded, checkLinkInfo,++   -- * PipeEnv+   PipeEnv(..), mkPipeEnv, phaseOutputFilenameNew,++   -- * Running individual phases+   TPhase(..), runPhase,+   hscPostBackendPhase,++   -- * Constructing Pipelines+   TPipelineClass, MonadUse(..),++   preprocessPipeline, fullPipeline, hscPipeline, hscBackendPipeline, hscPostBackendPipeline,+   hscGenBackendPipeline, asPipeline, viaCPipeline, cmmCppPipeline, cmmPipeline,+   llvmPipeline, llvmLlcPipeline, llvmManglePipeline, pipelineStart,++   -- * Default method of running a pipeline+   runPipeline+) where+++import GHC.Prelude++import GHC.Platform++import GHC.Utils.Monad ( MonadIO(liftIO), mapMaybeM )++import GHC.Driver.Main+import GHC.Driver.Env hiding ( Hsc )+import GHC.Driver.Errors+import GHC.Driver.Errors.Types+import GHC.Driver.Pipeline.Monad+import GHC.Driver.Config.Diagnostic+import GHC.Driver.Phases+import GHC.Driver.Pipeline.Execute+import GHC.Driver.Pipeline.Phases+import GHC.Driver.Session+import GHC.Driver.Backend+import GHC.Driver.Ppr+import GHC.Driver.Hooks++import GHC.Platform.Ways++import GHC.SysTools+import GHC.Utils.TmpFs++import GHC.Linker.ExtraObj+import GHC.Linker.Static+import GHC.Linker.Static.Utils+import GHC.Linker.Types++import GHC.Utils.Outputable+import GHC.Utils.Error+import GHC.Utils.Panic+import GHC.Utils.Misc+import GHC.Utils.Exception as Exception+import GHC.Utils.Logger++import qualified GHC.LanguageExtensions as LangExt++import GHC.Data.FastString     ( mkFastString )+import GHC.Data.StringBuffer   ( hPutStringBuffer )+import GHC.Data.Maybe          ( expectJust )++import GHC.Iface.Make          ( mkFullIface )+import GHC.Runtime.Loader      ( initializePlugins )+++import GHC.Types.Basic       ( SuccessFlag(..), ForeignSrcLang(..) )+import GHC.Types.Error       ( singleMessage, getMessages )+import GHC.Types.Target+import GHC.Types.SrcLoc+import GHC.Types.SourceFile+import GHC.Types.SourceError++import GHC.Unit+import GHC.Unit.Env+--import GHC.Unit.Finder+--import GHC.Unit.State+import GHC.Unit.Module.ModSummary+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.Deps+import GHC.Unit.Home.ModInfo++import System.Directory+import System.FilePath+import System.IO+import Control.Monad+import qualified Control.Monad.Catch as MC (handle)+import Data.Maybe+import Data.Either      ( partitionEithers )+import qualified Data.Set as Set++import Data.Time        ( getCurrentTime )+import GHC.Iface.Recomp++-- Simpler type synonym for actions in the pipeline monad+type P m = TPipelineClass TPhase m++-- ---------------------------------------------------------------------------+-- Pre-process++-- | Just preprocess a file, put the result in a temp. file (used by the+-- compilation manager during the summary phase).+--+-- We return the augmented DynFlags, because they contain the result+-- of slurping in the OPTIONS pragmas++preprocess :: HscEnv+           -> FilePath -- ^ input filename+           -> Maybe InputFileBuffer+           -- ^ optional buffer to use instead of reading the input file+           -> Maybe Phase -- ^ starting phase+           -> IO (Either DriverMessages (DynFlags, FilePath))+preprocess hsc_env input_fn mb_input_buf mb_phase =+  handleSourceError (\err -> return $ Left $ to_driver_messages $ srcErrorMessages err) $+  MC.handle handler $+  fmap Right $ do+  massertPpr (isJust mb_phase || isHaskellSrcFilename input_fn) (text input_fn)+  input_fn_final <- mkInputFn+  let preprocess_pipeline = preprocessPipeline pipe_env (setDumpPrefix pipe_env hsc_env) input_fn_final+  runPipeline (hsc_hooks hsc_env) preprocess_pipeline++  where+    srcspan = srcLocSpan $ mkSrcLoc (mkFastString input_fn) 1 1+    handler (ProgramError msg) =+      return $ Left $ singleMessage $+        mkPlainErrorMsgEnvelope srcspan $+        DriverUnknownMessage $ mkPlainError noHints $ text msg+    handler ex = throwGhcExceptionIO ex++    to_driver_messages :: Messages GhcMessage -> Messages DriverMessage+    to_driver_messages msgs = case traverse to_driver_message msgs of+      Nothing    -> pprPanic "non-driver message in preprocess"+                             (vcat $ pprMsgEnvelopeBagWithLoc (getMessages msgs))+      Just msgs' -> msgs'++    to_driver_message = \case+      GhcDriverMessage msg+        -> Just msg+      GhcPsMessage (PsHeaderMessage msg)+        -> Just (DriverPsHeaderMessage (PsHeaderMessage msg))+      _ -> Nothing++    pipe_env = mkPipeEnv StopPreprocess input_fn (Temporary TFL_GhcSession)+    mkInputFn  =+      case mb_input_buf of+        Just input_buf -> do+          fn <- newTempName (hsc_logger hsc_env)+                            (hsc_tmpfs hsc_env)+                            (tmpDir (hsc_dflags hsc_env))+                            TFL_CurrentModule+                            ("buf_" ++ src_suffix pipe_env)+          hdl <- openBinaryFile fn WriteMode+          -- Add a LINE pragma so reported source locations will+          -- mention the real input file, not this temp file.+          hPutStrLn hdl $ "{-# LINE 1 \""++ input_fn ++ "\"#-}"+          hPutStringBuffer hdl input_buf+          hClose hdl+          return fn+        Nothing -> return input_fn++-- ---------------------------------------------------------------------------++-- | Compile+--+-- Compile a single module, under the control of the compilation manager.+--+-- This is the interface between the compilation manager and the+-- compiler proper (hsc), where we deal with tedious details like+-- reading the OPTIONS pragma from the source file, converting the+-- C or assembly that GHC produces into an object file, and compiling+-- FFI stub files.+--+-- NB.  No old interface can also mean that the source has changed.+++compileOne :: HscEnv+           -> ModSummary      -- ^ summary for module being compiled+           -> Int             -- ^ module N ...+           -> Int             -- ^ ... of M+           -> Maybe ModIface  -- ^ old interface, if we have one+           -> Maybe Linkable  -- ^ old linkable, if we have one+           -> IO HomeModInfo   -- ^ the complete HomeModInfo, if successful++compileOne = compileOne' (Just batchMsg)++compileOne' :: Maybe Messager+            -> HscEnv+            -> ModSummary      -- ^ summary for module being compiled+            -> Int             -- ^ module N ...+            -> Int             -- ^ ... of M+            -> Maybe ModIface  -- ^ old interface, if we have one+            -> Maybe Linkable  -- ^ old linkable, if we have one+            -> IO HomeModInfo   -- ^ the complete HomeModInfo, if successful++compileOne' mHscMessage+            hsc_env0 summary mod_index nmods mb_old_iface mb_old_linkable+ = do++   debugTraceMsg logger 2 (text "compile: input file" <+> text input_fnpp)++   let flags = hsc_dflags hsc_env0+     in do unless (gopt Opt_KeepHiFiles flags) $+               addFilesToClean tmpfs TFL_CurrentModule $+                   [ml_hi_file $ ms_location summary]+           unless (gopt Opt_KeepOFiles flags) $+               addFilesToClean tmpfs TFL_GhcSession $+                   [ml_obj_file $ ms_location summary]++   plugin_hsc_env <- initializePlugins hsc_env+   let pipe_env = mkPipeEnv NoStop input_fn pipelineOutput+   status <- hscRecompStatus mHscMessage plugin_hsc_env upd_summary+                mb_old_iface mb_old_linkable (mod_index, nmods)+   let pipeline = hscPipeline pipe_env (setDumpPrefix pipe_env plugin_hsc_env, upd_summary, status)+   (iface, linkable) <- runPipeline (hsc_hooks hsc_env) pipeline+   -- See Note [ModDetails and --make mode]+   details <- initModDetails plugin_hsc_env upd_summary iface+   return $! HomeModInfo iface details linkable++ where lcl_dflags  = ms_hspp_opts summary+       location    = ms_location summary+       input_fn    = expectJust "compile:hs" (ml_hs_file location)+       input_fnpp  = ms_hspp_file summary++       pipelineOutput = case bcknd of+         Interpreter -> NoOutputFile+         NoBackend -> NoOutputFile+         _ -> Persistent++       logger = hsc_logger hsc_env0+       tmpfs  = hsc_tmpfs hsc_env0++       basename = dropExtension input_fn++       -- We add the directory in which the .hs files resides) to the import+       -- path.  This is needed when we try to compile the .hc file later, if it+       -- imports a _stub.h file that we created here.+       current_dir = takeDirectory basename+       old_paths   = includePaths lcl_dflags+       loadAsByteCode+         | Just Target { targetAllowObjCode = obj } <- findTarget summary (hsc_targets hsc_env0)+         , not obj+         = True+         | otherwise = False+       -- Figure out which backend we're using+       (bcknd, dflags3)+         -- #8042: When module was loaded with `*` prefix in ghci, but DynFlags+         -- suggest to generate object code (which may happen in case -fobject-code+         -- was set), force it to generate byte-code. This is NOT transitive and+         -- only applies to direct targets.+         | loadAsByteCode+         = (Interpreter, gopt_set (lcl_dflags { backend = Interpreter }) Opt_ForceRecomp)+         | otherwise+         = (backend dflags, lcl_dflags)+       -- See Note [Filepaths and Multiple Home Units]+       dflags  = dflags3 { includePaths = offsetIncludePaths dflags3 $ addImplicitQuoteInclude old_paths [current_dir] }+       upd_summary = summary { ms_hspp_opts = dflags }+       hsc_env = hscSetFlags dflags hsc_env0+++-- ---------------------------------------------------------------------------+-- Link+--+-- Note [Dynamic linking on macOS]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Since macOS Sierra (10.14), the dynamic system linker enforces+-- a limit on the Load Commands.  Specifically the Load Command Size+-- Limit is at 32K (32768).  The Load Commands contain the install+-- name, dependencies, runpaths, and a few other commands.  We however+-- only have control over the install name, dependencies and runpaths.+--+-- The install name is the name by which this library will be+-- referenced.  This is such that we do not need to bake in the full+-- absolute location of the library, and can move the library around.+--+-- The dependency commands contain the install names from of referenced+-- libraries.  Thus if a libraries install name is @rpath/libHS...dylib,+-- that will end up as the dependency.+--+-- Finally we have the runpaths, which informs the linker about the+-- directories to search for the referenced dependencies.+--+-- The system linker can do recursive linking, however using only the+-- direct dependencies conflicts with ghc's ability to inline across+-- packages, and as such would end up with unresolved symbols.+--+-- Thus we will pass the full dependency closure to the linker, and then+-- ask the linker to remove any unused dynamic libraries (-dead_strip_dylibs).+--+-- We still need to add the relevant runpaths, for the dynamic linker to+-- lookup the referenced libraries though.  The linker (ld64) does not+-- have any option to dead strip runpaths; which makes sense as runpaths+-- can be used for dependencies of dependencies as well.+--+-- The solution we then take in GHC is to not pass any runpaths to the+-- linker at link time, but inject them after the linking.  For this to+-- work we'll need to ask the linker to create enough space in the header+-- to add more runpaths after the linking (-headerpad 8000).+--+-- After the library has been linked by $LD (usually ld64), we will use+-- otool to inspect the libraries left over after dead stripping, compute+-- the relevant runpaths, and inject them into the linked product using+-- the install_name_tool command.+--+-- This strategy should produce the smallest possible set of load commands+-- while still retaining some form of relocatability via runpaths.+--+-- The only way I can see to reduce the load command size further would be+-- by shortening the library names, or start putting libraries into the same+-- folders, such that one runpath would be sufficient for multiple/all+-- libraries.+link :: GhcLink                 -- ^ interactive or batch+     -> Logger                  -- ^ Logger+     -> TmpFs+     -> Hooks+     -> DynFlags                -- ^ dynamic flags+     -> UnitEnv                 -- ^ unit environment+     -> Bool                    -- ^ attempt linking in batch mode?+     -> Maybe (RecompileRequired -> IO ())+     -> HomePackageTable        -- ^ what to link+     -> IO SuccessFlag++-- For the moment, in the batch linker, we don't bother to tell doLink+-- which packages to link -- it just tries all that are available.+-- batch_attempt_linking should only be *looked at* in batch mode.  It+-- should only be True if the upsweep was successful and someone+-- exports main, i.e., we have good reason to believe that linking+-- will succeed.++link ghcLink logger tmpfs hooks dflags unit_env batch_attempt_linking mHscMessage hpt =+  case linkHook hooks of+      Nothing -> case ghcLink of+          NoLink        -> return Succeeded+          LinkBinary    -> normal_link+          LinkStaticLib -> normal_link+          LinkDynLib    -> normal_link+          LinkMergedObj -> normal_link+          LinkInMemory+              | platformMisc_ghcWithInterpreter $ platformMisc dflags+              -> -- Not Linking...(demand linker will do the job)+                 return Succeeded+              | otherwise+              -> panicBadLink LinkInMemory+      Just h  -> h ghcLink dflags batch_attempt_linking hpt+  where+    normal_link = link' logger tmpfs dflags unit_env batch_attempt_linking mHscMessage hpt+++panicBadLink :: GhcLink -> a+panicBadLink other = panic ("link: GHC not built to link this way: " +++                            show other)++link' :: Logger+      -> TmpFs+      -> DynFlags                -- ^ dynamic flags+      -> UnitEnv                 -- ^ unit environment+      -> Bool                    -- ^ attempt linking in batch mode?+      -> Maybe (RecompileRequired -> IO ())+      -> HomePackageTable        -- ^ what to link+      -> IO SuccessFlag++link' logger tmpfs dflags unit_env batch_attempt_linking mHscMessager hpt+   | batch_attempt_linking+   = do+        let+            staticLink = case ghcLink dflags of+                          LinkStaticLib -> True+                          _ -> False++            home_mod_infos = eltsHpt hpt++            -- the packages we depend on+            pkg_deps  = Set.toList+                          $ Set.unions+                          $ fmap (dep_direct_pkgs . mi_deps . hm_iface)+                          $ home_mod_infos++            -- the linkables to link+            linkables = map (expectJust "link".hm_linkable) home_mod_infos++        debugTraceMsg logger 3 (text "link: linkables are ..." $$ vcat (map ppr linkables))++        -- check for the -no-link flag+        if isNoLink (ghcLink dflags)+          then do debugTraceMsg logger 3 (text "link(batch): linking omitted (-c flag given).")+                  return Succeeded+          else do++        let getOfiles LM{ linkableUnlinked } = map nameOfObject (filter isObject linkableUnlinked)+            obj_files = concatMap getOfiles linkables+            platform  = targetPlatform dflags+            exe_file  = exeFileName platform staticLink (outputFile_ dflags)++        linking_needed <- linkingNeeded logger dflags unit_env staticLink linkables pkg_deps++        forM_ mHscMessager $ \hscMessage -> hscMessage linking_needed+        if not (gopt Opt_ForceRecomp dflags) && (linking_needed == UpToDate)+           then do debugTraceMsg logger 2 (text exe_file <+> text "is up to date, linking not required.")+                   return Succeeded+           else do+++        -- Don't showPass in Batch mode; doLink will do that for us.+        let link = case ghcLink dflags of+                LinkBinary    -> linkBinary logger tmpfs+                LinkStaticLib -> linkStaticLib logger+                LinkDynLib    -> linkDynLibCheck logger tmpfs+                other         -> panicBadLink other+        link dflags unit_env obj_files pkg_deps++        debugTraceMsg logger 3 (text "link: done")++        -- linkBinary only returns if it succeeds+        return Succeeded++   | otherwise+   = do debugTraceMsg logger 3 (text "link(batch): upsweep (partially) failed OR" $$+                                text "   Main.main not exported; not linking.")+        return Succeeded+++linkingNeeded :: Logger -> DynFlags -> UnitEnv -> Bool -> [Linkable] -> [UnitId] -> IO RecompileRequired+linkingNeeded logger dflags unit_env staticLink linkables pkg_deps = do+        -- if the modification time on the executable is later than the+        -- modification times on all of the objects and libraries, then omit+        -- linking (unless the -fforce-recomp flag was given).+  let platform   = ue_platform unit_env+      unit_state = ue_units unit_env+      exe_file   = exeFileName platform staticLink (outputFile_ dflags)+  e_exe_time <- tryIO $ getModificationUTCTime exe_file+  case e_exe_time of+    Left _  -> return $ NeedsRecompile MustCompile+    Right t -> do+        -- first check object files and extra_ld_inputs+        let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ]+        e_extra_times <- mapM (tryIO . getModificationUTCTime) extra_ld_inputs+        let (errs,extra_times) = partitionEithers e_extra_times+        let obj_times =  map linkableTime linkables ++ extra_times+        if not (null errs) || any (t <) obj_times+            then return $ needsRecompileBecause ObjectsChanged+            else do++        -- next, check libraries. XXX this only checks Haskell libraries,+        -- not extra_libraries or -l things from the command line.+        let pkg_hslibs  = [ (collectLibraryDirs (ways dflags) [c], lib)+                          | Just c <- map (lookupUnitId unit_state) pkg_deps,+                            lib <- unitHsLibs (ghcNameVersion dflags) (ways dflags) c ]++        pkg_libfiles <- mapM (uncurry (findHSLib platform (ways dflags))) pkg_hslibs+        if any isNothing pkg_libfiles then return $ needsRecompileBecause LibraryChanged else do+        e_lib_times <- mapM (tryIO . getModificationUTCTime)+                          (catMaybes pkg_libfiles)+        let (lib_errs,lib_times) = partitionEithers e_lib_times+        if not (null lib_errs) || any (t <) lib_times+           then return $ needsRecompileBecause LibraryChanged+           else do+            res <- checkLinkInfo logger dflags unit_env pkg_deps exe_file+            if res+              then return $ needsRecompileBecause FlagsChanged+              else return UpToDate+++findHSLib :: Platform -> Ways -> [String] -> String -> IO (Maybe FilePath)+findHSLib platform ws dirs lib = do+  let batch_lib_file = if ws `hasNotWay` WayDyn+                      then "lib" ++ lib <.> "a"+                      else platformSOName platform lib+  found <- filterM doesFileExist (map (</> batch_lib_file) dirs)+  case found of+    [] -> return Nothing+    (x:_) -> return (Just x)++-- -----------------------------------------------------------------------------+-- Compile files in one-shot mode.++oneShot :: HscEnv -> StopPhase -> [(String, Maybe Phase)] -> IO ()+oneShot hsc_env stop_phase srcs = do+  o_files <- mapMaybeM (compileFile hsc_env stop_phase) srcs+  case stop_phase of+    StopPreprocess -> return ()+    StopC  -> return ()+    StopAs -> return ()+    NoStop -> doLink hsc_env o_files++compileFile :: HscEnv -> StopPhase -> (FilePath, Maybe Phase) -> IO (Maybe FilePath)+compileFile hsc_env stop_phase (src, _mb_phase) = do+   exists <- doesFileExist src+   when (not exists) $+        throwGhcExceptionIO (CmdLineError ("does not exist: " ++ src))++   let+        dflags    = hsc_dflags hsc_env+        mb_o_file = outputFile dflags+        ghc_link  = ghcLink dflags      -- Set by -c or -no-link+        notStopPreprocess | StopPreprocess <- stop_phase = False+                          | _              <- stop_phase = True+        -- When linking, the -o argument refers to the linker's output.+        -- otherwise, we use it as the name for the pipeline's output.+        output+         | NoBackend <- backend dflags, notStopPreprocess = NoOutputFile+                -- avoid -E -fno-code undesirable interactions. see #20439+         | NoStop <- stop_phase, not (isNoLink ghc_link) = Persistent+                -- -o foo applies to linker+         | isJust mb_o_file = SpecificFile+                -- -o foo applies to the file we are compiling now+         | otherwise = Persistent+        pipe_env = mkPipeEnv stop_phase src output+        pipeline = pipelineStart pipe_env (setDumpPrefix pipe_env hsc_env) src+   runPipeline (hsc_hooks hsc_env) pipeline+++doLink :: HscEnv -> [FilePath] -> IO ()+doLink hsc_env o_files =+    let+        dflags   = hsc_dflags   hsc_env+        logger   = hsc_logger   hsc_env+        unit_env = hsc_unit_env hsc_env+        tmpfs    = hsc_tmpfs    hsc_env+    in case ghcLink dflags of+        NoLink        -> return ()+        LinkBinary    -> linkBinary         logger tmpfs dflags unit_env o_files []+        LinkStaticLib -> linkStaticLib      logger       dflags unit_env o_files []+        LinkDynLib    -> linkDynLibCheck    logger tmpfs dflags unit_env o_files []+        LinkMergedObj+          | Just out <- outputFile dflags+          , let objs = [ f | FileOption _ f <- ldInputs dflags ]+                      -> joinObjectFiles hsc_env (o_files ++ objs) out+          | otherwise -> panic "Output path must be specified for LinkMergedObj"+        other         -> panicBadLink other++-----------------------------------------------------------------------------+-- stub .h and .c files (for foreign export support), and cc files.++-- The _stub.c file is derived from the haskell source file, possibly taking+-- into account the -stubdir option.+--+-- The object file created by compiling the _stub.c file is put into a+-- temporary file, which will be later combined with the main .o file+-- (see the MergeForeign phase).+--+-- Moreover, we also let the user emit arbitrary C/C++/ObjC/ObjC++ files+-- from TH, that are then compiled and linked to the module. This is+-- useful to implement facilities such as inline-c.++compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath+compileForeign _ RawObject object_file = return object_file+compileForeign hsc_env lang stub_c = do+        let pipeline = case lang of+              LangC      -> viaCPipeline Cc+              LangCxx    -> viaCPipeline Ccxx+              LangObjc   -> viaCPipeline Cobjc+              LangObjcxx -> viaCPipeline Cobjcxx+              LangAsm    -> \pe hsc_env ml fp -> asPipeline True pe hsc_env ml fp+#if __GLASGOW_HASKELL__ < 811+              RawObject  -> panic "compileForeign: should be unreachable"+#endif+            pipe_env = mkPipeEnv NoStop stub_c (Temporary TFL_GhcSession)+        res <- runPipeline (hsc_hooks hsc_env) (pipeline pipe_env hsc_env Nothing stub_c)+        case res of+          -- This should never happen as viaCPipeline should only return `Nothing` when the stop phase is `StopC`.+          -- and the same should never happen for asPipeline+          -- Future refactoring to not check StopC for this case+          Nothing -> pprPanic "compileForeign" (ppr stub_c)+          Just fp -> return fp++compileEmptyStub :: DynFlags -> HscEnv -> FilePath -> ModLocation -> ModuleName -> IO ()+compileEmptyStub dflags hsc_env basename location mod_name = do+  -- To maintain the invariant that every Haskell file+  -- compiles to object code, we make an empty (but+  -- valid) stub object file for signatures.  However,+  -- we make sure this object file has a unique symbol,+  -- so that ranlib on OS X doesn't complain, see+  -- https://gitlab.haskell.org/ghc/ghc/issues/12673+  -- and https://github.com/haskell/cabal/issues/2257+  let logger = hsc_logger hsc_env+  let tmpfs  = hsc_tmpfs hsc_env+  empty_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "c"+  let home_unit = hsc_home_unit hsc_env+      src = text "int" <+> ppr (mkHomeModule home_unit mod_name) <+> text "= 0;"+  writeFile empty_stub (showSDoc dflags (pprCode CStyle src))+  let pipe_env = (mkPipeEnv NoStop empty_stub Persistent) { src_basename = basename}+      pipeline = viaCPipeline HCc pipe_env hsc_env (Just location) empty_stub+  _ <- runPipeline (hsc_hooks hsc_env) pipeline+  return ()+++{- Environment Initialisation -}++mkPipeEnv :: StopPhase -- End phase+          -> FilePath -- input fn+          -> PipelineOutput -- Output+          -> PipeEnv+mkPipeEnv stop_phase  input_fn output =+  let (basename, suffix) = splitExtension input_fn+      suffix' = drop 1 suffix -- strip off the .+      env = PipeEnv{ stop_phase,+                     src_filename = input_fn,+                     src_basename = basename,+                     src_suffix = suffix',+                     output_spec = output }+  in env++setDumpPrefix :: PipeEnv -> HscEnv -> HscEnv+setDumpPrefix pipe_env hsc_env =+  hscUpdateFlags (\dflags -> dflags { dumpPrefix = src_basename pipe_env ++ "."}) hsc_env++{- The Pipelines -}++phaseIfFlag :: Monad m+            => HscEnv+            -> (DynFlags -> Bool)+            -> a+            -> m a+            -> m a+phaseIfFlag hsc_env flag def action =+  if flag (hsc_dflags hsc_env)+    then action+    else return def++-- | Check if the start is *before* the current phase, otherwise skip with a default+phaseIfAfter :: P m => Platform -> Phase -> Phase -> a -> m a -> m a+phaseIfAfter platform start_phase cur_phase def action =+  if start_phase `eqPhase` cur_phase+         || happensBefore platform start_phase cur_phase++    then action+    else return def++-- | The preprocessor pipeline+preprocessPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m (DynFlags, FilePath)+preprocessPipeline pipe_env hsc_env input_fn = do+  unlit_fn <-+    runAfter (Unlit HsSrcFile) input_fn $ do+      use (T_Unlit pipe_env hsc_env input_fn)+++  (dflags1, p_warns1, warns1) <- use (T_FileArgs hsc_env unlit_fn)+  let hsc_env1 = hscSetFlags dflags1 hsc_env++  (cpp_fn, hsc_env2)+    <- runAfterFlag hsc_env1 (Cpp HsSrcFile) (xopt LangExt.Cpp) (unlit_fn, hsc_env1) $ do+          cpp_fn <- use (T_Cpp pipe_env hsc_env1 unlit_fn)+          (dflags2, _, _) <- use (T_FileArgs hsc_env1 cpp_fn)+          let hsc_env2 = hscSetFlags dflags2 hsc_env1+          return (cpp_fn, hsc_env2)+++  pp_fn <- runAfterFlag hsc_env2 (HsPp HsSrcFile) (gopt Opt_Pp) cpp_fn $+            use (T_HsPp pipe_env hsc_env2 input_fn cpp_fn)++  (dflags3, p_warns3, warns3)+    <- if pp_fn == unlit_fn+          -- Didn't run any preprocessors so don't need to reparse, would be nicer+          -- if `T_FileArgs` recognised this.+          then return (dflags1, p_warns1, warns1)+          else do+            -- Reparse with original hsc_env so that we don't get duplicated options+            use (T_FileArgs hsc_env pp_fn)++  liftIO (printOrThrowDiagnostics (hsc_logger hsc_env) (initDiagOpts dflags3) (GhcPsMessage <$> p_warns3))+  liftIO (handleFlagWarnings (hsc_logger hsc_env) (initDiagOpts dflags3) warns3)+  return (dflags3, pp_fn)+++  -- This won't change through the compilation pipeline+  where platform = targetPlatform (hsc_dflags hsc_env)+        runAfter :: P p => Phase+                  -> a -> p a -> p a+        runAfter = phaseIfAfter platform start_phase+        start_phase = startPhase (src_suffix pipe_env)+        runAfterFlag :: P p+                  => HscEnv+                  -> Phase+                  -> (DynFlags -> Bool)+                  -> a+                  -> p a+                  -> p a+        runAfterFlag hsc_env phase flag def action =+          runAfter phase def+           $ phaseIfFlag hsc_env flag def action++-- | The complete compilation pipeline, from start to finish+fullPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> HscSource -> m (ModIface, Maybe Linkable)+fullPipeline pipe_env hsc_env pp_fn src_flavour = do+  (dflags, input_fn) <- preprocessPipeline pipe_env hsc_env pp_fn+  let hsc_env' = hscSetFlags dflags hsc_env+  (hsc_env_with_plugins, mod_sum, hsc_recomp_status)+    <- use (T_HscRecomp pipe_env hsc_env' input_fn src_flavour)+  hscPipeline pipe_env (hsc_env_with_plugins, mod_sum, hsc_recomp_status)++-- | Everything after preprocess+hscPipeline :: P m => PipeEnv ->  ((HscEnv, ModSummary, HscRecompStatus)) -> m (ModIface, Maybe Linkable)+hscPipeline pipe_env (hsc_env_with_plugins, mod_sum, hsc_recomp_status) = do+  case hsc_recomp_status of+    HscUpToDate iface mb_linkable -> return (iface, mb_linkable)+    HscRecompNeeded mb_old_hash -> do+      (tc_result, warnings) <- use (T_Hsc hsc_env_with_plugins mod_sum)+      hscBackendAction <- use (T_HscPostTc hsc_env_with_plugins mod_sum tc_result warnings mb_old_hash )+      hscBackendPipeline pipe_env hsc_env_with_plugins mod_sum hscBackendAction++hscBackendPipeline :: P m => PipeEnv -> HscEnv -> ModSummary -> HscBackendAction -> m (ModIface, Maybe Linkable)+hscBackendPipeline pipe_env hsc_env mod_sum result =+  case backend (hsc_dflags hsc_env) of+    NoBackend ->+      case result of+        HscUpdate iface ->  return (iface, Nothing)+        HscRecomp {} -> (,) <$> liftIO (mkFullIface hsc_env (hscs_partial_iface result) Nothing) <*> pure Nothing+    -- TODO: Why is there not a linkable?+    -- Interpreter -> (,) <$> use (T_IO (mkFullIface hsc_env (hscs_partial_iface result) Nothing)) <*> pure Nothing+    _ -> do+      res <- hscGenBackendPipeline pipe_env hsc_env mod_sum result+      when (gopt Opt_BuildDynamicToo (hsc_dflags hsc_env)) $ do+          let dflags' = setDynamicNow (hsc_dflags hsc_env) -- set "dynamicNow"+          () <$ hscGenBackendPipeline pipe_env (hscSetFlags dflags' hsc_env) mod_sum result+      return res++hscGenBackendPipeline :: P m+  => PipeEnv+  -> HscEnv+  -> ModSummary+  -> HscBackendAction+  -> m (ModIface, Maybe Linkable)+hscGenBackendPipeline pipe_env hsc_env mod_sum result = do+  let mod_name = moduleName (ms_mod mod_sum)+      src_flavour = (ms_hsc_src mod_sum)+  let location = ms_location mod_sum+  (fos, miface, mlinkable, o_file) <- use (T_HscBackend pipe_env hsc_env mod_name src_flavour location result)+  final_fp <- hscPostBackendPipeline pipe_env hsc_env (ms_hsc_src mod_sum) (backend (hsc_dflags hsc_env)) (Just location) o_file+  final_linkable <-+    case final_fp of+      -- No object file produced, bytecode or NoBackend+      Nothing -> return mlinkable+      Just o_fp -> do+        unlinked_time <- liftIO (liftIO getCurrentTime)+        final_unlinked <- DotO <$> use (T_MergeForeign pipe_env hsc_env o_fp fos)+        let !linkable = LM unlinked_time (ms_mod mod_sum) [final_unlinked]+        return (Just linkable)+  return (miface, final_linkable)++asPipeline :: P m => Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe ObjFile)+asPipeline use_cpp pipe_env hsc_env location input_fn =+  case stop_phase pipe_env of+    StopAs -> return Nothing+    _ -> Just <$> use (T_As use_cpp pipe_env hsc_env location input_fn)++viaCPipeline :: P m => Phase -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)+viaCPipeline c_phase pipe_env hsc_env location input_fn = do+  out_fn <- use (T_Cc c_phase pipe_env hsc_env input_fn)+  case stop_phase pipe_env of+    StopC -> return Nothing+    _ -> asPipeline False pipe_env hsc_env location out_fn++llvmPipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)+llvmPipeline pipe_env hsc_env location fp = do+  opt_fn <- use (T_LlvmOpt pipe_env hsc_env fp)+  llvmLlcPipeline pipe_env hsc_env location opt_fn++llvmLlcPipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)+llvmLlcPipeline pipe_env hsc_env location opt_fn = do+  llc_fn <- use (T_LlvmLlc pipe_env hsc_env opt_fn)+  llvmManglePipeline pipe_env hsc_env location llc_fn++llvmManglePipeline :: P m  => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)+llvmManglePipeline pipe_env hsc_env location llc_fn = do+  mangled_fn <-+    if gopt Opt_NoLlvmMangler (hsc_dflags hsc_env)+      then return llc_fn+      else use (T_LlvmMangle pipe_env hsc_env llc_fn)+  asPipeline False pipe_env hsc_env location mangled_fn++cmmCppPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m FilePath+cmmCppPipeline pipe_env hsc_env input_fn = do+  output_fn <- use (T_CmmCpp pipe_env hsc_env input_fn)+  cmmPipeline pipe_env hsc_env output_fn++cmmPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m FilePath+cmmPipeline pipe_env hsc_env input_fn = do+  (fos, output_fn) <- use (T_Cmm pipe_env hsc_env input_fn)+  mo_fn <- hscPostBackendPipeline pipe_env hsc_env HsSrcFile (backend (hsc_dflags hsc_env)) Nothing output_fn+  case mo_fn of+    Nothing -> panic "CMM pipeline - produced no .o file"+    Just mo_fn -> use (T_MergeForeign pipe_env hsc_env mo_fn fos)++hscPostBackendPipeline :: P m => PipeEnv -> HscEnv -> HscSource -> Backend -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)+hscPostBackendPipeline _ _ HsBootFile _ _ _   = return Nothing+hscPostBackendPipeline _ _ HsigFile _ _ _     = return Nothing+hscPostBackendPipeline pipe_env hsc_env _ bcknd ml input_fn =+  case bcknd of+        ViaC        -> viaCPipeline HCc pipe_env hsc_env ml input_fn+        NCG         -> asPipeline False pipe_env hsc_env ml input_fn+        LLVM        -> llvmPipeline pipe_env hsc_env ml input_fn+        NoBackend   -> return Nothing+        Interpreter -> return Nothing++-- Pipeline from a given suffix+pipelineStart :: P m => PipeEnv -> HscEnv -> FilePath -> m (Maybe FilePath)+pipelineStart pipe_env hsc_env input_fn =+  fromSuffix (src_suffix pipe_env)+  where+   stop_after = stop_phase pipe_env+   frontend :: P m => HscSource -> m (Maybe FilePath)+   frontend sf = case stop_after of+                    StopPreprocess -> do+                      -- The actual output from preprocessing+                      (_, out_fn) <- preprocessPipeline pipe_env hsc_env input_fn+                      let logger = hsc_logger hsc_env+                      -- Sometimes, a compilation phase doesn't actually generate any output+                      -- (eg. the CPP phase when -fcpp is not turned on).  If we end on this+                      -- stage, but we wanted to keep the output, then we have to explicitly+                      -- copy the file, remembering to prepend a {-# LINE #-} pragma so that+                      -- further compilation stages can tell what the original filename was.+                      -- File name we expected the output to have+                      final_fn <- liftIO $ phaseOutputFilenameNew (Hsc HsSrcFile) pipe_env hsc_env Nothing+                      when (final_fn /= out_fn) $ do+                        let msg = "Copying `" ++ out_fn ++"' to `" ++ final_fn ++ "'"+                            line_prag = "{-# LINE 1 \"" ++ src_filename pipe_env ++ "\" #-}\n"+                        liftIO (showPass logger msg)+                        liftIO (copyWithHeader line_prag out_fn final_fn)+                      return Nothing+                    _ -> objFromLinkable <$> fullPipeline pipe_env hsc_env input_fn sf+   c :: P m => Phase -> m (Maybe FilePath)+   c phase = viaCPipeline phase pipe_env hsc_env Nothing input_fn+   as :: P m => Bool -> m (Maybe FilePath)+   as use_cpp = asPipeline use_cpp pipe_env hsc_env Nothing input_fn++   objFromLinkable (_, Just (LM _ _ [DotO lnk])) = Just lnk+   objFromLinkable _ = Nothing+++   fromSuffix :: P m => String -> m (Maybe FilePath)+   fromSuffix "lhs"      = frontend HsSrcFile+   fromSuffix "lhs-boot" = frontend HsBootFile+   fromSuffix "lhsig"    = frontend HsigFile+   fromSuffix "hs"       = frontend HsSrcFile+   fromSuffix "hs-boot"  = frontend HsBootFile+   fromSuffix "hsig"     = frontend HsigFile+   fromSuffix "hscpp"    = frontend HsSrcFile+   fromSuffix "hspp"     = frontend HsSrcFile+   fromSuffix "hc"       = c HCc+   fromSuffix "c"        = c Cc+   fromSuffix "cpp"      = c Ccxx+   fromSuffix "C"        = c Cc+   fromSuffix "m"        = c Cobjc+   fromSuffix "M"        = c Cobjcxx+   fromSuffix "mm"       = c Cobjcxx+   fromSuffix "cc"       = c Ccxx+   fromSuffix "cxx"      = c Ccxx+   fromSuffix "s"        = as False+   fromSuffix "S"        = as True+   fromSuffix "ll"       = llvmPipeline pipe_env hsc_env Nothing input_fn+   fromSuffix "bc"       = llvmLlcPipeline pipe_env hsc_env Nothing input_fn+   fromSuffix "lm_s"     = llvmManglePipeline pipe_env hsc_env Nothing input_fn+   fromSuffix "o"        = return (Just input_fn)+   fromSuffix "cmm"      = Just <$> cmmCppPipeline pipe_env hsc_env input_fn+   fromSuffix "cmmcpp"   = Just <$> cmmPipeline pipe_env hsc_env input_fn+   fromSuffix _          = return (Just input_fn)++{-+Note [The Pipeline Monad]+~~~~~~~~~~~~~~~~~~~~~~~~~+The pipeline is represented as a free monad by the `TPipelineClass` type synonym,+which stipulates the general monadic interface for the pipeline and `MonadUse`, instantiated+to `TPhase`, which indicates the actions available in the pipeline.++The `TPhase` actions correspond to different compiled phases, they are executed by+the 'runPhase' function which interprets each action into IO.++The idea in the future is that we can now implement different instiations of+`TPipelineClass` to give different behaviours that the default `HookedPhase` implementation:++* Additional logging of different phases+* Automatic parrelism (in the style of shake)+* Easy consumption by external tools such as ghcide+* Easier to create your own pipeline and extend existing pipelines.++The structure of the code as a free monad also means that the return type of each+phase is a lot more flexible.+ -}
+ compiler/GHC/Driver/Pipeline.hs-boot view
@@ -0,0 +1,13 @@+module GHC.Driver.Pipeline where+++import GHC.Driver.Env.Types ( HscEnv )+import GHC.ForeignSrcLang ( ForeignSrcLang )+import GHC.Prelude (FilePath, IO)+import GHC.Unit.Module.Location (ModLocation)+import GHC.Unit.Module.Name (ModuleName)+import GHC.Driver.Session (DynFlags)++-- These are used in GHC.Driver.Pipeline.Execute, but defined in terms of runPipeline+compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath+compileEmptyStub :: DynFlags -> HscEnv -> FilePath -> ModLocation -> ModuleName -> IO ()
+ compiler/GHC/Driver/Pipeline/Execute.hs view
@@ -0,0 +1,1373 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GADTs #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+#include <ghcplatform.h>++{- Functions for providing the default interpretation of the 'TPhase' actions+-}+module GHC.Driver.Pipeline.Execute where++import GHC.Prelude+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Catch+import GHC.Driver.Hooks+import Control.Monad.Trans.Reader+import GHC.Driver.Pipeline.Monad+import GHC.Driver.Pipeline.Phases+import GHC.Driver.Env hiding (Hsc)+import GHC.Unit.Module.Location+import GHC.Driver.Phases+import GHC.Unit.Module.Name ( ModuleName )+import GHC.Unit.Types+import GHC.Types.SourceFile+import GHC.Unit.Module.Status+import GHC.Unit.Module.ModIface+import GHC.Linker.Types+import GHC.Driver.Backend+import GHC.Driver.Session+import GHC.Driver.CmdLine+import GHC.Unit.Module.ModSummary+import qualified GHC.LanguageExtensions as LangExt+import GHC.Types.SrcLoc+import GHC.Driver.Main+import GHC.Tc.Types+import GHC.Types.Error+import GHC.Driver.Errors.Types+import GHC.Fingerprint+import GHC.Utils.Logger+import GHC.Utils.TmpFs+import GHC.Platform+import Data.List (intercalate, isInfixOf)+import GHC.Unit.Env+import GHC.SysTools.Info+import GHC.Utils.Error+import Data.Maybe+import GHC.CmmToLlvm.Mangler+import GHC.SysTools+import GHC.Utils.Panic.Plain+import System.Directory+import System.FilePath+import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Unit.Info+import GHC.Unit.State+import GHC.Unit.Home+import GHC.Data.Maybe+import GHC.Iface.Make+import Data.Time+import GHC.Driver.Config.Parser+import GHC.Parser.Header+import GHC.Data.StringBuffer+import GHC.Types.SourceError+import GHC.Unit.Finder+import GHC.Runtime.Loader+import Data.IORef+import GHC.Types.Name.Env+import GHC.Platform.Ways+import GHC.Platform.ArchOS+import GHC.CmmToLlvm.Base ( llvmVersionList )+import {-# SOURCE #-} GHC.Driver.Pipeline (compileForeign, compileEmptyStub)+import GHC.Settings+import System.IO+import GHC.Linker.ExtraObj+import GHC.Linker.Dynamic+import Data.Version+import GHC.Utils.Panic+import GHC.Unit.Module.Env+import GHC.Driver.Env.KnotVars+import GHC.Driver.Config.Finder+import GHC.Rename.Names++newtype HookedUse a = HookedUse { runHookedUse :: (Hooks, PhaseHook) -> IO a }+  deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch) via (ReaderT (Hooks, PhaseHook) IO)++instance MonadUse TPhase HookedUse where+  use fa = HookedUse $ \(hooks, (PhaseHook k)) ->+    case runPhaseHook hooks of+      Nothing -> k fa+      Just (PhaseHook h) -> h fa++-- | The default mechanism to run a pipeline, see Note [The Pipeline Monad]+runPipeline :: Hooks -> HookedUse a -> IO a+runPipeline hooks pipeline = runHookedUse pipeline (hooks, PhaseHook runPhase)++-- | Default interpretation of each phase, in terms of IO.+runPhase :: TPhase out -> IO out+runPhase (T_Unlit pipe_env hsc_env inp_path) = do+  out_path <- phaseOutputFilenameNew (Cpp HsSrcFile) pipe_env hsc_env Nothing+  runUnlitPhase hsc_env inp_path out_path+runPhase (T_FileArgs hsc_env inp_path) = getFileArgs hsc_env inp_path+runPhase (T_Cpp pipe_env hsc_env inp_path) = do+  out_path <- phaseOutputFilenameNew (HsPp HsSrcFile) pipe_env hsc_env Nothing+  runCppPhase hsc_env inp_path out_path+runPhase (T_HsPp pipe_env hsc_env origin_path inp_path) = do+  out_path <- phaseOutputFilenameNew (Hsc HsSrcFile) pipe_env hsc_env Nothing+  runHsPpPhase hsc_env origin_path inp_path out_path+runPhase (T_HscRecomp pipe_env hsc_env fp hsc_src) = do+  runHscPhase pipe_env hsc_env fp hsc_src+runPhase (T_Hsc hsc_env mod_sum) = runHscTcPhase hsc_env mod_sum+runPhase (T_HscPostTc hsc_env ms fer m mfi) =+  runHscPostTcPhase hsc_env ms fer m mfi+runPhase (T_HscBackend pipe_env hsc_env mod_name hsc_src location x) = do+  runHscBackendPhase pipe_env hsc_env mod_name hsc_src location x+runPhase (T_CmmCpp pipe_env hsc_env input_fn) = do+  output_fn <- phaseOutputFilenameNew Cmm pipe_env hsc_env Nothing+  doCpp (hsc_logger hsc_env)+        (hsc_tmpfs hsc_env)+        (hsc_dflags hsc_env)+        (hsc_unit_env hsc_env)+        False{-not raw-}+        input_fn output_fn+  return output_fn+runPhase (T_Cmm pipe_env hsc_env input_fn) = do+  let dflags = hsc_dflags hsc_env+  let next_phase = hscPostBackendPhase HsSrcFile (backend dflags)+  output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env Nothing+  mstub <- hscCompileCmmFile hsc_env (src_filename pipe_env) input_fn output_fn+  stub_o <- mapM (compileStub hsc_env) mstub+  let foreign_os = maybeToList stub_o+  return (foreign_os, output_fn)++runPhase (T_Cc phase pipe_env hsc_env input_fn) = runCcPhase phase pipe_env hsc_env input_fn+runPhase (T_As cpp pipe_env hsc_env location input_fn) = do+  runAsPhase cpp pipe_env hsc_env location input_fn+runPhase (T_LlvmOpt pipe_env hsc_env input_fn) =+  runLlvmOptPhase pipe_env hsc_env input_fn+runPhase (T_LlvmLlc pipe_env hsc_env input_fn) =+  runLlvmLlcPhase pipe_env hsc_env input_fn+runPhase (T_LlvmMangle pipe_env hsc_env input_fn) =+  runLlvmManglePhase pipe_env hsc_env input_fn+runPhase (T_MergeForeign pipe_env hsc_env input_fn fos) =+  runMergeForeign pipe_env hsc_env input_fn fos++runLlvmManglePhase :: PipeEnv -> HscEnv -> FilePath -> IO [Char]+runLlvmManglePhase pipe_env hsc_env input_fn = do+      let next_phase = As False+      output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env Nothing+      let dflags = hsc_dflags hsc_env+      llvmFixupAsm (targetPlatform dflags) input_fn output_fn+      return output_fn++runMergeForeign :: PipeEnv -> HscEnv -> FilePath -> [FilePath] -> IO FilePath+runMergeForeign _pipe_env hsc_env input_fn foreign_os = do+     if null foreign_os+       then return input_fn+       else do+         -- Work around a binutil < 2.31 bug where you can't merge objects if the output file+         -- is one of the inputs+         new_o <- newTempName (hsc_logger hsc_env)+                              (hsc_tmpfs hsc_env)+                              (tmpDir (hsc_dflags hsc_env))+                              TFL_CurrentModule "o"+         copyFile input_fn new_o+         joinObjectFiles hsc_env (new_o : foreign_os) input_fn+         return input_fn++runLlvmLlcPhase :: PipeEnv -> HscEnv -> FilePath -> IO FilePath+runLlvmLlcPhase pipe_env hsc_env input_fn = do+    -- Note [Clamping of llc optimizations]+    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    -- See #13724+    --+    -- we clamp the llc optimization between [1,2]. This is because passing -O0+    -- to llc 3.9 or llc 4.0, the naive register allocator can fail with+    --+    --   Error while trying to spill R1 from class GPR: Cannot scavenge register+    --   without an emergency spill slot!+    --+    -- Observed at least with target 'arm-unknown-linux-gnueabihf'.+    --+    --+    -- With LLVM4, llc -O3 crashes when ghc-stage1 tries to compile+    --   rts/HeapStackCheck.cmm+    --+    -- llc -O3 '-mtriple=arm-unknown-linux-gnueabihf' -enable-tbaa /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc -o /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_7.lm_s+    -- 0  llc                      0x0000000102ae63e8 llvm::sys::PrintStackTrace(llvm::raw_ostream&) + 40+    -- 1  llc                      0x0000000102ae69a6 SignalHandler(int) + 358+    -- 2  libsystem_platform.dylib 0x00007fffc23f4b3a _sigtramp + 26+    -- 3  libsystem_c.dylib        0x00007fffc226498b __vfprintf + 17876+    -- 4  llc                      0x00000001029d5123 llvm::SelectionDAGISel::LowerArguments(llvm::Function const&) + 5699+    -- 5  llc                      0x0000000102a21a35 llvm::SelectionDAGISel::SelectAllBasicBlocks(llvm::Function const&) + 3381+    -- 6  llc                      0x0000000102a202b1 llvm::SelectionDAGISel::runOnMachineFunction(llvm::MachineFunction&) + 1457+    -- 7  llc                      0x0000000101bdc474 (anonymous namespace)::ARMDAGToDAGISel::runOnMachineFunction(llvm::MachineFunction&) + 20+    -- 8  llc                      0x00000001025573a6 llvm::MachineFunctionPass::runOnFunction(llvm::Function&) + 134+    -- 9  llc                      0x000000010274fb12 llvm::FPPassManager::runOnFunction(llvm::Function&) + 498+    -- 10 llc                      0x000000010274fd23 llvm::FPPassManager::runOnModule(llvm::Module&) + 67+    -- 11 llc                      0x00000001027501b8 llvm::legacy::PassManagerImpl::run(llvm::Module&) + 920+    -- 12 llc                      0x000000010195f075 compileModule(char**, llvm::LLVMContext&) + 12133+    -- 13 llc                      0x000000010195bf0b main + 491+    -- 14 libdyld.dylib            0x00007fffc21e5235 start + 1+    -- Stack dump:+    -- 0.  Program arguments: llc -O3 -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc -o /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_7.lm_s+    -- 1.  Running pass 'Function Pass Manager' on module '/var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc'.+    -- 2.  Running pass 'ARM Instruction Selection' on function '@"stg_gc_f1$def"'+    --+    -- Observed at least with -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa+    --+    let dflags = hsc_dflags hsc_env+        logger = hsc_logger hsc_env+        llvmOpts = case llvmOptLevel dflags of+          0 -> "-O1" -- required to get the non-naive reg allocator. Passing -regalloc=greedy is not sufficient.+          1 -> "-O1"+          _ -> "-O2"++        defaultOptions = map GHC.SysTools.Option . concatMap words . snd+                         $ unzip (llvmOptions dflags)+        optFlag = if null (getOpts dflags opt_lc)+                  then map GHC.SysTools.Option $ words llvmOpts+                  else []++    next_phase <- if -- hidden debugging flag '-dno-llvm-mangler' to skip mangling+                     | gopt Opt_NoLlvmMangler dflags -> return (As False)+                     | otherwise -> return LlvmMangle++    output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env Nothing++    GHC.SysTools.runLlvmLlc logger dflags+                (  optFlag+                ++ defaultOptions+                ++ [ GHC.SysTools.FileOption "" input_fn+                   , GHC.SysTools.Option "-o"+                   , GHC.SysTools.FileOption "" output_fn+                   ]+                )++    return output_fn++runLlvmOptPhase :: PipeEnv -> HscEnv -> FilePath -> IO FilePath+runLlvmOptPhase pipe_env hsc_env input_fn = do+    let dflags = hsc_dflags hsc_env+        logger = hsc_logger hsc_env+    let -- we always (unless -optlo specified) run Opt since we rely on it to+        -- fix up some pretty big deficiencies in the code we generate+        optIdx = max 0 $ min 2 $ llvmOptLevel dflags  -- ensure we're in [0,2]+        llvmOpts = case lookup optIdx $ llvmPasses $ llvmConfig dflags of+                    Just passes -> passes+                    Nothing -> panic ("runPhase LlvmOpt: llvm-passes file "+                                      ++ "is missing passes for level "+                                      ++ show optIdx)+        defaultOptions = map GHC.SysTools.Option . concat . fmap words . fst+                         $ unzip (llvmOptions dflags)++        -- don't specify anything if user has specified commands. We do this+        -- for opt but not llc since opt is very specifically for optimisation+        -- passes only, so if the user is passing us extra options we assume+        -- they know what they are doing and don't get in the way.+        optFlag = if null (getOpts dflags opt_lo)+                  then map GHC.SysTools.Option $ words llvmOpts+                  else []++    output_fn <- phaseOutputFilenameNew LlvmLlc pipe_env hsc_env Nothing++    GHC.SysTools.runLlvmOpt logger dflags+               (   optFlag+                ++ defaultOptions +++                [ GHC.SysTools.FileOption "" input_fn+                , GHC.SysTools.Option "-o"+                , GHC.SysTools.FileOption "" output_fn]+                )++    return output_fn+++runAsPhase :: Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> IO FilePath+runAsPhase with_cpp pipe_env hsc_env location input_fn = do+        let dflags     = hsc_dflags   hsc_env+        let logger     = hsc_logger   hsc_env+        let unit_env   = hsc_unit_env hsc_env+        let platform   = ue_platform unit_env++        -- LLVM from version 3.0 onwards doesn't support the OS X system+        -- assembler, so we use clang as the assembler instead. (#5636)+        let (as_prog, get_asm_info) | backend dflags == LLVM+                    , platformOS platform == OSDarwin+                    = (GHC.SysTools.runClang, pure Clang)+                    | otherwise+                    = (GHC.SysTools.runAs, getAssemblerInfo logger dflags)++        asmInfo <- get_asm_info++        let cmdline_include_paths = includePaths dflags+        let pic_c_flags = picCCOpts dflags++        output_fn <- phaseOutputFilenameNew StopLn pipe_env hsc_env location++        -- we create directories for the object file, because it+        -- might be a hierarchical module.+        createDirectoryIfMissing True (takeDirectory output_fn)++        let global_includes = [ GHC.SysTools.Option ("-I" ++ p)+                              | p <- includePathsGlobal cmdline_include_paths ]+        let local_includes = [ GHC.SysTools.Option ("-iquote" ++ p)+                             | p <- includePathsQuote cmdline_include_paths +++                                includePathsQuoteImplicit cmdline_include_paths]+        let runAssembler inputFilename outputFilename+              = withAtomicRename outputFilename $ \temp_outputFilename ->+                    as_prog+                       logger dflags+                       (local_includes ++ global_includes+                       -- See Note [-fPIC for assembler]+                       ++ map GHC.SysTools.Option pic_c_flags+                       -- See Note [Produce big objects on Windows]+                       ++ [ GHC.SysTools.Option "-Wa,-mbig-obj"+                          | platformOS (targetPlatform dflags) == OSMinGW32+                          , not $ target32Bit (targetPlatform dflags)+                          ]++                       ++ (if any (asmInfo ==) [Clang, AppleClang, AppleClang51]+                            then [GHC.SysTools.Option "-Qunused-arguments"]+                            else [])+                       ++ [ GHC.SysTools.Option "-x"+                          , if with_cpp+                              then GHC.SysTools.Option "assembler-with-cpp"+                              else GHC.SysTools.Option "assembler"+                          , GHC.SysTools.Option "-c"+                          , GHC.SysTools.FileOption "" inputFilename+                          , GHC.SysTools.Option "-o"+                          , GHC.SysTools.FileOption "" temp_outputFilename+                          ])++        debugTraceMsg logger 4 (text "Running the assembler")+        runAssembler input_fn output_fn++        return output_fn+++runCcPhase :: Phase -> PipeEnv -> HscEnv -> FilePath -> IO FilePath+runCcPhase cc_phase pipe_env hsc_env input_fn = do+  let dflags    = hsc_dflags hsc_env+  let logger    = hsc_logger hsc_env+  let unit_env  = hsc_unit_env hsc_env+  let home_unit = hsc_home_unit hsc_env+  let tmpfs     = hsc_tmpfs hsc_env+  let platform  = ue_platform unit_env+  let hcc       = cc_phase `eqPhase` HCc++  let cmdline_include_paths =  offsetIncludePaths dflags (includePaths dflags)++  -- HC files have the dependent packages stamped into them+  pkgs <- if hcc then getHCFilePackages input_fn else return []++  -- add package include paths even if we're just compiling .c+  -- files; this is the Value Add(TM) that using ghc instead of+  -- gcc gives you :)+  ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env pkgs)+  let pkg_include_dirs     = collectIncludeDirs ps+  let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []+        (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)+  let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []+        (includePathsQuote cmdline_include_paths +++         includePathsQuoteImplicit cmdline_include_paths)+  let include_paths = include_paths_quote ++ include_paths_global++  -- pass -D or -optP to preprocessor when compiling foreign C files+  -- (#16737). Doing it in this way is simpler and also enable the C+  -- compiler to perform preprocessing and parsing in a single pass,+  -- but it may introduce inconsistency if a different pgm_P is specified.+  let opts = getOpts dflags opt_P+      aug_imports = augmentImports dflags opts++      more_preprocessor_opts = concat+        [ ["-Xpreprocessor", i]+        | not hcc+        , i <- aug_imports+        ]++  let gcc_extra_viac_flags = extraGccViaCFlags dflags+  let pic_c_flags = picCCOpts dflags++  let verbFlags = getVerbFlags dflags++  -- cc-options are not passed when compiling .hc files.  Our+  -- hc code doesn't not #include any header files anyway, so these+  -- options aren't necessary.+  let pkg_extra_cc_opts+          | hcc       = []+          | otherwise = collectExtraCcOpts ps++  let framework_paths+          | platformUsesFrameworks platform+          = let pkgFrameworkPaths     = collectFrameworksDirs ps+                cmdlineFrameworkPaths = frameworkPaths dflags+            in map ("-F"++) (cmdlineFrameworkPaths ++ pkgFrameworkPaths)+          | otherwise+          = []++  let cc_opt | llvmOptLevel dflags >= 2 = [ "-O2" ]+             | llvmOptLevel dflags >= 1 = [ "-O" ]+             | otherwise            = []++  -- Decide next phase+  let next_phase = As False+  output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env Nothing++  let+    more_hcc_opts =+          -- on x86 the floating point regs have greater precision+          -- than a double, which leads to unpredictable results.+          -- By default, we turn this off with -ffloat-store unless+          -- the user specified -fexcess-precision.+          (if platformArch platform == ArchX86 &&+              not (gopt Opt_ExcessPrecision dflags)+                  then [ "-ffloat-store" ]+                  else []) ++++          -- gcc's -fstrict-aliasing allows two accesses to memory+          -- to be considered non-aliasing if they have different types.+          -- This interacts badly with the C code we generate, which is+          -- very weakly typed, being derived from C--.+          ["-fno-strict-aliasing"]++  ghcVersionH <- getGhcVersionPathName dflags unit_env++  GHC.SysTools.runCc (phaseForeignLanguage cc_phase) logger tmpfs dflags (+                  [ GHC.SysTools.FileOption "" input_fn+                  , GHC.SysTools.Option "-o"+                  , GHC.SysTools.FileOption "" output_fn+                  ]+                 ++ map GHC.SysTools.Option (+                    pic_c_flags++          -- Stub files generated for foreign exports references the runIO_closure+          -- and runNonIO_closure symbols, which are defined in the base package.+          -- These symbols are imported into the stub.c file via RtsAPI.h, and the+          -- way we do the import depends on whether we're currently compiling+          -- the base package or not.+                 ++ (if platformOS platform == OSMinGW32 &&+                        isHomeUnitId home_unit baseUnitId+                          then [ "-DCOMPILING_BASE_PACKAGE" ]+                          else [])++                 -- GCC 4.6+ doesn't like -Wimplicit when compiling C++.+                 ++ (if (cc_phase /= Ccxx && cc_phase /= Cobjcxx)+                       then ["-Wimplicit"]+                       else [])++                 ++ (if hcc+                       then gcc_extra_viac_flags ++ more_hcc_opts+                       else [])+                 ++ verbFlags+                 ++ [ "-S" ]+                 ++ cc_opt+                 ++ [ "-include", ghcVersionH ]+                 ++ framework_paths+                 ++ include_paths+                 ++ more_preprocessor_opts+                 ++ pkg_extra_cc_opts+                 ))++  return output_fn++-- This is where all object files get written from, for hs-boot and hsig files as well.+runHscBackendPhase :: PipeEnv+                   -> HscEnv+                   -> ModuleName+                   -> HscSource+                   -> ModLocation+                   -> HscBackendAction+                   -> IO ([FilePath], ModIface, Maybe Linkable, FilePath)+runHscBackendPhase pipe_env hsc_env mod_name src_flavour location result = do+  let dflags = hsc_dflags hsc_env+      logger = hsc_logger hsc_env+      o_file = if dynamicNow dflags then ml_dyn_obj_file location else ml_obj_file location -- The real object file+      next_phase = hscPostBackendPhase src_flavour (backend dflags)+  case result of+      HscUpdate iface ->+          do+             case src_flavour of+               HsigFile -> do+                 -- We need to create a REAL but empty .o file+                 -- because we are going to attempt to put it in a library+                 let input_fn = expectJust "runPhase" (ml_hs_file location)+                     basename = dropExtension input_fn+                 compileEmptyStub dflags hsc_env basename location mod_name++               -- In the case of hs-boot files, generate a dummy .o-boot+               -- stamp file for the benefit of Make+               HsBootFile -> touchObjectFile logger dflags o_file+               HsSrcFile -> panic "HscUpdate not relevant for HscSrcFile"++             return ([], iface, Nothing, o_file)+      HscRecomp { hscs_guts = cgguts,+                  hscs_mod_location = mod_location,+                  hscs_partial_iface = partial_iface,+                  hscs_old_iface_hash = mb_old_iface_hash+                }+        -> case backend dflags of+          NoBackend -> panic "HscRecomp not relevant for NoBackend"+          Interpreter -> do+              -- In interpreted mode the regular codeGen backend is not run so we+              -- generate a interface without codeGen info.+              final_iface <- mkFullIface hsc_env partial_iface Nothing+              hscMaybeWriteIface logger dflags True final_iface mb_old_iface_hash location++              (hasStub, comp_bc, spt_entries) <- hscInteractive hsc_env cgguts mod_location++              stub_o <- case hasStub of+                        Nothing -> return []+                        Just stub_c -> do+                            stub_o <- compileStub hsc_env stub_c+                            return [DotO stub_o]++              let hs_unlinked = [BCOs comp_bc spt_entries]+              unlinked_time <- getCurrentTime+              let !linkable = LM unlinked_time (mkHomeModule (hsc_home_unit hsc_env) mod_name)+                             (hs_unlinked ++ stub_o)+              return ([], final_iface, Just linkable, panic "interpreter")+          _ -> do+              output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env (Just location)+              (outputFilename, mStub, foreign_files, mb_cg_infos) <-+                hscGenHardCode hsc_env cgguts mod_location output_fn+              final_iface <- mkFullIface hsc_env partial_iface mb_cg_infos++              -- See Note [Writing interface files]+              hscMaybeWriteIface logger dflags False final_iface mb_old_iface_hash mod_location++              stub_o <- mapM (compileStub hsc_env) mStub+              foreign_os <-+                mapM (uncurry (compileForeign hsc_env)) foreign_files+              let fos = (maybe [] return stub_o ++ foreign_os)++              -- This is awkward, no linkable is produced here because we still+              -- have some way to do before the object file is produced+              -- In future we can split up the driver logic more so that this function+              -- is in TPipeline and in this branch we can invoke the rest of the backend phase.+              return (fos, final_iface, Nothing, outputFilename)+++runUnlitPhase :: HscEnv -> FilePath -> FilePath -> IO FilePath+runUnlitPhase hsc_env input_fn output_fn = do+    let+       -- escape the characters \, ", and ', but don't try to escape+       -- Unicode or anything else (so we don't use Util.charToC+       -- here).  If we get this wrong, then in+       -- GHC.HsToCore.Coverage.isGoodTickSrcSpan where we check that the filename in+       -- a SrcLoc is the same as the source filenaame, the two will+       -- look bogusly different. See test:+       -- libraries/hpc/tests/function/subdir/tough2.hs+       escape ('\\':cs) = '\\':'\\': escape cs+       escape ('\"':cs) = '\\':'\"': escape cs+       escape ('\'':cs) = '\\':'\'': escape cs+       escape (c:cs)    = c : escape cs+       escape []        = []++    let flags = [ -- The -h option passes the file name for unlit to+                  -- put in a #line directive+                  GHC.SysTools.Option     "-h"+                  -- See Note [Don't normalise input filenames].+                , GHC.SysTools.Option $ escape input_fn+                , GHC.SysTools.FileOption "" input_fn+                , GHC.SysTools.FileOption "" output_fn+                ]++    let dflags = hsc_dflags hsc_env+        logger = hsc_logger hsc_env+    GHC.SysTools.runUnlit logger dflags flags++    return output_fn++getFileArgs :: HscEnv -> FilePath -> IO ((DynFlags, Messages PsMessage, [Warn]))+getFileArgs hsc_env input_fn = do+  let dflags0 = hsc_dflags hsc_env+      parser_opts = initParserOpts dflags0+  (warns0, src_opts) <- getOptionsFromFile parser_opts input_fn+  (dflags1, unhandled_flags, warns)+    <- parseDynamicFilePragma dflags0 src_opts+  checkProcessArgsResult unhandled_flags+  return (dflags1, warns0, warns)++runCppPhase :: HscEnv -> FilePath -> FilePath -> IO FilePath+runCppPhase hsc_env input_fn output_fn = do+  doCpp (hsc_logger hsc_env)+           (hsc_tmpfs hsc_env)+           (hsc_dflags hsc_env)+           (hsc_unit_env hsc_env)+           True{-raw-}+           input_fn output_fn+  return output_fn+++runHscPhase :: PipeEnv+  -> HscEnv+  -> FilePath+  -> HscSource+  -> IO (HscEnv, ModSummary, HscRecompStatus)+runHscPhase pipe_env hsc_env0 input_fn src_flavour = do+  let dflags0 = hsc_dflags hsc_env0+      PipeEnv{ src_basename=basename,+               src_suffix=suff } = pipe_env++  -- we add the current directory (i.e. the directory in which+  -- the .hs files resides) to the include path, since this is+  -- what gcc does, and it's probably what you want.+  let current_dir = takeDirectory basename+      new_includes = addImplicitQuoteInclude paths [current_dir]+      paths = includePaths dflags0+      dflags = dflags0 { includePaths = new_includes }+      hsc_env = hscSetFlags dflags hsc_env0++++  -- gather the imports and module name+  (hspp_buf,mod_name,imps,src_imps, ghc_prim_imp) <- do+    buf <- hGetStringBuffer input_fn+    let imp_prelude = xopt LangExt.ImplicitPrelude dflags+        popts = initParserOpts dflags+        rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)+        rn_imps = fmap (\(rpk, lmn@(L _ mn)) -> (rn_pkg_qual mn rpk, lmn))+    eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff)+    case eimps of+        Left errs -> throwErrors (GhcPsMessage <$> errs)+        Right (src_imps,imps, ghc_prim_imp, L _ mod_name) -> return+              (Just buf, mod_name, rn_imps imps, rn_imps src_imps, ghc_prim_imp)++  -- Take -o into account if present+  -- Very like -ohi, but we must *only* do this if we aren't linking+  -- (If we're linking then the -o applies to the linked thing, not to+  -- the object file for one module.)+  -- Note the nasty duplication with the same computation in compileFile above+  location <- mkOneShotModLocation pipe_env dflags src_flavour mod_name+  let o_file = ml_obj_file location -- The real object file+      hi_file = ml_hi_file location+      hie_file = ml_hie_file location+      dyn_o_file = ml_dyn_obj_file location++  src_hash <- getFileHash (basename <.> suff)+  hi_date <- modificationTimeIfExists hi_file+  hie_date <- modificationTimeIfExists hie_file+  o_mod <- modificationTimeIfExists o_file+  dyn_o_mod <- modificationTimeIfExists dyn_o_file++  -- Tell the finder cache about this module+  mod <- do+    let home_unit = hsc_home_unit hsc_env+    let fc        = hsc_FC hsc_env+    addHomeModuleToFinder fc home_unit mod_name location++  -- Make the ModSummary to hand to hscMain+  let+    mod_summary = ModSummary {  ms_mod       = mod,+                                ms_hsc_src   = src_flavour,+                                ms_hspp_file = input_fn,+                                ms_hspp_opts = dflags,+                                ms_hspp_buf  = hspp_buf,+                                ms_location  = location,+                                ms_hs_hash   = src_hash,+                                ms_obj_date  = o_mod,+                                ms_dyn_obj_date = dyn_o_mod,+                                ms_parsed_mod   = Nothing,+                                ms_iface_date   = hi_date,+                                ms_hie_date     = hie_date,+                                ms_ghc_prim_import = ghc_prim_imp,+                                ms_textual_imps = imps,+                                ms_srcimps      = src_imps }+++  -- run the compiler!+  let msg :: Messager+      msg hsc_env _ what _ = oneShotMsg (hsc_logger hsc_env) what+  plugin_hsc_env' <- initializePlugins hsc_env++  -- Need to set the knot-tying mutable variable for interface+  -- files. See GHC.Tc.Utils.TcGblEnv.tcg_type_env_var.+  -- See also Note [hsc_type_env_var hack]+  type_env_var <- newIORef emptyNameEnv+  let plugin_hsc_env = plugin_hsc_env' { hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(mod, type_env_var)]) }++  status <- hscRecompStatus (Just msg) plugin_hsc_env mod_summary+                        Nothing Nothing (1, 1)++  return (plugin_hsc_env, mod_summary, status)++-- | Calculate the ModLocation from the provided DynFlags. This function is only used+-- in one-shot mode and therefore takes into account the effect of -o/-ohi flags+-- (which do nothing in --make mode)+mkOneShotModLocation :: PipeEnv -> DynFlags -> HscSource -> ModuleName -> IO ModLocation+mkOneShotModLocation pipe_env dflags src_flavour mod_name = do+    let PipeEnv{ src_basename=basename,+             src_suffix=suff } = pipe_env+    let location1 = mkHomeModLocation2 fopts mod_name basename suff++    -- Boot-ify it if necessary+    let location2+          | HsBootFile <- src_flavour = addBootSuffixLocnOut location1+          | otherwise                 = location1+++    -- Take -ohi into account if present+    -- This can't be done in mkHomeModuleLocation because+    -- it only applies to the module being compiles+    let ohi = outputHi dflags+        location3 | Just fn <- ohi = location2{ ml_hi_file = fn }+                  | otherwise      = location2++    let dynohi = dynOutputHi dflags+        location4 | Just fn <- dynohi = location3{ ml_dyn_hi_file = fn }+                  | otherwise         = location3++    -- Take -o into account if present+    -- Very like -ohi, but we must *only* do this if we aren't linking+    -- (If we're linking then the -o applies to the linked thing, not to+    -- the object file for one module.)+    -- Note the nasty duplication with the same computation in compileFile+    -- above+    let expl_o_file = outputFile_ dflags+        expl_dyn_o_file  = dynOutputFile_ dflags+        location5 | Just ofile <- expl_o_file+                  , let dyn_ofile = fromMaybe (ofile -<.> dynObjectSuf_ dflags) expl_dyn_o_file+                  , isNoLink (ghcLink dflags)+                  = location4 { ml_obj_file = ofile+                              , ml_dyn_obj_file = dyn_ofile }+                  | Just dyn_ofile <- expl_dyn_o_file+                  = location4 { ml_dyn_obj_file = dyn_ofile }+                  | otherwise = location4+    return location5+    where+      fopts = initFinderOpts dflags++runHscTcPhase :: HscEnv -> ModSummary -> IO (FrontendResult, Messages GhcMessage)+runHscTcPhase = hscTypecheckAndGetWarnings++runHscPostTcPhase ::+    HscEnv+  -> ModSummary+  -> FrontendResult+  -> Messages GhcMessage+  -> Maybe Fingerprint+  -> IO HscBackendAction+runHscPostTcPhase hsc_env mod_summary tc_result tc_warnings mb_old_hash = do+        runHsc hsc_env $ do+            hscDesugarAndSimplify mod_summary tc_result tc_warnings mb_old_hash+++runHsPpPhase :: HscEnv -> FilePath -> FilePath -> FilePath -> IO FilePath+runHsPpPhase hsc_env orig_fn input_fn output_fn = do+    let dflags = hsc_dflags hsc_env+    let logger = hsc_logger hsc_env+    GHC.SysTools.runPp logger dflags+      ( [ GHC.SysTools.Option     orig_fn+      , GHC.SysTools.Option     input_fn+      , GHC.SysTools.FileOption "" output_fn+      ] )+    return output_fn++phaseOutputFilenameNew :: Phase -- ^ The next phase+                       -> PipeEnv+                       -> HscEnv+                       -> Maybe ModLocation -- ^ A ModLocation, if we are compiling a Haskell source file+                       -> IO FilePath+phaseOutputFilenameNew next_phase pipe_env hsc_env maybe_loc = do+  let PipeEnv{stop_phase, src_basename, output_spec} = pipe_env+  let dflags = hsc_dflags hsc_env+      logger = hsc_logger hsc_env+      tmpfs = hsc_tmpfs hsc_env+  getOutputFilename logger tmpfs (stopPhaseToPhase stop_phase) output_spec+                    src_basename dflags next_phase maybe_loc+++-- | Computes the next output filename for something in the compilation+-- pipeline.  This is controlled by several variables:+--+--      1. 'Phase': the last phase to be run (e.g. 'stopPhase').  This+--         is used to tell if we're in the last phase or not, because+--         in that case flags like @-o@ may be important.+--      2. 'PipelineOutput': is this intended to be a 'Temporary' or+--         'Persistent' build output?  Temporary files just go in+--         a fresh temporary name.+--      3. 'String': what was the basename of the original input file?+--      4. 'DynFlags': the obvious thing+--      5. 'Phase': the phase we want to determine the output filename of.+--      6. @Maybe ModLocation@: the 'ModLocation' of the module we're+--         compiling; this can be used to override the default output+--         of an object file.  (TODO: do we actually need this?)+getOutputFilename+  :: Logger+  -> TmpFs+  -> Phase+  -> PipelineOutput+  -> String+  -> DynFlags+  -> Phase -- next phase+  -> Maybe ModLocation+  -> IO FilePath+getOutputFilename logger tmpfs stop_phase output basename dflags next_phase maybe_location+  -- 1. If we are generating object files for a .hs file, then return the odir as the ModLocation+  -- will have been modified to point to the accurate locations+ | StopLn <- next_phase, Just loc <- maybe_location  =+      return $ if dynamicNow dflags then ml_dyn_obj_file loc+                                    else ml_obj_file loc+ -- 2. If output style is persistant then+ | is_last_phase, Persistent   <- output = persistent_fn+ -- 3. Specific file is only set when outputFile is set by -o+ -- If we are in dynamic mode but -dyno is not set then write to the same path as+ -- -o with a .dyn_* extension. This case is not triggered for object files which+ -- are always handled by the ModLocation.+ | is_last_phase, SpecificFile <- output =+    return $+      if dynamicNow dflags+        then case dynOutputFile_ dflags of+                Nothing -> let ofile = getOutputFile_ dflags+                               new_ext = case takeExtension ofile of+                                            "" -> "dyn"+                                            ext -> "dyn_" ++ tail ext+                           in replaceExtension ofile new_ext+                Just fn -> fn+        else getOutputFile_ dflags+ | keep_this_output                      = persistent_fn+ | Temporary lifetime <- output          = newTempName logger tmpfs (tmpDir dflags) lifetime suffix+ | otherwise                             = newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule+   suffix+    where+          getOutputFile_ dflags = case outputFile_ dflags of+                                    Nothing -> pprPanic "SpecificFile: No filename" (ppr $ (dynamicNow dflags, outputFile_ dflags, dynOutputFile_ dflags))+                                    Just fn -> fn++          hcsuf      = hcSuf dflags+          odir       = objectDir dflags+          osuf       = objectSuf dflags+          keep_hc    = gopt Opt_KeepHcFiles dflags+          keep_hscpp = gopt Opt_KeepHscppFiles dflags+          keep_s     = gopt Opt_KeepSFiles dflags+          keep_bc    = gopt Opt_KeepLlvmFiles dflags++          myPhaseInputExt HCc       = hcsuf+          myPhaseInputExt MergeForeign = osuf+          myPhaseInputExt StopLn    = osuf+          myPhaseInputExt other     = phaseInputExt other++          is_last_phase = next_phase `eqPhase` stop_phase++          -- sometimes, we keep output from intermediate stages+          keep_this_output =+               case next_phase of+                       As _    | keep_s     -> True+                       LlvmOpt | keep_bc    -> True+                       HCc     | keep_hc    -> True+                       HsPp _  | keep_hscpp -> True   -- See #10869+                       _other               -> False++          suffix = myPhaseInputExt next_phase++          -- persistent object files get put in odir+          persistent_fn+             | StopLn <- next_phase = return odir_persistent+             | otherwise            = return persistent++          persistent = basename <.> suffix++          odir_persistent+             | Just d <- odir = (d </> persistent)+             | otherwise      = persistent+++-- | LLVM Options. These are flags to be passed to opt and llc, to ensure+-- consistency we list them in pairs, so that they form groups.+llvmOptions :: DynFlags+            -> [(String, String)]  -- ^ pairs of (opt, llc) arguments+llvmOptions dflags =+       [("-enable-tbaa -tbaa",  "-enable-tbaa") | gopt Opt_LlvmTBAA dflags ]+    ++ [("-relocation-model=" ++ rmodel+        ,"-relocation-model=" ++ rmodel) | not (null rmodel)]+    ++ [("-stack-alignment=" ++ (show align)+        ,"-stack-alignment=" ++ (show align)) | align > 0 ]++    -- Additional llc flags+    ++ [("", "-mcpu=" ++ mcpu)   | not (null mcpu)+                                 , not (any (isInfixOf "-mcpu") (getOpts dflags opt_lc)) ]+    ++ [("", "-mattr=" ++ attrs) | not (null attrs) ]+    ++ [("", "-target-abi=" ++ abi) | not (null abi) ]++  where target = platformMisc_llvmTarget $ platformMisc dflags+        Just (LlvmTarget _ mcpu mattr) = lookup target (llvmTargets $ llvmConfig dflags)++        -- Relocation models+        rmodel | gopt Opt_PIC dflags         = "pic"+               | positionIndependent dflags  = "pic"+               | ways dflags `hasWay` WayDyn = "dynamic-no-pic"+               | otherwise                   = "static"++        platform = targetPlatform dflags++        align :: Int+        align = case platformArch platform of+                  ArchX86_64 | isAvxEnabled dflags -> 32+                  _                                -> 0++        attrs :: String+        attrs = intercalate "," $ mattr+              ++ ["+sse42"   | isSse4_2Enabled dflags   ]+              ++ ["+sse2"    | isSse2Enabled platform   ]+              ++ ["+sse"     | isSseEnabled platform    ]+              ++ ["+avx512f" | isAvx512fEnabled dflags  ]+              ++ ["+avx2"    | isAvx2Enabled dflags     ]+              ++ ["+avx"     | isAvxEnabled dflags      ]+              ++ ["+avx512cd"| isAvx512cdEnabled dflags ]+              ++ ["+avx512er"| isAvx512erEnabled dflags ]+              ++ ["+avx512pf"| isAvx512pfEnabled dflags ]+              ++ ["+bmi"     | isBmiEnabled dflags      ]+              ++ ["+bmi2"    | isBmi2Enabled dflags     ]++        abi :: String+        abi = case platformArch (targetPlatform dflags) of+                ArchRISCV64 -> "lp64d"+                _           -> ""+++-- Note [Filepaths and Multiple Home Units]+offsetIncludePaths :: DynFlags -> IncludeSpecs -> IncludeSpecs+offsetIncludePaths dflags (IncludeSpecs incs quotes impl) =+     let go = map (augmentByWorkingDirectory dflags)+     in IncludeSpecs (go incs) (go quotes) (go impl)+-- -----------------------------------------------------------------------------+-- Running CPP++-- | Run CPP+--+-- UnitEnv is needed to compute MIN_VERSION macros+doCpp :: Logger -> TmpFs -> DynFlags -> UnitEnv -> Bool -> FilePath -> FilePath -> IO ()+doCpp logger tmpfs dflags unit_env raw input_fn output_fn = do+    let hscpp_opts = picPOpts dflags+    let cmdline_include_paths = offsetIncludePaths dflags (includePaths dflags)+    let unit_state = ue_units unit_env+    pkg_include_dirs <- mayThrowUnitErr+                        (collectIncludeDirs <$> preloadUnitsInfo unit_env)+    -- MP: This is not quite right, the headers which are supposed to be installed in+    -- the package might not be the same as the provided include paths, but it's a close+    -- enough approximation for things to work. A proper solution would be to have to declare which paths should+    -- be propagated to dependent packages.+    let home_pkg_deps =+         [homeUnitEnv_dflags . ue_findHomeUnitEnv uid $ unit_env | uid <- ue_transitiveHomeDeps (ue_currentUnit unit_env) unit_env]+        dep_pkg_extra_inputs = [offsetIncludePaths fs (includePaths fs) | fs <- home_pkg_deps]++    let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []+          (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs+                                                    ++ concatMap includePathsGlobal dep_pkg_extra_inputs)+    let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []+          (includePathsQuote cmdline_include_paths +++           includePathsQuoteImplicit cmdline_include_paths)+    let include_paths = include_paths_quote ++ include_paths_global++    let verbFlags = getVerbFlags dflags++    let cpp_prog args | raw       = GHC.SysTools.runCpp logger dflags args+                      | otherwise = GHC.SysTools.runCc Nothing logger tmpfs dflags+                                        (GHC.SysTools.Option "-E" : args)++    let platform   = targetPlatform dflags+        targetArch = stringEncodeArch $ platformArch platform+        targetOS = stringEncodeOS $ platformOS platform+        isWindows = platformOS platform == OSMinGW32+    let target_defs =+          [ "-D" ++ HOST_OS     ++ "_BUILD_OS",+            "-D" ++ HOST_ARCH   ++ "_BUILD_ARCH",+            "-D" ++ targetOS    ++ "_HOST_OS",+            "-D" ++ targetArch  ++ "_HOST_ARCH" ]+        -- remember, in code we *compile*, the HOST is the same our TARGET,+        -- and BUILD is the same as our HOST.++    let io_manager_defs =+          [ "-D__IO_MANAGER_WINIO__=1" | isWindows ] +++          [ "-D__IO_MANAGER_MIO__=1"               ]++    let sse_defs =+          [ "-D__SSE__"      | isSseEnabled      platform ] +++          [ "-D__SSE2__"     | isSse2Enabled     platform ] +++          [ "-D__SSE4_2__"   | isSse4_2Enabled   dflags ]++    let avx_defs =+          [ "-D__AVX__"      | isAvxEnabled      dflags ] +++          [ "-D__AVX2__"     | isAvx2Enabled     dflags ] +++          [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] +++          [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] +++          [ "-D__AVX512F__"  | isAvx512fEnabled  dflags ] +++          [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ]++    backend_defs <- getBackendDefs logger dflags++    let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ]+    -- Default CPP defines in Haskell source+    ghcVersionH <- getGhcVersionPathName dflags unit_env+    let hsSourceCppOpts = [ "-include", ghcVersionH ]++    -- MIN_VERSION macros+    let uids = explicitUnits unit_state+        pkgs = mapMaybe (lookupUnit unit_state . fst) uids+    mb_macro_include <-+        if not (null pkgs) && gopt Opt_VersionMacros dflags+            then do macro_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "h"+                    writeFile macro_stub (generatePackageVersionMacros pkgs)+                    -- Include version macros for every *exposed* package.+                    -- Without -hide-all-packages and with a package database+                    -- size of 1000 packages, it takes cpp an estimated 2+                    -- milliseconds to process this file. See #10970+                    -- comment 8.+                    return [GHC.SysTools.FileOption "-include" macro_stub]+            else return []++    cpp_prog       (   map GHC.SysTools.Option verbFlags+                    ++ map GHC.SysTools.Option include_paths+                    ++ map GHC.SysTools.Option hsSourceCppOpts+                    ++ map GHC.SysTools.Option target_defs+                    ++ map GHC.SysTools.Option backend_defs+                    ++ map GHC.SysTools.Option th_defs+                    ++ map GHC.SysTools.Option hscpp_opts+                    ++ map GHC.SysTools.Option sse_defs+                    ++ map GHC.SysTools.Option avx_defs+                    ++ map GHC.SysTools.Option io_manager_defs+                    ++ mb_macro_include+        -- Set the language mode to assembler-with-cpp when preprocessing. This+        -- alleviates some of the C99 macro rules relating to whitespace and the hash+        -- operator, which we tend to abuse. Clang in particular is not very happy+        -- about this.+                    ++ [ GHC.SysTools.Option     "-x"+                       , GHC.SysTools.Option     "assembler-with-cpp"+                       , GHC.SysTools.Option     input_fn+        -- We hackily use Option instead of FileOption here, so that the file+        -- name is not back-slashed on Windows.  cpp is capable of+        -- dealing with / in filenames, so it works fine.  Furthermore+        -- if we put in backslashes, cpp outputs #line directives+        -- with *double* backslashes.   And that in turn means that+        -- our error messages get double backslashes in them.+        -- In due course we should arrange that the lexer deals+        -- with these \\ escapes properly.+                       , GHC.SysTools.Option     "-o"+                       , GHC.SysTools.FileOption "" output_fn+                       ])++getBackendDefs :: Logger -> DynFlags -> IO [String]+getBackendDefs logger dflags | backend dflags == LLVM = do+    llvmVer <- figureLlvmVersion logger dflags+    return $ case fmap llvmVersionList llvmVer of+               Just [m] -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,0) ]+               Just (m:n:_) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]+               _ -> []+  where+    format (major, minor)+      | minor >= 100 = error "getBackendDefs: Unsupported minor version"+      | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int++getBackendDefs _ _ =+    return []++-- | What phase to run after one of the backend code generators has run+hscPostBackendPhase :: HscSource -> Backend -> Phase+hscPostBackendPhase HsBootFile _    =  StopLn+hscPostBackendPhase HsigFile _      =  StopLn+hscPostBackendPhase _ bcknd =+  case bcknd of+        ViaC        -> HCc+        NCG         -> As False+        LLVM        -> LlvmOpt+        NoBackend   -> StopLn+        Interpreter -> StopLn+++compileStub :: HscEnv -> FilePath -> IO FilePath+compileStub hsc_env stub_c = compileForeign hsc_env LangC stub_c+++-- ---------------------------------------------------------------------------+-- join object files into a single relocatable object file, using ld -r++{-+Note [Produce big objects on Windows]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The Windows Portable Executable object format has a limit of 32k sections, which+we tend to blow through pretty easily. Thankfully, there is a "big object"+extension, which raises this limit to 2^32. However, it must be explicitly+enabled in the toolchain:++ * the assembler accepts the -mbig-obj flag, which causes it to produce a+   bigobj-enabled COFF object.++ * the linker accepts the --oformat pe-bigobj-x86-64 flag. Despite what the name+   suggests, this tells the linker to produce a bigobj-enabled COFF object, no a+   PE executable.++Previously when we used ld.bfd we had to enable bigobj output in a few places:++ * When merging object files (GHC.Driver.Pipeline.Execute.joinObjectFiles)++ * When assembling (GHC.Driver.Pipeline.runPhase (RealPhase As ...))++However, this is no longer necessary with ld.lld, which detects that the+object is large on its own.++Unfortunately the big object format is not supported on 32-bit targets so+none of this can be used in that case.+++Note [Object merging]+~~~~~~~~~~~~~~~~~~~~~+On most platforms one can "merge" a set of relocatable object files into a new,+partiall-linked-but-still-relocatable object. In a typical UNIX-style linker,+this is accomplished with the `ld -r` command. We rely on this for two ends:++ * We rely on `ld -r` to squash together split sections, making GHCi loading+   more efficient. See Note [Merging object files for GHCi].++ * We use merging to combine a module's object code (e.g. produced by the NCG)+   with its foreign stubs (typically produced by a C compiler).++The command used for object linking is set using the -pgmlm and -optlm+command-line options.++Sadly, the LLD linker that we use on Windows does not support the `-r` flag+needed to support object merging (see #21068). For this reason on Windows we do+not support GHCi objects.  To deal with foreign stubs we build a static archive+of all of a module's object files instead merging them. Consequently, we can+end up producing `.o` files which are in fact static archives. However,+toolchains generally don't have a problem with this as they use file headers,+not the filename, to determine the nature of inputs.++Note that this has somewhat non-obvious consequences when producing+initializers and finalizers. See Note [Initializers and finalizers in Cmm]+in GHC.Cmm.InitFini for details.+++Note [Merging object files for GHCi]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHCi can usually loads standard linkable object files using GHC's linker+implementation. However, most users build their projects with -split-sections,+meaning that such object files can have an extremely high number of sections.+As the linker must map each of these sections individually, loading such object+files is very inefficient.++To avoid this inefficiency, we use the linker's `-r` flag and a linker script+to produce a merged relocatable object file. This file will contain a singe+text section section and can consequently be mapped far more efficiently. As+gcc tends to do unpredictable things to our linker command line, we opt to+invoke ld directly in this case, in contrast to our usual strategy of linking+via gcc.+-}++-- | See Note [Object merging].+joinObjectFiles :: HscEnv -> [FilePath] -> FilePath -> IO ()+joinObjectFiles hsc_env o_files output_fn+  | can_merge_objs = do+  let toolSettings' = toolSettings dflags+      ldIsGnuLd = toolSettings_ldIsGnuLd toolSettings'+      ld_r args = GHC.SysTools.runMergeObjects (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (hsc_dflags hsc_env) (+                        map GHC.SysTools.Option ld_build_id+                     ++ [ GHC.SysTools.Option "-o",+                          GHC.SysTools.FileOption "" output_fn ]+                     ++ args)++      -- suppress the generation of the .note.gnu.build-id section,+      -- which we don't need and sometimes causes ld to emit a+      -- warning:+      ld_build_id | toolSettings_ldSupportsBuildId toolSettings' = ["--build-id=none"]+                  | otherwise                                    = []++  if ldIsGnuLd+     then do+          script <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "ldscript"+          cwd <- getCurrentDirectory+          let o_files_abs = map (\x -> "\"" ++ (cwd </> x) ++ "\"") o_files+          writeFile script $ "INPUT(" ++ unwords o_files_abs ++ ")"+          ld_r [GHC.SysTools.FileOption "" script]+     else if toolSettings_ldSupportsFilelist toolSettings'+     then do+          filelist <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "filelist"+          writeFile filelist $ unlines o_files+          ld_r [GHC.SysTools.Option "-filelist",+                GHC.SysTools.FileOption "" filelist]+     else+          ld_r (map (GHC.SysTools.FileOption "") o_files)++  | otherwise = do+  withAtomicRename output_fn $ \tmp_ar ->+      liftIO $ runAr logger dflags Nothing $ map Option $ ["qc" ++ dashL, tmp_ar] ++ o_files+  where+    dashLSupported = sArSupportsDashL (settings dflags)+    dashL = if dashLSupported then "L" else ""+    can_merge_objs = isJust (pgm_lm (hsc_dflags hsc_env))+    dflags = hsc_dflags hsc_env+    tmpfs = hsc_tmpfs hsc_env+    logger = hsc_logger hsc_env+++-----------------------------------------------------------------------------+-- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file++getHCFilePackages :: FilePath -> IO [UnitId]+getHCFilePackages filename =+  withFile filename ReadMode $ \h -> do+    l <- hGetLine h+    case l of+      '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest ->+          return (map stringToUnitId (words rest))+      _other ->+          return []+++linkDynLibCheck :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO ()+linkDynLibCheck logger tmpfs dflags unit_env o_files dep_units = do+  when (haveRtsOptsFlags dflags) $+    logMsg logger MCInfo noSrcSpan+      $ withPprStyle defaultUserStyle+      (text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$+      text "    Call hs_init_ghc() from your main() function to set these options.")+  linkDynLib logger tmpfs dflags unit_env o_files dep_units++++-- ---------------------------------------------------------------------------+-- Macros (cribbed from Cabal)++generatePackageVersionMacros :: [UnitInfo] -> String+generatePackageVersionMacros pkgs = concat+  -- Do not add any C-style comments. See #3389.+  [ generateMacros "" pkgname version+  | pkg <- pkgs+  , let version = unitPackageVersion pkg+        pkgname = map fixchar (unitPackageNameString pkg)+  ]++fixchar :: Char -> Char+fixchar '-' = '_'+fixchar c   = c++generateMacros :: String -> String -> Version -> String+generateMacros prefix name version =+  concat+  ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n"+  ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n"+  ,"  (major1) <  ",major1," || \\\n"+  ,"  (major1) == ",major1," && (major2) <  ",major2," || \\\n"+  ,"  (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"+  ,"\n\n"+  ]+  where+    (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)+++-- -----------------------------------------------------------------------------+-- Misc.++++touchObjectFile :: Logger -> DynFlags -> FilePath -> IO ()+touchObjectFile logger dflags path = do+  createDirectoryIfMissing True $ takeDirectory path+  GHC.SysTools.touch logger dflags "Touching object file" path++-- | Find out path to @ghcversion.h@ file+getGhcVersionPathName :: DynFlags -> UnitEnv -> IO FilePath+getGhcVersionPathName dflags unit_env = do+  candidates <- case ghcVersionFile dflags of+    Just path -> return [path]+    Nothing -> do+        ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env [rtsUnitId])+        return ((</> "ghcversion.h") <$> collectIncludeDirs ps)++  found <- filterM doesFileExist candidates+  case found of+      []    -> throwGhcExceptionIO (InstallationError+                                    ("ghcversion.h missing; tried: "+                                      ++ intercalate ", " candidates))+      (x:_) -> return x++-- Note [-fPIC for assembler]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~+-- When compiling .c source file GHC's driver pipeline basically+-- does the following two things:+--   1. ${CC}              -S 'PIC_CFLAGS' source.c+--   2. ${CC} -x assembler -c 'PIC_CFLAGS' source.S+--+-- Why do we need to pass 'PIC_CFLAGS' both to C compiler and assembler?+-- Because on some architectures (at least sparc32) assembler also chooses+-- the relocation type!+-- Consider the following C module:+--+--     /* pic-sample.c */+--     int v;+--     void set_v (int n) { v = n; }+--     int  get_v (void)  { return v; }+--+--     $ gcc -S -fPIC pic-sample.c+--     $ gcc -c       pic-sample.s -o pic-sample.no-pic.o # incorrect binary+--     $ gcc -c -fPIC pic-sample.s -o pic-sample.pic.o    # correct binary+--+--     $ objdump -r -d pic-sample.pic.o    > pic-sample.pic.o.od+--     $ objdump -r -d pic-sample.no-pic.o > pic-sample.no-pic.o.od+--     $ diff -u pic-sample.pic.o.od pic-sample.no-pic.o.od+--+-- Most of architectures won't show any difference in this test, but on sparc32+-- the following assembly snippet:+--+--    sethi   %hi(_GLOBAL_OFFSET_TABLE_-8), %l7+--+-- generates two kinds or relocations, only 'R_SPARC_PC22' is correct:+--+--       3c:  2f 00 00 00     sethi  %hi(0), %l7+--    -                       3c: R_SPARC_PC22        _GLOBAL_OFFSET_TABLE_-0x8+--    +                       3c: R_SPARC_HI22        _GLOBAL_OFFSET_TABLE_-0x8++{- Note [Don't normalise input filenames]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Summary+  We used to normalise input filenames when starting the unlit phase. This+  broke hpc in `--make` mode with imported literate modules (#2991).++Introduction+  1) --main+  When compiling a module with --main, GHC scans its imports to find out which+  other modules it needs to compile too. It turns out that there is a small+  difference between saying `ghc --make A.hs`, when `A` imports `B`, and+  specifying both modules on the command line with `ghc --make A.hs B.hs`. In+  the former case, the filename for B is inferred to be './B.hs' instead of+  'B.hs'.++  2) unlit+  When GHC compiles a literate haskell file, the source code first needs to go+  through unlit, which turns it into normal Haskell source code. At the start+  of the unlit phase, in `Driver.Pipeline.runPhase`, we call unlit with the+  option `-h` and the name of the original file. We used to normalise this+  filename using System.FilePath.normalise, which among other things removes+  an initial './'. unlit then uses that filename in #line directives that it+  inserts in the transformed source code.++  3) SrcSpan+  A SrcSpan represents a portion of a source code file. It has fields+  linenumber, start column, end column, and also a reference to the file it+  originated from. The SrcSpans for a literate haskell file refer to the+  filename that was passed to unlit -h.++  4) -fhpc+  At some point during compilation with -fhpc, in the function+  `GHC.HsToCore.Coverage.isGoodTickSrcSpan`, we compare the filename that a+  `SrcSpan` refers to with the name of the file we are currently compiling.+  For some reason I don't yet understand, they can sometimes legitimally be+  different, and then hpc ignores that SrcSpan.++Problem+  When running `ghc --make -fhpc A.hs`, where `A.hs` imports the literate+  module `B.lhs`, `B` is inferred to be in the file `./B.lhs` (1). At the+  start of the unlit phase, the name `./B.lhs` is normalised to `B.lhs` (2).+  Therefore the SrcSpans of `B` refer to the file `B.lhs` (3), but we are+  still compiling `./B.lhs`. Hpc thinks these two filenames are different (4),+  doesn't include ticks for B, and we have unhappy customers (#2991).++Solution+  Do not normalise `input_fn` when starting the unlit phase.++Alternative solution+  Another option would be to not compare the two filenames on equality, but to+  use System.FilePath.equalFilePath. That function first normalises its+  arguments. The problem is that by the time we need to do the comparison, the+  filenames have been turned into FastStrings, probably for performance+  reasons, so System.FilePath.equalFilePath can not be used directly.++Archeology+  The call to `normalise` was added in a commit called "Fix slash+  direction on Windows with the new filePath code" (c9b6b5e8). The problem+  that commit was addressing has since been solved in a different manner, in a+  commit called "Fix the filename passed to unlit" (1eedbc6b). So the+  `normalise` is no longer necessary.+-}
+ compiler/GHC/Driver/Pipeline/LogQueue.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DerivingVia #-}+module GHC.Driver.Pipeline.LogQueue ( LogQueue(..)+                                  , newLogQueue+                                  , finishLogQueue+                                  , writeLogQueue+                                  , parLogAction++                                  , LogQueueQueue(..)+                                  , initLogQueue+                                  , allLogQueues+                                  , newLogQueueQueue++                                  , logThread+                                  ) where++import GHC.Prelude+import Control.Concurrent+import Data.IORef+import GHC.Types.Error+import GHC.Types.SrcLoc+import GHC.Utils.Logger+import qualified Data.IntMap as IM+import Control.Concurrent.STM+import Control.Monad++-- LogQueue Abstraction++-- | Each module is given a unique 'LogQueue' to redirect compilation messages+-- to. A 'Nothing' value contains the result of compilation, and denotes the+-- end of the message queue.+data LogQueue = LogQueue { logQueueId :: !Int+                         , logQueueMessages :: !(IORef [Maybe (MessageClass, SrcSpan, SDoc, LogFlags)])+                         , logQueueSemaphore :: !(MVar ())+                         }++newLogQueue :: Int -> IO LogQueue+newLogQueue n = do+  mqueue <- newIORef []+  sem <- newMVar ()+  return (LogQueue n mqueue sem)++finishLogQueue :: LogQueue -> IO ()+finishLogQueue lq = do+  writeLogQueueInternal lq Nothing+++writeLogQueue :: LogQueue -> (MessageClass,SrcSpan,SDoc, LogFlags) -> IO ()+writeLogQueue lq msg = do+  writeLogQueueInternal lq (Just msg)++-- | Internal helper for writing log messages+writeLogQueueInternal :: LogQueue -> Maybe (MessageClass,SrcSpan,SDoc, LogFlags) -> IO ()+writeLogQueueInternal (LogQueue _n ref sem) msg = do+    atomicModifyIORef' ref $ \msgs -> (msg:msgs,())+    _ <- tryPutMVar sem ()+    return ()++-- The log_action callback that is used to synchronize messages from a+-- worker thread.+parLogAction :: LogQueue -> LogAction+parLogAction log_queue log_flags !msgClass !srcSpan !msg =+    writeLogQueue log_queue (msgClass,srcSpan,msg, log_flags)++-- Print each message from the log_queue using the global logger+printLogs :: Logger -> LogQueue -> IO ()+printLogs !logger (LogQueue _n ref sem) = read_msgs+  where read_msgs = do+            takeMVar sem+            msgs <- atomicModifyIORef' ref $ \xs -> ([], reverse xs)+            print_loop msgs++        print_loop [] = read_msgs+        print_loop (x:xs) = case x of+            Just (msgClass,srcSpan,msg,flags) -> do+                logMsg (setLogFlags logger flags) msgClass srcSpan msg+                print_loop xs+            -- Exit the loop once we encounter the end marker.+            Nothing -> return ()++-- The LogQueueQueue abstraction++data LogQueueQueue = LogQueueQueue Int (IM.IntMap LogQueue)++newLogQueueQueue :: LogQueueQueue+newLogQueueQueue = LogQueueQueue 1 IM.empty++addToQueueQueue :: LogQueue -> LogQueueQueue -> LogQueueQueue+addToQueueQueue lq (LogQueueQueue n im) = LogQueueQueue n (IM.insert (logQueueId lq) lq im)++initLogQueue :: TVar LogQueueQueue -> LogQueue -> STM ()+initLogQueue lqq lq = modifyTVar lqq (addToQueueQueue lq)++-- | Return all items in the queue in ascending order+allLogQueues :: LogQueueQueue -> [LogQueue]+allLogQueues (LogQueueQueue _n im) = IM.elems im++dequeueLogQueueQueue :: LogQueueQueue -> Maybe (LogQueue, LogQueueQueue)+dequeueLogQueueQueue (LogQueueQueue n lqq) = case IM.minViewWithKey lqq of+                                                Just ((k, v), lqq') | k == n -> Just (v, LogQueueQueue (n + 1) lqq')+                                                _ -> Nothing++logThread :: Int -> Int -> Logger -> TVar Bool -- Signal that no more new logs will be added, clear the queue and exit+                    -> TVar LogQueueQueue -- Queue for logs+                    -> IO (IO ())+logThread _ _ logger stopped lqq_var = do+  finished_var <- newEmptyMVar+  _ <- forkIO $ print_logs *> putMVar finished_var ()+  return (takeMVar finished_var)+  where+    finish = mapM (printLogs logger)++    print_logs = join $ atomically $ do+      lqq <- readTVar lqq_var+      case dequeueLogQueueQueue lqq of+        Just (lq, lqq') -> do+          writeTVar lqq_var lqq'+          return (printLogs logger lq *> print_logs)+        Nothing -> do+          -- No log to print, check if we are finished.+          stopped <- readTVar stopped+          if not stopped then retry+                         else return (finish (allLogQueues lqq))
+ compiler/GHC/Hs/Syn/Type.hs view
@@ -0,0 +1,203 @@+-- | Compute the 'Type' of an @'HsExpr' 'GhcTc'@ in a pure fashion.+--+-- Note that this does /not/ currently support the use case of annotating+-- every subexpression in an 'HsExpr' with its 'Type'. For more information on+-- this task, see #12706, #15320, #16804, and #17331.+module GHC.Hs.Syn.Type (+    -- * Extracting types from HsExpr+    lhsExprType, hsExprType, hsWrapperType,+    -- * Extracting types from HsSyn+    hsLitType, hsPatType, hsLPatType++  ) where++import GHC.Prelude++import GHC.Builtin.Types+import GHC.Builtin.Types.Prim+import GHC.Core.Coercion+import GHC.Core.ConLike+import GHC.Core.DataCon+import GHC.Core.PatSyn+import GHC.Core.TyCo.Rep+import GHC.Core.Type+import GHC.Core.Utils+import GHC.Hs+import GHC.Tc.Types.Evidence+import GHC.Types.Id+import GHC.Types.SrcLoc+import GHC.Utils.Outputable+import GHC.Utils.Panic++{-+************************************************************************+*                                                                      *+       Extracting the type from HsSyn+*                                                                      *+************************************************************************++-}++hsLPatType :: LPat GhcTc -> Type+hsLPatType (L _ p) = hsPatType p++hsPatType :: Pat GhcTc -> Type+hsPatType (ParPat _ _ pat _)            = hsLPatType pat+hsPatType (WildPat ty)                  = ty+hsPatType (VarPat _ lvar)               = idType (unLoc lvar)+hsPatType (BangPat _ pat)               = hsLPatType pat+hsPatType (LazyPat _ pat)               = hsLPatType pat+hsPatType (LitPat _ lit)                = hsLitType lit+hsPatType (AsPat _ var _)               = idType (unLoc var)+hsPatType (ViewPat ty _ _)              = ty+hsPatType (ListPat ty _)                = mkListTy ty+hsPatType (TuplePat tys _ bx)           = mkTupleTy1 bx tys+                  -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make+hsPatType (SumPat tys _ _ _ )           = mkSumTy tys+hsPatType (ConPat { pat_con = lcon+                  , pat_con_ext = ConPatTc+                    { cpt_arg_tys = tys+                    }+                  })+                                        = conLikeResTy (unLoc lcon) tys+hsPatType (SigPat ty _ _)               = ty+hsPatType (NPat ty _ _ _)               = ty+hsPatType (NPlusKPat ty _ _ _ _ _)      = ty+hsPatType (XPat ext) =+  case ext of+    CoPat _ _ ty       -> ty+    ExpansionPat _ pat -> hsPatType pat+hsPatType (SplicePat v _)               = dataConCantHappen v++hsLitType :: HsLit (GhcPass p) -> Type+hsLitType (HsChar _ _)       = charTy+hsLitType (HsCharPrim _ _)   = charPrimTy+hsLitType (HsString _ _)     = stringTy+hsLitType (HsStringPrim _ _) = addrPrimTy+hsLitType (HsInt _ _)        = intTy+hsLitType (HsIntPrim _ _)    = intPrimTy+hsLitType (HsWordPrim _ _)   = wordPrimTy+hsLitType (HsInt64Prim _ _)  = int64PrimTy+hsLitType (HsWord64Prim _ _) = word64PrimTy+hsLitType (HsInteger _ _ ty) = ty+hsLitType (HsRat _ _ ty)     = ty+hsLitType (HsFloatPrim _ _)  = floatPrimTy+hsLitType (HsDoublePrim _ _) = doublePrimTy+++-- | Compute the 'Type' of an @'LHsExpr' 'GhcTc'@ in a pure fashion.+lhsExprType :: LHsExpr GhcTc -> Type+lhsExprType (L _ e) = hsExprType e++-- | Compute the 'Type' of an @'HsExpr' 'GhcTc'@ in a pure fashion.+hsExprType :: HsExpr GhcTc -> Type+hsExprType (HsVar _ (L _ id)) = idType id+hsExprType (HsUnboundVar (HER _ ty _) _) = ty+hsExprType (HsRecSel _ (FieldOcc id _)) = idType id+hsExprType (HsOverLabel v _) = dataConCantHappen v+hsExprType (HsIPVar v _) = dataConCantHappen v+hsExprType (HsOverLit _ lit) = overLitType lit+hsExprType (HsLit _ lit) = hsLitType lit+hsExprType (HsLam     _ (MG { mg_ext = match_group })) = matchGroupTcType match_group+hsExprType (HsLamCase _ _ (MG { mg_ext = match_group })) = matchGroupTcType match_group+hsExprType (HsApp _ f _) = funResultTy $ lhsExprType f+hsExprType (HsAppType x f _) = piResultTy (lhsExprType f) x+hsExprType (OpApp v _ _ _) = dataConCantHappen v+hsExprType (NegApp _ _ se) = syntaxExprType se+hsExprType (HsPar _ _ e _) = lhsExprType e+hsExprType (SectionL v _ _) = dataConCantHappen v+hsExprType (SectionR v _ _) = dataConCantHappen v+hsExprType (ExplicitTuple _ args box) = mkTupleTy box $ map hsTupArgType args+hsExprType (ExplicitSum alt_tys _ _ _) = mkSumTy alt_tys+hsExprType (HsCase _ _ (MG { mg_ext = match_group })) = mg_res_ty match_group+hsExprType (HsIf _ _ t _) = lhsExprType t+hsExprType (HsMultiIf ty _) = ty+hsExprType (HsLet _ _ _ _ body) = lhsExprType body+hsExprType (HsDo ty _ _) = ty+hsExprType (ExplicitList ty _) = mkListTy ty+hsExprType (RecordCon con_expr _ _) = hsExprType con_expr+hsExprType e@(RecordUpd (RecordUpdTc { rupd_cons = cons, rupd_out_tys = out_tys }) _ _) =+  case cons of+    con_like:_ -> conLikeResTy con_like out_tys+    []         -> pprPanic "hsExprType: RecordUpdTc with empty rupd_cons"+                           (ppr e)+hsExprType (HsGetField { gf_ext = v }) = dataConCantHappen v+hsExprType (HsProjection { proj_ext = v }) = dataConCantHappen v+hsExprType (ExprWithTySig _ e _) = lhsExprType e+hsExprType (ArithSeq _ mb_overloaded_op asi) = case mb_overloaded_op of+  Just op -> piResultTy (syntaxExprType op) asi_ty+  Nothing -> asi_ty+  where+    asi_ty = arithSeqInfoType asi+hsExprType (HsTypedBracket   (HsBracketTc _ ty _wrap _pending) _) = ty+hsExprType (HsUntypedBracket (HsBracketTc _ ty _wrap _pending) _) = ty+hsExprType e@(HsSpliceE{}) = pprPanic "hsExprType: Unexpected HsSpliceE"+                                      (ppr e)+                                      -- Typed splices should have been eliminated during zonking, but we+                                      -- can't use `dataConCantHappen` since they are still present before+                                      -- than in the typechecked AST.+hsExprType (HsProc _ _ lcmd_top) = lhsCmdTopType lcmd_top+hsExprType (HsStatic (_, ty) _s) = ty+hsExprType (HsPragE _ _ e) = lhsExprType e+hsExprType (XExpr (WrapExpr (HsWrap wrap e))) = hsWrapperType wrap $ hsExprType e+hsExprType (XExpr (ExpansionExpr (HsExpanded _ tc_e))) = hsExprType tc_e+hsExprType (XExpr (ConLikeTc con _ _)) = conLikeType con+hsExprType (XExpr (HsTick _ e)) = lhsExprType e+hsExprType (XExpr (HsBinTick _ _ e)) = lhsExprType e++arithSeqInfoType :: ArithSeqInfo GhcTc -> Type+arithSeqInfoType asi = mkListTy $ case asi of+  From x           -> lhsExprType x+  FromThen x _     -> lhsExprType x+  FromTo x _       -> lhsExprType x+  FromThenTo x _ _ -> lhsExprType x++conLikeType :: ConLike -> Type+conLikeType (RealDataCon con)  = dataConNonlinearType con+conLikeType (PatSynCon patsyn) = case patSynBuilder patsyn of+    Just (_, ty, _) -> ty+    Nothing         -> pprPanic "conLikeType: Unidirectional pattern synonym in expression position"+                                (ppr patsyn)++hsTupArgType :: HsTupArg GhcTc -> Type+hsTupArgType (Present _ e)           = lhsExprType e+hsTupArgType (Missing (Scaled _ ty)) = ty+++-- | The PRType (ty, tas) is short for (piResultTys ty (reverse tas))+type PRType = (Type, [Type])++prTypeType :: PRType -> Type+prTypeType (ty, tys)+  | null tys  = ty+  | otherwise = piResultTys ty (reverse tys)++liftPRType :: (Type -> Type) -> PRType -> PRType+liftPRType f pty = (f (prTypeType pty), [])++hsWrapperType :: HsWrapper -> Type -> Type+hsWrapperType wrap ty = prTypeType $ go wrap (ty,[])+  where+    go WpHole              = id+    go (w1 `WpCompose` w2) = go w1 . go w2+    go (WpFun _ w2 (Scaled m exp_arg)) = liftPRType $ \t ->+      let act_res = funResultTy t+          exp_res = hsWrapperType w2 act_res+      in mkFunctionType m exp_arg exp_res+    go (WpCast co)        = liftPRType $ \_ -> coercionRKind co+    go (WpEvLam v)        = liftPRType $ mkInvisFunTyMany (idType v)+    go (WpEvApp _)        = liftPRType $ funResultTy+    go (WpTyLam tv)       = liftPRType $ mkForAllTy tv Inferred+    go (WpTyApp ta)       = \(ty,tas) -> (ty, ta:tas)+    go (WpLet _)          = id+    go (WpMultCoercion _) = id++lhsCmdTopType :: LHsCmdTop GhcTc -> Type+lhsCmdTopType (L _ (HsCmdTop (CmdTopTc _ ret_ty _) _)) = ret_ty++matchGroupTcType :: MatchGroupTc -> Type+matchGroupTcType (MatchGroupTc args res) = mkVisFunTys args res++syntaxExprType :: SyntaxExpr GhcTc -> Type+syntaxExprType (SyntaxExprTc e _ _) = hsExprType e+syntaxExprType NoSyntaxExprTc       = panic "syntaxExprType: Unexpected NoSyntaxExprTc"
compiler/GHC/HsToCore.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP          #-}+ {-# LANGUAGE TypeFamilies #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}@@ -16,19 +16,19 @@     deSugar, deSugarExpr     ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Driver.Session import GHC.Driver.Config import GHC.Driver.Env import GHC.Driver.Backend+import GHC.Driver.Plugins  import GHC.Hs  import GHC.HsToCore.Usage import GHC.HsToCore.Monad+import GHC.HsToCore.Errors.Types import GHC.HsToCore.Expr import GHC.HsToCore.Binds import GHC.HsToCore.Foreign.Decl@@ -46,24 +46,25 @@ import GHC.Core.SimpleOpt ( simpleOptPgm, simpleOptExpr ) import GHC.Core.Utils import GHC.Core.Unfold.Make-import GHC.Core.Ppr import GHC.Core.Coercion import GHC.Core.DataCon ( dataConWrapId ) import GHC.Core.Make import GHC.Core.Rules import GHC.Core.Opt.Monad ( CoreToDo(..) ) import GHC.Core.Lint     ( endPassIO )+import GHC.Core.Ppr  import GHC.Builtin.Names import GHC.Builtin.Types.Prim import GHC.Builtin.Types  import GHC.Data.FastString+import GHC.Data.Maybe    ( expectJust ) import GHC.Data.OrdList  import GHC.Utils.Error import GHC.Utils.Outputable-import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Misc import GHC.Utils.Monad import GHC.Utils.Logger@@ -86,11 +87,10 @@ import GHC.Unit import GHC.Unit.Module.ModGuts import GHC.Unit.Module.ModIface+import GHC.Unit.Module.Deps  import Data.List (partition) import Data.IORef-import Control.Monad( when )-import GHC.Driver.Plugins ( LoadedPlugin(..) )  {- ************************************************************************@@ -101,7 +101,7 @@ -}  -- | Main entry point to the desugarer.-deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages DecoratedSDoc, Maybe ModGuts)+deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages DsMessage, Maybe ModGuts) -- Can modify PCS by faulting in more declarations  deSugar hsc_env@@ -133,13 +133,14 @@                             tcg_insts        = insts,                             tcg_fam_insts    = fam_insts,                             tcg_hpc          = other_hpc_info,-                            tcg_complete_matches = complete_matches+                            tcg_complete_matches = complete_matches,+                            tcg_self_boot    = self_boot                             })    = do { let dflags = hsc_dflags hsc_env              logger = hsc_logger hsc_env              print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env-        ; withTiming logger dflags+        ; withTiming logger                      (text "Desugar"<+>brackets (ppr mod))                      (const ()) $      do { -- Desugar the program@@ -149,7 +150,13 @@          ; (binds_cvr, ds_hpc_info, modBreaks)                          <- if not (isHsBootOrSig hsc_src)-                              then addTicksToBinds hsc_env mod mod_loc+                              then addTicksToBinds+                                       (CoverageConfig+                                        { coverageConfig_logger = hsc_logger hsc_env+                                        , coverageConfig_dynFlags = hsc_dflags hsc_env+                                        , coverageConfig_mInterp = hsc_interp hsc_env+                                        })+                                       mod mod_loc                                        export_set (typeEnvTyCons type_env) binds                               else return (binds, hpcInfo, Nothing)         ; (msgs, mb_res) <- initDs hsc_env tcg_env $@@ -160,7 +167,7 @@                           ; (ds_fords, foreign_prs) <- dsForeigns fords                           ; ds_rules <- mapMaybeM dsRule rules                           ; let hpc_init-                                  | gopt Opt_Hpc dflags = hpcInitCode (hsc_dflags hsc_env) mod ds_hpc_info+                                  | gopt Opt_Hpc dflags = hpcInitCode (targetPlatform $ hsc_dflags hsc_env) mod ds_hpc_info                                   | otherwise = mempty                           ; return ( ds_ev_binds                                    , foreign_prs `appOL` core_prs `appOL` spec_prs@@ -190,31 +197,35 @@                 = simpleOptPgm simpl_opts mod final_pgm rules_for_imps                          -- The simpleOptPgm gets rid of type                          -- bindings plus any stupid dead code-        ; dumpIfSet_dyn logger dflags Opt_D_dump_occur_anal "Occurrence analysis"+        ; putDumpFileMaybe logger Opt_D_dump_occur_anal "Occurrence analysis"             FormatCore (pprCoreBindings occ_anald_binds $$ pprRules ds_rules_for_imps )          ; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps          ; let used_names = mkUsedNames tcg_env-              pluginModules = map lpModule (hsc_plugins hsc_env)+              pluginModules = map lpModule (loadedPlugins (hsc_plugins hsc_env))               home_unit = hsc_home_unit hsc_env-        ; deps <- mkDependencies (homeUnitId home_unit)-                                 (map mi_module pluginModules) tcg_env+        ; let deps = mkDependencies home_unit+                                    (tcg_mod tcg_env)+                                    (tcg_imports tcg_env)+                                    (map mi_module pluginModules)          ; used_th <- readIORef tc_splice_used         ; dep_files <- readIORef dependent_files         ; safe_mode <- finalSafeMode dflags tcg_env+        ; (needed_mods, needed_pkgs) <- readIORef (tcg_th_needed_deps tcg_env)+         ; usages <- mkUsageInfo hsc_env mod (imp_mods imports) used_names-                      dep_files merged pluginModules+                      dep_files merged needed_mods needed_pkgs         -- id_mod /= mod when we are processing an hsig, but hsigs         -- never desugared and compiled (there's no code!)         -- Consequently, this should hold for any ModGuts that make         -- past desugaring. See Note [Identity versus semantic module].-        ; MASSERT( id_mod == mod )+        ; massert (id_mod == mod)          ; foreign_files <- readIORef th_foreign_files_var -        ; (doc_hdr, decl_docs, arg_docs) <- extractDocs tcg_env+        ; docs <- extractDocs dflags tcg_env          ; let mod_guts = ModGuts {                 mg_module       = mod,@@ -233,6 +244,7 @@                 mg_fam_insts    = fam_insts,                 mg_inst_env     = inst_env,                 mg_fam_inst_env = fam_inst_env,+                mg_boot_exports = bootExports self_boot,                 mg_patsyns      = patsyns,                 mg_rules        = ds_rules_for_imps,                 mg_binds        = ds_binds,@@ -243,9 +255,7 @@                 mg_safe_haskell = safe_mode,                 mg_trust_pkg    = imp_trust_own_pkg imports,                 mg_complete_matches = complete_matches,-                mg_doc_hdr      = doc_hdr,-                mg_decl_docs    = decl_docs,-                mg_arg_docs     = arg_docs+                mg_docs         = docs               }         ; return (msgs, Just mod_guts)         }}}}@@ -285,24 +295,35 @@ and Rec the rest. -} -deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages DecoratedSDoc, Maybe CoreExpr)+deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages DsMessage, Maybe CoreExpr) deSugarExpr hsc_env tc_expr = do-    let dflags = hsc_dflags hsc_env     let logger = hsc_logger hsc_env -    showPass logger dflags "Desugar"+    showPass logger "Desugar"      -- Do desugaring-    (msgs, mb_core_expr) <- runTcInteractive hsc_env $ initDsTc $-                                 dsLExpr tc_expr+    (tc_msgs, mb_result) <- runTcInteractive hsc_env $+                            initDsTc $+                            dsLExpr tc_expr +    massert (isEmptyMessages tc_msgs)  -- the type-checker isn't doing anything here++      -- mb_result is Nothing only when a failure happens in the type-checker,+      -- but mb_core_expr is Nothing when a failure happens in the desugarer+    let (ds_msgs, mb_core_expr) = expectJust "deSugarExpr" mb_result+     case mb_core_expr of        Nothing   -> return ()-       Just expr -> dumpIfSet_dyn logger dflags Opt_D_dump_ds "Desugared"+       Just expr -> putDumpFileMaybe logger Opt_D_dump_ds "Desugared"                     FormatCore (pprCoreExpr expr) -    return (msgs, mb_core_expr)+      -- callers (i.e. ioMsgMaybe) expect that no expression is returned if+      -- there are errors+    let final_res | errorsFound ds_msgs = Nothing+                  | otherwise           = mb_core_expr +    return (ds_msgs, final_res)+ {- ************************************************************************ *                                                                      *@@ -419,7 +440,7 @@         -- and take the body apart into a (f args) form         ; dflags <- getDynFlags         ; case decomposeRuleLhs dflags bndrs'' lhs'' of {-                Left msg -> do { warnDs NoReason msg; return Nothing } ;+                Left msg -> do { diagnosticDs msg; return Nothing } ;                 Right (final_bndrs, fn_id, args) -> do          { let is_local = isLocalId fn_id@@ -437,8 +458,7 @@         ; rule <- dsMkUserRule this_mod is_local                          rule_name rule_act fn_name final_bndrs args                          final_rhs-        ; when (wopt Opt_WarnInlineRuleShadowing dflags) $-          warnRuleShadowing rule_name rule_act fn_id arg_ids+        ; warnRuleShadowing rule_name rule_act fn_id arg_ids          ; return (Just rule)         } } }@@ -455,26 +475,10 @@       | isLocalId lhs_id || canUnfold (idUnfolding lhs_id)                        -- If imported with no unfolding, no worries       , idInlineActivation lhs_id `competesWith` rule_act-      = warnDs (Reason Opt_WarnInlineRuleShadowing)-               (vcat [ hang (text "Rule" <+> pprRuleName rule_name-                               <+> text "may never fire")-                            2 (text "because" <+> quotes (ppr lhs_id)-                               <+> text "might inline first")-                     , text "Probable fix: add an INLINE[n] or NOINLINE[n] pragma for"-                       <+> quotes (ppr lhs_id)-                     , whenPprDebug (ppr (idInlineActivation lhs_id) $$ ppr rule_act) ])-+      = diagnosticDs (DsRuleMightInlineFirst rule_name lhs_id rule_act)       | check_rules_too       , bad_rule : _ <- get_bad_rules lhs_id-      = warnDs (Reason Opt_WarnInlineRuleShadowing)-               (vcat [ hang (text "Rule" <+> pprRuleName rule_name-                               <+> text "may never fire")-                            2 (text "because rule" <+> pprRuleName (ruleName bad_rule)-                               <+> text "for"<+> quotes (ppr lhs_id)-                               <+> text "might fire first")-                      , text "Probable fix: add phase [n] or [~n] to the competing rule"-                      , whenPprDebug (ppr bad_rule) ])-+      = diagnosticDs (DsAnotherRuleMightFireFirst rule_name (ruleName bad_rule) lhs_id)       | otherwise       = return () @@ -651,9 +655,9 @@             (x |> (GRefl :: a ~# (a |> TYPE co1)) ; co2)  It looks like we can write this in Haskell directly, but we can't:-the levity polymorphism checks defeat us. Note that `x` is a levity--polymorphic variable. So we must wire it in with a compulsory-unfolding, like other levity-polymorphic primops.+the representation polymorphism checks defeat us. Note that `x` is a+representation-polymorphic variable. So we must wire it in with a+compulsory unfolding, like other representation-polymorphic primops.  The challenge is that UnsafeEquality is a GADT, and wiring in a GADT is *hard*: it has a worker separate from its wrapper, with all manner@@ -686,8 +690,8 @@   = do { magic_pair@(magic_id, _) <- mk_magic_pair orig_id orig_rhs         -- Patching should not change the Name or the type of the Id-       ; MASSERT( getUnique magic_id == getUnique orig_id )-       ; MASSERT( varType magic_id `eqType` varType orig_id )+       ; massert (getUnique magic_id == getUnique orig_id)+       ; massert (varType magic_id `eqType` varType orig_id)         ; return magic_pair }   | otherwise@@ -743,7 +747,7 @@              (scrut1, scrut1_ty, rr_cv_ty) = unsafe_equality runtimeRepTy                                                              runtimeRep1Ty                                                              runtimeRep2Ty-             (scrut2, scrut2_ty, ab_cv_ty) = unsafe_equality (tYPE runtimeRep2Ty)+             (scrut2, scrut2_ty, ab_cv_ty) = unsafe_equality (mkTYPEapp runtimeRep2Ty)                                                              (openAlphaTy `mkCastTy` alpha_co)                                                              openBetaTy @@ -758,10 +762,13 @@               info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma                                 `setUnfoldingInfo` mkCompulsoryUnfolding' rhs+                                `setArityInfo`     arity               ty = mkSpecForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar                                   , openAlphaTyVar, openBetaTyVar ] $                   mkVisFunTyMany openAlphaTy openBetaTy++             arity = 1               id   = mkExportedVanillaId unsafeCoercePrimName ty `setIdInfo` info        ; return (id, old_expr) }
compiler/GHC/HsToCore/Arrows.hs view
@@ -1,5 +1,6 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE TupleSections #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -13,8 +14,6 @@  module GHC.HsToCore.Arrows ( dsProcExpr ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.HsToCore.Match@@ -22,18 +21,17 @@ import GHC.HsToCore.Monad  import GHC.Hs-import GHC.Tc.Utils.Zonk+import GHC.Hs.Syn.Type  -- NB: The desugarer, which straddles the source and Core worlds, sometimes --     needs to see source types (newtypes etc), and sometimes not --     So WATCH OUT; check each use of split*Ty functions. -- Sigh.  This is a pain. -import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds,+import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsLExpr, dsLocalBinds,                                           dsSyntaxExpr )  import GHC.Tc.Utils.TcType-import GHC.Core.Type( splitPiTy ) import GHC.Core.Multiplicity import GHC.Tc.Types.Evidence import GHC.Core@@ -42,6 +40,7 @@ import GHC.Core.Make import GHC.HsToCore.Binds (dsHsWrapper) + import GHC.Types.Id import GHC.Core.ConLike import GHC.Builtin.Types@@ -52,7 +51,9 @@ import GHC.Types.Var.Set import GHC.Types.SrcLoc import GHC.Data.List.SetOps( assocMaybe )+import Data.Foldable (toList) import Data.List (mapAccumL)+import Data.List.NonEmpty (NonEmpty(..), nonEmpty) import GHC.Utils.Misc import GHC.Types.Unique.DSet @@ -75,25 +76,6 @@              the_choice_id  = assocMaybe prs choiceAName              the_loop_id    = assocMaybe prs loopAName -           -- used as an argument in, e.g., do_premap-       ; check_lev_poly 3 the_arr_id--           -- used as an argument in, e.g., dsCmdStmt/BodyStmt-       ; check_lev_poly 5 the_compose_id--           -- used as an argument in, e.g., dsCmdStmt/BodyStmt-       ; check_lev_poly 4 the_first_id--           -- the result of the_app_id is used as an argument in, e.g.,-           -- dsCmd/HsCmdArrApp/HsHigherOrderApp-       ; check_lev_poly 2 the_app_id--           -- used as an argument in, e.g., HsCmdIf-       ; check_lev_poly 5 the_choice_id--           -- used as an argument in, e.g., RecStmt-       ; check_lev_poly 4 the_loop_id-        ; return (meth_binds, DsCmdEnv {                arr_id     = Var (unmaybe the_arr_id arrAName),                compose_id = Var (unmaybe the_compose_id composeAName),@@ -112,21 +94,6 @@     unmaybe Nothing name = pprPanic "mkCmdEnv" (text "Not found:" <+> ppr name)     unmaybe (Just id) _  = id -      -- returns the result type of a pi-type (that is, a forall or a function)-      -- Note that this result type may be ill-scoped.-    res_type :: Type -> Type-    res_type ty = res_ty-      where-        (_, res_ty) = splitPiTy ty--    check_lev_poly :: Int -- arity-                   -> Maybe Id -> DsM ()-    check_lev_poly _     Nothing = return ()-    check_lev_poly arity (Just id)-      = dsNoLevPoly (nTimes arity res_type (idType id))-          (text "In the result of the function" <+> quotes (ppr id))-- -- arr :: forall b c. (b -> c) -> a b c do_arr :: DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr do_arr ids b_ty c_ty f = mkApps (arr_id ids) [Type b_ty, Type c_ty, f]@@ -368,7 +335,7 @@     let         (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty         (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty-    core_arrow <- dsLExprNoLP arrow+    core_arrow <- dsLExpr arrow     core_arg   <- dsLExpr arg     stack_id   <- newSysLocalDs Many stack_ty     core_make_arg <- matchEnvStack env_ids stack_id core_arg@@ -424,7 +391,7 @@     (core_cmd, free_vars, env_ids')              <- dsfixCmd ids local_vars stack_ty' res_ty cmd     stack_id <- newSysLocalDs Many stack_ty-    arg_id <- newSysLocalDsNoLP Many arg_ty+    arg_id <- newSysLocalDs Many arg_ty     -- push the argument expression onto the stack     let         stack' = mkCorePairExpr (Var arg_id) (Var stack_id)@@ -449,7 +416,7 @@         env_ids   = dsCmdLam ids local_vars stack_ty res_ty pats body env_ids -dsCmd ids local_vars stack_ty res_ty (HsCmdPar _ cmd) env_ids+dsCmd ids local_vars stack_ty res_ty (HsCmdPar _ _ cmd _) env_ids   = dsLCmd ids local_vars stack_ty res_ty cmd env_ids  -- D, xs |- e :: Bool@@ -502,6 +469,8 @@         fvs_cond `unionDVarSet` fvs_then `unionDVarSet` fvs_else)  {-+Note [Desugaring HsCmdCase]+~~~~~~~~~~~~~~~~~~~~~~~~~~~ Case commands are treated in much the same way as if commands (see above) except that there are more alternatives.  For example @@ -528,74 +497,87 @@    bodies with |||. -} +dsCmd ids local_vars stack_ty res_ty (HsCmdCase _ exp match) env_ids = do+    stack_id <- newSysLocalDs Many stack_ty+    (match', core_choices)+      <- dsCases ids local_vars stack_id stack_ty res_ty match+    let MG{ mg_ext = MatchGroupTc _ sum_ty } = match'+        in_ty = envStackType env_ids stack_ty++    core_body <- dsExpr (HsCase noExtField exp match')++    core_matches <- matchEnvStack env_ids stack_id core_body+    return (do_premap ids in_ty sum_ty res_ty core_matches core_choices,+            exprFreeIdsDSet core_body `uniqDSetIntersectUniqSet` local_vars)++{-+\cases and \case are desugared analogously to a case command (see above).+For example++        \cases {p1 q1 -> c1; p2 q2 -> c2; p3 q3 -> c3 }++is translated to++        premap (\ ((xs), (e1, (e2,stk))) -> cases e1 e2 of+                  p1 q1 -> (Left (Left (xs1), stk))+                  p2 q2 -> Left ((Right (xs2), stk))+                  p3 q3 -> Right ((xs3), stk))+        ((c1 ||| c2) ||| c3)++(cases...of is hypothetical notation that works like case...of but with+multiple scrutinees)++-} dsCmd ids local_vars stack_ty res_ty-      (HsCmdCase _ exp (MG { mg_alts = L l matches-                           , mg_ext = MatchGroupTc arg_tys _-                           , mg_origin = origin }))+      (HsCmdLamCase _ lc_variant match@MG { mg_ext = MatchGroupTc {mg_arg_tys = arg_tys} } )       env_ids = do-    stack_id <- newSysLocalDs Many stack_ty+    arg_ids <- newSysLocalsDs arg_tys -    -- Extract and desugar the leaf commands in the case, building tuple-    -- expressions that will (after tagging) replace these leaves+    let match_ctxt = ArrowLamCaseAlt lc_variant+        pat_vars = mkVarSet arg_ids+        local_vars' = pat_vars `unionVarSet` local_vars+        (pat_tys, stack_ty') = splitTypeAt (length arg_tys) stack_ty -    let-        leaves = concatMap leavesMatch matches-        make_branch (leaf, bound_vars) = do-            (core_leaf, _fvs, leaf_ids)-               <- dsfixCmd ids (bound_vars `unionVarSet` local_vars) stack_ty-                    res_ty leaf-            return ([mkHsEnvStackExpr leaf_ids stack_id],-                    envStackType leaf_ids stack_ty,-                    core_leaf)+    -- construct and desugar a case expression with multiple scrutinees+    (core_body, free_vars, env_ids') <- trimInput \env_ids -> do+      stack_id <- newSysLocalDs Many stack_ty'+      (match', core_choices)+        <- dsCases ids local_vars' stack_id stack_ty' res_ty match -    branches <- mapM make_branch leaves-    either_con <- dsLookupTyCon eitherTyConName-    left_con <- dsLookupDataCon leftDataConName-    right_con <- dsLookupDataCon rightDataConName-    let-        left_id  = HsConLikeOut noExtField (RealDataCon left_con)-        right_id = HsConLikeOut noExtField (RealDataCon right_con)-        left_expr  ty1 ty2 e = noLocA $ HsApp noComments-                           (noLocA $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e-        right_expr ty1 ty2 e = noLocA $ HsApp noComments-                           (noLocA $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e+      let MG{ mg_ext = MatchGroupTc _ sum_ty } = match'+          in_ty = envStackType env_ids stack_ty'+          discrims = map nlHsVar arg_ids+      (discrim_vars, matching_code)+        <- matchWrapper (ArrowMatchCtxt match_ctxt) (Just discrims) match'+      core_body <- flip (bind_vars discrim_vars) matching_code <$>+        traverse dsLExpr discrims -        -- Prefix each tuple with a distinct series of Left's and Right's,-        -- in a balanced way, keeping track of the types.+      core_matches <- matchEnvStack env_ids stack_id core_body+      return (do_premap ids in_ty sum_ty res_ty core_matches core_choices,+              exprFreeIdsDSet core_body `uniqDSetIntersectUniqSet` local_vars') -        merge_branches :: ([LHsExpr GhcTc], Type, CoreExpr)-                      -> ([LHsExpr GhcTc], Type, CoreExpr)-                      -> ([LHsExpr GhcTc], Type, CoreExpr) -- AZ-        merge_branches (builds1, in_ty1, core_exp1)-                       (builds2, in_ty2, core_exp2)-          = (map (left_expr in_ty1 in_ty2) builds1 ++-                map (right_expr in_ty1 in_ty2) builds2,-             mkTyConApp either_con [in_ty1, in_ty2],-             do_choice ids in_ty1 in_ty2 res_ty core_exp1 core_exp2)-        (leaves', sum_ty, core_choices) = foldb merge_branches branches+    param_ids <- mapM (newSysLocalDs Many) pat_tys+    stack_id' <- newSysLocalDs Many stack_ty' -        -- Replace the commands in the case with these tagged tuples,-        -- yielding a HsExpr Id we can feed to dsExpr.+    -- the expression is built from the inside out, so the actions+    -- are presented in reverse order -        (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches+    let -- build a new environment, plus what's left of the stack+        core_expr = buildEnvStack env_ids' stack_id'         in_ty = envStackType env_ids stack_ty--    core_body <- dsExpr (HsCase noExtField exp-                         (MG { mg_alts = L l matches'-                             , mg_ext = MatchGroupTc arg_tys sum_ty-                             , mg_origin = origin }))-        -- Note that we replace the HsCase result type by sum_ty,-        -- which is the type of matches'+        in_ty' = envStackType env_ids' stack_ty' -    core_matches <- matchEnvStack env_ids stack_id core_body-    return (do_premap ids in_ty sum_ty res_ty core_matches core_choices,-            exprFreeIdsDSet core_body `uniqDSetIntersectUniqSet` local_vars)+    -- bind the scrutinees to the parameters+    let match_code = bind_vars arg_ids (map Var param_ids) core_expr -dsCmd ids local_vars stack_ty res_ty-      (HsCmdLamCase _ mg@MG { mg_ext = MatchGroupTc [Scaled arg_mult arg_ty] _ }) env_ids = do-  arg_id <- newSysLocalDs arg_mult arg_ty-  let case_cmd  = noLocA $ HsCmdCase noExtField (nlHsVar arg_id) mg-  dsCmdLam ids local_vars stack_ty res_ty [nlVarPat arg_id] case_cmd env_ids+    -- match the parameters against the top of the old stack+    (stack_id, param_code) <- matchVarStack param_ids stack_id' match_code+    -- match the old environment and stack against the input+    select_code <- matchEnvStack env_ids stack_id param_code+    return (do_premap ids in_ty in_ty' res_ty select_code core_body,+            free_vars `uniqDSetMinusUniqSet` pat_vars)+    where+      bind_vars vars exprs expr = foldr (uncurry bindNonRec) expr $ zip vars exprs  -- D; ys |-a cmd : stk --> t -- ----------------------------------@@ -603,7 +585,7 @@ -- --              ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c -dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@binds body) env_ids = do+dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ _ lbinds@binds _ body) env_ids = do     let         defined_vars = mkVarSet (collectLocalBinders CollWithDictBinders binds)         local_vars' = defined_vars `unionVarSet` local_vars@@ -629,12 +611,7 @@ -- --              ---> premap (\ (env,stk) -> env) c -dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo stmts_ty-                                               (L loc stmts))-                                                                   env_ids = do-    putSrcSpanDsA loc $-      dsNoLevPoly stmts_ty-        (text "In the do-command:" <+> ppr do_block)+dsCmd ids local_vars stack_ty res_ty (HsCmdDo _ (L _ stmts)) env_ids = do     (core_stmts, env_ids') <- dsCmdDo ids local_vars res_ty stmts env_ids     let env_ty = mkBigCoreVarTupTy env_ids     core_fst <- mkFstExpr env_ty stack_ty@@ -704,9 +681,7 @@                 DIdSet,         -- subset of local vars that occur free                 [Id])           -- the same local vars as a list, fed back dsfixCmd ids local_vars stk_ty cmd_ty cmd-  = do { putSrcSpanDs (getLocA cmd) $ dsNoLevPoly cmd_ty-           (text "When desugaring the command:" <+> ppr cmd)-       ; trimInput (dsLCmd ids local_vars stk_ty cmd_ty cmd) }+  = trimInput (dsLCmd ids local_vars stk_ty cmd_ty cmd)  -- Feed back the list of local variables actually used a command, -- for use as the input tuple of the generated arrow.@@ -723,7 +698,7 @@         (core_cmd, free_vars) <- build_arrow env_ids         return (core_cmd, free_vars, dVarSetElems free_vars)) --- Desugaring for both HsCmdLam and HsCmdLamCase.+-- Desugaring for both HsCmdLam -- -- D; ys |-a cmd : stk t' -- -----------------------------------------------@@ -747,7 +722,7 @@         (pat_tys, stack_ty') = splitTypeAt (length pats) stack_ty     (core_body, free_vars, env_ids')        <- dsfixCmd ids local_vars' stack_ty' res_ty body-    param_ids <- mapM (newSysLocalDsNoLP Many) pat_tys+    param_ids <- mapM (newSysLocalDs Many) pat_tys     stack_id' <- newSysLocalDs Many stack_ty'      -- the expression is built from the inside out, so the actions@@ -769,6 +744,82 @@     return (do_premap ids in_ty in_ty' res_ty select_code core_body,             free_vars `uniqDSetMinusUniqSet` pat_vars) +-- Used for case and \case(s)+-- See Note [Desugaring HsCmdCase]+dsCases :: DsCmdEnv                               -- arrow combinators+        -> IdSet                                  -- set of local vars available to this command+        -> Id                                     -- stack id+        -> Type                                   -- type of the stack (right-nested tuple)+        -> Type                                   -- return type of the command+        -> MatchGroup GhcTc (LHsCmd GhcTc)        -- match group to desugar+        -> DsM (MatchGroup GhcTc (LHsExpr GhcTc), -- match group with choice tree+                CoreExpr)                         -- desugared choices+dsCases ids local_vars stack_id stack_ty res_ty+        (MG { mg_alts = L l matches+            , mg_ext = MatchGroupTc arg_tys _+            , mg_origin = origin }) = do++  -- Extract and desugar the leaf commands in the case, building tuple+  -- expressions that will (after tagging) replace these leaves++  let leaves = concatMap leavesMatch matches+      make_branch (leaf, bound_vars) = do+          (core_leaf, _fvs, leaf_ids)+             <- dsfixCmd ids (bound_vars `unionVarSet` local_vars) stack_ty+                  res_ty leaf+          return ([mkHsEnvStackExpr leaf_ids stack_id],+                  envStackType leaf_ids stack_ty,+                  core_leaf)++  branches <- mapM make_branch leaves+  either_con <- dsLookupTyCon eitherTyConName+  left_con <- dsLookupDataCon leftDataConName+  right_con <- dsLookupDataCon rightDataConName+  void_ty <- mkTyConTy <$> dsLookupTyCon voidTyConName+  let+      left_id  = mkConLikeTc (RealDataCon left_con)+      right_id = mkConLikeTc (RealDataCon right_con)+      left_expr  ty1 ty2 e = noLocA $ HsApp noComments+                         (noLocA $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e+      right_expr ty1 ty2 e = noLocA $ HsApp noComments+                         (noLocA $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e++      -- Prefix each tuple with a distinct series of Left's and Right's,+      -- in a balanced way, keeping track of the types.++      merge_branches :: ([LHsExpr GhcTc], Type, CoreExpr)+                    -> ([LHsExpr GhcTc], Type, CoreExpr)+                    -> ([LHsExpr GhcTc], Type, CoreExpr) -- AZ+      merge_branches (builds1, in_ty1, core_exp1)+                     (builds2, in_ty2, core_exp2)+        = (map (left_expr in_ty1 in_ty2) builds1 +++              map (right_expr in_ty1 in_ty2) builds2,+           mkTyConApp either_con [in_ty1, in_ty2],+           do_choice ids in_ty1 in_ty2 res_ty core_exp1 core_exp2)+  (leaves', sum_ty, core_choices) <- case nonEmpty branches of+    Just bs -> return $ foldb merge_branches bs+    -- when the case command has no alternatives, the sum type from+    -- Note [Desugaring HsCmdCase] becomes the empty sum type,+    -- i.e. Void. The choices then effectively become `arr absurd`,+    -- implemented as `arr \case {}`.+    Nothing -> ([], void_ty,) . do_arr ids void_ty res_ty <$>+      dsExpr (HsLamCase EpAnnNotUsed LamCase+        (MG { mg_alts = noLocA []+            , mg_ext = MatchGroupTc [Scaled Many void_ty] res_ty+            , mg_origin = Generated }))++      -- Replace the commands in the case with these tagged tuples,+      -- yielding a HsExpr Id we can feed to dsExpr.++  let (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches++  -- Note that we replace the MatchGroup result type by sum_ty,+  -- which is the type of matches'+  return (MG { mg_alts = L l matches'+             , mg_ext = MatchGroupTc arg_tys sum_ty+             , mg_origin = origin },+          core_choices)+ {- Translation of command judgements of the form @@ -793,9 +844,7 @@ -- --              ---> premap (\ (xs) -> ((xs), ())) c -dsCmdDo ids local_vars res_ty [L loc (LastStmt _ body _ _)] env_ids = do-    putSrcSpanDsA loc $ dsNoLevPoly res_ty-                         (text "In the command:" <+> ppr body)+dsCmdDo ids local_vars res_ty [L _ (LastStmt _ body _ _)] env_ids = do     (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids     let env_ty = mkBigCoreVarTupTy env_ids     env_var <- newSysLocalDs Many env_ty@@ -863,7 +912,6 @@         out_ty = mkBigCoreVarTupTy out_ids         before_c_ty = mkCorePairTy in_ty1 out_ty         after_c_ty = mkCorePairTy c_ty out_ty-    dsNoLevPoly c_ty empty -- I (Richard E, Dec '16) have no idea what to say here     snd_fn <- mkSndExpr c_ty out_ty     return (do_premap ids in_ty before_c_ty out_ty core_mux $                 do_compose ids before_c_ty after_c_ty out_ty@@ -908,10 +956,10 @@        out_ty = mkBigCoreVarTupTy out_ids        body_expr = coreCaseTuple uniqs env_id env_ids2 (mkBigCoreVarTup out_ids) -    fail_expr <- mkFailExpr (StmtCtxt (DoExpr Nothing)) out_ty+    fail_expr <- mkFailExpr (StmtCtxt (HsDoStmt (DoExpr Nothing))) out_ty     pat_id    <- selectSimpleMatchVarL Many pat     match_code-      <- matchSimply (Var pat_id) (StmtCtxt (DoExpr Nothing)) pat body_expr fail_expr+      <- matchSimply (Var pat_id) (StmtCtxt (HsDoStmt (DoExpr Nothing))) pat body_expr fail_expr     pair_id   <- newSysLocalDs Many after_c_ty     let         proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code)@@ -1106,7 +1154,7 @@  dsfixCmdStmts ids local_vars out_ids stmts   = trimInput (dsCmdStmts ids local_vars out_ids stmts)-   -- TODO: Add levity polymorphism check for the resulting expression.+   -- TODO: Add representation polymorphism check for the resulting expression.    -- But I (Richard E.) don't know enough about arrows to do so.  dsCmdStmts@@ -1197,11 +1245,12 @@  -- Balanced fold of a non-empty list. -foldb :: (a -> a -> a) -> [a] -> a-foldb _ [] = error "foldb of empty list"-foldb _ [x] = x+foldb :: (a -> a -> a) -> NonEmpty a -> a+foldb _ (x:|[]) = x foldb f xs = foldb f (fold_pairs xs)   where-    fold_pairs [] = []-    fold_pairs [x] = [x]-    fold_pairs (x1:x2:xs) = f x1 x2:fold_pairs xs+    fold_pairs (x1:|x2:xs) = f x1 x2 :| keep_empty fold_pairs xs+    fold_pairs xs          = xs++    keep_empty :: (NonEmpty a -> NonEmpty a) -> [a] -> [a]+    keep_empty f = maybe [] (toList . f) . nonEmpty
compiler/GHC/HsToCore/Binds.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} @@ -22,14 +22,19 @@    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude +import GHC.Driver.Session+import GHC.Driver.Ppr+import GHC.Driver.Config+import qualified GHC.LanguageExtensions as LangExt+import GHC.Unit.Module+ import {-# SOURCE #-}   GHC.HsToCore.Expr  ( dsLExpr ) import {-# SOURCE #-}   GHC.HsToCore.Match ( matchWrapper )  import GHC.HsToCore.Monad+import GHC.HsToCore.Errors.Types import GHC.HsToCore.GuardedRHSs import GHC.HsToCore.Utils import GHC.HsToCore.Pmc ( addTyCs, pmcGRHSs )@@ -43,39 +48,41 @@ import GHC.Core.Opt.Arity     ( etaExpand ) import GHC.Core.Unfold.Make import GHC.Core.FVs-import GHC.Data.Graph.Directed import GHC.Core.Predicate--import GHC.Builtin.Names import GHC.Core.TyCon-import GHC.Tc.Types.Evidence-import GHC.Tc.Utils.TcType import GHC.Core.Type import GHC.Core.Coercion import GHC.Core.Multiplicity+import GHC.Core.Rules++import GHC.Builtin.Names import GHC.Builtin.Types ( naturalTy, typeSymbolKind, charTy )++import GHC.Tc.Types.Evidence+ import GHC.Types.Id import GHC.Types.Name import GHC.Types.Var.Set-import GHC.Core.Rules import GHC.Types.Var.Env import GHC.Types.Var( EvVar )-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Unit.Module import GHC.Types.SrcLoc+import GHC.Types.Basic+import GHC.Types.Unique.Set( nonDetEltsUniqSet )+ import GHC.Data.Maybe import GHC.Data.OrdList+import GHC.Data.Graph.Directed import GHC.Data.Bag-import GHC.Types.Basic-import GHC.Driver.Session-import GHC.Driver.Ppr-import GHC.Driver.Config import GHC.Data.FastString++import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Misc-import GHC.Types.Unique.Set( nonDetEltsUniqSet ) import GHC.Utils.Monad-import qualified GHC.LanguageExtensions as LangExt+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Utils.Trace+ import Control.Monad  {-**********************************************************************@@ -90,15 +97,15 @@ dsTopLHsBinds binds      -- see Note [Strict binds checks]   | not (isEmptyBag unlifted_binds) || not (isEmptyBag bang_binds)-  = do { mapBagM_ (top_level_err "bindings for unlifted types") unlifted_binds-       ; mapBagM_ (top_level_err "strict bindings")             bang_binds+  = do { mapBagM_ (top_level_err UnliftedTypeBinds) unlifted_binds+       ; mapBagM_ (top_level_err StrictBinds)       bang_binds        ; return nilOL }    | otherwise   = do { (force_vars, prs) <- dsLHsBinds binds        ; when debugIsOn $          do { xstrict <- xoptM LangExt.Strict-            ; MASSERT2( null force_vars || xstrict, ppr binds $$ ppr force_vars ) }+            ; massertPpr (null force_vars || xstrict) (ppr binds $$ ppr force_vars) }               -- with -XStrict, even top-level vars are listed as force vars.         ; return (toOL prs) }@@ -107,10 +114,9 @@     unlifted_binds = filterBag (isUnliftedHsBind . unLoc) binds     bang_binds     = filterBag (isBangedHsBind   . unLoc) binds -    top_level_err desc (L loc bind)+    top_level_err bindsType (L loc bind)       = putSrcSpanDs (locA loc) $-        errDs (hang (text "Top-level" <+> text desc <+> text "aren't allowed:")-                  2 (ppr bind))+        diagnosticDs (DsTopLevelBindsNotAllowed bindsType bind)   -- | Desugar all other kind of bindings, Ids of strict binds are returned to@@ -158,9 +164,7 @@                           -- addTyCs: Add type evidence to the refinement type                           --            predicate of the coverage checker                           -- See Note [Long-distance information] in "GHC.HsToCore.Pmc"-                          matchWrapper-                           (mkPrefixFunRhs (L loc (idName fun)))-                           Nothing matches+                          matchWrapper (mkPrefixFunRhs (L loc (idName fun))) Nothing matches          ; core_wrap <- dsHsWrapper co_fn         ; let body' = mkOptTickBox tick body@@ -195,10 +199,12 @@                            else []         ; return (force_var', sel_binds) } -dsHsBind dflags (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts-                          , abs_exports = exports-                          , abs_ev_binds = ev_binds-                          , abs_binds = binds, abs_sig = has_sig })+dsHsBind+  dflags+  (XHsBindsLR (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts+                        , abs_exports = exports+                        , abs_ev_binds = ev_binds+                        , abs_binds = binds, abs_sig = has_sig }))   = do { ds_binds <- addTyCs FromSource (listToBag dicts) $                      dsLHsBinds binds              -- addTyCs: push type constraints deeper@@ -214,7 +220,7 @@  ----------------------- dsAbsBinds :: DynFlags-           -> [TyVar] -> [EvVar] -> [ABExport GhcTc]+           -> [TyVar] -> [EvVar] -> [ABExport]            -> [CoreBind]                -- Desugared evidence bindings            -> ([Id], [(Id,CoreExpr)])   -- Desugared value bindings            -> Bool                      -- Single binding with signature@@ -226,6 +232,9 @@     -- A very important common case: one exported variable     -- Non-recursive bindings come through this way     -- So do self-recursive bindings+    --    gbl_id = wrap (/\tvs \dicts. let ev_binds+    --                                 letrec bind_prs+    --                                 in lcl_id)   | [export] <- exports   , ABE { abe_poly = global_id, abe_mono = local_id         , abe_wrap = wrap, abe_prags = prags } <- export@@ -259,26 +268,28 @@      -- Another common case: no tyvars, no dicts     -- In this case we can have a much simpler desugaring+    --    lcl_id{inl-prag} = rhs  -- Auxiliary binds+    --    gbl_id = lcl_id |> co   -- Main binds   | null tyvars, null dicts--  = do { let mk_bind (ABE { abe_wrap = wrap-                          , abe_poly = global-                          , abe_mono = local-                          , abe_prags = prags })-              = do { core_wrap <- dsHsWrapper wrap-                   ; return (makeCorePair dflags global-                                          (isDefaultMethod prags)-                                          0 (core_wrap (Var local))) }-       ; main_binds <- mapM mk_bind exports+  = do { let mk_main :: ABExport -> DsM (Id, CoreExpr)+             mk_main (ABE { abe_poly = gbl_id, abe_mono = lcl_id+                          , abe_wrap = wrap })+                     -- No SpecPrags (no dicts)+                     -- Can't be a default method (default methods are singletons)+               = do { core_wrap <- dsHsWrapper wrap+                    ; return ( gbl_id `setInlinePragma` defaultInlinePragma+                             , core_wrap (Var lcl_id)) } -       ; return (force_vars, flattenBinds ds_ev_binds ++ bind_prs ++ main_binds) }+       ; main_prs <- mapM mk_main exports+       ; return (force_vars, flattenBinds ds_ev_binds+                              ++ mk_aux_binds bind_prs ++ main_prs ) }      -- The general case     -- See Note [Desugaring AbsBinds]   | otherwise-  = do { let core_bind = Rec [ makeCorePair dflags (add_inline lcl_id) False 0 rhs-                              | (lcl_id, rhs) <- bind_prs ]+  = do { let aux_binds = Rec (mk_aux_binds bind_prs)                 -- Monomorphic recursion possible, hence Rec+              new_force_vars = get_new_force_vars force_vars              locals       = map abe_mono exports              all_locals   = locals ++ new_force_vars@@ -286,7 +297,7 @@              tup_ty       = exprType tup_expr        ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $                             mkCoreLets ds_ev_binds $-                            mkLet core_bind $+                            mkLet aux_binds $                             tup_expr         ; poly_tup_id <- newSysLocalDs Many (exprType poly_tup_rhs)@@ -320,19 +331,21 @@                 , (poly_tup_id, poly_tup_rhs) :                    concat export_binds_s) }   where+    mk_aux_binds :: [(Id,CoreExpr)] -> [(Id,CoreExpr)]+    mk_aux_binds bind_prs = [ makeCorePair dflags lcl_w_inline False 0 rhs+                            | (lcl_id, rhs) <- bind_prs+                            , let lcl_w_inline = lookupVarEnv inline_env lcl_id+                                                 `orElse` lcl_id ]+     inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with-                             -- the inline pragma from the source-                             -- The type checker put the inline pragma-                             -- on the *global* Id, so we need to transfer it+                           -- the inline pragma from the source+                           -- The type checker put the inline pragma+                           -- on the *global* Id, so we need to transfer it     inline_env       = mkVarEnv [ (lcl_id, setInlinePragma lcl_id prag)                  | ABE { abe_mono = lcl_id, abe_poly = gbl_id } <- exports                  , let prag = idInlinePragma gbl_id ] -    add_inline :: Id -> Id    -- tran-    add_inline lcl_id = lookupVarEnv inline_env lcl_id-                        `orElse` lcl_id-     global_env :: IdEnv Id -- Maps local Id to its global exported Id     global_env =       mkVarEnv [ (local, global)@@ -347,7 +360,7 @@             [] lcls      -- find exports or make up new exports for force variables-    get_exports :: [Id] -> DsM ([Id], [ABExport GhcTc])+    get_exports :: [Id] -> DsM ([Id], [ABExport])     get_exports lcls =       foldM (\(glbls, exports) lcl ->               case lookupVarEnv global_env lcl of@@ -360,8 +373,7 @@     mk_export local =       do global <- newSysLocalDs Many                      (exprType (mkLams tyvars (mkLams dicts (Var local))))-         return (ABE { abe_ext   = noExtField-                     , abe_poly  = global+         return (ABE { abe_poly  = global                      , abe_mono  = local                      , abe_wrap  = WpHole                      , abe_prags = SpecPrags [] })@@ -384,10 +396,10 @@   | otherwise   = case inlinePragmaSpec inline_prag of           NoUserInlinePrag -> (gbl_id, rhs)-          NoInline         -> (gbl_id, rhs)-          Inlinable        -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)-          Inline           -> inline_pair-+          NoInline  {}     -> (gbl_id, rhs)+          Opaque    {}     -> (gbl_id, rhs)+          Inlinable {}     -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)+          Inline    {}     -> inline_pair   where     simpl_opts    = initSimpleOpts dflags     inline_prag   = idInlinePragma gbl_id@@ -616,8 +628,8 @@ There are several checks around properly formed strict bindings. They all link to this Note. These checks must be here in the desugarer because we cannot know whether or not a type is unlifted until after zonking, due-to levity polymorphism. These checks all used to be handled in the typechecker-in checkStrictBinds (before Jan '17).+to representation polymorphism. These checks all used to be handled in the+typechecker in checkStrictBinds (before Jan '17).  We define an "unlifted bind" to be any bind that binds an unlifted id. Note that @@ -665,16 +677,14 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))   | isJust (isClassOpId_maybe poly_id)   = putSrcSpanDs loc $-    do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for class method selector"-                          <+> quotes (ppr poly_id))+    do { diagnosticDs (DsUselessSpecialiseForClassMethodSelector poly_id)        ; return Nothing  }  -- There is no point in trying to specialise a class op                             -- Moreover, classops don't (currently) have an inl_sat arity set                             -- (it would be Just 0) and that in turn makes makeCorePair bleat    | no_act_spec && isNeverActive rule_act   = putSrcSpanDs loc $-    do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for NOINLINE function:"-                          <+> quotes (ppr poly_id))+    do { diagnosticDs (DsUselessSpecialiseForNoInlineFunction poly_id)        ; return Nothing  }  -- Function is NOINLINE, and the specialisation inherits that                             -- See Note [Activation pragmas for SPECIALISE] @@ -699,7 +709,7 @@          --                         , text "ds_rhs:" <+> ppr ds_lhs ]) $          dflags <- getDynFlags        ; case decomposeRuleLhs dflags spec_bndrs ds_lhs of {-           Left msg -> do { warnDs NoReason msg; return Nothing } ;+           Left msg -> do { diagnosticDs msg; return Nothing } ;            Right (rule_bndrs, _fn, rule_lhs_args) -> do         { this_mod <- getModule@@ -720,7 +730,7 @@  -- Commented out: see Note [SPECIALISE on INLINE functions] --       ; when (isInlinePragma id_inl)---              (warnDs $ text "SPECIALISE pragma on INLINE function probably won't fire:"+--              (diagnosticDs $ text "SPECIALISE pragma on INLINE function probably won't fire:" --                        <+> quotes (ppr poly_name))         ; return (Just (unitOL (spec_id, spec_rhs), rule))@@ -757,8 +767,9 @@     -- no_act_spec is True if the user didn't write an explicit     -- phase specification in the SPECIALISE pragma     no_act_spec = case inlinePragmaSpec spec_inl of-                    NoInline -> isNeverActive  spec_prag_act-                    _        -> isAlwaysActive spec_prag_act+                    NoInline _   -> isNeverActive  spec_prag_act+                    Opaque _     -> isNeverActive  spec_prag_act+                    _            -> isAlwaysActive spec_prag_act     rule_act | no_act_spec = inlinePragmaActivation id_inl   -- Inherit              | otherwise   = spec_prag_act                   -- Specified by user @@ -767,14 +778,10 @@        -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> DsM CoreRule dsMkUserRule this_mod is_local name act fn bndrs args rhs = do     let rule = mkRule this_mod False is_local name act fn bndrs args rhs-    dflags <- getDynFlags-    when (isOrphan (ru_orphan rule) && wopt Opt_WarnOrphans dflags) $-        warnDs (Reason Opt_WarnOrphans) (ruleOrphWarn rule)+    when (isOrphan (ru_orphan rule)) $+        diagnosticDs (DsOrphanRule rule)     return rule -ruleOrphWarn :: CoreRule -> SDoc-ruleOrphWarn rule = text "Orphan rule:" <+> ppr rule- {- Note [SPECIALISE on INLINE functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We used to warn that using SPECIALISE for a function marked INLINE@@ -837,7 +844,7 @@ -}  decomposeRuleLhs :: DynFlags -> [Var] -> CoreExpr-                 -> Either SDoc ([Var], Id, [CoreExpr])+                 -> Either DsMessage ([Var], Id, [CoreExpr]) -- (decomposeRuleLhs bndrs lhs) takes apart the LHS of a RULE, -- The 'bndrs' are the quantified binders of the rules, but decomposeRuleLhs -- may add some extra dictionary binders (see Note [Free dictionaries])@@ -847,10 +854,10 @@ decomposeRuleLhs dflags orig_bndrs orig_lhs   | not (null unbound)    -- Check for things unbound on LHS                           -- See Note [Unused spec binders]-  = Left (vcat (map dead_msg unbound))+  = Left (DsRuleBindersNotBound unbound orig_bndrs orig_lhs lhs2)   | Var funId <- fun2   , Just con <- isDataConId_maybe funId-  = Left (constructor_msg con) -- See Note [No RULES on datacons]+  = Left (DsRuleIgnoredDueToConstructor con) -- See Note [No RULES on datacons]   | Just (fn_id, args) <- decompose fun2 args2   , let extra_bndrs = mk_extra_bndrs fn_id args   = -- pprTrace "decomposeRuleLhs" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs@@ -862,7 +869,7 @@     Right (orig_bndrs ++ extra_bndrs, fn_id, args)    | otherwise-  = Left bad_shape_msg+  = Left (DsRuleLhsTooComplicated orig_lhs lhs2)  where    simpl_opts   = initSimpleOpts dflags    lhs1         = drop_dicts orig_lhs@@ -894,24 +901,6 @@     decompose _ _ = Nothing -   bad_shape_msg = hang (text "RULE left-hand side too complicated to desugar")-                      2 (vcat [ text "Optimised lhs:" <+> ppr lhs2-                              , text "Orig lhs:" <+> ppr orig_lhs])-   dead_msg bndr = hang (sep [ text "Forall'd" <+> pp_bndr bndr-                             , text "is not bound in RULE lhs"])-                      2 (vcat [ text "Orig bndrs:" <+> ppr orig_bndrs-                              , text "Orig lhs:" <+> ppr orig_lhs-                              , text "optimised lhs:" <+> ppr lhs2 ])-   pp_bndr bndr-    | isTyVar bndr = text "type variable" <+> quotes (ppr bndr)-    | isEvVar bndr = text "constraint"    <+> quotes (ppr (varType bndr))-    | otherwise    = text "variable"      <+> quotes (ppr bndr)--   constructor_msg con = vcat-     [ text "A constructor," <+> ppr con <>-         text ", appears as outermost match in RULE lhs."-     , text "This rule will be ignored." ]-    drop_dicts :: CoreExpr -> CoreExpr    drop_dicts e        = wrap_lets needed bnds body@@ -1130,28 +1119,25 @@                                    ; return (w1 . w2) }  -- See comments on WpFun in GHC.Tc.Types.Evidence for an explanation of what  -- the specification of this clause is-dsHsWrapper (WpFun c1 c2 (Scaled w t1) doc)-                              = do { x <- newSysLocalDsNoLP w t1+dsHsWrapper (WpFun c1 c2 (Scaled w t1))+                              = do { x <- newSysLocalDs w t1                                    ; w1 <- dsHsWrapper c1                                    ; w2 <- dsHsWrapper c2                                    ; let app f a = mkCoreAppDs (text "dsHsWrapper") f a                                          arg     = w1 (Var x)-                                   ; (_, ok) <- askNoErrsDs $ dsNoLevPolyExpr arg doc-                                   ; if ok-                                     then return (\e -> (Lam x (w2 (app e arg))))-                                     else return id }  -- this return is irrelevant-dsHsWrapper (WpCast co)       = ASSERT(coercionRole co == Representational)+                                   ; return (\e -> (Lam x (w2 (app e arg)))) }+dsHsWrapper (WpCast co)       = assert (coercionRole co == Representational) $                                 return $ \e -> mkCastDs e co dsHsWrapper (WpEvApp tm)      = do { core_tm <- dsEvTerm tm                                    ; return (\e -> App e core_tm) }   -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. dsHsWrapper (WpMultCoercion co) = do { when (not (isReflexiveCo co)) $-                                         errDs (text "Multiplicity coercions are currently not supported")+                                         diagnosticDs DsMultiplicityCoercionsNotSupported                                      ; return $ \e -> e } -------------------------------------- dsTcEvBinds_s :: [TcEvBinds] -> DsM [CoreBind] dsTcEvBinds_s []       = return []-dsTcEvBinds_s (b:rest) = ASSERT( null rest )  -- Zonker ensures null+dsTcEvBinds_s (b:rest) = assert (null rest) $  -- Zonker ensures null                          dsTcEvBinds b  dsTcEvBinds :: TcEvBinds -> DsM [CoreBind]@@ -1286,7 +1272,7 @@        ; em <- getRep evm m        ; mkTrFun <- dsLookupGlobalId mkTrFunName                     -- mkTrFun :: forall (m :: Multiplicity) r1 r2 (a :: TYPE r1) (b :: TYPE r2).-                    --            TypeRep m -> TypeRep a -> TypeRep b -> TypeRep (a # m -> b)+                    --            TypeRep m -> TypeRep a -> TypeRep b -> TypeRep (a % m -> b)        ; let r1 = getRuntimeRep t1              r2 = getRuntimeRep t2        ; return $ mkApps (mkTyApps (Var mkTrFun) [m, r1, r2, t1, t2])
compiler/GHC/HsToCore/Coverage.hs view
@@ -9,14 +9,16 @@ (c) University of Glasgow, 2007 -} -module GHC.HsToCore.Coverage (addTicksToBinds, hpcInitCode) where+module GHC.HsToCore.Coverage+  ( CoverageConfig (..)+  , addTicksToBinds+  , hpcInitCode+  ) where  import GHC.Prelude as Prelude  import GHC.Driver.Session import GHC.Driver.Backend-import GHC.Driver.Ppr-import GHC.Driver.Env  import qualified GHC.Runtime.Interpreter as GHCi import GHCi.RemoteTypes@@ -33,6 +35,10 @@ import GHC.Data.FastString import GHC.Data.Bag +import GHC.Platform++import GHC.Runtime.Interpreter.Types+ import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic@@ -72,8 +78,17 @@ ************************************************************************ -} +data CoverageConfig = CoverageConfig+  { coverageConfig_logger   :: Logger++  -- FIXME: replace this with the specific fields of DynFlags we care about.+  , coverageConfig_dynFlags :: DynFlags++  , coverageConfig_mInterp  :: Maybe Interp+  }+ addTicksToBinds-        :: HscEnv+        :: CoverageConfig         -> Module         -> ModLocation          -- ... off the current module         -> NameSet              -- Exported Ids.  When we call addTicksToBinds,@@ -83,9 +98,13 @@         -> LHsBinds GhcTc         -> IO (LHsBinds GhcTc, HpcInfo, Maybe ModBreaks) -addTicksToBinds hsc_env mod mod_loc exports tyCons binds-  | let dflags = hsc_dflags hsc_env-        passes = coveragePasses dflags+addTicksToBinds (CoverageConfig+                 { coverageConfig_logger = logger+                 , coverageConfig_dynFlags = dflags+                 , coverageConfig_mInterp = m_interp+                 })+                mod mod_loc exports tyCons binds+  | let passes = coveragePasses dflags   , not (null passes)   , Just orig_file <- ml_hs_file mod_loc = do @@ -95,7 +114,7 @@             let env = TTE                       { fileName     = mkFastString orig_file2                       , declPath     = []-                      , tte_dflags   = dflags+                      , tte_countEntries = gopt Opt_ProfCountEntries dflags                       , exports      = exports                       , inlines      = emptyVarSet                       , inScope      = emptyVarSet@@ -121,10 +140,9 @@      let tickCount = tickBoxCount st          entries = reverse $ mixEntries st      hashNo <- writeMixEntries dflags mod tickCount entries orig_file2-     modBreaks <- mkModBreaks hsc_env mod tickCount entries+     modBreaks <- mkModBreaks m_interp dflags mod tickCount entries -     let logger = hsc_logger hsc_env-     dumpIfSet_dyn logger dflags Opt_D_dump_ticked "HPC" FormatHaskell+     putDumpFileMaybe logger Opt_D_dump_ticked "HPC" FormatHaskell        (pprLHsBinds binds1)       return (binds1, HpcInfo tickCount hashNo, modBreaks)@@ -144,12 +162,12 @@         _ -> orig_file  -mkModBreaks :: HscEnv -> Module -> Int -> [MixEntry_] -> IO (Maybe ModBreaks)-mkModBreaks hsc_env mod count entries-  | Just interp <- hsc_interp hsc_env-  , breakpointsEnabled (hsc_dflags hsc_env) = do+mkModBreaks :: Maybe Interp -> DynFlags -> Module -> Int -> [MixEntry_] -> IO (Maybe ModBreaks)+mkModBreaks m_interp dflags mod count entries+  | Just interp <- m_interp+  , breakpointsEnabled dflags = do     breakArray <- GHCi.newBreakArray interp (length entries)-    ccs <- mkCCSArray hsc_env mod count entries+    ccs <- mkCCSArray interp mod count entries     let            locsTicks  = listArray (0,count-1) [ span  | (span,_,_,_)  <- entries ]            varsTicks  = listArray (0,count-1) [ vars  | (_,_,vars,_)  <- entries ]@@ -164,21 +182,18 @@   | otherwise = return Nothing  mkCCSArray-  :: HscEnv -> Module -> Int -> [MixEntry_]+  :: Interp -> Module -> Int -> [MixEntry_]   -> IO (Array BreakIndex (RemotePtr GHC.Stack.CCS.CostCentre))-mkCCSArray hsc_env modul count entries =-  case hsc_interp hsc_env of-    Just interp | GHCi.interpreterProfiled interp -> do+mkCCSArray interp modul count entries+  | GHCi.interpreterProfiled interp = do       let module_str = moduleNameString (moduleName modul)       costcentres <- GHCi.mkCostCentres interp module_str (map mk_one entries)       return (listArray (0,count-1) costcentres)--    _ -> return (listArray (0,-1) [])+  | otherwise = return (listArray (0,-1) [])  where-    dflags = hsc_dflags hsc_env     mk_one (srcspan, decl_path, _, _) = (name, src)       where name = concat (intersperse "." decl_path)-            src = showSDoc dflags (ppr srcspan)+            src = renderWithContext defaultSDocContext (ppr srcspan)   writeMixEntries@@ -270,12 +285,13 @@ addTickLHsBinds = mapBagM addTickLHsBind  addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc)-addTickLHsBind (L pos bind@(AbsBinds { abs_binds   = binds,-                                       abs_exports = abs_exports })) =+addTickLHsBind (L pos (XHsBindsLR bind@(AbsBinds { abs_binds = binds+                                                 , abs_exports = abs_exports+                                                 }))) =   withEnv add_exports $     withEnv add_inlines $ do       binds' <- addTickLHsBinds binds-      return $ L pos $ bind { abs_binds = binds' }+      return $ L pos $ XHsBindsLR $ bind { abs_binds = binds' }   where    -- in AbsBinds, the Id on each binding is not the actual top-level    -- Id that we are defining, they are related by the abs_exports@@ -400,7 +416,7 @@   -- Note [inline sccs]---+-- ~~~~~~~~~~~~~~~~~~ -- The reason not to add ticks to INLINE functions is that this is -- sometimes handy for avoiding adding a tick to a particular function -- (see #6131)@@ -518,26 +534,21 @@ addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc) addTickHsExpr e@(HsVar _ (L _ id))  = do freeVar id; return e addTickHsExpr e@(HsUnboundVar {})   = return e-addTickHsExpr e@(HsRecFld _ (Ambiguous id _))   = do freeVar id; return e-addTickHsExpr e@(HsRecFld _ (Unambiguous id _)) = do freeVar id; return e+addTickHsExpr e@(HsRecSel _ (FieldOcc id _))   = do freeVar id; return e -addTickHsExpr e@(HsConLikeOut {}) = return e-  -- We used to do a freeVar on a pat-syn builder, but actually-  -- such builders are never in the inScope env, which-  -- doesn't include top level bindings-addTickHsExpr e@(HsIPVar {})     = return e-addTickHsExpr e@(HsOverLit {})   = return e-addTickHsExpr e@(HsOverLabel{})  = return e-addTickHsExpr e@(HsLit {})       = return e-addTickHsExpr (HsLam x mg)       = liftM (HsLam x)-                                         (addTickMatchGroup True mg)-addTickHsExpr (HsLamCase x mgs)  = liftM (HsLamCase x)-                                         (addTickMatchGroup True mgs)-addTickHsExpr (HsApp x e1 e2)    = liftM2 (HsApp x) (addTickLHsExprNever e1)-                                                    (addTickLHsExpr      e2)-addTickHsExpr (HsAppType x e ty) = liftM3 HsAppType (return x)-                                                    (addTickLHsExprNever e)-                                                    (return ty)+addTickHsExpr e@(HsIPVar {})            = return e+addTickHsExpr e@(HsOverLit {})          = return e+addTickHsExpr e@(HsOverLabel{})         = return e+addTickHsExpr e@(HsLit {})              = return e+addTickHsExpr (HsLam x mg)              = liftM (HsLam x)+                                                (addTickMatchGroup True mg)+addTickHsExpr (HsLamCase x lc_variant mgs) = liftM (HsLamCase x lc_variant)+                                                   (addTickMatchGroup True mgs)+addTickHsExpr (HsApp x e1 e2)          = liftM2 (HsApp x) (addTickLHsExprNever e1)+                                                          (addTickLHsExpr      e2)+addTickHsExpr (HsAppType x e ty)       = liftM3 HsAppType (return x)+                                                          (addTickLHsExprNever e)+                                                          (return ty) addTickHsExpr (OpApp fix e1 e2 e3) =         liftM4 OpApp                 (return fix)@@ -548,8 +559,9 @@         liftM2 (NegApp x)                 (addTickLHsExpr e)                 (addTickSyntaxExpr hpcSrcSpan neg)-addTickHsExpr (HsPar x e) =-        liftM (HsPar x) (addTickLHsExprEvalInner e)+addTickHsExpr (HsPar x lpar e rpar) = do+        e' <- addTickLHsExprEvalInner e+        return (HsPar x lpar e' rpar) addTickHsExpr (SectionL x e1 e2) =         liftM2 (SectionL x)                 (addTickLHsExpr e1)@@ -579,11 +591,11 @@   = do { let isOneOfMany = case alts of [_] -> False; _ -> True        ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts        ; return $ HsMultiIf ty alts' }-addTickHsExpr (HsLet x binds e) =-        bindLocals (collectLocalBinders CollNoDictBinders binds) $-          liftM2 (HsLet x)-                  (addTickHsLocalBinds binds) -- to think about: !patterns.-                  (addTickLHsExprLetBody e)+addTickHsExpr (HsLet x tkLet binds tkIn e) =+        bindLocals (collectLocalBinders CollNoDictBinders binds) $ do+          binds' <- addTickHsLocalBinds binds -- to think about: !patterns.+          e' <- addTickLHsExprLetBody e+          return (HsLet x tkLet binds' tkIn e') addTickHsExpr (HsDo srcloc cxt (L l stmts))   = do { (stmts', _) <- addTickLStmts' forQual stmts (return ())        ; return (HsDo srcloc cxt (L l stmts')) }@@ -624,17 +636,10 @@                    addTickWit (Just fl) = do fl' <- addTickSyntaxExpr hpcSrcSpan fl                                              return (Just fl') --- We might encounter existing ticks (multiple Coverage passes)-addTickHsExpr (HsTick x t e) =-        liftM (HsTick x t) (addTickLHsExprNever e)-addTickHsExpr (HsBinTick x t0 t1 e) =-        liftM (HsBinTick x t0 t1) (addTickLHsExprNever e)- addTickHsExpr (HsPragE x p e) =         liftM (HsPragE x p) (addTickLHsExpr e)-addTickHsExpr e@(HsBracket     {})   = return e-addTickHsExpr e@(HsTcBracketOut  {}) = return e-addTickHsExpr e@(HsRnBracketOut  {}) = return e+addTickHsExpr e@(HsTypedBracket {})  = return e+addTickHsExpr e@(HsUntypedBracket{}) = return e addTickHsExpr e@(HsSpliceE  {})      = return e addTickHsExpr e@(HsGetField {})      = return e addTickHsExpr e@(HsProjection {})    = return e@@ -649,6 +654,17 @@         liftM (XExpr . ExpansionExpr . HsExpanded a) $               (addTickHsExpr b) +addTickHsExpr e@(XExpr (ConLikeTc {})) = return e+  -- We used to do a freeVar on a pat-syn builder, but actually+  -- such builders are never in the inScope env, which+  -- doesn't include top level bindings++-- We might encounter existing ticks (multiple Coverage passes)+addTickHsExpr (XExpr (HsTick t e)) =+        liftM (XExpr . HsTick t) (addTickLHsExprNever e)+addTickHsExpr (XExpr (HsBinTick t0 t1 e)) =+        liftM (XExpr . HsBinTick t0 t1) (addTickLHsExprNever e)+ addTickTupArg :: HsTupArg GhcTc -> TM (HsTupArg GhcTc) addTickTupArg (Present x e)  = do { e' <- addTickLHsExpr e                                   ; return (Present x e') }@@ -830,9 +846,8 @@  addTickIPBind :: IPBind GhcTc -> TM (IPBind GhcTc) addTickIPBind (IPBind x nm e) =-        liftM2 (IPBind x)-                (return nm)-                (addTickLHsExpr e)+        liftM (IPBind x nm)+               (addTickLHsExpr e)  -- There is no location here, so we might need to use a context location?? addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)@@ -869,23 +884,25 @@                 (return fix)                 (addTickLHsCmd c3) -}-addTickHsCmd (HsCmdPar x e) = liftM (HsCmdPar x) (addTickLHsCmd e)+addTickHsCmd (HsCmdPar x lpar e rpar) = do+        e' <- addTickLHsCmd e+        return (HsCmdPar x lpar e' rpar) addTickHsCmd (HsCmdCase x e mgs) =         liftM2 (HsCmdCase x)                 (addTickLHsExpr e)                 (addTickCmdMatchGroup mgs)-addTickHsCmd (HsCmdLamCase x mgs) =-        liftM (HsCmdLamCase x) (addTickCmdMatchGroup mgs)+addTickHsCmd (HsCmdLamCase x lc_variant mgs) =+        liftM (HsCmdLamCase x lc_variant) (addTickCmdMatchGroup mgs) addTickHsCmd (HsCmdIf x cnd e1 c2 c3) =         liftM3 (HsCmdIf x cnd)                 (addBinTickLHsExpr (BinBox CondBinBox) e1)                 (addTickLHsCmd c2)                 (addTickLHsCmd c3)-addTickHsCmd (HsCmdLet x binds c) =-        bindLocals (collectLocalBinders CollNoDictBinders binds) $-          liftM2 (HsCmdLet x)-                   (addTickHsLocalBinds binds) -- to think about: !patterns.-                   (addTickLHsCmd c)+addTickHsCmd (HsCmdLet x tkLet binds tkIn c) =+        bindLocals (collectLocalBinders CollNoDictBinders binds) $ do+          binds' <- addTickHsLocalBinds binds -- to think about: !patterns.+          c' <- addTickLHsCmd c+          return (HsCmdLet x tkLet binds' tkIn c') addTickHsCmd (HsCmdDo srcloc (L l stmts))   = do { (stmts', _) <- addTickLCmdStmts' stmts (return ())        ; return (HsCmdDo srcloc (L l stmts')) }@@ -992,11 +1009,11 @@   = do  { fields' <- mapM addTickHsRecField fields         ; return (HsRecFields fields' dd) } -addTickHsRecField :: LHsRecField' GhcTc id (LHsExpr GhcTc)-                  -> TM (LHsRecField' GhcTc id (LHsExpr GhcTc))-addTickHsRecField (L l (HsRecField x id expr pun))+addTickHsRecField :: LHsFieldBind GhcTc id (LHsExpr GhcTc)+                  -> TM (LHsFieldBind GhcTc id (LHsExpr GhcTc))+addTickHsRecField (L l (HsFieldBind x id expr pun))         = do { expr' <- addTickLHsExpr expr-             ; return (L l (HsRecField x id expr' pun)) }+             ; return (L l (HsFieldBind x id expr' pun)) }  addTickArithSeqInfo :: ArithSeqInfo GhcTc -> TM (ArithSeqInfo GhcTc) addTickArithSeqInfo (From e1) =@@ -1032,7 +1049,9 @@  data TickTransEnv = TTE { fileName     :: FastString                         , density      :: TickDensity-                        , tte_dflags   :: DynFlags+                        , tte_countEntries :: !Bool+                          -- ^ Whether the number of times functions are+                          -- entered should be counted.                         , exports      :: NameSet                         , inlines      :: VarSet                         , declPath     :: [String]@@ -1073,6 +1092,7 @@ noFVs = emptyOccEnv  -- Note [freevars]+-- ~~~~~~~~~~~~~~~ --   For breakpoints we want to collect the free variables of an --   expression for pinning on the HsTick.  We don't want to collect --   *all* free variables though: in particular there's no point pinning@@ -1101,9 +1121,6 @@                                        (r2,fv2,st2) ->                                           (r2, fv1 `plusOccEnv` fv2, st2) -instance HasDynFlags TM where-  getDynFlags = TM $ \ env st -> (tte_dflags env, noFVs, st)- -- | Get the next HPC cost centre index for a given centre name getCCIndexM :: FastString -> TM CostCentreIndex getCCIndexM n = TM $ \_ st -> let (idx, is') = getCCIndex n $@@ -1186,7 +1203,7 @@     (fvs, e) <- getFreeVars m     env <- getEnv     tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env)-    return (L (noAnnSrcSpan pos) (HsTick noExtField tickish (L (noAnnSrcSpan pos) e)))+    return (L (noAnnSrcSpan pos) (XExpr $ HsTick tickish $ L (noAnnSrcSpan pos) e))   ) (do     e <- m     return (L (noAnnSrcSpan pos) e)@@ -1212,7 +1229,7 @@           -> TM CoreTickish mkTickish boxLabel countEntries topOnly pos fvs decl_path = do -  let ids = filter (not . isUnliftedType . idType) $ occEnvElts fvs+  let ids = filter (not . mightBeUnliftedType . idType) $ nonDetOccEnvElts fvs           -- unlifted types cause two problems here:           --   * we can't bind them  at the GHCi prompt           --     (bindLocalsAtBreakpoint already filters them out),@@ -1224,7 +1241,6 @@       cc_name | topOnly   = head decl_path               | otherwise = concat (intersperse "." decl_path) -  dflags <- getDynFlags   env <- getEnv   case tickishType env of     HpcTicks -> HpcTick (this_mod env) <$> addMixEntry me@@ -1233,7 +1249,7 @@       let nm = mkFastString cc_name       flavour <- HpcCC <$> getCCIndexM nm       let cc = mkUserCC nm (this_mod env) pos flavour-          count = countEntries && gopt Opt_ProfCountEntries dflags+          count = countEntries && tte_countEntries env       return $ ProfNote cc count True{-scopes-}      Breakpoints -> Breakpoint noExtField <$> addMixEntry me <*> pure ids@@ -1259,14 +1275,14 @@                 -> TM (LHsExpr GhcTc) mkBinTickBoxHpc boxLabel pos e = do   env <- getEnv-  binTick <- HsBinTick noExtField+  binTick <- HsBinTick     <$> addMixEntry (pos,declPath env, [],boxLabel True)     <*> addMixEntry (pos,declPath env, [],boxLabel False)     <*> pure e   tick <- HpcTick (this_mod env)     <$> addMixEntry (pos,declPath env, [],ExpBox False)   let pos' = noAnnSrcSpan pos-  return $ L pos' $ HsTick noExtField tick (L pos' binTick)+  return $ L pos' $ XExpr $ HsTick tick (L pos' (XExpr binTick))  mkHpcPos :: SrcSpan -> HpcPos mkHpcPos pos@(RealSrcSpan s _)@@ -1324,27 +1340,21 @@  hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc);} -} -hpcInitCode :: DynFlags -> Module -> HpcInfo -> CStub+hpcInitCode :: Platform -> Module -> HpcInfo -> CStub hpcInitCode _ _ (NoHpcInfo {}) = mempty-hpcInitCode dflags this_mod (HpcInfo tickCount hashNo)- = CStub $ vcat-    [ text "static void hpc_init_" <> ppr this_mod-         <> text "(void) __attribute__((constructor));"-    , text "static void hpc_init_" <> ppr this_mod <> text "(void)"-    , braces (vcat [-        text "extern StgWord64 " <> tickboxes <>-               text "[]" <> semi,-        text "hs_hpc_module" <>-          parens (hcat (punctuate comma [-              doubleQuotes full_name_str,-              int tickCount, -- really StgWord32-              int hashNo,    -- really StgWord32-              tickboxes-            ])) <> semi-       ])-    ]+hpcInitCode platform this_mod (HpcInfo tickCount hashNo)+ = initializerCStub platform fn_name decls body   where-    platform  = targetPlatform dflags+    fn_name = mkInitializerStubLabel this_mod "hpc"+    decls = text "extern StgWord64 " <> tickboxes <> text "[]" <> semi+    body = text "hs_hpc_module" <>+              parens (hcat (punctuate comma [+                  doubleQuotes full_name_str,+                  int tickCount, -- really StgWord32+                  int hashNo,    -- really StgWord32+                  tickboxes+                ])) <> semi+     tickboxes = pprCLabel platform CStyle (mkHpcTicksLabel $ this_mod)      module_name  = hcat (map (text.charToC) $ BS.unpack $
compiler/GHC/HsToCore/Docs.hs view
@@ -8,8 +8,6 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}- module GHC.HsToCore.Docs where  import GHC.Prelude@@ -32,89 +30,237 @@ import Data.Bifunctor (first) import Data.IntMap (IntMap) import qualified Data.IntMap as IM-import Data.Map (Map)+import Data.Map.Strict (Map) import qualified Data.Map as M+import qualified Data.Set as Set import Data.Maybe import Data.Semigroup import GHC.IORef (readIORef)+import GHC.Unit.Types+import GHC.Hs+import GHC.Types.Avail+import GHC.Unit.Module+import qualified Data.List.NonEmpty as NonEmpty+import Data.List.NonEmpty (NonEmpty ((:|)))+import GHC.Unit.Module.Imported+import GHC.Driver.Session+import GHC.Types.TypeEnv+import GHC.Types.Id+import GHC.Types.Unique.Map  -- | Extract docs from renamer output. -- This is monadic since we need to be able to read documentation added from -- Template Haskell's @putDoc@, which is stored in 'tcg_th_docs'. extractDocs :: MonadIO m-            => TcGblEnv-            -> m (Maybe HsDocString, DeclDocMap, ArgDocMap)+            => DynFlags -> TcGblEnv+            -> m (Maybe Docs)             -- ^             -- 1. Module header             -- 2. Docs on top level declarations             -- 3. Docs on arguments-extractDocs TcGblEnv { tcg_semantic_mod = mod-                     , tcg_rn_decls = mb_rn_decls-                     , tcg_insts = insts-                     , tcg_fam_insts = fam_insts-                     , tcg_doc_hdr = mb_doc_hdr-                     , tcg_th_docs = th_docs_var-                     } = do+extractDocs dflags+      TcGblEnv { tcg_semantic_mod = semantic_mdl+               , tcg_mod = mdl+               , tcg_rn_decls = Just rn_decls+               , tcg_rn_exports = mb_rn_exports+               , tcg_exports = all_exports+               , tcg_imports = import_avails+               , tcg_insts = insts+               , tcg_fam_insts = fam_insts+               , tcg_doc_hdr = mb_doc_hdr+               , tcg_th_docs = th_docs_var+               , tcg_type_env = ty_env+               } = do     th_docs <- liftIO $ readIORef th_docs_var-    let doc_hdr = th_doc_hdr <|> (unLoc <$> mb_doc_hdr)-        ExtractedTHDocs-          th_doc_hdr-          (DeclDocMap th_doc_map)-          (ArgDocMap th_arg_map)-          (DeclDocMap th_inst_map) = extractTHDocs th_docs-    return-      ( doc_hdr-      , DeclDocMap (th_doc_map <> th_inst_map <> doc_map)-      , ArgDocMap (th_arg_map `unionArgMaps` arg_map)-      )+    let doc_hdr = (unLoc <$> mb_doc_hdr)+        ExtractedTHDocs th_hdr th_decl_docs th_arg_docs th_inst_docs = extractTHDocs th_docs+        mod_docs+         =  Docs+         { docs_mod_hdr = th_hdr <|> doc_hdr+         -- Left biased union (see #21220)+         , docs_decls = plusUniqMap_C (\a _ -> a)+                          ((:[]) <$> th_decl_docs `plusUniqMap` th_inst_docs)+                          -- These will not clash so safe to use plusUniqMap+                          doc_map+         , docs_args = th_arg_docs `unionArgMaps` arg_map+         , docs_structure = doc_structure+         , docs_named_chunks = named_chunks+         , docs_haddock_opts = haddockOptions dflags+         , docs_language = language_+         , docs_extensions = exts+         }+    pure (Just mod_docs)   where-    (doc_map, arg_map) = maybe (M.empty, M.empty)-                               (mkMaps local_insts)-                               mb_decls_with_docs-    mb_decls_with_docs = topDecls <$> mb_rn_decls-    local_insts = filter (nameIsLocalOrFrom mod)+    exts = extensionFlags dflags+    language_ = language dflags++    -- We need to lookup the Names for default methods, so we+    -- can put them in the correct map+    -- See Note [default method Name] in GHC.Iface.Recomp+    def_meths_env = mkOccEnv [(occ, nm)+                             | id <- typeEnvIds ty_env+                             , let nm = idName id+                                   occ = nameOccName nm+                             , isDefaultMethodOcc occ+                             ]++    (doc_map, arg_map) = mkMaps def_meths_env local_insts decls_with_docs+    decls_with_docs = topDecls rn_decls+    local_insts = filter (nameIsLocalOrFrom semantic_mdl)                          $ map getName insts ++ map getName fam_insts+    doc_structure = mkDocStructure mdl import_avails mb_rn_exports rn_decls+                                   all_exports def_meths_env+    named_chunks = getNamedChunks (isJust mb_rn_exports) rn_decls+extractDocs _ _ = pure Nothing +-- | If we have an explicit export list, we extract the documentation structure+-- from that.+-- Otherwise we use the renamed exports and declarations.+mkDocStructure :: Module                               -- ^ The current module+               -> ImportAvails                         -- ^ Imports+               -> Maybe [(LIE GhcRn, Avails)] -- ^ Explicit export list+               -> HsGroup GhcRn+               -> [AvailInfo]                          -- ^ All exports+               -> OccEnv Name                          -- ^ Default Methods+               -> DocStructure+mkDocStructure mdl import_avails (Just export_list) _ _ _ =+    mkDocStructureFromExportList mdl import_avails export_list+mkDocStructure _ _ Nothing rn_decls all_exports def_meths_env =+    mkDocStructureFromDecls def_meths_env all_exports rn_decls++-- TODO:+-- * Maybe remove items that export nothing?+-- * Combine sequences of DsiExports?+-- * Check the ordering of avails in DsiModExport+mkDocStructureFromExportList+  :: Module                         -- ^ The current module+  -> ImportAvails+  -> [(LIE GhcRn, Avails)] -- ^ Explicit export list+  -> DocStructure+mkDocStructureFromExportList mdl import_avails export_list =+    toDocStructure . first unLoc <$> export_list+  where+    toDocStructure :: (IE GhcRn, Avails) -> DocStructureItem+    toDocStructure = \case+      (IEModuleContents _ lmn, avails) -> moduleExport (unLoc lmn) avails+      (IEGroup _ level doc, _)         -> DsiSectionHeading level (unLoc doc)+      (IEDoc _ doc, _)                 -> DsiDocChunk (unLoc doc)+      (IEDocNamed _ name, _)           -> DsiNamedChunkRef name+      (_, avails)                      -> DsiExports (nubAvails avails)++    moduleExport :: ModuleName -- Alias+                 -> Avails+                 -> DocStructureItem+    moduleExport alias avails =+        DsiModExport (nubSortNE orig_names) (nubAvails avails)+      where+        orig_names = M.findWithDefault aliasErr alias aliasMap+        aliasErr = error $ "mkDocStructureFromExportList: "+                           ++ (moduleNameString . moduleName) mdl+                           ++ ": Can't find alias " ++ moduleNameString alias+        nubSortNE = NonEmpty.fromList .+                    Set.toList .+                    Set.fromList .+                    NonEmpty.toList++    -- Map from aliases to true module names.+    aliasMap :: Map ModuleName (NonEmpty ModuleName)+    aliasMap =+        M.fromListWith (<>) $+          (this_mdl_name, this_mdl_name :| [])+          : (flip concatMap (moduleEnvToList imported) $ \(mdl, imvs) ->+              [(imv_name imv, moduleName mdl :| []) | imv <- imvs])+      where+        this_mdl_name = moduleName mdl++    imported :: ModuleEnv [ImportedModsVal]+    imported = mapModuleEnv importedByUser (imp_mods import_avails)++-- | Figure out the documentation structure by correlating+-- the module exports with the located declarations.+mkDocStructureFromDecls :: OccEnv Name -- ^ The default method environment+                        -> [AvailInfo] -- ^ All exports, unordered+                        -> HsGroup GhcRn+                        -> DocStructure+mkDocStructureFromDecls env all_exports decls =+    map unLoc (sortLocated (docs ++ avails))+  where+    avails :: [Located DocStructureItem]+    avails = flip fmap all_exports $ \avail ->+      case M.lookup (availName avail) name_locs of+        Just loc -> L loc (DsiExports [avail])+        -- FIXME: This is just a workaround that we use when handling e.g.+        -- associated data families like in the html-test Instances.hs.+        Nothing -> noLoc (DsiExports [avail])+        -- Nothing -> panicDoc "mkDocStructureFromDecls: No loc found for"+        --                     (ppr avail)++    docs = mapMaybe structuralDoc (hs_docs decls)++    structuralDoc :: LDocDecl GhcRn+                  -> Maybe (Located DocStructureItem)+    structuralDoc = \case+      L loc (DocCommentNamed _name doc) ->+        -- TODO: Is this correct?+        -- NB: There is no export list where we could reference the named chunk.+        Just (L (locA loc) (DsiDocChunk (unLoc doc)))++      L loc (DocGroup level doc) ->+        Just (L (locA loc) (DsiSectionHeading level (unLoc doc)))++      _ -> Nothing++    name_locs = M.fromList (concatMap ldeclNames (ungroup decls))+    ldeclNames (L loc d) = zip (getMainDeclBinder env d) (repeat (locA loc))++-- | Extract named documentation chunks from the renamed declarations.+--+-- If there is no explicit export list, we simply return an empty map+-- since there would be no way to link to a named chunk.+getNamedChunks :: Bool -- ^ Do we have an explicit export list?+               -> HsGroup (GhcPass pass)+               -> Map String (HsDoc (GhcPass pass))+getNamedChunks True decls =+  M.fromList $ flip mapMaybe (unLoc <$> hs_docs decls) $ \case+    DocCommentNamed name doc -> Just (name, unLoc doc)+    _                        -> Nothing+getNamedChunks False _ = M.empty+ -- | Create decl and arg doc-maps by looping through the declarations. -- For each declaration, find its names, its subordinates, and its doc strings.-mkMaps :: [Name]-       -> [(LHsDecl GhcRn, [HsDocString])]-       -> (Map Name (HsDocString), Map Name (IntMap HsDocString))-mkMaps instances decls =-    ( f' (map (nubByName fst) decls')-    , f  (filterMapping (not . IM.null) args)+mkMaps :: OccEnv Name+       -> [Name]+       -> [(LHsDecl GhcRn, [HsDoc GhcRn])]+       -> (UniqMap Name [HsDoc GhcRn], UniqMap Name (IntMap (HsDoc GhcRn)))+mkMaps env instances decls =+    ( listsToMapWith (++) (map (nubByName fst) decls')+    , listsToMapWith (<>) (filterMapping (not . IM.null) args)     )   where     (decls', args) = unzip (map mappings decls) -    f :: (Ord a, Semigroup b) => [[(a, b)]] -> Map a b-    f = M.fromListWith (<>) . concat--    f' :: Ord a => [[(a, HsDocString)]] -> Map a HsDocString-    f' = M.fromListWith appendDocs . concat+    listsToMapWith f = listToUniqMap_C f . concat      filterMapping :: (b -> Bool) ->  [[(a, b)]] -> [[(a, b)]]     filterMapping p = map (filter (p . snd)) -    mappings :: (LHsDecl GhcRn, [HsDocString])-             -> ( [(Name, HsDocString)]-                , [(Name, IntMap HsDocString)]+    mappings :: (LHsDecl GhcRn, [HsDoc GhcRn])+             -> ( [(Name, [HsDoc GhcRn])]+                , [(Name, IntMap (HsDoc GhcRn))]                 )-    mappings (L (SrcSpanAnn _ (RealSrcSpan l _)) decl, docStrs) =+    mappings (L (SrcSpanAnn _ (RealSrcSpan l _)) decl, doc) =            (dm, am)       where-        doc = concatDocs docStrs         args = declTypeDocs decl -        subs :: [(Name, [HsDocString], IntMap HsDocString)]-        subs = subordinates instanceMap decl+        subs :: [(Name, [HsDoc GhcRn], IntMap (HsDoc GhcRn))]+        subs = subordinates env instanceMap decl -        (subDocs, subArgs) =-          unzip (map (\(_, strs, m) -> (concatDocs strs, m)) subs)+        (subNs, subDocs, subArgs) =+          unzip3 subs          ns = names l decl-        subNs = [ n | (n, _, _) <- subs ]-        dm = [(n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs]+        dm = [(n, d) | (n, d) <- zip ns (repeat doc) ++ zip subNs subDocs, not $ all (isEmptyDocString . hsDocString) d]         am = [(n, args) | n <- ns] ++ zip subNs subArgs     mappings (L (SrcSpanAnn _ (UnhelpfulSpan _)) _, _) = ([], []) @@ -124,7 +270,7 @@     names :: RealSrcSpan -> HsDecl GhcRn -> [Name]     names _ (InstD _ d) = maybeToList $ lookupSrcSpan (getInstLoc d) instanceMap     names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See Note [1].-    names _ decl = getMainDeclBinder decl+    names _ decl = getMainDeclBinder env decl  {- Note [1]:@@ -135,27 +281,37 @@ user-written. This lets us relate Names (from ClsInsts) to comments (associated with InstDecls and DerivDecls). -}-getMainDeclBinder :: (Anno (IdGhcP p) ~ SrcSpanAnnN, CollectPass (GhcPass p))-                  => HsDecl (GhcPass p) -> [IdP (GhcPass p)]-getMainDeclBinder (TyClD _ d) = [tcdName d]-getMainDeclBinder (ValD _ d) =++getMainDeclBinder+  :: OccEnv Name -- ^ Default method environment for this module. See Note [default method Name] in GHC.Iface.Recomp+  -> HsDecl GhcRn -> [Name]+getMainDeclBinder _ (TyClD _ d) = [tcdName d]+getMainDeclBinder _ (ValD _ d) =   case collectHsBindBinders CollNoDictBinders d of     []       -> []     (name:_) -> [name]-getMainDeclBinder (SigD _ d) = sigNameNoLoc d-getMainDeclBinder (ForD _ (ForeignImport _ name _ _)) = [unLoc name]-getMainDeclBinder (ForD _ (ForeignExport _ _ _ _)) = []-getMainDeclBinder _ = []+getMainDeclBinder env (SigD _ d) = sigNameNoLoc env d+getMainDeclBinder _   (ForD _ (ForeignImport _ name _ _)) = [unLoc name]+getMainDeclBinder _   (ForD _ (ForeignExport _ _ _ _)) = []+getMainDeclBinder _ _ = []  -sigNameNoLoc :: forall pass. UnXRec pass => Sig pass -> [IdP pass]-sigNameNoLoc (TypeSig    _   ns _)         = map (unXRec @pass) ns-sigNameNoLoc (ClassOpSig _ _ ns _)         = map (unXRec @pass) ns-sigNameNoLoc (PatSynSig  _   ns _)         = map (unXRec @pass) ns-sigNameNoLoc (SpecSig    _   n _ _)        = [unXRec @pass n]-sigNameNoLoc (InlineSig  _   n _)          = [unXRec @pass n]-sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map (unXRec @pass) ns-sigNameNoLoc _                             = []+-- | The "OccEnv Name" is the default method environment for this module+-- Ultimately, the a special "defaultMethodOcc" name is used for+-- the signatures on bindings for default methods. Unfortunately, this+-- name isn't generated until typechecking, so it is not in the renamed AST.+-- We have to look it up from the 'OccEnv' parameter constructed from the typechecked+-- AST.+-- See also Note [default method Name] in GHC.Iface.Recomp+sigNameNoLoc :: forall a . (UnXRec a, HasOccName (IdP a)) => OccEnv (IdP a) -> Sig a -> [IdP a]+sigNameNoLoc _   (TypeSig    _   ns _)         = map (unXRec @a) ns+sigNameNoLoc _   (ClassOpSig _ False ns _)     = map (unXRec @a) ns+sigNameNoLoc env (ClassOpSig _ True  ns _)     = mapMaybe (lookupOccEnv env . mkDefaultMethodOcc . occName) $ map (unXRec @a) ns+sigNameNoLoc _   (PatSynSig  _   ns _)         = map (unXRec @a) ns+sigNameNoLoc _   (SpecSig    _   n _ _)        = [unXRec @a n]+sigNameNoLoc _   (InlineSig  _   n _)          = [unXRec @a n]+sigNameNoLoc _   (FixSig _ (FixitySig _ ns _)) = map (unXRec @a) ns+sigNameNoLoc _   _                             = []  -- Extract the source location where an instance is defined. This is used -- to correlate InstDecls with their Instance/CoAxiom Names, via the@@ -180,15 +336,21 @@ -- | Get all subordinate declarations inside a declaration, and their docs. -- A subordinate declaration is something like the associate type or data -- family of a type class.-subordinates :: Map RealSrcSpan Name+subordinates :: OccEnv Name -- ^ The default method environment+             -> Map RealSrcSpan Name              -> HsDecl GhcRn-             -> [(Name, [HsDocString], IntMap HsDocString)]-subordinates instMap decl = case decl of-  InstD _ (ClsInstD _ d) -> do-    DataFamInstDecl { dfid_eqn =-      FamEqn { feqn_tycon = L l _-             , feqn_rhs   = defn }} <- unLoc <$> cid_datafam_insts d-    [ (n, [], IM.empty) | Just n <- [lookupSrcSpan (locA l) instMap] ] ++ dataSubs defn+             -> [(Name, [HsDoc GhcRn], IntMap (HsDoc GhcRn))]+subordinates env instMap decl = case decl of+  InstD _ (ClsInstD _ d) -> let+    data_fams = do+      DataFamInstDecl { dfid_eqn =+        FamEqn { feqn_tycon = L l _+               , feqn_rhs   = defn }} <- unLoc <$> cid_datafam_insts d+      [ (n, [], IM.empty) | Just n <- [lookupSrcSpan (locA l) instMap] ] ++ dataSubs defn+    ty_fams = do+      TyFamInstDecl { tfid_eqn = FamEqn { feqn_tycon = L l _ } } <- unLoc <$> cid_tyfam_insts d+      [ (n, [], IM.empty) | Just n <- [lookupSrcSpan (locA l) instMap] ]+    in data_fams ++ ty_fams    InstD _ (DataFamInstD _ (DataFamInstDecl d))     -> dataSubs (feqn_rhs d)@@ -198,18 +360,18 @@   where     classSubs dd = [ (name, doc, declTypeDocs d)                    | (L _ d, doc) <- classDecls dd-                   , name <- getMainDeclBinder d, not (isValD d)+                   , name <- getMainDeclBinder env d, not (isValD d)                    ]     dataSubs :: HsDataDefn GhcRn-             -> [(Name, [HsDocString], IntMap HsDocString)]-    dataSubs dd = constrs ++ fields ++ derivs+             -> [(Name, [HsDoc GhcRn], IntMap (HsDoc GhcRn))]+    dataSubs dd = constrs ++ fields  ++ derivs       where         cons = map unLoc $ (dd_cons dd)         constrs = [ ( unLoc cname                     , maybeToList $ fmap unLoc $ con_doc c                     , conArgDocs c)                   | c <- cons, cname <- getConNames c ]-        fields  = [ (extFieldOcc n, maybeToList $ fmap unLoc doc, IM.empty)+        fields  = [ (foExt n, maybeToList $ fmap unLoc doc, IM.empty)                   | Just flds <- map getRecConArgs_maybe cons                   , (L _ (ConDeclField _ ns _ doc)) <- (unLoc flds)                   , (L _ n) <- ns ]@@ -220,13 +382,13 @@                                 dd_derivs dd                   , Just instName <- [lookupSrcSpan l instMap] ] -        extract_deriv_clause_tys :: LDerivClauseTys GhcRn -> [(SrcSpan, LHsDocString)]+        extract_deriv_clause_tys :: LDerivClauseTys GhcRn -> [(SrcSpan, LHsDoc GhcRn)]         extract_deriv_clause_tys (L _ dct) =           case dct of             DctSingle _ ty -> maybeToList $ extract_deriv_ty ty             DctMulti _ tys -> mapMaybe extract_deriv_ty tys -        extract_deriv_ty :: LHsSigType GhcRn -> Maybe (SrcSpan, LHsDocString)+        extract_deriv_ty :: LHsSigType GhcRn -> Maybe (SrcSpan, LHsDoc GhcRn)         extract_deriv_ty (L l (HsSig{sig_body = L _ ty})) =           case ty of             -- deriving (C a {- ^ Doc comment -})@@ -234,25 +396,25 @@             _               -> Nothing  -- | Extract constructor argument docs from inside constructor decls.-conArgDocs :: ConDecl GhcRn -> IntMap HsDocString+conArgDocs :: ConDecl GhcRn -> IntMap (HsDoc GhcRn) conArgDocs (ConDeclH98{con_args = args}) =   h98ConArgDocs args conArgDocs (ConDeclGADT{con_g_args = args, con_res_ty = res_ty}) =   gadtConArgDocs args (unLoc res_ty) -h98ConArgDocs :: HsConDeclH98Details GhcRn -> IntMap HsDocString+h98ConArgDocs :: HsConDeclH98Details GhcRn -> IntMap (HsDoc GhcRn) h98ConArgDocs con_args = case con_args of   PrefixCon _ args   -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args   InfixCon arg1 arg2 -> con_arg_docs 0 [ unLoc (hsScaledThing arg1)                                        , unLoc (hsScaledThing arg2) ]   RecCon _           -> IM.empty -gadtConArgDocs :: HsConDeclGADTDetails GhcRn -> HsType GhcRn -> IntMap HsDocString+gadtConArgDocs :: HsConDeclGADTDetails GhcRn -> HsType GhcRn -> IntMap (HsDoc GhcRn) gadtConArgDocs con_args res_ty = case con_args of   PrefixConGADT args -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args ++ [res_ty]-  RecConGADT _       -> con_arg_docs 1 [res_ty]+  RecConGADT _ _     -> con_arg_docs 1 [res_ty] -con_arg_docs :: Int -> [HsType GhcRn] -> IntMap HsDocString+con_arg_docs :: Int -> [HsType GhcRn] -> IntMap (HsDoc GhcRn) con_arg_docs n = IM.fromList . catMaybes . zipWith f [n..]   where     f n (HsDocTy _ _ lds) = Just (n, unLoc lds)@@ -265,7 +427,7 @@  -- | All the sub declarations of a class (that we handle), ordered by -- source location, with documentation attached if it exists.-classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])]+classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDoc GhcRn])] classDecls class_ = filterDecls . collectDocs . sortLocatedA $ decls   where     decls = docs ++ defs ++ sigs ++ ats@@ -275,7 +437,7 @@     ats   = mkDecls tcdATs (TyClD noExtField . FamDecl noExtField) class_  -- | Extract function argument docs from inside top-level decls.-declTypeDocs :: HsDecl GhcRn -> IntMap (HsDocString)+declTypeDocs :: HsDecl GhcRn -> IntMap (HsDoc GhcRn) declTypeDocs = \case   SigD  _ (TypeSig _ _ ty)          -> sigTypeDocs (unLoc (dropWildCards ty))   SigD  _ (ClassOpSig _ _ _ ty)     -> sigTypeDocs (unLoc ty)@@ -296,7 +458,7 @@         y = f x  -- | Extract function argument docs from inside types.-typeDocs :: HsType GhcRn -> IntMap HsDocString+typeDocs :: HsType GhcRn -> IntMap (HsDoc GhcRn) typeDocs = go 0   where     go n = \case@@ -308,12 +470,12 @@       _                                     -> IM.empty  -- | Extract function argument docs from inside types.-sigTypeDocs :: HsSigType GhcRn -> IntMap HsDocString+sigTypeDocs :: HsSigType GhcRn -> IntMap (HsDoc GhcRn) sigTypeDocs (HsSig{sig_body = body}) = typeDocs (unLoc body)  -- | The top-level declarations of a module that we care about, -- ordered by source location, with documentation attached if it exists.-topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDocString])]+topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDoc GhcRn])] topDecls = filterClasses . filterDecls . collectDocs . sortLocatedA . ungroup  -- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'.@@ -340,14 +502,14 @@ -- | Collect docs and attach them to the right declarations. -- -- A declaration may have multiple doc strings attached to it.-collectDocs :: forall p. UnXRec p => [LHsDecl p] -> [(LHsDecl p, [HsDocString])]+collectDocs :: forall p. UnXRec p => [LHsDecl p] -> [(LHsDecl p, [HsDoc p])] -- ^ This is an example. collectDocs = go [] Nothing   where     go docs mprev decls = case (decls, mprev) of-      ((unXRec @p -> DocD _ (DocCommentNext s)) : ds, Nothing)   -> go (s:docs) Nothing ds-      ((unXRec @p -> DocD _ (DocCommentNext s)) : ds, Just prev) -> finished prev docs $ go [s] Nothing ds-      ((unXRec @p -> DocD _ (DocCommentPrev s)) : ds, mprev)     -> go (s:docs) mprev ds+      ((unXRec @p -> DocD _ (DocCommentNext s)) : ds, Nothing)   -> go (unLoc s:docs) Nothing ds+      ((unXRec @p -> DocD _ (DocCommentNext s)) : ds, Just prev) -> finished prev docs $ go [unLoc s] Nothing ds+      ((unXRec @p -> DocD _ (DocCommentPrev s)) : ds, mprev)     -> go (unLoc s:docs) mprev ds       (d                                  : ds, Nothing)   -> go docs (Just d) ds       (d                                  : ds, Just prev) -> finished prev docs $ go [] (Just d) ds       ([]                                     , Nothing)   -> []@@ -401,14 +563,15 @@ extractTHDocs docs =   -- Split up docs into separate maps for each 'DocLoc' type   ExtractedTHDocs-    docHeader-    (DeclDocMap (searchDocs decl))-    (ArgDocMap (searchDocs args))-    (DeclDocMap (searchDocs insts))+    { ethd_mod_header = docHeader+    , ethd_decl_docs  = searchDocs decl+    , ethd_arg_docs   = searchDocs args+    , ethd_inst_docs  = searchDocs insts+    }   where-    docHeader :: Maybe HsDocString+    docHeader :: Maybe (HsDoc GhcRn)     docHeader-      | ((_, s):_) <- filter isModDoc (M.toList docs) = Just (mkHsDocString s)+      | ((_, s):_) <- filter isModDoc (M.toList docs) = Just s       | otherwise = Nothing      isModDoc (ModuleDoc, _) = True@@ -417,38 +580,40 @@     -- Folds over the docs, applying 'f' as the accumulating function.     -- We use different accumulating functions to sift out the specific types of     -- documentation-    searchDocs :: Monoid a => (a -> (DocLoc, String) -> a) -> a-    searchDocs f = foldl' f mempty $ M.toList docs+    searchDocs :: (UniqMap Name a -> (DocLoc, HsDoc GhcRn) -> UniqMap Name a) -> UniqMap Name a+    searchDocs f = foldl' f emptyUniqMap $ M.toList docs      -- Pick out the declaration docs-    decl acc ((DeclDoc name), s) = M.insert name (mkHsDocString s) acc+    decl acc ((DeclDoc name), s) = addToUniqMap acc name s     decl acc _ = acc      -- Pick out the instance docs-    insts acc ((InstDoc name), s) = M.insert name (mkHsDocString s) acc+    insts acc ((InstDoc name), s) = addToUniqMap acc name s     insts acc _ = acc      -- Pick out the argument docs-    args :: Map Name (IntMap HsDocString)-         -> (DocLoc, String)-         -> Map Name (IntMap HsDocString)+    args :: UniqMap Name (IntMap (HsDoc GhcRn))+         -> (DocLoc, HsDoc GhcRn)+         -> UniqMap Name (IntMap (HsDoc GhcRn))     args acc ((ArgDoc name i), s) =       -- Insert the doc for the arg into the argument map for the function. This       -- means we have to search to see if an map already exists for the       -- function, and insert the new argument if it exists, or create a new map-      let ds = mkHsDocString s-       in M.insertWith (\_ m -> IM.insert i ds m) name (IM.singleton i ds) acc+       addToUniqMap_C (\_ m -> IM.insert i s m) acc name (IM.singleton i s)     args acc _ = acc  -- | Unions together two 'ArgDocMaps' (or ArgMaps in haddock-api), such that two -- maps with values for the same key merge the inner map as well. -- Left biased so @unionArgMaps a b@ prefers @a@ over @b@.-unionArgMaps :: Map Name (IntMap b)-             -> Map Name (IntMap b)-             -> Map Name (IntMap b)-unionArgMaps a b = M.foldlWithKey go b a++unionArgMaps :: forall b . UniqMap Name (IntMap b)+             -> UniqMap Name (IntMap b)+             -> UniqMap Name (IntMap b)+unionArgMaps a b = nonDetFoldUniqMap go b a   where-    go acc n newArgMap-      | Just oldArgMap <- M.lookup n acc =-          M.insert n (newArgMap `IM.union` oldArgMap) acc-      | otherwise = M.insert n newArgMap acc+    go :: (Name, IntMap b)+            -> UniqMap Name (IntMap b) -> UniqMap Name (IntMap b)+    go (n, newArgMap) acc+      | Just oldArgMap <- lookupUniqMap acc n =+          addToUniqMap acc n (newArgMap `IM.union` oldArgMap)+      | otherwise = addToUniqMap acc n newArgMap
compiler/GHC/HsToCore/Expr.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP          #-}+ {-# LANGUAGE TypeFamilies #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}@@ -13,13 +13,11 @@ -}  module GHC.HsToCore.Expr-   ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds+   ( dsExpr, dsLExpr, dsLocalBinds    , dsValBinds, dsLit, dsSyntaxExpr    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.HsToCore.Match@@ -31,6 +29,7 @@ import GHC.HsToCore.Arrows import GHC.HsToCore.Monad import GHC.HsToCore.Pmc ( addTyCs, pmcGRHSs )+import GHC.HsToCore.Errors.Types import GHC.Types.SourceText import GHC.Types.Name import GHC.Types.Name.Env@@ -44,8 +43,8 @@ import GHC.Tc.Types.Evidence import GHC.Tc.Utils.Monad import GHC.Core.Type+import GHC.Core.TyCo.Rep import GHC.Core.Multiplicity-import GHC.Core.Coercion( Coercion ) import GHC.Core import GHC.Core.Utils import GHC.Core.Make@@ -58,7 +57,6 @@ import GHC.Unit.Module import GHC.Core.ConLike import GHC.Core.DataCon-import GHC.Core.TyCo.Ppr( pprWithTYPE ) import GHC.Builtin.Types import GHC.Builtin.Names import GHC.Types.Basic@@ -69,9 +67,9 @@ import GHC.Data.Bag import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Core.PatSyn import Control.Monad-import Data.Void( absurd )  {- ************************************************************************@@ -104,7 +102,7 @@         ; foldrM ds_ip_bind inner ip_binds }   where     ds_ip_bind :: LIPBind GhcTc -> CoreExpr -> DsM CoreExpr-    ds_ip_bind (L _ (IPBind _ ~(Right n) e)) body+    ds_ip_bind (L _ (IPBind n _ e)) body       = do e' <- dsLExpr e            return (Let (NonRec n e') body) @@ -125,7 +123,7 @@   = putSrcSpanDs (locA loc) $      -- see Note [Strict binds checks] in GHC.HsToCore.Binds     if is_polymorphic bind-    then errDsCoreExpr (poly_bind_err bind)+    then errDsCoreExpr (DsCannotMixPolyAndUnliftedBindings bind)             -- data Ptr a = Ptr Addr#             -- f x = let p@(Ptr y) = ... in ...             -- Here the binding for 'p' is polymorphic, but does@@ -133,7 +131,7 @@             -- use a bang pattern.  #6078.      else do { when (looksLazyPatBind bind) $-              warnIfSetDs Opt_WarnUnbangedStrictPatterns (unlifted_must_be_bang bind)+              diagnosticDs (DsUnbangedStrictPatterns bind)         -- Complain about a binding that looks lazy         --    e.g.    let I# y = x in ...         -- Remember, in checkStrictBinds we are going to do strict@@ -144,35 +142,25 @@              ; dsUnliftedBind bind body }   where-    is_polymorphic (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs })+    is_polymorphic (XHsBindsLR (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs }))                      = not (null tvs && null evs)     is_polymorphic _ = False -    unlifted_must_be_bang bind-      = hang (text "Pattern bindings containing unlifted types should use" $$-              text "an outermost bang pattern:")-           2 (ppr bind) -    poly_bind_err bind-      = hang (text "You can't mix polymorphic and unlifted bindings:")-           2 (ppr bind) $$-        text "Probable fix: add a type signature"- ds_val_bind (is_rec, binds) _body   | anyBag (isUnliftedHsBind . unLoc) binds  -- see Note [Strict binds checks] in GHC.HsToCore.Binds-  = ASSERT( isRec is_rec )-    errDsCoreExpr $-    hang (text "Recursive bindings for unlifted types aren't allowed:")-       2 (vcat (map ppr (bagToList binds)))+  = assert (isRec is_rec )+    errDsCoreExpr $ DsRecBindsNotAllowedForUnliftedTys (bagToList binds)  -- Ordinary case for bindings; none should be unlifted ds_val_bind (is_rec, binds) body-  = do  { MASSERT( isRec is_rec || isSingletonBag binds )+  = do  { massert (isRec is_rec || isSingletonBag binds)                -- we should never produce a non-recursive list of multiple binds          ; (force_vars,prs) <- dsLHsBinds binds         ; let body' = foldr seqVar body force_vars-        ; ASSERT2( not (any (isUnliftedType . idType . fst) prs), ppr is_rec $$ ppr binds )+        ; assertPpr (not (any (isUnliftedType . idType . fst) prs)) (ppr is_rec $$ ppr binds) $+          -- NB: bindings have a fixed RuntimeRep, so it's OK to call isUnliftedType           case prs of             [] -> return body             _  -> return (Let (Rec prs) body') }@@ -189,10 +177,10 @@  ------------------ dsUnliftedBind :: HsBind GhcTc -> CoreExpr -> DsM CoreExpr-dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = []-               , abs_exports = exports-               , abs_ev_binds = ev_binds-               , abs_binds = lbinds }) body+dsUnliftedBind (XHsBindsLR (AbsBinds { abs_tvs = [], abs_ev_vars = []+                                     , abs_exports = exports+                                     , abs_ev_binds = ev_binds+                                     , abs_binds = lbinds })) body   = do { let body1 = foldr bind_export body exports              bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b        ; body2 <- foldlM (\body lbind -> dsUnliftedBind (unLoc lbind) body)@@ -206,9 +194,8 @@                         , fun_tick = tick }) body                -- Can't be a bang pattern (that looks like a PatBind)                -- so must be simply unboxed-  = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (L l $ idName fun))-                                     Nothing matches-       ; MASSERT( null args ) -- Functions aren't lifted+  = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (L l $ idName fun)) Nothing matches+       ; massert (null args) -- Functions aren't unlifted        ; core_wrap <- dsHsWrapper co_fn  -- Can be non-identity (#21516)        ; let rhs' = core_wrap (mkOptTickBox tick rhs)        ; return (bindNonRec fun rhs' body) }@@ -244,41 +231,27 @@ -- function in GHC.Tc.Utils.Zonk: -- putSrcSpanDs loc $ do --   { core_expr <- dsExpr e---   ; MASSERT2( exprType core_expr `eqType` hsExprType e---             , ppr e <+> dcolon <+> ppr (hsExprType e) $$---                 ppr core_expr <+> dcolon <+> ppr (exprType core_expr) )+--   ; massertPpr (exprType core_expr `eqType` hsExprType e)+--                (ppr e <+> dcolon <+> ppr (hsExprType e) $$+--                 ppr core_expr <+> dcolon <+> ppr (exprType core_expr)) --   ; return core_expr } dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr dsLExpr (L loc e) =   putSrcSpanDsA loc $ dsExpr e --- | Variant of 'dsLExpr' that ensures that the result is not levity--- polymorphic. This should be used when the resulting expression will--- be an argument to some other function.--- See Note [Levity polymorphism checking] in "GHC.HsToCore.Monad"--- See Note [Levity polymorphism invariants] in "GHC.Core"-dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr-dsLExprNoLP (L loc e)-  = putSrcSpanDsA loc $-    do { e' <- dsExpr e-       ; dsNoLevPolyExpr e' (text "In the type of expression:" <+> ppr e)-       ; return e' }- dsExpr :: HsExpr GhcTc -> DsM CoreExpr dsExpr (HsVar    _ (L _ id))           = dsHsVar id-dsExpr (HsRecFld _ (Unambiguous id _)) = dsHsVar id-dsExpr (HsRecFld _ (Ambiguous   id _)) = dsHsVar id+dsExpr (HsRecSel _ (FieldOcc id _))    = dsHsVar id dsExpr (HsUnboundVar (HER ref _ _) _)  = dsEvTerm =<< readMutVar ref         -- See Note [Holes] in GHC.Tc.Types.Constraint -dsExpr (HsPar _ e)            = dsLExpr e+dsExpr (HsPar _ _ e _)        = dsLExpr e dsExpr (ExprWithTySig _ e _)  = dsLExpr e -dsExpr (HsConLikeOut _ con)   = dsConLike con-dsExpr (HsIPVar {})           = panic "dsExpr: HsIPVar"+dsExpr (HsIPVar x _)          = dataConCantHappen x -dsExpr (HsGetField x _ _)     = absurd x-dsExpr (HsProjection x _)     = absurd x+dsExpr (HsGetField x _ _)     = dataConCantHappen x+dsExpr (HsProjection x _)     = dataConCantHappen x  dsExpr (HsLit _ lit)   = do { warnAboutOverflowedLit lit@@ -288,11 +261,29 @@   = do { warnAboutOverflowedOverLit lit        ; dsOverLit lit } -dsExpr e@(XExpr expansion)-  = case expansion of+dsExpr e@(XExpr ext_expr_tc)+  = case ext_expr_tc of       ExpansionExpr (HsExpanded _ b) -> dsExpr b       WrapExpr {}                    -> dsHsWrapped e+      ConLikeTc con tvs tys          -> dsConLike con tvs tys+      -- Hpc Support+      HsTick tickish e -> do+        e' <- dsLExpr e+        return (Tick tickish e') +      -- There is a problem here. The then and else branches+      -- have no free variables, so they are open to lifting.+      -- We need someway of stopping this.+      -- This will make no difference to binary coverage+      -- (did you go here: YES or NO), but will effect accurate+      -- tick counting.++      HsBinTick ixT ixF e -> do+        e2 <- dsLExpr e+        do { assert (exprType e2 `eqType` boolTy)+            mkBinaryTickBox ixT ixF e2+          }+ dsExpr (NegApp _ (L loc                     (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i})))                 neg_expr)@@ -307,16 +298,15 @@        ; dsSyntaxExpr neg_expr [expr'] }  dsExpr (HsLam _ a_Match)-  = uncurry mkLams <$> matchWrapper LambdaExpr Nothing a_Match+  = uncurry mkCoreLams <$> matchWrapper LambdaExpr Nothing a_Match -dsExpr (HsLamCase _ matches)-  = do { ([discrim_var], matching_code) <- matchWrapper CaseAlt Nothing matches-       ; return $ Lam discrim_var matching_code }+dsExpr (HsLamCase _ lc_variant matches)+  = uncurry mkCoreLams <$> matchWrapper (LamCaseAlt lc_variant) Nothing matches  dsExpr e@(HsApp _ fun arg)   = do { fun' <- dsLExpr fun-       ; dsWhenNoErrs (dsLExprNoLP arg)-                      (\arg' -> mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg') }+       ; arg' <- dsLExpr arg+       ; return $ mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg' }  dsExpr e@(HsAppType {}) = dsHsWrapped e @@ -342,35 +332,33 @@   = do { let go (lam_vars, args) (Missing (Scaled mult ty))                     -- For every missing expression, we need                     -- another lambda in the desugaring.-               = do { lam_var <- newSysLocalDsNoLP mult ty+               = do { lam_var <- newSysLocalDs mult ty                     ; return (lam_var : lam_vars, Var lam_var : args) }              go (lam_vars, args) (Present _ expr)                     -- Expressions that are present don't generate                     -- lambdas, just arguments.-               = do { core_expr <- dsLExprNoLP expr+               = do { core_expr <- dsLExpr expr                     ; return (lam_vars, core_expr : args) } -       ; dsWhenNoErrs (foldM go ([], []) (reverse tup_args))+       ; (lam_vars, args) <- foldM go ([], []) (reverse tup_args)                 -- The reverse is because foldM goes left-to-right-                      (\(lam_vars, args) ->-                        mkCoreLams lam_vars $-                          mkCoreTupBoxity boxity args) }+       ; return $ mkCoreLams lam_vars (mkCoreTupBoxity boxity args) }                         -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make  dsExpr (ExplicitSum types alt arity expr)-  = dsWhenNoErrs (dsLExprNoLP expr) (mkCoreUbxSum arity alt types)+  = mkCoreUbxSum arity alt types <$> dsLExpr expr  dsExpr (HsPragE _ prag expr) =   ds_prag_expr prag expr  dsExpr (HsCase _ discrim matches)   = do { core_discrim <- dsLExpr discrim-       ; ([discrim_var], matching_code) <- matchWrapper CaseAlt (Just discrim) matches+       ; ([discrim_var], matching_code) <- matchWrapper CaseAlt (Just [discrim]) matches        ; return (bindNonRec discrim_var core_discrim matching_code) }  -- Pepe: The binds are in scope in the body but NOT in the binding group --       This is to avoid silliness in breakpoints-dsExpr (HsLet _ binds body) = do+dsExpr (HsLet _ _ binds _ body) = do     body' <- dsLExpr body     dsLocalBinds binds body' @@ -428,9 +416,9 @@     g = ... makeStatic loc f ... -} -dsExpr (HsStatic _ expr@(L loc _)) = do-    expr_ds <- dsLExprNoLP expr-    let ty = exprType expr_ds+dsExpr (HsStatic (_, whole_ty) expr@(L loc _)) = do+    expr_ds <- dsLExpr expr+    let (_, [ty]) = splitTyConApp whole_ty     makeStaticId <- dsLookupGlobalId makeStaticName      dflags <- getDynFlags@@ -483,8 +471,8 @@               mk_arg (arg_ty, fl)                = case findField (rec_flds rbinds) (flSelector fl) of-                   (rhs:rhss) -> ASSERT( null rhss )-                                 dsLExprNoLP rhs+                   (rhs:rhss) -> assert (null rhss)+                                 dsLExpr rhs                    []         -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr (flLabel fl))              unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty @@ -602,7 +590,7 @@   | null fields   = dsLExpr record_expr   | otherwise-  = ASSERT2( notNull cons_to_upd, ppr expr )+  = assertPpr (notNull cons_to_upd) (ppr expr) $      do  { record_expr' <- dsLExpr record_expr         ; field_binds' <- mapM ds_field fields@@ -615,7 +603,7 @@         -- constructor arguments.         ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd         ; ([discrim_var], matching_code)-                <- matchWrapper RecUpd (Just record_expr) -- See Note [Scrutinee in Record updates]+                <- matchWrapper RecUpd (Just [record_expr]) -- See Note [Scrutinee in Record updates]                                       (MG { mg_alts = noLocA alts                                           , mg_ext = MatchGroupTc [unrestricted in_ty] out_ty                                           , mg_origin = FromSource@@ -632,7 +620,7 @@       -- else we shadow other uses of the record selector       -- Hence 'lcl_id'.  Cf #2735     ds_field (L _ rec_field)-      = do { rhs <- dsLExpr (hsRecFieldArg rec_field)+      = do { rhs <- dsLExpr (hfbRHS rec_field)            ; let fld_id = unLoc (hsRecUpdFieldId rec_field)            ; lcl_id <- newSysLocalDs (idMult fld_id) (idType fld_id)            ; return (idName fld_id, lcl_id, rhs) }@@ -678,7 +666,7 @@                  mk_val_arg fl pat_arg_id                      = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id) -                 inst_con = noLocA $ mkHsWrap wrap (HsConLikeOut noExtField con)+                 inst_con = noLocA $ mkHsWrap wrap (mkConLikeTc con)                         -- Reconstruct with the WrapId so that unpacking happens                  wrap = mkWpEvVarApps theta_vars                                <.>                         dict_req_wrap                                           <.>@@ -755,50 +743,28 @@ -- Here is where we desugar the Template Haskell brackets and escapes  -- Template Haskell stuff+-- See Note [The life cycle of a TH quotation] -dsExpr (HsRnBracketOut _ _ _)  = panic "dsExpr HsRnBracketOut"-dsExpr (HsTcBracketOut _ hs_wrapper x ps) = dsBracket hs_wrapper x ps-dsExpr (HsSpliceE _ s)         = pprPanic "dsExpr:splice" (ppr s)+dsExpr (HsTypedBracket   (HsBracketTc q _ hs_wrapper ps) _) = dsBracket hs_wrapper q ps+dsExpr (HsUntypedBracket (HsBracketTc q _ hs_wrapper ps) _) = dsBracket hs_wrapper q ps+dsExpr (HsSpliceE _ s) = pprPanic "dsExpr:splice" (ppr s)  -- Arrow notation extension dsExpr (HsProc _ pat cmd) = dsProcExpr pat cmd --- Hpc Support -dsExpr (HsTick _ tickish e) = do-  e' <- dsLExpr e-  return (Tick tickish e')---- There is a problem here. The then and else branches--- have no free variables, so they are open to lifting.--- We need someway of stopping this.--- This will make no difference to binary coverage--- (did you go here: YES or NO), but will effect accurate--- tick counting.--dsExpr (HsBinTick _ ixT ixF e) = do-  e2 <- dsLExpr e-  do { ASSERT(exprType e2 `eqType` boolTy)-       mkBinaryTickBox ixT ixF e2-     }-- -- HsSyn constructs that just shouldn't be here, because -- the renamer removed them.  See GHC.Rename.Expr. -- Note [Handling overloaded and rebindable constructs]-dsExpr (HsOverLabel x _) = absurd x-dsExpr (OpApp x _ _ _)   = absurd x-dsExpr (SectionL x _ _)  = absurd x-dsExpr (SectionR x _ _)  = absurd x---- HsSyn constructs that just shouldn't be here:-dsExpr (HsBracket   {}) = panic "dsExpr:HsBracket"-dsExpr (HsDo        {}) = panic "dsExpr:HsDo"+dsExpr (HsOverLabel x _) = dataConCantHappen x+dsExpr (OpApp x _ _ _)   = dataConCantHappen x+dsExpr (SectionL x _ _)  = dataConCantHappen x+dsExpr (SectionR x _ _)  = dataConCantHappen x  ds_prag_expr :: HsPragE GhcTc -> LHsExpr GhcTc -> DsM CoreExpr ds_prag_expr (HsPragSCC _ _ cc) expr = do     dflags <- getDynFlags-    if sccProfilingEnabled dflags+    if sccProfilingEnabled dflags && gopt Opt_ProfManualCcs dflags       then do         mod_name <- getModule         count <- goptM Opt_ProfCountEntries@@ -818,18 +784,13 @@        ; core_arg_wraps <- mapM dsHsWrapper arg_wraps        ; core_res_wrap  <- dsHsWrapper res_wrap        ; let wrapped_args = zipWithEqual "dsSyntaxExpr" ($) core_arg_wraps arg_exprs-       ; dsWhenNoErrs (zipWithM_ dsNoLevPolyExpr wrapped_args [ mk_doc n | n <- [1..] ])-                      (\_ -> core_res_wrap (mkCoreApps fun wrapped_args)) }-                      -- Use mkCoreApps instead of mkApps:-                      -- unboxed types are possible with RebindableSyntax (#19883)-  where-    mk_doc n = text "In the" <+> speakNth n <+> text "argument of" <+> quotes (ppr expr)+       ; return $ core_res_wrap (mkCoreApps fun wrapped_args) } dsSyntaxExpr NoSyntaxExprTc _ = panic "dsSyntaxExpr"  findField :: [LHsRecField GhcTc arg] -> Name -> [arg] findField rbinds sel-  = [hsRecFieldArg fld | L _ fld <- rbinds-                       , sel == idName (unLoc $ hsRecFieldId fld) ]+  = [hfbRHS fld | L _ fld <- rbinds+                       , sel == idName (hsRecFieldId fld) ]  {- %--------------------------------------------------------------------@@ -896,7 +857,7 @@ -- See Note [Desugaring explicit lists] dsExplicitList elt_ty xs   = do { dflags <- getDynFlags-       ; xs' <- mapM dsLExprNoLP xs+       ; xs' <- mapM dsLExpr xs        ; if xs' `lengthExceeds` maxBuildLength                 -- Don't generate builds if the list is very long.          || null xs'@@ -912,25 +873,25 @@  dsArithSeq :: PostTcExpr -> (ArithSeqInfo GhcTc) -> DsM CoreExpr dsArithSeq expr (From from)-  = App <$> dsExpr expr <*> dsLExprNoLP from+  = App <$> dsExpr expr <*> dsLExpr from dsArithSeq expr (FromTo from to)   = do fam_envs <- dsGetFamInstEnvs        dflags <- getDynFlags        warnAboutEmptyEnumerations fam_envs dflags from Nothing to        expr' <- dsExpr expr-       from' <- dsLExprNoLP from-       to'   <- dsLExprNoLP to+       from' <- dsLExpr from+       to'   <- dsLExpr to        return $ mkApps expr' [from', to'] dsArithSeq expr (FromThen from thn)-  = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, thn]+  = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn] dsArithSeq expr (FromThenTo from thn to)   = do fam_envs <- dsGetFamInstEnvs        dflags <- getDynFlags        warnAboutEmptyEnumerations fam_envs dflags from (Just thn) to        expr' <- dsExpr expr-       from' <- dsLExprNoLP from-       thn'  <- dsLExprNoLP thn-       to'   <- dsLExprNoLP to+       from' <- dsLExpr from+       thn'  <- dsLExpr thn+       to'   <- dsLExpr to        return $ mkApps expr' [from', thn', to']  {-@@ -939,7 +900,7 @@ Haskell 98 report: -} -dsDo :: HsStmtContext GhcRn -> [ExprLStmt GhcTc] -> DsM CoreExpr+dsDo :: HsDoFlavour -> [ExprLStmt GhcTc] -> DsM CoreExpr dsDo ctx stmts   = goL stmts   where@@ -947,7 +908,7 @@     goL ((L loc stmt):lstmts) = putSrcSpanDsA loc (go loc stmt lstmts)      go _ (LastStmt _ body _ _) stmts-      = ASSERT( null stmts ) dsLExpr body+      = assert (null stmts ) dsLExpr body         -- The 'return' op isn't used for 'do' expressions      go _ (BodyStmt _ rhs then_expr _) stmts@@ -964,7 +925,7 @@       = do  { body     <- goL stmts             ; rhs'     <- dsLExpr rhs             ; var   <- selectSimpleMatchVarL (xbstc_boundResultMult xbs) pat-            ; match <- matchSinglePatVar var Nothing (StmtCtxt ctx) pat+            ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt ctx)) pat                          (xbstc_boundResultType xbs) (cantFailMatchResult body)             ; match_code <- dsHandleMonadicFailure ctx pat match (xbstc_failOp xbs)             ; dsSyntaxExpr (xbstc_bindOp xbs) [rhs', Lam var match_code] }@@ -984,9 +945,8 @@            ; body' <- dsLExpr $ noLocA $ HsDo body_ty ctx (noLocA stmts)             ; let match_args (pat, fail_op) (vs,body)-                   = putSrcSpanDs (getLocA pat) $-                     do { var   <- selectSimpleMatchVarL Many pat-                        ; match <- matchSinglePatVar var Nothing (StmtCtxt ctx) pat+                   = do { var   <- selectSimpleMatchVarL Many pat+                        ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt ctx)) pat                                    body_ty (cantFailMatchResult body)                         ; match_code <- dsHandleMonadicFailure ctx pat match fail_op                         ; return (var:vs, match_code)@@ -1052,13 +1012,15 @@ -}  dsHsVar :: Id -> DsM CoreExpr+-- We could just call dsHsUnwrapped; but this is a short-cut+-- for the very common case of a variable with no wrapper. dsHsVar var-  = do { checkLevPolyFunction (ppr var) var (idType var)-       ; return (varToCoreExpr var) }   -- See Note [Desugaring vars]+  = return (varToCoreExpr var) -- See Note [Desugaring vars] -dsConLike :: ConLike -> DsM CoreExpr-dsConLike (RealDataCon dc) = dsHsVar (dataConWrapId dc)-dsConLike (PatSynCon ps)+dsHsConLike :: ConLike -> DsM CoreExpr+dsHsConLike (RealDataCon dc)+  = return (varToCoreExpr (dataConWrapId dc))+dsHsConLike (PatSynCon ps)   | Just (builder_name, _, add_void) <- patSynBuilder ps   = do { builder_id <- dsLookupGlobalId builder_name        ; return (if add_void@@ -1068,6 +1030,24 @@   | otherwise   = pprPanic "dsConLike" (ppr ps) +dsConLike :: ConLike -> [TcTyVar] -> [Scaled Type] -> DsM CoreExpr+-- This function desugars ConLikeTc+-- See Note [Typechecking data constructors] in GHC.Tc.Gen.Head+--     for what is going on here+dsConLike con tvs tys+  = do { ds_con <- dsHsConLike con+       ; ids    <- newSysLocalsDs tys+                   -- newSysLocalDs: /can/ be lev-poly; see+       ; return (mkLams tvs $+                 mkLams ids $+                 ds_con `mkTyApps` mkTyVarTys tvs+                        `mkVarApps` drop_stupid ids) }+  where++    drop_stupid = dropList (conLikeStupidTheta con)+    -- drop_stupid: see Note [Instantiating stupid theta]+    --              in GHC.Tc.Gen.Head+ {- ************************************************************************ *                                                                      *@@ -1088,8 +1068,7 @@             -- Warn about discarding non-() things in 'monadic' binding        ; if warn_unused && not (isUnitTy norm_elt_ty)-         then warnDs (Reason Opt_WarnUnusedDoBind)-                     (badMonadBind rhs elt_ty)+         then diagnosticDs (DsUnusedDoBind rhs elt_ty)          else             -- Warn about discarding m a things in 'monadic' binding of the same type,@@ -1098,136 +1077,42 @@                 case tcSplitAppTy_maybe norm_elt_ty of                       Just (elt_m_ty, _)                          | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty-                         -> warnDs (Reason Opt_WarnWrongDoBind)-                                   (badMonadBind rhs elt_ty)+                         -> diagnosticDs (DsWrongDoBind rhs elt_ty)                       _ -> return () } }    | otherwise   -- RHS does have type of form (m ty), which is weird   = return ()   -- but at least this warning is irrelevant -badMonadBind :: LHsExpr GhcTc -> Type -> SDoc-badMonadBind rhs elt_ty-  = vcat [ hang (text "A do-notation statement discarded a result of type")-              2 (quotes (ppr elt_ty))-         , hang (text "Suppress this warning by saying")-              2 (quotes $ text "_ <-" <+> ppr rhs)-         ]- {- ************************************************************************ *                                                                      *-            Levity polymorphism checks+            dsHsWrapped *                                                                      * ************************************************************************--Note [Checking for levity-polymorphic functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We cannot have levity polymorphic function arguments. See-Note [Levity polymorphism invariants] in GHC.Core. That is-checked by dsLExprNoLP.--But what about-  const True (unsafeCoerce# :: forall r1 r2 (a :: TYPE r1) (b :: TYPE r2). a -> b)--Since `unsafeCoerce#` has no binding, it has a compulsory unfolding.-But that compulsory unfolding is a levity-polymorphic lambda, which-is no good.  So we want to reject this.  On the other hand-  const True (unsafeCoerce# @LiftedRep @UnliftedRep)-is absolutely fine.--We have to collect all the type-instantiation and *then* check.  That-is what dsHsWrapped does.  Because we might have an HsVar without a-wrapper, we check in dsHsVar as well. typecheck/should_fail/T17021-triggers this case.--Note that if `f :: forall r (a :: Type r). blah`, then-   const True f-is absolutely fine.  Here `f` is a function, represented by a-pointer, and we can pass it to `const` (or anything else).  (See-#12708 for an example.)  It's only the Id.hasNoBinding functions-that are a problem.--Interestingly, this approach does not look to see whether the Id in-question will be eta expanded. The logic is this:-  * Either the Id in question is saturated or not.-  * If it is, then it surely can't have levity polymorphic arguments.-    If its wrapped type contains levity polymorphic arguments, reject.-  * If it's not, then it can't be eta expanded with levity polymorphic-    argument. If its wrapped type contains levity polymorphic arguments, reject.-So, either way, we're good to reject.- -}  ------------------------------ dsHsWrapped :: HsExpr GhcTc -> DsM CoreExpr--- Looks for a function 'f' wrapped in type applications (HsAppType)--- or wrappers (HsWrap), and checks that any hasNoBinding function--- is not levity polymorphic, *after* instantiation with those wrappers dsHsWrapped orig_hs_expr-  = go id orig_hs_expr+  = go idHsWrapper orig_hs_expr   where-    go wrap (XExpr (WrapExpr (HsWrap co_fn hs_e)))-       = do { wrap' <- dsHsWrapper co_fn-            ; addTyCs FromSource (hsWrapDictBinders co_fn) $-              go (wrap . wrap') hs_e }-    go wrap (HsConLikeOut _ (RealDataCon dc))-      = go_head wrap (dataConWrapId dc)-    go wrap (HsAppType ty hs_e _) = go_l (wrap . (\e -> App e (Type ty))) hs_e-    go wrap (HsPar _ hs_e)        = go_l wrap hs_e-    go wrap (HsVar _ (L _ var))   = go_head wrap var-    go wrap hs_e                  = do { e <- dsExpr hs_e; return (wrap e) }--    go_l wrap (L _ hs_e) = go wrap hs_e--    go_head wrap var-      = do { let wrapped_e  = wrap (Var var)-                 wrapped_ty = exprType wrapped_e--           ; checkLevPolyFunction (ppr orig_hs_expr) var wrapped_ty-             -- See Note [Checking for levity-polymorphic functions]-             -- Pass orig_hs_expr, so that the user can see entire-             -- expression with -fprint-typechecker-elaboration+    go wrap (HsPar _ _ (L _ hs_e) _)+       = go wrap hs_e+    go wrap1 (XExpr (WrapExpr (HsWrap wrap2 hs_e)))+       = go (wrap1 <.> wrap2) hs_e+    go wrap (HsAppType ty (L _ hs_e) _)+       = go (wrap <.> WpTyApp ty) hs_e +    go wrap (HsVar _ (L _ var))+      = do { wrap' <- dsHsWrapper wrap+           ; let expr = wrap' (varToCoreExpr var)+                 ty   = exprType expr            ; dflags <- getDynFlags-           ; warnAboutIdentities dflags var wrapped_ty--           ; return wrapped_e }----- | Takes a (pretty-printed) expression, a function, and its--- instantiated type.  If the function is a hasNoBinding op, and the--- type has levity-polymorphic arguments, issue an error.--- Note [Checking for levity-polymorphic functions]-checkLevPolyFunction :: SDoc -> Id -> Type -> DsM ()-checkLevPolyFunction pp_hs_expr var ty-  | let bad_tys = isBadLevPolyFunction var ty-  , not (null bad_tys)-  = errDs $ vcat-    [ hang (text "Cannot use function with levity-polymorphic arguments:")-         2 (pp_hs_expr <+> dcolon <+> pprWithTYPE ty)-    , ppUnlessOption sdocPrintTypecheckerElaboration $ vcat-        [ text "(Note that levity-polymorphic primops such as 'coerce' and unboxed tuples"-        , text "are eta-expanded internally because they must occur fully saturated."-        , text "Use -fprint-typechecker-elaboration to display the full expression.)"-        ]-    , hang (text "Levity-polymorphic arguments:")-         2 $ vcat $ map-           (\t -> pprWithTYPE t <+> dcolon <+> pprWithTYPE (typeKind t))-           bad_tys-    ]--checkLevPolyFunction _ _ _ = return ()+           ; warnAboutIdentities dflags var ty+           ; return expr } --- | Is this a hasNoBinding Id with a levity-polymorphic type?--- Returns the arguments that are levity polymorphic if they are bad;--- or an empty list otherwise--- Note [Checking for levity-polymorphic functions]-isBadLevPolyFunction :: Id -> Type -> [Type]-isBadLevPolyFunction id ty-  | hasNoBinding id-  = filter isTypeLevPoly arg_tys-  | otherwise-  = []-  where-    (binders, _) = splitPiTys ty-    arg_tys      = mapMaybe binderRelevantType_maybe binders+    go wrap hs_e+       = do { wrap' <- dsHsWrapper wrap+            ; addTyCs FromSource (hsWrapDictBinders wrap) $+              do { e <- dsExpr hs_e+                 ; return (wrap' e) } }
compiler/GHC/HsToCore/Expr.hs-boot view
@@ -5,6 +5,6 @@ import GHC.Hs.Extension ( GhcTc)  dsExpr  :: HsExpr GhcTc -> DsM CoreExpr-dsLExpr, dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr+dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr dsLocalBinds :: HsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
compiler/GHC/HsToCore/Foreign/Call.hs view
@@ -6,8 +6,8 @@ Desugaring foreign calls -} -{-# LANGUAGE CPP #-} + {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  module GHC.HsToCore.Foreign.Call@@ -19,8 +19,6 @@    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Core@@ -46,8 +44,8 @@ import GHC.Builtin.Names import GHC.Driver.Session import GHC.Utils.Outputable-import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain  import Data.Maybe @@ -90,7 +88,7 @@  dsCCall :: CLabelString -- C routine to invoke         -> [CoreExpr]   -- Arguments (desugared)-                        -- Precondition: none have levity-polymorphic types+        -- Precondition: none have representation-polymorphic types         -> Safety       -- Safety of the call         -> Type         -- Type of the result: IO t         -> DsM CoreExpr -- Result, of type ???@@ -99,14 +97,13 @@   = do (unboxed_args, arg_wrappers) <- mapAndUnzipM unboxArg args        (ccall_result_ty, res_wrapper) <- boxResult result_ty        uniq <- newUnique-       dflags <- getDynFlags        let            target = StaticTarget NoSourceText lbl Nothing True            the_fcall    = CCall (CCallSpec target CCallConv may_gc)-           the_prim_app = mkFCall dflags uniq the_fcall unboxed_args ccall_result_ty+           the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty        return (foldr ($) (res_wrapper the_prim_app) arg_wrappers) -mkFCall :: DynFlags -> Unique -> ForeignCall+mkFCall :: Unique -> ForeignCall         -> [CoreExpr]     -- Args         -> Type           -- Result type         -> CoreExpr@@ -119,17 +116,17 @@ -- Here we build a ccall thus --      (ccallid::(forall a b.  StablePtr (a -> b) -> Addr -> Char -> IO Addr)) --                      a b s x c-mkFCall dflags uniq the_fcall val_args res_ty-  = ASSERT( all isTyVar tyvars )  -- this must be true because the type is top-level+mkFCall uniq the_fcall val_args res_ty+  = assert (all isTyVar tyvars) $ -- this must be true because the type is top-level     mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args   where     arg_tys = map exprType val_args     body_ty = (mkVisFunTysMany arg_tys res_ty)     tyvars  = tyCoVarsOfTypeWellScoped body_ty     ty      = mkInfForAllTys tyvars body_ty-    the_fcall_id = mkFCallId dflags uniq the_fcall ty+    the_fcall_id = mkFCallId uniq the_fcall ty -unboxArg :: CoreExpr                    -- The supplied argument, not levity-polymorphic+unboxArg :: CoreExpr                    -- The supplied argument, not representation-polymorphic          -> DsM (CoreExpr,              -- To pass as the actual argument                  CoreExpr -> CoreExpr   -- Wrapper to unbox the arg                 )@@ -137,7 +134,7 @@ --      (x#::Int#, \W. case x of I# x# -> W) -- where W is a CoreExpr that probably mentions x# --- always returns a non-levity-polymorphic expression+-- always returns a non-representation-polymorphic expression  unboxArg arg   -- Primitive types: nothing to unbox@@ -163,7 +160,7 @@   -- Data types with a single constructor, which has a single, primitive-typed arg   -- This deals with Int, Float etc; also Ptr, ForeignPtr   | is_product_type && data_con_arity == 1-  = ASSERT2(isUnliftedType data_con_arg_ty1, pprType arg_ty)+  = assertPpr (isUnliftedType data_con_arg_ty1) (pprType arg_ty) $                         -- Typechecker ensures this     do case_bndr <- newSysLocalDs Many arg_ty        prim_arg <- newSysLocalDs Many data_con_arg_ty1@@ -226,17 +223,10 @@         -- another case, and a coercion.)         -- The result is IO t, so wrap the result in an IO constructor   = do  { res <- resultWrapper io_res_ty-        ; let extra_result_tys-                = case res of-                     (Just ty,_)-                       | isUnboxedTupleType ty-                       -> let Just ls = tyConAppArgs_maybe ty in tail ls-                     _ -> []--              return_result state anss+        ; let return_result state anss                 = mkCoreUbxTup-                    (realWorldStatePrimTy : io_res_ty : extra_result_tys)-                    (state : anss)+                    [realWorldStatePrimTy, io_res_ty]+                    [state, anss]          ; (ccall_res_ty, the_alt) <- mk_alt return_result res @@ -268,11 +258,10 @@                                            [the_alt]        return (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap)   where-    return_result _ [ans] = ans-    return_result _ _     = panic "return_result: expected single result"+    return_result _ ans = ans  -mk_alt :: (Expr Var -> [Expr Var] -> Expr Var)+mk_alt :: (Expr Var -> Expr Var -> Expr Var)        -> (Maybe Type, Expr Var -> Expr Var)        -> DsM (Type, CoreAlt) mk_alt return_result (Nothing, wrap_result)@@ -280,7 +269,7 @@        state_id <- newSysLocalDs Many realWorldStatePrimTy        let              the_rhs = return_result (Var state_id)-                                     [wrap_result (panic "boxResult")]+                                     (wrap_result (panic "boxResult"))               ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy]              the_alt      = Alt (DataAlt (tupleDataCon Unboxed 1)) [state_id] the_rhs@@ -289,12 +278,12 @@  mk_alt return_result (Just prim_res_ty, wrap_result)   = -- The ccall returns a non-() value-    ASSERT2( isPrimitiveType prim_res_ty, ppr prim_res_ty )+    assertPpr (isPrimitiveType prim_res_ty) (ppr prim_res_ty) $              -- True because resultWrapper ensures it is so     do { result_id <- newSysLocalDs Many prim_res_ty        ; state_id <- newSysLocalDs Many realWorldStatePrimTy        ; let the_rhs = return_result (Var state_id)-                                [wrap_result (Var result_id)]+                                (wrap_result (Var result_id))              ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy, prim_res_ty]              the_alt      = Alt (DataAlt (tupleDataCon Unboxed 2)) [state_id, result_id] the_rhs        ; return (ccall_res_ty, the_alt) }
compiler/GHC/HsToCore/Foreign/Decl.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} @@ -14,7 +14,6 @@  module GHC.HsToCore.Foreign.Decl ( dsForeigns ) where -#include "GhclibHsVersions.h" import GHC.Prelude  import GHC.Tc.Utils.Monad        -- temp@@ -23,6 +22,7 @@  import GHC.HsToCore.Foreign.Call import GHC.HsToCore.Monad+import GHC.HsToCore.Types (ds_next_wrapper_num)  import GHC.Hs import GHC.Core.DataCon@@ -43,6 +43,7 @@  import GHC.Cmm.Expr import GHC.Cmm.Utils+import GHC.Cmm.CLabel import GHC.Driver.Ppr import GHC.Types.ForeignCall import GHC.Builtin.Types@@ -56,8 +57,8 @@ import GHC.Driver.Config import GHC.Platform import GHC.Data.OrdList-import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Driver.Hooks import GHC.Utils.Encoding @@ -95,11 +96,12 @@   = return (NoStubs, nilOL) dsForeigns' fos = do     mod <- getModule+    platform <- targetPlatform <$> getDynFlags     fives <- mapM do_ldecl fos     let         (hs, cs, idss, bindss) = unzip4 fives         fe_ids = concat idss-        fe_init_code = foreignExportsInitialiser mod fe_ids+        fe_init_code = foreignExportsInitialiser platform mod fe_ids     --     return (ForeignStubs              (mconcat hs)@@ -173,7 +175,7 @@                  IsFunction              _ -> IsData    (resTy, foRhs) <- resultWrapper ty-   ASSERT(fromJust resTy `eqType` addrPrimTy)    -- typechecker ensures this+   assert (fromJust resTy `eqType` addrPrimTy) $    -- typechecker ensures this     let         rhs = foRhs (Lit (LitLabel cid stdcall_info fod))         rhs' = Cast rhs co@@ -218,7 +220,7 @@         (tv_bndrs, rho)      = tcSplitForAllTyVarBinders ty         (arg_tys, io_res_ty) = tcSplitFunTys rho -    args <- newSysLocalsDs arg_tys  -- no FFI levity-polymorphism+    args <- newSysLocalsDs arg_tys  -- no FFI representation polymorphism     (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args)      let@@ -229,12 +231,12 @@     ccall_uniq <- newUnique     work_uniq  <- newUnique -    dflags <- getDynFlags     (fcall', cDoc) <-               case fcall of               CCall (CCallSpec (StaticTarget _ cName mUnitId isFun)                                CApiConv safety) ->-               do wrapperName <- mkWrapperName "ghc_wrapper" (unpackFS cName)+               do nextWrapperNum <- ds_next_wrapper_num <$> getGblEnv+                  wrapperName <- mkWrapperName nextWrapperNum "ghc_wrapper" (unpackFS cName)                   let fcall' = CCall (CCallSpec                                       (StaticTarget NoSourceText                                                     wrapperName mUnitId@@ -278,11 +280,12 @@                   return (fcall', c)               _ ->                   return (fcall, empty)+    dflags <- getDynFlags     let         -- Build the worker         worker_ty     = mkForAllTys tv_bndrs (mkVisFunTysMany (map idType work_arg_ids) ccall_result_ty)         tvs           = map binderVar tv_bndrs-        the_ccall_app = mkFCall dflags ccall_uniq fcall' val_args ccall_result_ty+        the_ccall_app = mkFCall ccall_uniq fcall' val_args ccall_result_ty         work_rhs      = mkLams tvs (mkLams work_arg_ids the_ccall_app)         work_id       = mkSysLocal (fsLit "$wccall") work_uniq Many worker_ty @@ -297,7 +300,7 @@                                                 simpl_opts                                                 wrap_rhs' -    return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], mempty, CStub cDoc)+    return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], mempty, CStub cDoc [] [])  {- ************************************************************************@@ -322,12 +325,11 @@         (tvs, fun_ty)        = tcSplitForAllInvisTyVars ty         (arg_tys, io_res_ty) = tcSplitFunTys fun_ty -    args <- newSysLocalsDs arg_tys  -- no FFI levity-polymorphism+    args <- newSysLocalsDs arg_tys  -- no FFI representation polymorphism      ccall_uniq <- newUnique-    dflags <- getDynFlags     let-        call_app = mkFCall dflags ccall_uniq fcall (map Var args) io_res_ty+        call_app = mkFCall ccall_uniq fcall (map Var args) io_res_ty         rhs      = mkLams tvs (mkLams args call_app)         rhs'     = Cast rhs co     return ([(fn_id, rhs')], mempty, mempty)@@ -526,7 +528,9 @@                    Int          -- total size of arguments                   ) mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc- = (header_bits, c_bits, type_string,+ = ( header_bits+   , CStub body [] []+   , type_string,     sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args          -- NB. the calculation here isn't strictly speaking correct.          -- We have a primitive Haskell type (eg. Int#, Double#), and@@ -646,7 +650,7 @@     -- finally, the whole darn thing-  c_bits = CStub $+  body =     space $$     extern_decl $$     fun_proto  $$@@ -662,9 +666,9 @@                 text "rts_apply" <> parens (                     cap <>                     text "(HaskellObj)"-                 <> ptext (if is_IO_res_ty-                                then (sLit "runIO_closure")-                                else (sLit "runNonIO_closure"))+                 <> (if is_IO_res_ty+                      then text "runIO_closure"+                      else text "runNonIO_closure")                  <> comma                  <> expr_to_run                 ) <+> comma@@ -682,9 +686,9 @@      , rbrace      ] --foreignExportsInitialiser :: Module -> [Id] -> CStub-foreignExportsInitialiser mod hs_fns =+foreignExportsInitialiser :: Platform -> Module -> [Id] -> CStub+foreignExportsInitialiser _        _   []     = mempty+foreignExportsInitialiser platform mod hs_fns =    -- Initialise foreign exports by registering a stable pointer from an    -- __attribute__((constructor)) function.    -- The alternative is to do this from stginit functions generated in@@ -695,21 +699,18 @@    -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL)    --    -- See Note [Tracking foreign exports] in rts/ForeignExports.c-   CStub $ vcat-    [ text "static struct ForeignExportsList" <+> list_symbol <+> equals+   initializerCStub platform fn_nm list_decl fn_body+  where+    fn_nm       = mkInitializerStubLabel mod "fexports"+    mod_str     = pprModuleName (moduleName mod)+    fn_body     = text "registerForeignExports" <> parens (char '&' <> list_symbol) <> semi+    list_symbol = text "stg_exports_" <> mod_str+    list_decl   = text "static struct ForeignExportsList" <+> list_symbol <+> equals          <+> braces (            text ".exports = " <+> export_list <> comma <+>            text ".n_entries = " <+> ppr (length hs_fns))          <> semi-    , text "static void " <> ctor_symbol <> text "(void)"-         <+> text " __attribute__((constructor));"-    , text "static void " <> ctor_symbol <> text "()"-    , braces (text "registerForeignExports" <> parens (char '&' <> list_symbol) <> semi)-    ]-  where-    mod_str = pprModuleName (moduleName mod)-    ctor_symbol = text "stginit_export_" <> mod_str-    list_symbol = text "stg_exports_" <> mod_str+     export_list = braces $ pprWithCommas closure_ptr hs_fns      closure_ptr :: Id -> SDoc@@ -817,8 +818,10 @@   | otherwise =   case splitDataProductType_maybe rep_ty of      Just (_, _, data_con, [Scaled _ prim_ty]) ->-        ASSERT(dataConSourceArity data_con == 1)-        ASSERT2(isUnliftedType prim_ty, ppr prim_ty)+        assert (dataConSourceArity data_con == 1) $+        assertPpr (isUnliftedType prim_ty) (ppr prim_ty)+          -- NB: it's OK to call isUnliftedType here, as we don't allow+          -- representation-polymorphic types in foreign import/export declarations         prim_ty      _other -> pprPanic "GHC.HsToCore.Foreign.Decl.getPrimTyOf" (ppr ty)   where
compiler/GHC/HsToCore/GuardedRHSs.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -10,8 +10,6 @@  module GHC.HsToCore.GuardedRHSs ( dsGuarded, dsGRHSs, isTrueLHsExpr ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import {-# SOURCE #-} GHC.HsToCore.Expr  ( dsLExpr, dsLocalBinds )@@ -30,6 +28,7 @@ import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Core.Multiplicity import Control.Monad ( zipWithM ) import Data.List.NonEmpty ( NonEmpty, toList )@@ -50,7 +49,8 @@ dsGuarded :: GRHSs GhcTc (LHsExpr GhcTc) -> Type -> NonEmpty Nablas -> DsM CoreExpr dsGuarded grhss rhs_ty rhss_nablas = do     match_result <- dsGRHSs PatBindRhs grhss rhs_ty rhss_nablas-    error_expr <- mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty empty+    error_expr <- mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty+                               (text "pattern binding")     extractMatchResult match_result error_expr  -- In contrast, @dsGRHSs@ produces a @MatchResult CoreExpr@.@@ -63,8 +63,8 @@                                        --   one for each GRHS.         -> DsM (MatchResult CoreExpr) dsGRHSs hs_ctx (GRHSs _ grhss binds) rhs_ty rhss_nablas-  = ASSERT( notNull grhss )-    do { match_results <- ASSERT( length grhss == length rhss_nablas )+  = assert (notNull grhss) $+    do { match_results <- assert (length grhss == length rhss_nablas) $                           zipWithM (dsGRHS hs_ctx rhs_ty) (toList rhss_nablas) grhss        ; nablas <- getPmNablas        -- We need to remember the Nablas from the particular match context we
compiler/GHC/HsToCore/ListComp.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP            #-}+ {-# LANGUAGE TypeFamilies   #-}  {-@@ -11,14 +11,12 @@  module GHC.HsToCore.ListComp ( dsListComp, dsMonadComp ) where -#include "GhclibHsVersions.h"- import GHC.Prelude -import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr )+import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsLExpr, dsLocalBinds, dsSyntaxExpr )  import GHC.Hs-import GHC.Tc.Utils.Zonk+import GHC.Hs.Syn.Type import GHC.Core import GHC.Core.Make @@ -35,9 +33,9 @@ import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Tc.Utils.TcType import GHC.Data.List.SetOps( getNth )-import GHC.Utils.Misc  {- List comprehensions may be desugared in one of two ways: ``ordinary''@@ -140,9 +138,6 @@                 , Var unzip_fn'                 , inner_list_expr' ] -    dsNoLevPoly (tcFunResultTyN (length usingArgs') (exprType usingExpr'))-      (text "In the result of a" <+> quotes (text "using") <+> text "function:" <+> ppr using)-     -- Build a pattern that ensures the consumer binds into the NEW binders,     -- which hold lists rather than single values     let pat = mkBigLHsVarPatTupId to_bndrs  -- NB: no '!@@ -222,7 +217,7 @@  deListComp (LastStmt _ body _ _ : quals) list   =     -- Figure 7.4, SLPJ, p 135, rule C above-    ASSERT( null quals )+    assert (null quals) $     do { core_body <- dsLExpr body        ; return (mkConsExpr (exprType core_body) core_body list) } @@ -242,7 +237,7 @@     deBindComp pat inner_list_expr quals list  deListComp (BindStmt _ pat list1 : quals) core_list2 = do -- rule A' above-    core_list1 <- dsLExprNoLP list1+    core_list1 <- dsLExpr list1     deBindComp pat core_list1 quals core_list2  deListComp (ParStmt _ stmtss_w_bndrs _ _ : quals) list@@ -280,8 +275,8 @@     let res_ty = exprType core_list2         h_ty   = u1_ty `mkVisFunTyMany` res_ty -       -- no levity polymorphism here, as list comprehensions don't work-       -- with RebindableSyntax. NB: These are *not* monad comps.+       -- no representation polymorphism here, as list comprehensions+       -- don't work with RebindableSyntax. NB: These are *not* monad comps.     [h, u1, u2, u3] <- newSysLocalsDs $ map unrestricted [h_ty, u1_ty, u2_ty, u3_ty]      -- the "fail" value ...@@ -290,7 +285,7 @@         letrec_body = App (Var h) core_list1      rest_expr <- deListComp quals core_fail-    core_match <- matchSimply (Var u2) (StmtCtxt ListComp) pat rest_expr core_fail+    core_match <- matchSimply (Var u2) (StmtCtxt (HsDoStmt ListComp)) pat rest_expr core_fail      let         rhs = Lam u1 $@@ -329,8 +324,8 @@ dfListComp _ _ [] = panic "dfListComp"  dfListComp c_id n_id (LastStmt _ body _ _ : quals)-  = ASSERT( null quals )-    do { core_body <- dsLExprNoLP body+  = assert (null quals) $+    do { core_body <- dsLExpr body        ; return (mkApps (Var c_id) [core_body, Var n_id]) }          -- Non-last: must be a guard@@ -378,7 +373,7 @@     core_rest <- dfListComp c_id b quals      -- build the pattern match-    core_expr <- matchSimply (Var x) (StmtCtxt ListComp)+    core_expr <- matchSimply (Var x) (StmtCtxt (HsDoStmt ListComp))                 pat core_rest (Var b)      -- now build the outermost foldr, and return@@ -485,7 +480,7 @@ dsMcStmt :: ExprStmt GhcTc -> [ExprLStmt GhcTc] -> DsM CoreExpr  dsMcStmt (LastStmt _ body _ ret_op) stmts-  = ASSERT( null stmts )+  = assert (null stmts) $     do { body' <- dsLExpr body        ; dsSyntaxExpr ret_op [body'] } @@ -551,7 +546,7 @@        ; let tup_n_ty' = mkBigCoreVarTupTy to_bndrs         ; body        <- dsMcStmts stmts_rest-       ; n_tup_var'  <- newSysLocalDsNoLP Many n_tup_ty'+       ; n_tup_var'  <- newSysLocalDs Many n_tup_ty'        ; tup_n_var'  <- newSysLocalDs Many tup_n_ty'        ; tup_n_expr' <- mkMcUnzipM form fmap_op n_tup_var' from_bndr_tys        ; us          <- newUniqueSupply@@ -616,9 +611,9 @@ dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts   = do  { body     <- dsMcStmts stmts         ; var      <- selectSimpleMatchVarL Many pat-        ; match <- matchSinglePatVar var Nothing (StmtCtxt (DoExpr Nothing)) pat+        ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt (DoExpr Nothing))) pat                                   res1_ty (cantFailMatchResult body)-        ; match_code <- dsHandleMonadicFailure (MonadComp :: HsStmtContext GhcRn) pat match fail_op+        ; match_code <- dsHandleMonadicFailure MonadComp pat match fail_op         ; dsSyntaxExpr bind_op [rhs', Lam var match_code] }  -- Desugar nested monad comprehensions, for example in `then..` constructs@@ -649,7 +644,7 @@ mkMcUnzipM :: TransForm            -> HsExpr GhcTc      -- fmap            -> Id                -- Of type n (a,b,c)-           -> [Type]            -- [a,b,c]   (not levity-polymorphic)+           -> [Type]            -- [a,b,c]   (not representation-polymorphic)            -> DsM CoreExpr      -- Of type (n a, n b, n c) mkMcUnzipM ThenForm _ ys _   = return (Var ys) -- No unzipping to do
compiler/GHC/HsToCore/Match.hs view
@@ -1,7 +1,9 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}@@ -20,18 +22,16 @@    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Platform -import {-#SOURCE#-} GHC.HsToCore.Expr (dsLExpr, dsSyntaxExpr)+import {-#SOURCE#-} GHC.HsToCore.Expr (dsExpr)  import GHC.Types.Basic ( Origin(..), isGenerated, Boxity(..) ) import GHC.Types.SourceText import GHC.Driver.Session import GHC.Hs-import GHC.Tc.Utils.Zonk+import GHC.Hs.Syn.Type import GHC.Tc.Types.Evidence import GHC.Tc.Utils.Monad import GHC.HsToCore.Pmc@@ -48,6 +48,7 @@ import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Core.PatSyn+import GHC.HsToCore.Errors.Types import GHC.HsToCore.Match.Constructor import GHC.HsToCore.Match.Literal import GHC.Core.Type@@ -61,6 +62,7 @@ import GHC.Types.Name import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Data.FastString import GHC.Types.Unique import GHC.Types.Unique.DFM@@ -184,15 +186,15 @@       -> DsM (MatchResult CoreExpr) -- ^ Desugared result!  match [] ty eqns-  = ASSERT2( not (null eqns), ppr ty )+  = assertPpr (not (null eqns)) (ppr ty) $     return (foldr1 combineMatchResults match_results)   where-    match_results = [ ASSERT( null (eqn_pats eqn) )+    match_results = [ assert (null (eqn_pats eqn)) $                       eqn_rhs eqn                     | eqn <- eqns ]  match (v:vs) ty eqns    -- Eqns *can* be empty-  = ASSERT2( all (isInternalName . idName) vars, ppr vars )+  = assertPpr (all (isInternalName . idName) vars) (ppr vars) $     do  { dflags <- getDynFlags         ; let platform = targetPlatform dflags                 -- Tidy the first pattern, generating@@ -232,7 +234,6 @@             PgBang    -> matchBangs      vars ty (dropGroup eqns)             PgCo {}   -> matchCoercion   vars ty (dropGroup eqns)             PgView {} -> matchView       vars ty (dropGroup eqns)-            PgOverloadedList -> matchOverloadedList vars ty (dropGroup eqns)       where eqns' = NEL.toList eqns             ne l = case NEL.nonEmpty l of               Just nel -> nel@@ -248,13 +249,12 @@                                            case p of PgView e _ -> e:acc                                                      _ -> acc) [] group) eqns             maybeWarn [] = return ()-            maybeWarn l = warnDs NoReason (vcat l)+            maybeWarn l  = diagnosticDs (DsAggregatedViewExpressions l)         in-          maybeWarn $ (map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g))-                       (filter (not . null) gs))+          maybeWarn $ filter (not . null) gs  matchEmpty :: MatchId -> Type -> DsM (NonEmpty (MatchResult CoreExpr))--- See Note [Empty case expressions]+-- See Note [Empty case alternatives] matchEmpty var res_ty   = return [MR_Fallible mk_seq]   where@@ -290,47 +290,43 @@   = do  { -- we could pass in the expr from the PgView,          -- but this needs to extract the pat anyway          -- to figure out the type of the fresh variable-         let ViewPat _ viewExpr (L _ pat) = firstPat eqn1+         let TcViewPat viewExpr pat = firstPat eqn1          -- do the rest of the compilation         ; let pat_ty' = hsPatType pat         ; var' <- newUniqueId var (idMult var) pat_ty'         ; match_result <- match (var':vars) ty $ NEL.toList $             decomposeFirstPat getViewPat <$> eqns          -- compile the view expressions-        ; viewExpr' <- dsLExpr viewExpr+        ; viewExpr' <- dsExpr viewExpr         ; return (mkViewMatchResult var'                     (mkCoreAppDs (text "matchView") viewExpr' (Var var))                     match_result) } -matchOverloadedList :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)-matchOverloadedList (var :| vars) ty (eqns@(eqn1 :| _))--- Since overloaded list patterns are treated as view patterns,--- the code is roughly the same as for matchView-  = do { let ListPat (ListPatTc elt_ty (Just (_,e))) _ = firstPat eqn1-       ; var' <- newUniqueId var (idMult var) (mkListTy elt_ty)  -- we construct the overall type by hand-       ; match_result <- match (var':vars) ty $ NEL.toList $-           decomposeFirstPat getOLPat <$> eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern-       ; e' <- dsSyntaxExpr e [Var var]-       ; return (mkViewMatchResult var' e' match_result)-       }- -- decompose the first pattern and leave the rest alone decomposeFirstPat :: (Pat GhcTc -> Pat GhcTc) -> EquationInfo -> EquationInfo decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats }))         = eqn { eqn_pats = extractpat pat : pats} decomposeFirstPat _ _ = panic "decomposeFirstPat" -getCoPat, getBangPat, getViewPat, getOLPat :: Pat GhcTc -> Pat GhcTc+getCoPat, getBangPat, getViewPat :: Pat GhcTc -> Pat GhcTc getCoPat (XPat (CoPat _ pat _)) = pat getCoPat _                   = panic "getCoPat" getBangPat (BangPat _ pat  ) = unLoc pat getBangPat _                 = panic "getBangPat"-getViewPat (ViewPat _ _ pat) = unLoc pat+getViewPat (TcViewPat _ pat) = pat getViewPat _                 = panic "getViewPat"-getOLPat (ListPat (ListPatTc ty (Just _)) pats)-        = ListPat (ListPatTc ty Nothing)  pats-getOLPat _                   = panic "getOLPat" +-- | Use this pattern synonym to match on a 'ViewPat'.+--+-- N.B.: View patterns can occur inside HsExpansions.+pattern TcViewPat :: HsExpr GhcTc -> Pat GhcTc -> Pat GhcTc+pattern TcViewPat viewExpr pat <- (getTcViewPat -> (viewExpr, pat))++getTcViewPat :: Pat GhcTc -> (HsExpr GhcTc, Pat GhcTc)+getTcViewPat (ViewPat _ viewLExpr pat)  = (unLoc viewLExpr, unLoc pat)+getTcViewPat (XPat (ExpansionPat  _ p)) = getTcViewPat p+getTcViewPat p = pprPanic "getTcViewPat" (ppr p)+ {- Note [Empty case alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -347,7 +343,7 @@    error "empty case" or some such, because 'x' might be bound to (error "hello"), in which case we want to see that "hello" exception, not (error "empty case").-See also Note [Case elimination: lifted case] in GHC.Core.Opt.Simplify.+See also the "lifted case" discussion in Note [Case elimination] in GHC.Core.Opt.Simplify.   ************************************************************************@@ -422,7 +418,7 @@ -- It eliminates many pattern forms (as-patterns, variable patterns, -- list patterns, etc) and returns any created bindings in the wrapper. -tidy1 v o (ParPat _ pat)      = tidy1 v o (unLoc pat)+tidy1 v o (ParPat _ _ pat _)  = tidy1 v o (unLoc pat) tidy1 v o (SigPat _ pat _)    = tidy1 v o (unLoc pat) tidy1 _ _ (WildPat ty)        = return (idDsWrapper, WildPat ty) tidy1 v o (BangPat _ (L l p)) = tidy_bang_pat v o l p@@ -454,18 +450,16 @@     -- Doing this check during type-checking is unsatisfactory because we may     -- not fully know the zonked types yet. We sure do here.   = do  { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders CollNoDictBinders pat)+            -- NB: the binders can't be representation-polymorphic, so we're OK to call isUnliftedType         ; unless (null unlifted_bndrs) $           putSrcSpanDs (getLocA pat) $-          errDs (hang (text "A lazy (~) pattern cannot bind variables of unlifted type." $$-                       text "Unlifted variables:")-                    2 (vcat (map (\id -> ppr id <+> dcolon <+> ppr (idType id))-                                 unlifted_bndrs)))+          diagnosticDs (DsLazyPatCantBindVarsOfUnliftedType unlifted_bndrs)          ; (_,sel_prs) <- mkSelectorBinds [] pat (Var v)         ; let sel_binds =  [NonRec b rhs | (b,rhs) <- sel_prs]         ; return (mkCoreLets sel_binds, WildPat (idType v)) } -tidy1 _ _ (ListPat (ListPatTc ty Nothing) pats )+tidy1 _ _ (ListPat ty pats)   = return (idDsWrapper, unLoc list_ConPat)   where     list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty])@@ -518,7 +512,7 @@               -> DsM (DsWrapper, Pat GhcTc)  -- Discard par/sig under a bang-tidy_bang_pat v o _ (ParPat _ (L l p)) = tidy_bang_pat v o l p+tidy_bang_pat v o _ (ParPat _ _ (L l p) _) = tidy_bang_pat v o l p tidy_bang_pat v o _ (SigPat _ (L l p) _) = tidy_bang_pat v o l p  -- Push the bang-pattern inwards, in the hope that@@ -574,13 +568,13 @@ -- See Note [Bang patterns and newtypes] -- We are transforming   !(N p)   into   (N !p) push_bang_into_newtype_arg l _ty (PrefixCon ts (arg:args))-  = ASSERT( null args)+  = assert (null args) $     PrefixCon ts [L l (BangPat noExtField arg)] push_bang_into_newtype_arg l _ty (RecCon rf)   | HsRecFields { rec_flds = L lf fld : flds } <- rf-  , HsRecField { hsRecFieldArg = arg } <- fld-  = ASSERT( null flds)-    RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg+  , HsFieldBind { hfbRHS = arg } <- fld+  = assert (null flds) $+    RecCon (rf { rec_flds = [L lf (fld { hfbRHS                                            = L l (BangPat noExtField arg) })] }) push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {})   | HsRecFields { rec_flds = [] } <- rf@@ -714,15 +708,32 @@ \end{enumerate} -} +-- Note [matchWrapper scrutinees]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- There are three possible cases for matchWrapper's scrutinees argument:+--+-- 1. Nothing   Used for FunBind, HsLam, HsLamcase, where there is no explicit scrutinee+--              The MatchGroup may have matchGroupArity of 0 or more. Examples:+--                  f p1 q1 = ... -- matchGroupArity 2+--                  f p2 q2 = ...+--+--                  \cases | g1 -> ... -- matchGroupArity 0+--                         | g2 -> ...+--+-- 2. Just [e]  Used for HsCase, RecordUpd; exactly one scrutinee+--              The MatchGroup has matchGroupArity of exactly 1. Example:+--                  case e of p1 -> e1 -- matchGroupArity 1+--                            p2 -> e2+--+-- 3. Just es   Used for HsCmdLamCase; zero or more scrutinees+--              The MatchGroup has matchGroupArity of (length es). Example:+--                  \cases p1 q1 -> returnA -< ... -- matchGroupArity 2+--                         p2 q2 -> ...+ matchWrapper   :: HsMatchContext GhcRn              -- ^ For shadowing warning messages-  -> Maybe (LHsExpr GhcTc)             -- ^ Scrutinee. (Just scrut) for a case expr-                                       --      case scrut of { p1 -> e1 ... }-                                       --   (and in this case the MatchGroup will-                                       --    have all singleton patterns)-                                       --   Nothing for a function definition-                                       --      f p1 q1 = ...  -- No "scrutinee"-                                       --      f p2 q2 = ...  -- in this case+  -> Maybe [LHsExpr GhcTc]             -- ^ Scrutinee(s)+                                       -- see Note [matchWrapper scrutinees]   -> MatchGroup GhcTc (LHsExpr GhcTc)  -- ^ Matches being desugared   -> DsM ([Id], CoreExpr)              -- ^ Results (usually passed to 'match') @@ -750,14 +761,14 @@ JJQC 30-Nov-1997 -} -matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches+matchWrapper ctxt scrs (MG { mg_alts = L _ matches                              , mg_ext = MatchGroupTc arg_tys rhs_ty                              , mg_origin = origin })   = do  { dflags <- getDynFlags         ; locn   <- getSrcSpanDs          ; new_vars    <- case matches of-                           []    -> newSysLocalsDsNoLP arg_tys+                           []    -> newSysLocalsDs arg_tys                            (m:_) ->                             selectMatchVars (zipWithEqual "matchWrapper"                                               (\a b -> (scaledMult a, unLoc b))@@ -768,7 +779,7 @@         -- @rhss_nablas@ is a flat list of covered Nablas for each RHS.         -- Each Match will split off one Nablas for its RHSs from this.         ; matches_nablas <- if isMatchContextPmChecked dflags origin ctxt-            then addHsScrutTmCs mb_scr new_vars $+            then addHsScrutTmCs (concat scrs) new_vars $                  -- See Note [Long-distance information]                  pmcMatches (DsMatchContext ctxt locn) new_vars matches             else pure (initNablasMatches matches)@@ -873,12 +884,12 @@                   -> HsMatchContext GhcRn -> LPat GhcTc                   -> Type -> MatchResult CoreExpr -> DsM (MatchResult CoreExpr) matchSinglePatVar var mb_scrut ctx pat ty match_result-  = ASSERT2( isInternalName (idName var), ppr var )+  = assertPpr (isInternalName (idName var)) (ppr var) $     do { dflags <- getDynFlags        ; locn   <- getSrcSpanDs        -- Pattern match check warnings        ; when (isMatchContextPmChecked dflags FromSource ctx) $-           addCoreScrutTmCs mb_scrut [var] $+           addCoreScrutTmCs (maybeToList mb_scrut) [var] $            pmcPatBind (DsMatchContext ctx locn) var (unLoc pat)         ; let eqn_info = EqnInfo { eqn_pats = [unLoc (decideBangHood dflags pat)]@@ -911,7 +922,6 @@   | PgView (LHsExpr GhcTc) -- view pattern (e -> p):                         -- the LHsExpr is the expression e            Type         -- the Type is the type of p (equivalently, the result type of e)-  | PgOverloadedList  {- Note [Don't use Literal for PgN] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1018,11 +1028,11 @@         -- Order is significant, match PgN after PgLit         -- If the exponents are small check for value equality rather than syntactic equality         -- This is implemented in the Eq instance for FractionalLit, we do this to avoid-        -- computing the value of excessivly large rationals.+        -- computing the value of excessively large rationals. sameGroup (PgOverS s1)  (PgOverS s2)  = s1==s2 sameGroup (PgNpK l1)    (PgNpK l2)    = l1==l2  -- See Note [Grouping overloaded literal patterns] sameGroup (PgCo t1)     (PgCo t2)     = t1 `eqType` t2-        -- CoPats are in the same goup only if the type of the+        -- CoPats are in the same group only if the type of the         -- enclosed pattern is the same. The patterns outside the CoPat         -- always have the same type, so this boils down to saying that         -- the two coercions are identical.@@ -1053,8 +1063,8 @@     exp :: HsExpr GhcTc -> HsExpr GhcTc -> Bool     -- real comparison is on HsExpr's     -- strip parens-    exp (HsPar _ (L _ e)) e'   = exp e e'-    exp e (HsPar _ (L _ e'))   = exp e e'+    exp (HsPar _ _ (L _ e) _) e' = exp e e'+    exp e (HsPar _ _ (L _ e') _) = exp e e'     -- because the expressions do not necessarily have the same type,     -- we have to compare the wrappers     exp (XExpr (WrapExpr (HsWrap h e))) (XExpr (WrapExpr (HsWrap  h' e'))) =@@ -1062,7 +1072,7 @@     exp (XExpr (ExpansionExpr (HsExpanded _ b))) (XExpr (ExpansionExpr (HsExpanded _ b'))) =       exp b b'     exp (HsVar _ i) (HsVar _ i') =  i == i'-    exp (HsConLikeOut _ c) (HsConLikeOut _ c') = c == c'+    exp (XExpr (ConLikeTc c _ _)) (XExpr (ConLikeTc c' _ _)) = c == c'     -- the instance for IPName derives using the id, so this works if the     -- above does     exp (HsIPVar _ i) (HsIPVar _ i') = i == i'@@ -1125,7 +1135,7 @@     --        equating different ways of writing a coercion)     wrap WpHole WpHole = True     wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2'-    wrap (WpFun w1 w2 _ _) (WpFun w1' w2' _ _) = wrap w1 w1' && wrap w2 w2'+    wrap (WpFun w1 w2 _)   (WpFun w1' w2' _)   = wrap w1 w1' && wrap w2 w2'     wrap (WpCast co)       (WpCast co')        = co `eqCoercion` co'     wrap (WpEvApp et1)     (WpEvApp et2)       = et1 `ev_term` et2     wrap (WpTyApp t)       (WpTyApp t')        = eqType t t'@@ -1171,17 +1181,17 @@     (HsFractional f, is_neg)       | is_neg    -> PgN $! negateFractionalLit f       | otherwise -> PgN f-    (HsIsString _ s, _) -> ASSERT(isNothing mb_neg)+    (HsIsString _ s, _) -> assert (isNothing mb_neg) $                             PgOverS s patGroup _ (NPlusKPat _ _ (L _ (OverLit {ol_val=oval})) _ _ _) =   case oval of    HsIntegral i -> PgNpK (il_value i)    _ -> pprPanic "patGroup NPlusKPat" (ppr oval)-patGroup _ (XPat (CoPat _ p _))         = PgCo  (hsPatType p)-                                                    -- Type of innelexp pattern patGroup _ (ViewPat _ expr p)           = PgView expr (hsPatType (unLoc p))-patGroup _ (ListPat (ListPatTc _ (Just _)) _) = PgOverloadedList patGroup platform (LitPat _ lit)        = PgLit (hsLitKey platform lit)+patGroup platform (XPat ext) = case ext of+  CoPat _ p _      -> PgCo (hsPatType p) -- Type of innelexp pattern+  ExpansionPat _ p -> patGroup platform p patGroup _ pat                          = pprPanic "patGroup" (ppr pat)  {-
compiler/GHC/HsToCore/Match.hs-boot view
@@ -15,7 +15,7 @@  matchWrapper         :: HsMatchContext GhcRn-        -> Maybe (LHsExpr GhcTc)+        -> Maybe [LHsExpr GhcTc]         -> MatchGroup GhcTc (LHsExpr GhcTc)         -> DsM ([Id], CoreExpr)
compiler/GHC/HsToCore/Match/Constructor.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE TypeFamilies #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}@@ -13,8 +13,6 @@  module GHC.HsToCore.Match.Constructor ( matchConFamily, matchPatSyn ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import {-# SOURCE #-} GHC.HsToCore.Match ( match )@@ -36,6 +34,7 @@ import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import Control.Monad(liftM) import Data.List (groupBy) import Data.List.NonEmpty (NonEmpty(..))@@ -133,10 +132,10 @@                 -> NonEmpty EquationInfo                 -> DsM (CaseAlt ConLike) matchOneConLike vars ty mult (eqn1 :| eqns)   -- All eqns for a single constructor-  = do  { let inst_tys = ASSERT( all tcIsTcTyVar ex_tvs )+  = do  { let inst_tys = assert (all tcIsTcTyVar ex_tvs) $                            -- ex_tvs can only be tyvars as data types in source                            -- Haskell cannot mention covar yet (Aug 2018).-                         ASSERT( tvs1 `equalLength` ex_tvs )+                         assert (tvs1 `equalLength` ex_tvs) $                          arg_tys ++ mkTyVarTys tvs1                val_arg_tys = conLikeInstOrigArgTys con1 inst_tys@@ -147,7 +146,7 @@                           -> [(ConArgPats, EquationInfo)] -> DsM (MatchResult CoreExpr)               -- All members of the group have compatible ConArgPats               match_group arg_vars arg_eqn_prs-                = ASSERT( notNull arg_eqn_prs )+                = assert (notNull arg_eqn_prs) $                   do { (wraps, eqns') <- liftM unzip (mapM shift arg_eqn_prs)                      ; let group_arg_vars = select_arg_vars arg_vars arg_eqn_prs                      ; match_result <- match (group_arg_vars ++ vars) ty eqns'@@ -216,15 +215,15 @@       | RecCon flds <- arg_pats       , let rpats = rec_flds flds       , not (null rpats)     -- Treated specially; cf conArgPats-      = ASSERT2( fields1 `equalLength` arg_vars,-                 ppr con1 $$ ppr fields1 $$ ppr arg_vars )+      = assertPpr (fields1 `equalLength` arg_vars)+                  (ppr con1 $$ ppr fields1 $$ ppr arg_vars) $         map lookup_fld rpats       | otherwise       = arg_vars       where         fld_var_env = mkNameEnv $ zipEqual "get_arg_vars" fields1 arg_vars         lookup_fld (L _ rpat) = lookupNameEnv_NF fld_var_env-                                            (idName (unLoc (hsRecFieldId rpat)))+                                            (idName (hsRecFieldId rpat))     select_arg_vars _ [] = panic "matchOneCon/select_arg_vars []"  -----------------@@ -240,16 +239,17 @@             -> Bool same_fields flds1 flds2   = all2 (\(L _ f1) (L _ f2)-                          -> unLoc (hsRecFieldId f1) == unLoc (hsRecFieldId f2))+                          -> hsRecFieldId f1 == hsRecFieldId f2)          (rec_flds flds1) (rec_flds flds2)   ----------------- selectConMatchVars :: [Scaled Type] -> ConArgPats -> DsM [Id]-selectConMatchVars arg_tys con = case con of-                                   (RecCon {}) -> newSysLocalsDsNoLP arg_tys-                                   (PrefixCon _ ps) -> selectMatchVars (zipMults arg_tys ps)-                                   (InfixCon p1 p2) -> selectMatchVars (zipMults arg_tys [p1, p2])+selectConMatchVars arg_tys con+  = case con of+      RecCon {}      -> newSysLocalsDs arg_tys+      PrefixCon _ ps -> selectMatchVars (zipMults arg_tys ps)+      InfixCon p1 p2 -> selectMatchVars (zipMults arg_tys [p1, p2])   where     zipMults = zipWithEqual "selectConMatchVar" (\a b -> (scaledMult a, unLoc b)) @@ -264,7 +264,7 @@   | null rpats = map WildPat (map scaledThing arg_tys)         -- Important special case for C {}, which can be used for a         -- datacon that isn't declared to have fields at all-  | otherwise  = map (unLoc . hsRecFieldArg . unLoc) rpats+  | otherwise  = map (unLoc . hfbRHS . unLoc) rpats  {- Note [Record patterns]
compiler/GHC/HsToCore/Match/Literal.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiWayIf          #-} {-# LANGUAGE TypeApplications    #-}@@ -24,14 +24,13 @@    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Platform  import {-# SOURCE #-} GHC.HsToCore.Match ( match ) import {-# SOURCE #-} GHC.HsToCore.Expr  ( dsExpr, dsSyntaxExpr ) +import GHC.HsToCore.Errors.Types import GHC.HsToCore.Monad import GHC.HsToCore.Utils @@ -42,6 +41,7 @@ import GHC.Core import GHC.Core.Make import GHC.Core.TyCon+import GHC.Core.Reduction ( Reduction(..) ) import GHC.Core.DataCon import GHC.Tc.Utils.Zonk ( shortCutLit ) import GHC.Tc.Utils.TcType@@ -56,8 +56,8 @@ import GHC.Driver.Session import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Data.FastString-import qualified GHC.LanguageExtensions as LangExt import GHC.Core.FamInstEnv ( FamInstEnvs, normaliseType )  import Control.Monad@@ -108,7 +108,7 @@     HsDoublePrim _ fl -> return (Lit (LitDouble (rationalFromFractionalLit fl)))     HsChar _ c       -> return (mkCharExpr c)     HsString _ str   -> mkStringExprFS str-    HsInteger _ i _  -> return (mkIntegerExpr i)+    HsInteger _ i _  -> return (mkIntegerExpr platform i)     HsInt _ i        -> return (mkIntExpr platform (il_value i))     HsRat _ fl ty    -> dsFractionalLitToRational fl ty @@ -199,15 +199,17 @@ dsFractionalLitToRational fl@FL{ fl_signi = signi, fl_exp = exp, fl_exp_base = base } ty   -- We compute "small" rationals here and now   | abs exp <= 100-  = let !val   = rationalFromFractionalLit fl-        !num   = mkIntegerExpr (numerator val)-        !denom = mkIntegerExpr (denominator val)+  = do+    platform <- targetPlatform <$> getDynFlags+    let !val   = rationalFromFractionalLit fl+        !num   = mkIntegerExpr platform (numerator val)+        !denom = mkIntegerExpr platform (denominator val)         (ratio_data_con, integer_ty)             = case tcSplitTyConApp ty of-                    (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)+                    (tycon, [i_ty]) -> assert (isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)                                        (head (tyConDataCons tycon), i_ty)                     x -> pprPanic "dsLit" (ppr x)-    in return $! (mkCoreConApps ratio_data_con [Type integer_ty, num, denom])+    return $! (mkCoreConApps ratio_data_con [Type integer_ty, num, denom])   -- Large rationals will be computed at runtime.   | otherwise   = do@@ -216,22 +218,23 @@                              Base10 -> mkRationalBase10Name       mkRational <- dsLookupGlobalId mkRationalName       litR <- dsRational signi-      let litE = mkIntegerExpr exp+      platform <- targetPlatform <$> getDynFlags+      let litE = mkIntegerExpr platform exp       return (mkCoreApps (Var mkRational) [litR, litE])  dsRational :: Rational -> DsM CoreExpr dsRational (n :% d) = do+  platform <- targetPlatform <$> getDynFlags   dcn <- dsLookupDataCon ratioDataConName-  let cn = mkIntegerExpr n-  let dn = mkIntegerExpr d+  let cn = mkIntegerExpr platform n+  let dn = mkIntegerExpr platform d   return $ mkCoreConApps dcn [Type integerTy, cn, dn]   dsOverLit :: HsOverLit GhcTc -> DsM CoreExpr -- ^ Post-typechecker, the 'HsExpr' field of an 'OverLit' contains -- (an expression for) the literal value itself.-dsOverLit (OverLit { ol_val = val, ol_ext = OverLitTc rebindable ty-                   , ol_witness = witness }) = do+dsOverLit (OverLit { ol_val = val, ol_ext = OverLitTc rebindable witness ty }) = do   dflags <- getDynFlags   let platform = targetPlatform dflags   case shortCutLit platform val ty of@@ -264,10 +267,7 @@   , idName conv_fn `elem` conversionNames   , Just (_, arg_ty, res_ty) <- splitFunTy_maybe type_of_conv   , arg_ty `eqType` res_ty  -- So we are converting  ty -> ty-  = warnDs (Reason Opt_WarnIdentities)-           (vcat [ text "Call of" <+> ppr conv_fn <+> dcolon <+> ppr type_of_conv-                 , nest 2 $ text "can probably be omitted"-           ])+  = diagnosticDs (DsIdentitiesFound conv_fn type_of_conv) warnAboutIdentities _ _ _ = return ()  conversionNames :: [Name]@@ -348,37 +348,13 @@     checkPositive :: Integer -> Name -> DsM ()     checkPositive i tc       = when (i < 0) $-        warnDs (Reason Opt_WarnOverflowedLiterals)-               (vcat [ text "Literal" <+> integer i-                       <+> text "is negative but" <+> ppr tc-                       <+> ptext (sLit "only supports positive numbers")-                     ])+        diagnosticDs (DsOverflowedLiterals i tc Nothing (negLiteralExtEnabled dflags))      check i tc minB maxB       = when (i < minB || i > maxB) $-        warnDs (Reason Opt_WarnOverflowedLiterals)-               (vcat [ text "Literal" <+> integer i-                       <+> text "is out of the" <+> ppr tc <+> ptext (sLit "range")-                       <+> integer minB <> text ".." <> integer maxB-                     , sug ])+        diagnosticDs (DsOverflowedLiterals i tc bounds (negLiteralExtEnabled dflags))       where-        sug | minB == -i   -- Note [Suggest NegativeLiterals]-            , i > 0-            , not (xopt LangExt.NegativeLiterals dflags)-            = text "If you are trying to write a large negative literal, use NegativeLiterals"-            | otherwise = Outputable.empty--{--Note [Suggest NegativeLiterals]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If you write-  x :: Int8-  x = -128-it'll parse as (negate 128), and overflow.  In this case, suggest NegativeLiterals.-We get an erroneous suggestion for-  x = 128-but perhaps that does not matter too much.--}+        bounds = Just (MinBound minB, MaxBound maxB)  warnAboutEmptyEnumerations :: FamInstEnvs -> DynFlags -> LHsExpr GhcTc                            -> Maybe (LHsExpr GhcTc)@@ -441,19 +417,20 @@    | otherwise = return ()   where-    raiseWarning = warnDs (Reason Opt_WarnEmptyEnumerations) (text "Enumeration is empty")+    raiseWarning =+      diagnosticDs DsEmptyEnumeration  getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Type) -- ^ See if the expression is an 'Integral' literal. getLHsIntegralLit (L _ e) = go e   where-    go (HsPar _ e)            = getLHsIntegralLit e+    go (HsPar _ _ e _)        = getLHsIntegralLit e     go (HsOverLit _ over_lit) = getIntegralLit over_lit     go (HsLit _ lit)          = getSimpleIntegralLit lit      -- Remember to look through automatically-added tick-boxes! (#8384)-    go (HsTick _ _ e)         = getLHsIntegralLit e-    go (HsBinTick _ _ _ e)    = getLHsIntegralLit e+    go (XExpr (HsTick _ e))       = getLHsIntegralLit e+    go (XExpr (HsBinTick _ _ e))  = getLHsIntegralLit e      -- The literal might be wrapped in a case with -XOverloadedLists     go (XExpr (WrapExpr (HsWrap _ e))) = go e@@ -462,7 +439,7 @@ -- | If 'Integral', extract the value and type of the overloaded literal. -- See Note [Literals and the OverloadedLists extension] getIntegralLit :: HsOverLit GhcTc -> Maybe (Integer, Type)-getIntegralLit (OverLit { ol_val = HsIntegral i, ol_ext = OverLitTc _ ty })+getIntegralLit (OverLit { ol_val = HsIntegral i, ol_ext = OverLitTc { ol_type = ty } })   = Just (il_value i, ty) getIntegralLit _ = Nothing @@ -478,10 +455,10 @@  -- | Extract the Char if the expression is a Char literal. getLHsCharLit :: LHsExpr GhcTc -> Maybe Char-getLHsCharLit (L _ (HsPar _ e))            = getLHsCharLit e-getLHsCharLit (L _ (HsTick _ _ e))         = getLHsCharLit e-getLHsCharLit (L _ (HsBinTick _ _ _ e))    = getLHsCharLit e+getLHsCharLit (L _ (HsPar _ _ e _))        = getLHsCharLit e getLHsCharLit (L _ (HsLit _ (HsChar _ c))) = Just c+getLHsCharLit (L _ (XExpr (HsTick _ e)))         = getLHsCharLit e+getLHsCharLit (L _ (XExpr (HsBinTick _ _ e)))    = getLHsCharLit e getLHsCharLit _ = Nothing  -- | Convert a pair (Integer, Type) to (Integer, Name) after eventually@@ -493,7 +470,9 @@     | otherwise = Nothing   where     normaliseNominal :: FamInstEnvs -> Type -> Type-    normaliseNominal fam_envs ty = snd $ normaliseType fam_envs Nominal ty+    normaliseNominal fam_envs ty+      = reductionReducedType+      $ normaliseType fam_envs Nominal ty  -- | Convert a pair (Integer, Type) to (Integer, Name) without normalising -- the type@@ -527,9 +506,9 @@  tidyLitPat :: HsLit GhcTc -> Pat GhcTc -- Result has only the following HsLits:---      HsIntPrim, HsWordPrim, HsCharPrim, HsFloatPrim---      HsDoublePrim, HsStringPrim, HsString---  * HsInteger, HsRat, HsInt can't show up in LitPats+--      HsIntPrim, HsWordPrim, HsCharPrim, HsString+--  * HsInteger, HsRat, HsInt, as well as HsStringPrim,+--    HsFloatPrim and HsDoublePrim can't show up in LitPats --  * We get rid of HsChar right here tidyLitPat (HsChar src c) = unLoc (mkCharLitPat src c) tidyLitPat (HsString src s)@@ -545,7 +524,7 @@ tidyNPat :: HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> SyntaxExpr GhcTc          -> Type          -> Pat GhcTc-tidyNPat (OverLit (OverLitTc False ty) val _) mb_neg _eq outer_ty+tidyNPat (OverLit (OverLitTc False _ ty) val) mb_neg _eq outer_ty         -- False: Take short cuts only if the literal is not using rebindable syntax         --         -- Once that is settled, look for cases where the type of the@@ -589,7 +568,7 @@                    _ -> Nothing  tidyNPat over_lit mb_neg eq outer_ty-  = NPat outer_ty (noLoc over_lit) mb_neg eq+  = NPat outer_ty (noLocA over_lit) mb_neg eq  {- ************************************************************************
compiler/GHC/HsToCore/Monad.hs view
@@ -19,8 +19,8 @@         foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM, xoptM,         Applicative(..),(<$>), -        duplicateLocalDs, newSysLocalDsNoLP, newSysLocalDs,-        newSysLocalsDsNoLP, newSysLocalsDs, newUniqueId,+        duplicateLocalDs, newSysLocalDs,+        newSysLocalsDs, newUniqueId,         newFailLocalDs, newPredVarDs,         getSrcSpanDs, putSrcSpanDs, putSrcSpanDsA,         mkPrintUnqualifiedDs,@@ -40,17 +40,13 @@         dsGetCompleteMatches,          -- Warnings and errors-        DsWarning, warnDs, warnIfSetDs, errDs, errDsCoreExpr,+        DsWarning, diagnosticDs, errDsCoreExpr,         failWithDs, failDs, discardWarningsDs,-        askNoErrsDs,          -- Data types         DsMatchContext(..),         EquationInfo(..), MatchResult (..), runMatchResult, DsWrapper, idDsWrapper, -        -- Levity polymorphism-        dsNoLevPoly, dsNoLevPolyExpr, dsWhenNoErrs,-         -- Trace injection         pprRuntimeTrace     ) where@@ -60,16 +56,18 @@ import GHC.Driver.Env import GHC.Driver.Session import GHC.Driver.Ppr+import GHC.Driver.Config.Diagnostic  import GHC.Hs  import GHC.HsToCore.Types+import GHC.HsToCore.Errors.Types import GHC.HsToCore.Pmc.Solver.Types (Nablas, initNablas)  import GHC.Core.FamInstEnv import GHC.Core import GHC.Core.Make  ( unitExpr )-import GHC.Core.Utils ( exprType, isExprLevPoly )+import GHC.Core.Utils ( exprType ) import GHC.Core.DataCon import GHC.Core.ConLike import GHC.Core.TyCon@@ -79,7 +77,6 @@ import GHC.IfaceToCore  import GHC.Tc.Utils.Monad-import GHC.Tc.Utils.TcMType ( checkForLevPolyX, formatLevPolyErr )  import GHC.Builtin.Names @@ -105,11 +102,13 @@ import GHC.Types.TyThing import GHC.Types.Error +import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Error+import qualified GHC.Data.Strict as Strict  import Data.IORef+import GHC.Driver.Env.KnotVars  {- ************************************************************************@@ -204,17 +203,22 @@         -- into a Doc.  -- | Run a 'DsM' action inside the 'TcM' monad.-initDsTc :: DsM a -> TcM a+initDsTc :: DsM a -> TcM (Messages DsMessage, Maybe a) initDsTc thing_inside   = do { tcg_env  <- getGblEnv-       ; msg_var  <- getErrsVar+       ; msg_var  <- liftIO $ newIORef emptyMessages        ; hsc_env  <- getTopEnv        ; envs     <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env-       ; setEnvs envs thing_inside+       ; e_result <- tryM $  -- need to tryM so that we don't discard+                             -- DsMessages+                     setEnvs envs thing_inside+       ; msgs     <- liftIO $ readIORef msg_var+       ; return (msgs, case e_result of Left _  -> Nothing+                                        Right x -> Just x)        }  -- | Run a 'DsM' action inside the 'IO' monad.-initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages DecoratedSDoc, Maybe a)+initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages DsMessage, Maybe a) initDs hsc_env tcg_env thing_inside   = do { msg_var <- newIORef emptyMessages        ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env@@ -223,7 +227,7 @@  -- | Build a set of desugarer environments derived from a 'TcGblEnv'. mkDsEnvsFromTcGbl :: MonadIO m-                  => HscEnv -> IORef (Messages DecoratedSDoc) -> TcGblEnv+                  => HscEnv -> IORef (Messages DsMessage) -> TcGblEnv                   -> m (DsGblEnv, DsLclEnv) mkDsEnvsFromTcGbl hsc_env msg_var tcg_env   = do { cc_st_var   <- liftIO $ newIORef newCostCentreState@@ -236,11 +240,13 @@              complete_matches = hptCompleteSigs hsc_env         -- from the home package                                 ++ tcg_complete_matches tcg_env -- from the current module                                 ++ eps_complete_matches eps     -- from imports+             -- re-use existing next_wrapper_num to ensure uniqueness+             next_wrapper_num_var = tcg_next_wrapper_num tcg_env        ; return $ mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env-                           msg_var cc_st_var complete_matches+                           msg_var cc_st_var next_wrapper_num_var complete_matches        } -runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages DecoratedSDoc, Maybe a)+runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages DsMessage, Maybe a) runDs hsc_env (ds_gbl, ds_lcl) thing_inside   = do { res    <- initTcRnIf 'd' hsc_env ds_gbl ds_lcl                               (tryM thing_inside)@@ -253,7 +259,7 @@        }  -- | Run a 'DsM' action in the context of an existing 'ModGuts'-initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages DecoratedSDoc, Maybe a)+initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages DsMessage, Maybe a) initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds                                    , mg_tcs = tycons, mg_fam_insts = fam_insts                                    , mg_patsyns = patsyns, mg_rdr_env = rdr_env@@ -261,6 +267,7 @@                                    , mg_complete_matches = local_complete_matches                           }) thing_inside   = do { cc_st_var   <- newIORef newCostCentreState+       ; next_wrapper_num <- newIORef emptyModuleEnv        ; msg_var <- newIORef emptyMessages        ; eps <- liftIO $ hscEPS hsc_env        ; let unit_env = hsc_unit_env hsc_env@@ -275,7 +282,7 @@               envs  = mkDsEnvs unit_env this_mod rdr_env type_env                               fam_inst_env msg_var cc_st_var-                              complete_matches+                              next_wrapper_num complete_matches        ; runDs hsc_env envs thing_inside        } @@ -313,12 +320,19 @@            Nothing  -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLoc (getErrorMessages msgs)) }  mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv-         -> IORef (Messages DecoratedSDoc) -> IORef CostCentreState -> CompleteMatches+         -> IORef (Messages DsMessage) -> IORef CostCentreState+         -> IORef (ModuleEnv Int) -> CompleteMatches          -> (DsGblEnv, DsLclEnv) mkDsEnvs unit_env mod rdr_env type_env fam_inst_env msg_var cc_st_var-         complete_matches-  = let if_genv = IfGblEnv { if_doc       = text "mkDsEnvs",-                             if_rec_types = Just (mod, return type_env) }+         next_wrapper_num complete_matches+  = let if_genv = IfGblEnv { if_doc       = text "mkDsEnvs"+  -- Failing tests here are `ghci` and `T11985` if you get this wrong.+  -- this is very very "at a distance" because the reason for this check is that the type_env in interactive+  -- mode is the smushed together of all the interactive modules.+  -- See Note [Why is KnotVars not a ModuleEnv]+                             , if_rec_types = KnotVars [mod] (\that_mod -> if that_mod == mod || isInteractiveModule mod+                                                          then Just (return type_env)+                                                          else Nothing) }         if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod)                              NotBoot         real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1)@@ -330,6 +344,7 @@                            , ds_msgs    = msg_var                            , ds_complete_matches = complete_matches                            , ds_cc_st   = cc_st_var+                           , ds_next_wrapper_num = next_wrapper_num                            }         lcl_env = DsLclEnv { dsl_meta    = emptyNameEnv                            , dsl_loc     = real_span@@ -350,49 +365,11 @@ functions are defined with it.  The difference in name-strings makes it easier to read debugging output. -Note [Levity polymorphism checking]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-According to the "Levity Polymorphism" paper (PLDI '17), levity-polymorphism is forbidden in precisely two places: in the type of a bound-term-level argument and in the type of an argument to a function. The paper-explains it more fully, but briefly: expressions in these contexts need to be-stored in registers, and it's hard (read, impossible) to store something-that's levity polymorphic.--We cannot check for bad levity polymorphism conveniently in the type checker,-because we can't tell, a priori, which levity metavariables will be solved.-At one point, I (Richard) thought we could check in the zonker, but it's hard-to know where precisely are the abstracted variables and the arguments. So-we check in the desugarer, the only place where we can see the Core code and-still report respectable syntax to the user. This covers the vast majority-of cases; see calls to GHC.HsToCore.Monad.dsNoLevPoly and friends.--Levity polymorphism is also prohibited in the types of binders, and the-desugarer checks for this in GHC-generated Ids. (The zonker handles-the user-writted ids in zonkIdBndr.) This is done in newSysLocalDsNoLP.-The newSysLocalDs variant is used in the vast majority of cases where-the binder is obviously not levity polymorphic, omitting the check.-It would be nice to ASSERT that there is no levity polymorphism here,-but we can't, because of the fixM in GHC.HsToCore.Arrows. It's all OK, though:-Core Lint will catch an error here.--However, the desugarer is the wrong place for certain checks. In particular,-the desugarer can't report a sensible error message if an HsWrapper is malformed.-After all, GHC itself produced the HsWrapper. So we store some message text-in the appropriate HsWrappers (e.g. WpFun) that we can print out in the-desugarer.--There are a few more checks in places where Core is generated outside the-desugarer. For example, in datatype and class declarations, where levity-polymorphism is checked for during validity checking. It would be nice to-have one central place for all this, but that doesn't seem possible while-still reporting nice error messages.- -}  -- Make a new Id with the same print name, but different type, and new unique newUniqueId :: Id -> Mult -> Type -> DsM Id-newUniqueId id = mk_local (occNameFS (nameOccName (idName id)))+newUniqueId id = mkSysLocalOrCoVarM (occNameFS (nameOccName (idName id)))  duplicateLocalDs :: Id -> DsM Id duplicateLocalDs old_local@@ -403,27 +380,13 @@ newPredVarDs  = mkSysLocalOrCoVarM (fsLit "ds") Many  -- like newSysLocalDs, but we allow covars -newSysLocalDsNoLP, newSysLocalDs, newFailLocalDs :: Mult -> Type -> DsM Id-newSysLocalDsNoLP  = mk_local (fsLit "ds")---- this variant should be used when the caller can be sure that the variable type--- is not levity-polymorphic. It is necessary when the type is knot-tied because--- of the fixM used in GHC.HsToCore.Arrows. See Note [Levity polymorphism checking]+newSysLocalDs, newFailLocalDs :: Mult -> Type -> DsM Id newSysLocalDs = mkSysLocalM (fsLit "ds") newFailLocalDs = mkSysLocalM (fsLit "fail")-  -- the fail variable is used only in a situation where we can tell that-  -- levity-polymorphism is impossible. -newSysLocalsDsNoLP, newSysLocalsDs :: [Scaled Type] -> DsM [Id]-newSysLocalsDsNoLP = mapM (\(Scaled w t) -> newSysLocalDsNoLP w t)+newSysLocalsDs :: [Scaled Type] -> DsM [Id] newSysLocalsDs = mapM (\(Scaled w t) -> newSysLocalDs w t) -mk_local :: FastString -> Mult -> Type -> DsM Id-mk_local fs w ty = do { dsNoLevPoly ty (text "When trying to create a variable of type:" <+>-                                        ppr ty)  -- could improve the msg with another-                                                 -- parameter indicating context-                      ; mkSysLocalOrCoVarM fs w ty }- {- We can also reach out and either set/grab location information from the @SrcSpan@ being carried around.@@ -443,7 +406,7 @@  getSrcSpanDs :: DsM SrcSpan getSrcSpanDs = do { env <- getLclEnv-                  ; return (RealSrcSpan (dsl_loc env) Nothing) }+                  ; return (RealSrcSpan (dsl_loc env) Strict.Nothing) }  putSrcSpanDs :: SrcSpan -> DsM a -> DsM a putSrcSpanDs (UnhelpfulSpan {}) thing_inside@@ -454,74 +417,32 @@ putSrcSpanDsA :: SrcSpanAnn' ann -> DsM a -> DsM a putSrcSpanDsA loc = putSrcSpanDs (locA loc) --- | Emit a warning for the current source location--- NB: Warns whether or not -Wxyz is set-warnDs :: WarnReason -> SDoc -> DsM ()-warnDs reason warn+-- | Emit a diagnostic for the current source location. In case the diagnostic is a warning,+-- the latter will be ignored and discarded if the relevant 'WarningFlag' is not set in the DynFlags.+-- See Note [Discarding Messages] in 'GHC.Types.Error'.+diagnosticDs :: DsMessage -> DsM ()+diagnosticDs dsMessage   = do { env <- getGblEnv        ; loc <- getSrcSpanDs-       ; let msg = makeIntoWarning reason $-                   mkWarnMsg loc (ds_unqual env) warn+       ; !diag_opts <- initDiagOpts <$> getDynFlags+       ; let msg = mkMsgEnvelope diag_opts loc (ds_unqual env) dsMessage        ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) } --- | Emit a warning only if the correct WarnReason is set in the DynFlags-warnIfSetDs :: WarningFlag -> SDoc -> DsM ()-warnIfSetDs flag warn-  = whenWOptM flag $-    warnDs (Reason flag) warn--errDs :: SDoc -> DsM ()-errDs err-  = do  { env <- getGblEnv-        ; loc <- getSrcSpanDs-        ; let msg = mkMsgEnvelope loc (ds_unqual env) err-        ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) }- -- | Issue an error, but return the expression for (), so that we can continue -- reporting errors.-errDsCoreExpr :: SDoc -> DsM CoreExpr-errDsCoreExpr err-  = do { errDs err+errDsCoreExpr :: DsMessage -> DsM CoreExpr+errDsCoreExpr msg+  = do { diagnosticDs msg        ; return unitExpr } -failWithDs :: SDoc -> DsM a-failWithDs err-  = do  { errDs err+failWithDs :: DsMessage -> DsM a+failWithDs msg+  = do  { diagnosticDs msg         ; failM }  failDs :: DsM a failDs = failM --- (askNoErrsDs m) runs m--- If m fails,---    then (askNoErrsDs m) fails--- If m succeeds with result r,---    then (askNoErrsDs m) succeeds with result (r, b),---         where b is True iff m generated no errors--- Regardless of success or failure,---   propagate any errors/warnings generated by m------ c.f. GHC.Tc.Utils.Monad.askNoErrs-askNoErrsDs :: DsM a -> DsM (a, Bool)-askNoErrsDs thing_inside- = do { errs_var <- newMutVar emptyMessages-      ; env <- getGblEnv-      ; mb_res <- tryM $  -- Be careful to catch exceptions-                          -- so that we propagate errors correctly-                          -- (#13642)-                  setGblEnv (env { ds_msgs = errs_var }) $-                  thing_inside--      -- Propagate errors-      ; msgs <- readMutVar errs_var-      ; updMutVar (ds_msgs env) (unionMessages msgs)--      -- And return-      ; case mb_res of-           Left _    -> failM-           Right res -> do { let errs_found = errorsFound msgs-                           ; return (res, not errs_found) } }- mkPrintUnqualifiedDs :: DsM PrintUnqualified mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv @@ -586,33 +507,6 @@         ; writeTcRef (ds_msgs env) old_msgs          ; return result }---- | Fail with an error message if the type is levity polymorphic.-dsNoLevPoly :: Type -> SDoc -> DsM ()--- See Note [Levity polymorphism checking]-dsNoLevPoly ty doc = checkForLevPolyX failWithDs doc ty---- | Check an expression for levity polymorphism, failing if it is--- levity polymorphic.-dsNoLevPolyExpr :: CoreExpr -> SDoc -> DsM ()--- See Note [Levity polymorphism checking]-dsNoLevPolyExpr e doc-  | isExprLevPoly e = errDs (formatLevPolyErr (exprType e) $$ doc)-  | otherwise       = return ()---- | Runs the thing_inside. If there are no errors, then returns the expr--- given. Otherwise, returns unitExpr. This is useful for doing a bunch--- of levity polymorphism checks and then avoiding making a core App.--- (If we make a core App on a levity polymorphic argument, detecting how--- to handle the let/app invariant might call isUnliftedType, which panics--- on a levity polymorphic type.)--- See #12709 for an example of why this machinery is necessary.-dsWhenNoErrs :: DsM a -> (a -> CoreExpr) -> DsM CoreExpr-dsWhenNoErrs thing_inside mk_expr-  = do { (result, no_errs) <- askNoErrsDs thing_inside-       ; return $ if no_errs-                  then mk_expr result-                  else unitExpr }  -- | Inject a trace message into the compiled program. Whereas -- pprTrace prints out information *while compiling*, pprRuntimeTrace
compiler/GHC/HsToCore/Pmc.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE CPP               #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs             #-}-{-# LANGUAGE LambdaCase        #-} +{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE GADTs              #-}+{-# LANGUAGE LambdaCase         #-}+{-# LANGUAGE StandaloneDeriving #-}+ -- | This module coverage checks pattern matches. It finds -- --     * Uncovered patterns, certifying non-exhaustivity@@ -41,20 +42,17 @@         addTyCs, addCoreScrutTmCs, addHsScrutTmCs     ) where -#include "GhclibHsVersions.h"- import GHC.Prelude +import GHC.HsToCore.Errors.Types import GHC.HsToCore.Pmc.Types import GHC.HsToCore.Pmc.Utils import GHC.HsToCore.Pmc.Desugar import GHC.HsToCore.Pmc.Check import GHC.HsToCore.Pmc.Solver-import GHC.HsToCore.Pmc.Ppr import GHC.Types.Basic (Origin(..)) import GHC.Core (CoreExpr) import GHC.Driver.Session-import GHC.Driver.Env import GHC.Hs import GHC.Types.Id import GHC.Types.SrcLoc@@ -62,12 +60,12 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Types.Var (EvVar)-import GHC.Tc.Types import GHC.Tc.Utils.TcType (evVarPred)+import GHC.Tc.Utils.Monad (updTopFlags) import {-# SOURCE #-} GHC.HsToCore.Expr (dsLExpr) import GHC.HsToCore.Monad import GHC.Data.Bag-import GHC.Data.IOEnv (updEnv, unsafeInterleaveM)+import GHC.Data.IOEnv (unsafeInterleaveM) import GHC.Data.OrdList import GHC.Utils.Monad (mapMaybeM) @@ -97,10 +95,7 @@ -- is one concern, but also a lack of properly set up long-distance information -- might trigger warnings that we normally wouldn't emit. noCheckDs :: DsM a -> DsM a-noCheckDs k = do-  dflags <- getDynFlags-  let dflags' = foldl' wopt_unset dflags allPmCheckWarnings-  updEnv (\env -> env{env_top = (env_top env) {hsc_dflags = dflags'} }) k+noCheckDs = updTopFlags (\dflags -> foldl' wopt_unset dflags allPmCheckWarnings)  -- | Check a pattern binding (let, where) for exhaustiveness. pmcPatBind :: DsMatchContext -> Id -> Pat GhcTc -> DsM ()@@ -111,7 +106,7 @@   tracePm "pmcPatBind {" (vcat [ppr ctxt, ppr var, ppr p, ppr pat_bind, ppr missing])   result <- unCA (checkPatBind pat_bind) missing   tracePm "}: " (ppr (cr_uncov result))-  formatReportWarnings cirbsPatBind ctxt [var] result+  formatReportWarnings ReportPatBind ctxt [var] result pmcPatBind _ _ _ = pure ()  -- | Exhaustive for guard matches, is used for guards in pattern bindings and@@ -122,7 +117,7 @@   -> DsM (NonEmpty Nablas)        -- ^ Covered 'Nablas' for each RHS, for long                                   --   distance info pmcGRHSs hs_ctxt guards@(GRHSs _ grhss _) = do-  let combined_loc = foldl1 combineSrcSpans (map getLoc grhss)+  let combined_loc = foldl1 combineSrcSpans (map getLocA grhss)       ctxt = DsMatchContext hs_ctxt combined_loc   !missing <- getLdiNablas   matches  <- noCheckDs $ desugarGRHSs combined_loc empty guards@@ -132,7 +127,7 @@                                 (pprGRHSs hs_ctxt guards $$ ppr missing))   result <- unCA (checkGRHSs matches) missing   tracePm "}: " (ppr (cr_uncov result))-  formatReportWarnings cirbsGRHSs ctxt [] result+  formatReportWarnings ReportGRHSs ctxt [] result   return (ldiGRHSs (cr_ret result))  -- | Check a list of syntactic 'Match'es (part of case, functions, etc.), each@@ -156,7 +151,7 @@   -> [LMatch GhcTc (LHsExpr GhcTc)]  -- ^ List of matches   -> DsM [(Nablas, NonEmpty Nablas)] -- ^ One covered 'Nablas' per Match and                                      --   GRHS, for long distance info.-pmcMatches ctxt vars matches = do+pmcMatches ctxt vars matches = {-# SCC "pmcMatches" #-} do   -- We have to force @missing@ before printing out the trace message,   -- otherwise we get interleaved output from the solver. This function   -- should be strict in @missing@ anyway!@@ -172,13 +167,15 @@       empty_case <- noCheckDs $ desugarEmptyCase var       result <- unCA (checkEmptyCase empty_case) missing       tracePm "}: " (ppr (cr_uncov result))-      formatReportWarnings cirbsEmptyCase ctxt vars result+      formatReportWarnings ReportEmptyCase ctxt vars result       return []     Just matches -> do-      matches <- noCheckDs $ desugarMatches vars matches-      result <- unCA (checkMatchGroup matches) missing+      matches <- {-# SCC "desugarMatches" #-}+                 noCheckDs $ desugarMatches vars matches+      result  <- {-# SCC "checkMatchGroup" #-}+                 unCA (checkMatchGroup matches) missing       tracePm "}: " (ppr (cr_uncov result))-      formatReportWarnings cirbsMatchGroup ctxt vars result+      {-# SCC "formatReportWarnings" #-} formatReportWarnings ReportMatchGroup ctxt vars result       return (NE.toList (ldiMatchGroup (cr_ret result)))  {- Note [pmcPatBind only checks PatBindRhs]@@ -321,25 +318,45 @@ -- * Formatting and reporting warnings -- --- | Given a function that collects 'CIRB's, this function will emit warnings+-- | A datatype to accomodate the different call sites of+-- 'formatReportWarnings'. Used for extracting 'CIRB's from a concrete 'ann'+-- through 'collectInMode'. Since this is only possible for a couple of+-- well-known 'ann's, this is a GADT.+data FormatReportWarningsMode ann where+  ReportPatBind :: FormatReportWarningsMode (PmPatBind Post)+  ReportGRHSs   :: FormatReportWarningsMode (PmGRHSs Post)+  ReportMatchGroup:: FormatReportWarningsMode (PmMatchGroup Post)+  ReportEmptyCase:: FormatReportWarningsMode PmEmptyCase++deriving instance Eq (FormatReportWarningsMode ann)++-- | A function collecting 'CIRB's for each of the different+-- 'FormatReportWarningsMode's.+collectInMode :: FormatReportWarningsMode ann -> ann -> DsM CIRB+collectInMode ReportPatBind    = cirbsPatBind+collectInMode ReportGRHSs      = cirbsGRHSs+collectInMode ReportMatchGroup = cirbsMatchGroup+collectInMode ReportEmptyCase  = cirbsEmptyCase++-- | Given a 'FormatReportWarningsMode', this function will emit warnings -- for a 'CheckResult'.-formatReportWarnings :: (ann -> DsM CIRB) -> DsMatchContext -> [Id] -> CheckResult ann -> DsM ()-formatReportWarnings collect ctx vars cr@CheckResult { cr_ret = ann } = do-  cov_info <- collect ann+formatReportWarnings :: FormatReportWarningsMode ann -> DsMatchContext -> [Id] -> CheckResult ann -> DsM ()+formatReportWarnings report_mode ctx vars cr@CheckResult { cr_ret = ann } = do+  cov_info <- collectInMode report_mode ann   dflags <- getDynFlags-  reportWarnings dflags ctx vars cr{cr_ret=cov_info}+  reportWarnings dflags report_mode ctx vars cr{cr_ret=cov_info}  -- | Issue all the warnings -- (redundancy, inaccessibility, exhaustiveness, redundant bangs).-reportWarnings :: DynFlags -> DsMatchContext -> [Id] -> CheckResult CIRB -> DsM ()-reportWarnings dflags ctx@(DsMatchContext kind loc) vars+reportWarnings :: DynFlags -> FormatReportWarningsMode ann -> DsMatchContext -> [Id] -> CheckResult CIRB -> DsM ()+reportWarnings dflags report_mode (DsMatchContext kind loc) vars   CheckResult { cr_ret    = CIRB { cirb_inacc = inaccessible_rhss                                  , cirb_red   = redundant_rhss                                  , cirb_bangs = redundant_bangs }               , cr_uncov  = uncovered               , cr_approx = precision }   = when (flag_i || flag_u || flag_b) $ do-      unc_examples <- getNFirstUncovered vars (maxPatterns + 1) uncovered+      unc_examples <- getNFirstUncovered gen_mode vars (maxPatterns + 1) uncovered       let exists_r = flag_i && notNull redundant_rhss           exists_i = flag_i && notNull inaccessible_rhss           exists_u = flag_u && notNull unc_examples@@ -347,85 +364,39 @@           approx   = precision == Approximate        when (approx && (exists_u || exists_i)) $-        putSrcSpanDs loc (warnDs NoReason approx_msg)+        putSrcSpanDs loc (diagnosticDs (DsMaxPmCheckModelsReached (maxPmCheckModels dflags)))        when exists_b $ forM_ redundant_bangs $ \(SrcInfo (L l q)) ->-        putSrcSpanDs l (warnDs (Reason Opt_WarnRedundantBangPatterns)-                               (pprEqn q "has redundant bang"))+        putSrcSpanDs l (diagnosticDs (DsRedundantBangPatterns kind q))        when exists_r $ forM_ redundant_rhss $ \(SrcInfo (L l q)) ->-        putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)-                               (pprEqn q "is redundant"))+        putSrcSpanDs l (diagnosticDs (DsOverlappingPatterns kind q))       when exists_i $ forM_ inaccessible_rhss $ \(SrcInfo (L l q)) ->-        putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)-                               (pprEqn q "has inaccessible right hand side"))+        putSrcSpanDs l (diagnosticDs (DsInaccessibleRhs kind q)) -      when exists_u $ putSrcSpanDs loc $ warnDs flag_u_reason $-        pprEqns vars unc_examples+      when exists_u $+        putSrcSpanDs loc (diagnosticDs (DsNonExhaustivePatterns kind check_type maxPatterns vars unc_examples))   where     flag_i = overlapping dflags kind     flag_u = exhaustive dflags kind     flag_b = redundantBang dflags-    flag_u_reason = maybe NoReason Reason (exhaustiveWarningFlag kind)+    check_type = ExhaustivityCheckType (exhaustiveWarningFlag kind)+    gen_mode = case report_mode of -- See Note [Case split inhabiting patterns]+      ReportEmptyCase -> CaseSplitTopLevel+      _               -> MinimalCover      maxPatterns = maxUncoveredPatterns dflags -    -- Print a single clause (for redundant/with-inaccessible-rhs)-    pprEqn q txt = pprContext True ctx (text txt) $ \f ->-      f (q <+> matchSeparator kind <+> text "...")--    -- Print several clauses (for uncovered clauses)-    pprEqns vars nablas = pprContext False ctx (text "are non-exhaustive") $ \_ ->-      case vars of -- See #11245-           [] -> text "Guards do not cover entire pattern space"-           _  -> let us = map (\nabla -> pprUncovered nabla vars) nablas-                     pp_tys = pprQuotedList $ map idType vars-                 in  hang-                       (text "Patterns of type" <+> pp_tys <+> text "not matched:")-                       4-                       (vcat (take maxPatterns us) $$ dots maxPatterns us)--    approx_msg = vcat-      [ hang-          (text "Pattern match checker ran into -fmax-pmcheck-models="-            <> int (maxPmCheckModels dflags)-            <> text " limit, so")-          2-          (  bullet <+> text "Redundant clauses might not be reported at all"-          $$ bullet <+> text "Redundant clauses might be reported as inaccessible"-          $$ bullet <+> text "Patterns reported as unmatched might actually be matched")-      , text "Increase the limit or resolve the warnings to suppress this message." ]--getNFirstUncovered :: [Id] -> Int -> Nablas -> DsM [Nabla]-getNFirstUncovered vars n (MkNablas nablas) = go n (bagToList nablas)+getNFirstUncovered :: GenerateInhabitingPatternsMode -> [Id] -> Int -> Nablas -> DsM [Nabla]+getNFirstUncovered mode vars n (MkNablas nablas) = go n (bagToList nablas)   where     go 0 _              = pure []     go _ []             = pure []     go n (nabla:nablas) = do-      front <- generateInhabitingPatterns vars n nabla+      front <- generateInhabitingPatterns mode vars n nabla       back <- go (n - length front) nablas       pure (front ++ back) -dots :: Int -> [a] -> SDoc-dots maxPatterns qs-    | qs `lengthExceeds` maxPatterns = text "..."-    | otherwise                      = empty--pprContext :: Bool -> DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc-pprContext singular (DsMatchContext kind _loc) msg rest_of_msg_fun-  = vcat [text txt <+> msg,-          sep [ text "In" <+> ppr_match <> char ':'-              , nest 4 (rest_of_msg_fun pref)]]-  where-    txt | singular  = "Pattern match"-        | otherwise = "Pattern match(es)"--    (ppr_match, pref)-        = case kind of-             FunRhs { mc_fun = L _ fun }-                  -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)-             _    -> (pprMatchContext kind, \ pp -> pp)- -- -- * Adding external long-distance information --@@ -448,24 +419,25 @@               addPhiCtsNablas nablas (PhiTyCt . evVarPred <$> ev_vars))             m --- | Add equalities for the 'CoreExpr' scrutinee to the local 'DsM' environment--- when checking a case expression:+-- | Add equalities for the 'CoreExpr' scrutinees to the local 'DsM' environment,+-- e.g. when checking a case expression: --     case e of x { matches } -- When checking matches we record that (x ~ e) where x is the initial -- uncovered. All matches will have to satisfy this equality.-addCoreScrutTmCs :: Maybe CoreExpr -> [Id] -> DsM a -> DsM a-addCoreScrutTmCs Nothing    _   k = k-addCoreScrutTmCs (Just scr) [x] k =-  flip locallyExtendPmNablas k $ \nablas ->+-- This is also used for the Arrows \cases command, where these equalities have+-- to be added for multiple scrutinees rather than just one.+addCoreScrutTmCs :: [CoreExpr] -> [Id] -> DsM a -> DsM a+addCoreScrutTmCs []         _      k = k+addCoreScrutTmCs (scr:scrs) (x:xs) k =+  flip locallyExtendPmNablas (addCoreScrutTmCs scrs xs k) $ \nablas ->     addPhiCtsNablas nablas (unitBag (PhiCoreCt x scr))-addCoreScrutTmCs _   _   _ = panic "addCoreScrutTmCs: scrutinee, but more than one match id"+addCoreScrutTmCs _   _   _ = panic "addCoreScrutTmCs: numbers of scrutinees and match ids differ" --- | 'addCoreScrutTmCs', but desugars the 'LHsExpr' first.-addHsScrutTmCs :: Maybe (LHsExpr GhcTc) -> [Id] -> DsM a -> DsM a-addHsScrutTmCs Nothing    _    k = k-addHsScrutTmCs (Just scr) vars k = do-  scr_e <- dsLExpr scr-  addCoreScrutTmCs (Just scr_e) vars k+-- | 'addCoreScrutTmCs', but desugars the 'LHsExpr's first.+addHsScrutTmCs :: [LHsExpr GhcTc] -> [Id] -> DsM a -> DsM a+addHsScrutTmCs scrs vars k = do+  scr_es <- traverse dsLExpr scrs+  addCoreScrutTmCs scr_es vars k  {- Note [Long-distance information] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/HsToCore/Pmc/Check.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP               #-}+ {-# LANGUAGE DeriveFunctor     #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs             #-}@@ -21,8 +21,6 @@         CheckAction(..),         checkMatchGroup, checkGRHSs, checkPatBind, checkEmptyCase     ) where--#include "GhclibHsVersions.h"  import GHC.Prelude
compiler/GHC/HsToCore/Pmc/Desugar.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE CPP               #-}+ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs             #-} {-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE DisambiguateRecordFields #-}  -- | Desugaring step of the -- [Lower Your Guards paper](https://dl.acm.org/doi/abs/10.1145/3408989).@@ -13,8 +14,6 @@       desugarPatBind, desugarGRHSs, desugarMatches, desugarEmptyCase     ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.HsToCore.Pmc.Types@@ -33,7 +32,6 @@ import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Misc import GHC.Core.DataCon import GHC.Types.Var (EvVar) import GHC.Core.Coercion@@ -76,7 +74,7 @@ -- where @b@ and @c@ are freshly allocated in @mkListGrds@ and @a@ is the match -- variable. mkListGrds :: Id -> [(Id, [PmGrd])] -> DsM [PmGrd]--- See Note [Order of guards matter] for why we need to intertwine guards+-- See Note [Order of guards matters] for why we need to intertwine guards -- on list elements. mkListGrds a []                  = pure [vanillaConGrd a nilDataCon []] mkListGrds a ((x, head_grds):xs) = do@@ -111,7 +109,7 @@ desugarPat x pat = case pat of   WildPat  _ty -> pure []   VarPat _ y   -> pure (mkPmLetVar (unLoc y) x)-  ParPat _ p   -> desugarLPat x p+  ParPat _ _ p _ -> desugarLPat x p   LazyPat _ _  -> pure [] -- like a wildcard   BangPat _ p@(L l p') ->     -- Add the bang in front of the list, because it will happen before any@@ -125,17 +123,38 @@    SigPat _ p _ty -> desugarLPat x p -  -- See Note [Desugar CoPats]-  -- Generally the translation is-  -- pat |> co   ===>   let y = x |> co, pat <- y  where y is a match var of pat-  XPat (CoPat wrapper p _ty)-    | isIdHsWrapper wrapper                   -> desugarPat x p-    | WpCast co <-  wrapper, isReflexiveCo co -> desugarPat x p-    | otherwise -> do-        (y, grds) <- desugarPatV p-        wrap_rhs_y <- dsHsWrapper wrapper-        pure (PmLet y (wrap_rhs_y (Var x)) : grds)+  XPat ext -> case ext of +    ExpansionPat orig expansion -> do+      dflags <- getDynFlags+      case orig of+        -- We add special logic for overloaded list patterns. When:+        --   - a ViewPat is the expansion of a ListPat,+        --   - RebindableSyntax is off,+        --   - the type of the pattern is the built-in list type,+        -- then we assume that the view function, 'toList', is the identity.+        -- This improves pattern-match overload checks, as this will allow+        -- the pattern match checker to directly inspect the inner pattern.+        -- See #14547, and Note [Desugaring overloaded list patterns] (Wrinkle).+        ListPat {}+          | ViewPat arg_ty _lexpr pat <- expansion+          , not (xopt LangExt.RebindableSyntax dflags)+          , Just _ <- splitListTyConApp_maybe arg_ty+          -> desugarLPat x pat++        _ -> desugarPat x expansion++    -- See Note [Desugar CoPats]+    -- Generally the translation is+    -- pat |> co   ===>   let y = x |> co, pat <- y  where y is a match var of pat+    CoPat wrapper p _ty+      | isIdHsWrapper wrapper                   -> desugarPat x p+      | WpCast co <-  wrapper, isReflexiveCo co -> desugarPat x p+      | otherwise -> do+          (y, grds) <- desugarPatV p+          wrap_rhs_y <- dsHsWrapper wrapper+          pure (PmLet y (wrap_rhs_y (Var x)) : grds)+   -- (n + k)  ===>   let b = x >= k, True <- b, let n = x-k   NPlusKPat _pat_ty (L _ n) k1 k2 ge minus -> do     b <- mkPmId boolTy@@ -152,37 +171,9 @@     pure $ PmLet y (App fun (Var x)) : grds    -- list-  ListPat (ListPatTc _elem_ty Nothing) ps ->+  ListPat _ ps ->     desugarListPat x ps -  -- overloaded list-  ListPat (ListPatTc elem_ty (Just (pat_ty, to_list))) pats -> do-    dflags <- getDynFlags-    case splitListTyConApp_maybe pat_ty of-      Just _e_ty-        | not (xopt LangExt.RebindableSyntax dflags)-        -- Just desugar it as a regular ListPat-        -> desugarListPat x pats-      _ -> do-        y <- mkPmId (mkListTy elem_ty)-        grds <- desugarListPat y pats-        rhs_y <- dsSyntaxExpr to_list [Var x]-        pure $ PmLet y rhs_y : grds--    -- (a) In the presence of RebindableSyntax, we don't know anything about-    --     `toList`, we should treat `ListPat` as any other view pattern.-    ---    -- (b) In the absence of RebindableSyntax,-    --     - If the pat_ty is `[a]`, then we treat the overloaded list pattern-    --       as ordinary list pattern. Although we can give an instance-    --       `IsList [Int]` (more specific than the default `IsList [a]`), in-    --       practice, we almost never do that. We assume the `to_list` is-    --       the `toList` from `instance IsList [a]`.-    ---    --     - Otherwise, we treat the `ListPat` as ordinary view pattern.-    ---    -- See #14547, especially comment#9 and comment#10.-   ConPat { pat_con     = L _ con          , pat_args    = ps          , pat_con_ext = ConPatTc@@ -203,7 +194,7 @@     dflags <- getDynFlags     let platform = targetPlatform dflags     pm_lit <- case olit of-      OverLit{ ol_val = val, ol_ext = OverLitTc rebindable _ }+      OverLit{ ol_val = val, ol_ext = OverLitTc { ol_rebindable = rebindable } }         | not rebindable         , Just expr <- shortCutLit platform val ty         -> coreExprAsPmLit <$> dsExpr expr@@ -290,7 +281,7 @@     -- LHsRecField     rec_field_ps fs = map (tagged_pat . unLoc) fs       where-        tagged_pat f = (lbl_to_index (getName (hsRecFieldId f)), hsRecFieldArg f)+        tagged_pat f = (lbl_to_index (getName (hsRecFieldId f)), hfbRHS f)         -- Unfortunately the label info is empty when the DataCon wasn't defined         -- with record field labels, hence we desugar to field index.         orig_lbls        = map flSelector $ conLikeFieldLabels con@@ -397,15 +388,17 @@       , GRHSs{grhssGRHSs = [L _ (GRHS _ _grds rhs)]} <- grhss = do           core_rhs <- dsLExpr rhs           return [PmLet x core_rhs]-    go (L _ AbsBinds{ abs_tvs = [], abs_ev_vars = []-                    , abs_exports=exports, abs_binds = binds }) = do+    go (L _ (XHsBindsLR (AbsBinds+                          { abs_tvs = [], abs_ev_vars = []+                          , abs_exports=exports, abs_binds = binds }))) = do       -- Typechecked HsLocalBinds are wrapped in AbsBinds, which carry       -- renamings. See Note [Long-distance information for HsLocalBinds]       -- for the details.-      let go_export :: ABExport GhcTc -> Maybe PmGrd+      let go_export :: ABExport -> Maybe PmGrd           go_export ABE{abe_poly = x, abe_mono = y, abe_wrap = wrap}             | isIdHsWrapper wrap-            = ASSERT2(idType x `eqType` idType y, ppr x $$ ppr (idType x) $$ ppr y $$ ppr (idType y))+            = assertPpr (idType x `eqType` idType y)+                        (ppr x $$ ppr (idType x) $$ ppr y $$ ppr (idType y)) $               Just $ PmLet x (Var y)             | otherwise             = Nothing
− compiler/GHC/HsToCore/Pmc/Ppr.hs 
@@ -1,210 +0,0 @@-{-# LANGUAGE CPP #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}---- | Provides factilities for pretty-printing 'Nabla's in a way appropriate for--- user facing pattern match warnings.-module GHC.HsToCore.Pmc.Ppr (-        pprUncovered-    ) where--#include "GhclibHsVersions.h"--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 Control.Monad.Trans.RWS.CPS-import GHC.Utils.Misc-import GHC.Data.Maybe-import Data.List.NonEmpty (NonEmpty, nonEmpty, toList)--import GHC.HsToCore.Pmc.Types-import GHC.HsToCore.Pmc.Solver---- | Pretty-print the guts of an uncovered value vector abstraction, i.e., its--- components and refutable shapes associated to any mentioned variables.------ 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.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE LambdaCase          #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns        #-}@@ -23,23 +23,20 @@ module GHC.HsToCore.Pmc.Solver (          Nabla, Nablas(..), initNablas,-        lookupRefuts, lookupSolution,          PhiCt(..), PhiCts,         addPhiCtNablas,         addPhiCtsNablas,          isInhabited,-        generateInhabitingPatterns+        generateInhabitingPatterns, GenerateInhabitingPatternsMode(..)      ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.HsToCore.Pmc.Types-import GHC.HsToCore.Pmc.Utils (tracePm, mkPmId)+import GHC.HsToCore.Pmc.Utils (tracePm, traceWhenFailPm, mkPmId)  import GHC.Driver.Session import GHC.Driver.Config@@ -47,7 +44,9 @@ import GHC.Utils.Misc import GHC.Utils.Monad (allM) import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Data.Bag+import GHC.Types.Basic (Levity(..)) import GHC.Types.CompleteMatch import GHC.Types.Unique.Set import GHC.Types.Unique.DSet@@ -72,6 +71,7 @@ import GHC.Core.PatSyn import GHC.Core.TyCon import GHC.Core.TyCon.RecWalk+import GHC.Builtin.Names import GHC.Builtin.Types import GHC.Builtin.Types.Prim (tYPETyCon) import GHC.Core.TyCo.Rep@@ -80,6 +80,7 @@ import GHC.Tc.Solver   (tcNormalise, tcCheckGivens, tcCheckWanteds) import GHC.Core.Unify    (tcMatchTy) import GHC.Core.Coercion+import GHC.Core.Reduction import GHC.HsToCore.Monad hiding (foldlM) import GHC.Tc.Instance.Family import GHC.Core.FamInstEnv@@ -96,6 +97,9 @@ import qualified Data.List.NonEmpty as NE import Data.Ord      (comparing) +import GHC.Utils.Trace+_ = pprTrace -- to silence unused import warnings+ -- -- * Main exports --@@ -143,7 +147,7 @@ -- Ex.: @vanillaCompleteMatchTC 'Maybe' ==> Just ("Maybe", {'Just','Nothing'})@ vanillaCompleteMatchTC :: TyCon -> Maybe CompleteMatch vanillaCompleteMatchTC tc =-  let -- | TYPE acts like an empty data type on the term-level (#14086), but+  let -- TYPE acts like an empty data type on the term-level (#14086), but       -- it is a PrimTyCon, so tyConDataCons_maybe returns Nothing. Hence a       -- special case.       mb_dcs | tc == tYPETyCon = Just []@@ -169,7 +173,7 @@ addTyConMatches :: TyCon -> ResidualCompleteMatches -> DsM ResidualCompleteMatches addTyConMatches tc rcm = add_tc_match <$> addCompleteMatches rcm   where-    -- | Add the vanilla COMPLETE set from the data defn, if any. But only if+    -- Add the vanilla COMPLETE set from the data defn, if any. But only if     -- it's not already present.     add_tc_match rcm       = rcm{rcm_vanilla = rcm_vanilla rcm <|> vanillaCompleteMatchTC tc}@@ -326,23 +330,23 @@ -- NB: Normalisation can potentially change kinds, if the head of the type -- is a type family with a variable result kind. I (Richard E) can't think -- of a way to cause trouble here, though.-pmTopNormaliseType (TySt _ inert) typ-  = do env <- dsGetFamInstEnvs-       tracePm "normalise" (ppr typ)-       -- Before proceeding, we chuck typ into the constraint solver, in case-       -- solving for given equalities may reduce typ some. See-       -- "Wrinkle: local equalities" in Note [Type normalisation].-       typ' <- initTcDsForSolver $ tcNormalise inert typ-       -- Now we look with topNormaliseTypeX through type and data family-       -- applications and newtypes, which tcNormalise does not do.-       -- See also 'TopNormaliseTypeResult'.-       pure $ case topNormaliseTypeX (stepper env) comb typ' of-         Nothing                -> NormalisedByConstraints typ'-         Just ((ty_f,tm_f), ty) -> HadRedexes src_ty newtype_dcs core_ty-           where-             src_ty = eq_src_ty ty (typ' : ty_f [ty])-             newtype_dcs = tm_f []-             core_ty = ty+pmTopNormaliseType (TySt _ inert) typ = {-# SCC "pmTopNormaliseType" #-} do+  env <- dsGetFamInstEnvs+  tracePm "normalise" (ppr typ)+  -- Before proceeding, we chuck typ into the constraint solver, in case+  -- solving for given equalities may reduce typ some. See+  -- "Wrinkle: local equalities" in Note [Type normalisation].+  typ' <- initTcDsForSolver $ tcNormalise inert typ+  -- Now we look with topNormaliseTypeX through type and data family+  -- applications and newtypes, which tcNormalise does not do.+  -- See also 'TopNormaliseTypeResult'.+  pure $ case topNormaliseTypeX (stepper env) comb typ' of+    Nothing                -> NormalisedByConstraints typ'+    Just ((ty_f,tm_f), ty) -> HadRedexes src_ty newtype_dcs core_ty+      where+        src_ty = eq_src_ty ty (typ' : ty_f [ty])+        newtype_dcs = tm_f []+        core_ty = ty   where     -- Find the first type in the sequence of rewrites that is a data type,     -- newtype, or a data family application (not the representation tycon!).@@ -378,8 +382,9 @@     tyFamStepper :: FamInstEnvs -> NormaliseStepper ([Type] -> [Type], a -> a)     tyFamStepper env rec_nts tc tys  -- Try to step a type/data family       = case topReduceTyFamApp_maybe env tc tys of-          Just (_, rhs, _) -> NS_Step rec_nts rhs ((rhs:), id)-          _                -> NS_Done+          Just (HetReduction (Reduction _ rhs) _)+            -> NS_Step rec_nts rhs ((rhs:), id)+          _ -> NS_Done  -- | Returns 'True' if the argument 'Type' is a fully saturated application of -- a closed type constructor.@@ -397,7 +402,7 @@   = case splitTyConApp_maybe ty of       Just (tc, ty_args)              | is_algebraic_like tc && not (isFamilyTyCon tc)-             -> ASSERT2( ty_args `lengthIs` tyConArity tc, ppr ty ) True+             -> assertPpr (ty_args `lengthIs` tyConArity tc) (ppr ty) True       _other -> False   where     -- This returns True for TyCons which /act like/ algebraic types.@@ -511,61 +516,9 @@ In order to avoid this pitfall, we need to normalise the type passed to pmTopNormaliseType, using the constraint solver to solve for any local equalities (such as i ~ Int) that may be in scope.--} --------------------------- * Looking up VarInfo--emptyRCM :: ResidualCompleteMatches-emptyRCM = RCM Nothing Nothing--emptyVarInfo :: Id -> VarInfo-emptyVarInfo x-  = VI-  { vi_id = x-  , vi_pos = []-  , vi_neg = emptyPmAltConSet-  -- Why not set IsNotBot for unlifted type here?-  -- Because we'd have to trigger an inhabitation test, which we can't.-  -- See case (4) in Note [Strict fields and variables of unlifted type]-  -- in GHC.HsToCore.Pmc.Solver-  , vi_bot = MaybeBot-  , vi_rcm = emptyRCM-  }--lookupVarInfo :: TmState -> Id -> VarInfo--- (lookupVarInfo tms x) tells what we know about 'x'-lookupVarInfo (TmSt env _ _) x = fromMaybe (emptyVarInfo x) (lookupUSDFM env x)---- | Like @lookupVarInfo ts x@, but @lookupVarInfo ts x = (y, vi)@ also looks--- through newtype constructors. We have @x ~ N1 (... (Nk y))@ such that the--- returned @y@ doesn't have a positive newtype constructor constraint--- associated with it (yet). The 'VarInfo' returned is that of @y@'s--- representative.------ Careful, this means that @idType x@ might be different to @idType y@, even--- modulo type normalisation!------ See also Note [Coverage checking Newtype matches].-lookupVarInfoNT :: TmState -> Id -> (Id, VarInfo)-lookupVarInfoNT ts x = case lookupVarInfo ts x of-  VI{ vi_pos = as_newtype -> Just y } -> lookupVarInfoNT ts y-  res                                 -> (x, res)-  where-    as_newtype = listToMaybe . mapMaybe go-    go PACA{paca_con = PmAltConLike (RealDataCon dc), paca_ids = [y]}-      | isNewDataCon dc = Just y-    go _                = Nothing--trvVarInfo :: Functor f => (VarInfo -> f (a, VarInfo)) -> Nabla -> Id -> f (a, Nabla)-trvVarInfo f nabla@MkNabla{ nabla_tm_st = ts@TmSt{ts_facts = env} } x-  = set_vi <$> f (lookupVarInfo ts x)-  where-    set_vi (a, vi') =-      (a, nabla{ nabla_tm_st = ts{ ts_facts = addToUSDFM env (vi_id vi') vi' } })--{- Note [Coverage checking Newtype matches]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [Coverage checking Newtype matches]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Newtypes have quite peculiar match semantics compared to ordinary DataCons. In a pattern-match, they behave like a irrefutable (lazy) match, but for inhabitation testing purposes (e.g. at construction sites), they behave rather like a DataCon@@ -592,28 +545,6 @@ where you can find the solution in a perhaps more digestible format. -} ---------------------------------------------------- * Exported utility functions querying 'Nabla'--lookupRefuts :: Nabla -> Id -> [PmAltCon]--- Unfortunately we need the extra bit of polymorphism and the unfortunate--- duplication of lookupVarInfo here.-lookupRefuts MkNabla{ nabla_tm_st = ts } x =-  pmAltConSetElems $ vi_neg $ lookupVarInfo ts x--isDataConSolution :: PmAltConApp -> Bool-isDataConSolution PACA{paca_con = PmAltConLike (RealDataCon _)} = True-isDataConSolution _                                             = False---- @lookupSolution nabla x@ picks a single solution ('vi_pos') of @x@ from--- possibly many, preferring 'RealDataCon' solutions whenever possible.-lookupSolution :: Nabla -> Id -> Maybe PmAltConApp-lookupSolution nabla x = case vi_pos (lookupVarInfo (nabla_tm_st nabla) x) of-  []                                         -> Nothing-  pos-    | Just sol <- find isDataConSolution pos -> Just sol-    | otherwise                              -> Just (head pos)- ------------------------- -- * Adding φ constraints --@@ -691,13 +622,16 @@  -- | Add some extra type constraints to the 'TyState'; return 'Nothing' if we -- find a contradiction (e.g. @Int ~ Bool@).+--+-- See Note [Pattern match warnings with insoluble Givens] in GHC.Tc.Solver. tyOracle :: TyState -> Bag PredType -> DsM (Maybe TyState) tyOracle ty_st@(TySt n inert) cts   | isEmptyBag cts   = pure (Just ty_st)   | otherwise-  = do { evs <- traverse nameTyCt cts-       ; tracePm "tyOracle" (ppr cts $$ ppr inert)+  = {-# SCC "tyOracle" #-}+    do { evs <- traverse nameTyCt cts+       ; tracePm "tyOracle" (ppr n $$ ppr cts $$ ppr inert)        ; mb_new_inert <- initTcDsForSolver $ tcCheckGivens inert evs          -- return the new inert set and increment the sequence number n        ; return (TySt (n+1) <$> mb_new_inert) }@@ -741,7 +675,7 @@ filterUnliftedFields :: PmAltCon -> [Id] -> [Id] filterUnliftedFields con args =   [ arg | (arg, bang) <- zipEqual "addPhiCt" args (pmAltConImplBangs con)-        , isBanged bang || isUnliftedType (idType arg) ]+        , isBanged bang || typeLevity_maybe (idType arg) == Just Unlifted ]  -- | Adds the constraint @x ~ ⊥@, e.g. that evaluation of a particular 'Id' @x@ -- surely diverges. Quite similar to 'addConCt', only that it only cares about@@ -752,11 +686,12 @@   case bot of     IsNotBot -> mzero      -- There was x ≁ ⊥. Contradiction!     IsBot    -> pure nabla -- There already is x ~ ⊥. Nothing left to do-    MaybeBot ->            -- We add x ~ ⊥+    MaybeBot               -- We add x ~ ⊥+      | Just Unlifted <- typeLevity_maybe (idType x)       -- Case (3) in Note [Strict fields and variables of unlifted type]-      if isUnliftedType (idType x)-        then mzero -- unlifted vars can never be ⊥-        else do+      -> mzero -- unlifted vars can never be ⊥+      | otherwise+      -> do           let vi' = vi{ vi_bot = IsBot }           pure nabla{ nabla_tm_st = ts{ts_facts = addToUSDFM env y vi' } } @@ -787,7 +722,7 @@     Just x  -> markDirty x nabla'     Nothing -> nabla'   where-    -- | Update `x`'s 'VarInfo' entry. Fail ('MaybeT') if contradiction,+    -- Update `x`'s 'VarInfo' entry. Fail ('MaybeT') if contradiction,     -- otherwise return updated entry and `Just x'` if `x` should be marked dirty,     -- where `x'` is the representative of `x`.     go :: VarInfo -> MaybeT DsM (Maybe Id, VarInfo)@@ -803,7 +738,7 @@             -- See Note [Completeness checking with required Thetas]             | hasRequiredTheta nalt  = neg             | otherwise              = extendPmAltConSet neg nalt-      MASSERT( isPmAltConMatchStrict nalt )+      massert (isPmAltConMatchStrict nalt)       let vi' = vi{ vi_neg = neg', vi_bot = IsNotBot }       -- 3. Make sure there's at least one other possible constructor       mb_rcm' <- lift (markMatched nalt rcm)@@ -844,8 +779,6 @@     Just (PACA _con other_tvs other_args) -> do       -- We must unify existentially bound ty vars and arguments!       let ty_cts = equateTys (map mkTyVarTy tvs) (map mkTyVarTy other_tvs)-      when (length args /= length other_args) $-        lift $ tracePm "error" (ppr x <+> ppr alt <+> ppr args <+> ppr other_args)       nabla' <- MaybeT $ addPhiCts nabla (listToBag ty_cts)       let add_var_ct nabla (a, b) = addVarCt nabla a b       foldlM add_var_ct nabla' $ zipEqual "addConCt" args other_args@@ -860,7 +793,7 @@             MaybeBot -> pure (nabla_with MaybeBot)             IsBot    -> addBotCt (nabla_with MaybeBot) y             IsNotBot -> addNotBotCt (nabla_with MaybeBot) y-        _ -> ASSERT( isPmAltConMatchStrict alt )+        _ -> assert (isPmAltConMatchStrict alt )              pure (nabla_with IsNotBot) -- strict match ==> not ⊥  equateTys :: [Type] -> [Type] -> [PhiCt]@@ -913,7 +846,7 @@   -- lift $ tracePm "addCoreCt" (ppr x <+> dcolon <+> ppr (idType x) $$ ppr e $$ ppr e')   execStateT (core_expr x e') nabla   where-    -- | Takes apart a 'CoreExpr' and tries to extract as much information about+    -- Takes apart a 'CoreExpr' and tries to extract as much information about     -- literals and constructor applications as possible.     core_expr :: Id -> CoreExpr -> StateT Nabla (MaybeT DsM) ()     -- TODO: Handle newtypes properly, by wrapping the expression in a DataCon@@ -954,7 +887,7 @@         -- up substituting inside a forall or lambda (i.e. seldom)         -- so using exprFreeVars seems fine.   See MR !1647. -    -- | The @e@ in @let x = e@ had no familiar form. But we can still see if+    -- The @e@ in @let x = e@ had no familiar form. But we can still see if     -- see if we already encountered a constraint @let y = e'@ with @e'@     -- semantically equivalent to @e@, in which case we may add the constraint     -- @x ~ y@.@@ -970,7 +903,7 @@       core_expr x e       pure x -    -- | Look at @let x = K taus theta es@ and generate the following+    -- Look at @let x = K taus theta es@ and generate the following     -- constraints (assuming universals were dropped from @taus@ before):     --   1. @x ≁ ⊥@ if 'K' is not a Newtype constructor.     --   2. @a_1 ~ tau_1, ..., a_n ~ tau_n@ for fresh @a_i@@@ -997,7 +930,7 @@       -- 4. @x ~ K as ys@       pm_alt_con_app x (PmAltConLike (RealDataCon dc)) ex_tvs arg_ids -    -- | Adds a literal constraint, i.e. @x ~ 42@.+    -- Adds a literal constraint, i.e. @x ~ 42@.     -- Also we assume that literal expressions won't diverge, so this     -- will add a @x ~/ ⊥@ constraint.     pm_lit :: Id -> PmLit -> StateT Nabla (MaybeT DsM) ()@@ -1005,7 +938,7 @@       modifyT $ \nabla -> addNotBotCt nabla x       pm_alt_con_app x (PmAltLit lit) [] [] -    -- | Adds the given constructor application as a solution for @x@.+    -- Adds the given constructor application as a solution for @x@.     pm_alt_con_app :: Id -> PmAltCon -> [TyVar] -> [Id] -> StateT Nabla (MaybeT DsM) ()     pm_alt_con_app x con tvs args = modifyT $ \nabla -> addConCt nabla x con tvs args @@ -1073,7 +1006,7 @@ oracle or doing inhabitation testing) contradictory. This implies a few invariants: * Whenever vi_pos overlaps with vi_neg according to 'eqPmAltCon', we refute.-  This is implied by the Note [Pos/Neg invariant].+  This is implied by the Note [The Pos/Neg invariant]. * Whenever vi_neg subsumes a COMPLETE set, we refute. We consult vi_rcm to   detect this, but we could just compare whole COMPLETE sets to vi_neg every   time, if it weren't for performance.@@ -1262,7 +1195,7 @@ -- The \(∇ ⊢ x inh\) judgment form in Figure 8 of the LYG paper. inhabitationTest :: Int -> TyState -> Nabla -> MaybeT DsM Nabla inhabitationTest 0     _         nabla             = pure nabla-inhabitationTest fuel  old_ty_st nabla@MkNabla{ nabla_tm_st = ts } = do+inhabitationTest fuel  old_ty_st nabla@MkNabla{ nabla_tm_st = ts } = {-# SCC "inhabitationTest" #-} do   -- lift $ tracePm "inhabitation test" $ vcat   --   [ ppr fuel   --   , ppr old_ty_st@@ -1315,11 +1248,12 @@ --     remain that do not statisfy it.  This lazy approach just --     avoids doing unnecessary work. instantiate :: Int -> Nabla -> VarInfo -> MaybeT DsM VarInfo-instantiate fuel nabla vi = instBot fuel nabla vi <|> instCompleteSets fuel nabla vi+instantiate fuel nabla vi = {-# SCC "instantiate" #-}+  (instBot fuel nabla vi <|> instCompleteSets fuel nabla vi)  -- | The \(⊢_{Bot}\) rule from the paper instBot :: Int -> Nabla -> VarInfo -> MaybeT DsM VarInfo-instBot _fuel nabla vi = do+instBot _fuel nabla vi = {-# SCC "instBot" #-} do   _nabla' <- addBotCt nabla (vi_id vi)   pure vi @@ -1353,7 +1287,7 @@ -- where all the attempted ConLike instantiations have been purged from the -- 'ResidualCompleteMatches', which functions as a cache. instCompleteSets :: Int -> Nabla -> VarInfo -> MaybeT DsM VarInfo-instCompleteSets fuel nabla vi = do+instCompleteSets fuel nabla vi = {-# SCC "instCompleteSets" #-} do   let x = vi_id vi   (rcm, nabla) <- lift (addNormalisedTypeMatches nabla x)   nabla <- foldM (\nabla cls -> instCompleteSet fuel nabla x cls) nabla (getRcm rcm)@@ -1384,7 +1318,7 @@   | not (completeMatchAppliesAtType (varType x) cs)   = pure nabla   | otherwise-  = go nabla (sorted_candidates cs)+  = {-# SCC "instCompleteSet" #-} go nabla (sorted_candidates cs)   where     vi = lookupVarInfo (nabla_tm_st nabla) x @@ -1423,23 +1357,26 @@ isDataConTriviallyInhabited dc   | isTyConTriviallyInhabited (dataConTyCon dc) = True isDataConTriviallyInhabited dc =-  null (dataConTheta dc) &&         -- (1)-  null (dataConImplBangs dc) &&     -- (2)-  null (dataConUnliftedFieldTys dc) -- (3)+  null (dataConTheta dc) &&                -- (1)+  null (dataConImplBangs dc) &&            -- (2)+  null (dataConMightBeUnliftedFieldTys dc) -- (3) -dataConUnliftedFieldTys :: DataCon -> [Type]-dataConUnliftedFieldTys =-  -- A levity polymorphic field requires an inhabitation test, hence compare to-  -- @Just True@-  filter ((== Just True) . isLiftedType_maybe) . map scaledThing . dataConOrigArgTys+dataConMightBeUnliftedFieldTys :: DataCon -> [Type]+dataConMightBeUnliftedFieldTys =+  filter mightBeUnliftedType . map scaledThing . dataConOrigArgTys  isTyConTriviallyInhabited :: TyCon -> Bool-isTyConTriviallyInhabited tc = elementOfUniqSet tc triviallyInhabitedTyCons+isTyConTriviallyInhabited tc = elementOfUniqSet (getUnique tc) triviallyInhabitedTyConKeys  -- | All these types are trivially inhabited-triviallyInhabitedTyCons :: UniqSet TyCon-triviallyInhabitedTyCons = mkUniqSet [-    charTyCon, doubleTyCon, floatTyCon, intTyCon, wordTyCon, word8TyCon+triviallyInhabitedTyConKeys :: UniqSet Unique+triviallyInhabitedTyConKeys = mkUniqSet [+    charTyConKey, doubleTyConKey, floatTyConKey,+    intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey,+    intPrimTyConKey, int8PrimTyConKey, int16PrimTyConKey, int32PrimTyConKey, int64PrimTyConKey,+    wordTyConKey, word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey,+    wordPrimTyConKey, word8PrimTyConKey, word16PrimTyConKey, word32PrimTyConKey, word64PrimTyConKey,+    trTyConTyConKey   ]  compareConLikeTestability :: ConLike -> ConLike -> Ordering@@ -1464,16 +1401,19 @@     -- the unlikely bogus case of an unlifted field that has a bang.     unlifted_or_strict_fields :: DataCon -> Int     unlifted_or_strict_fields dc = fast_length (dataConImplBangs dc)-                                 + fast_length (dataConUnliftedFieldTys dc)+                                 + fast_length (dataConMightBeUnliftedFieldTys dc)  -- | @instCon fuel nabla (x::match_ty) K@ tries to instantiate @x@ to @K@ by -- adding the proper constructor constraint. -- -- See Note [Instantiating a ConLike]. instCon :: Int -> Nabla -> Id -> ConLike -> MaybeT DsM Nabla-instCon fuel nabla@MkNabla{nabla_ty_st = ty_st} x con = MaybeT $ do+instCon fuel nabla@MkNabla{nabla_ty_st = ty_st} x con = {-# SCC "instCon" #-} MaybeT $ do+  let hdr what = "instCon " ++ show fuel ++ " " ++ what   env <- dsGetFamInstEnvs   let match_ty = idType x+  tracePm (hdr "{") $+    ppr con <+> text "... <-" <+> ppr x <+> dcolon <+> ppr match_ty   norm_match_ty <- normaliseSourceTypeWHNF ty_st match_ty   mb_sigma_univ <- matchConLikeResTy env ty_st norm_match_ty con   case mb_sigma_univ of@@ -1490,28 +1430,45 @@       -- (4) Instantiate fresh term variables as arguments to the constructor       let field_tys' = substTys sigma_ex $ map scaledThing field_tys       arg_ids <- mapM mkPmId field_tys'-      tracePm "instCon" $ vcat+      tracePm (hdr "(cts)") $ vcat         [ ppr x <+> dcolon <+> ppr match_ty         , text "In WHNF:" <+> ppr (isSourceTypeInWHNF match_ty) <+> ppr norm_match_ty         , ppr con <+> dcolon <+> text "... ->" <+> ppr _con_res_ty         , ppr (map (\tv -> ppr tv <+> char '↦' <+> ppr (substTyVar sigma_univ tv)) _univ_tvs)         , ppr gammas         , ppr (map (\x -> ppr x <+> dcolon <+> ppr (idType x)) arg_ids)-        , ppr fuel         ]       -- (5) Finally add the new constructor constraint       runMaybeT $ do         -- Case (2) of Note [Strict fields and variables of unlifted type]         let alt = PmAltConLike con-        nabla' <- addPhiTmCt nabla (PhiConCt x alt ex_tvs gammas arg_ids)         let branching_factor = length $ filterUnliftedFields alt arg_ids+        let ct = PhiConCt x alt ex_tvs gammas arg_ids+        nabla1 <- traceWhenFailPm (hdr "(ct unsatisfiable) }") (ppr ct) $+                  addPhiTmCt nabla ct         -- See Note [Fuel for the inhabitation test]         let new_fuel               | branching_factor <= 1 = fuel               | otherwise             = min fuel 2-        inhabitationTest new_fuel (nabla_ty_st nabla) nabla'-    Nothing -> pure (Just nabla) -- Matching against match_ty failed. Inhabited!-                                 -- See Note [Instantiating a ConLike].+        lift $ tracePm (hdr "(ct satisfiable)") $ vcat+          [ ppr ct+          , ppr x <+> dcolon <+> ppr match_ty+          , text "In WHNF:" <+> ppr (isSourceTypeInWHNF match_ty) <+> ppr norm_match_ty+          , ppr con <+> dcolon <+> text "... ->" <+> ppr _con_res_ty+          , ppr (map (\tv -> ppr tv <+> char '↦' <+> ppr (substTyVar sigma_univ tv)) _univ_tvs)+          , ppr gammas+          , ppr (map (\x -> ppr x <+> dcolon <+> ppr (idType x)) arg_ids)+          , ppr branching_factor+          , ppr new_fuel+          ]+        nabla2 <- traceWhenFailPm (hdr "(inh test failed) }") (ppr nabla1) $+                  inhabitationTest new_fuel (nabla_ty_st nabla) nabla1+        lift $ tracePm (hdr "(inh test succeeded) }") (ppr nabla2)+        pure nabla2+    Nothing -> do+      tracePm (hdr "(match_ty not instance of res_ty) }") empty+      pure (Just nabla) -- Matching against match_ty failed. Inhabited!+                        -- See Note [Instantiating a ConLike].  -- | @matchConLikeResTy _ _ ty K@ tries to match @ty@ against the result -- type of @K@, @res_ty@. It returns a substitution @s@ for @K@'s universal@@ -1526,7 +1483,7 @@   if rep_tc == dataConTyCon dc     then Just (zipTCvSubst (dataConUnivTyVars dc) tc_args)     else Nothing-matchConLikeResTy _   (TySt _ inert) ty (PatSynCon ps) = runMaybeT $ do+matchConLikeResTy _   (TySt _ inert) ty (PatSynCon ps) = {-# SCC "matchConLikeResTy" #-} runMaybeT $ do   let (univ_tvs,req_theta,_,_,_,con_res_ty) = patSynSig ps   subst <- MaybeT $ pure $ tcMatchTy con_res_ty ty   guard $ all (`elemTCvSubst` subst) univ_tvs -- See the Note about T11336b@@ -1539,9 +1496,9 @@         then pure subst         else mzero -{- Note [Soundness and completeness]+{- Note [Soundness and Completeness] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Soundness and completeness of the pattern-match checker depends entirely on the+Soundness and completeness of the pattern-match checker depend entirely on the soundness and completeness of the inhabitation test.  Achieving both soundness and completeness at the same time is undecidable.@@ -1660,7 +1617,7 @@ currently isn't equipped to do.  In order to prevent endless instantiation attempts in @inhabitationTest@, we-use the fuel as an upper bound such attempts.+use the fuel as an upper bound on such attempts.  The same problem occurs with recursive newtypes, like in the following code: @@ -1798,8 +1755,8 @@ If matching /fails/, it trivially (and conservatively) reports "inhabited" by returning the unrefined input Nabla. After all, the match might have failed due to incomplete type information in Nabla.-(Type refinement from unpacking GADT constructors might monomorphise `match_ty`-so much that `res_ty` ultimately subsumes it.)+(Later type refinement from unpacking GADT constructors might monomorphise+`match_ty` so much that `res_ty` ultimately subsumes it.)  If matching /succeeds/, we get a substitution σ for the (universal) tyvars `us`. After applying σ, we get@@ -1833,38 +1790,53 @@ -- This is important for warnings. Roughly corresponds to G in Figure 6 of the -- LYG paper, with a few tweaks for better warning messages. +-- | See Note [Case split inhabiting patterns]+data GenerateInhabitingPatternsMode+  = CaseSplitTopLevel+  | MinimalCover+  deriving (Eq, Show)++instance Outputable GenerateInhabitingPatternsMode where+  ppr = text . show+ -- | @generateInhabitingPatterns vs n nabla@ returns a list of at most @n@ (but -- perhaps empty) refinements of @nabla@ that represent inhabited patterns. -- Negative information is only retained if literals are involved or for -- recursive GADTs.-generateInhabitingPatterns :: [Id] -> Int -> Nabla -> DsM [Nabla]+generateInhabitingPatterns :: GenerateInhabitingPatternsMode -> [Id] -> Int -> Nabla -> DsM [Nabla] -- See Note [Why inhabitationTest doesn't call generateInhabitingPatterns]-generateInhabitingPatterns _      0 _     = pure []-generateInhabitingPatterns []     _ nabla = pure [nabla]-generateInhabitingPatterns (x:xs) n nabla = do-  tracePm "generateInhabitingPatterns" (ppr n <+> ppr (x:xs) $$ ppr nabla)+generateInhabitingPatterns _    _      0 _     = pure []+generateInhabitingPatterns _    []     _ nabla = pure [nabla]+generateInhabitingPatterns mode (x:xs) n nabla = do+  tracePm "generateInhabitingPatterns" (ppr mode <+> ppr n <+> ppr (x:xs) $$ ppr nabla)   let VI _ pos neg _ _ = lookupVarInfo (nabla_tm_st nabla) x   case pos of     _:_ -> do-      -- All solutions must be valid at once. Try to find candidates for their-      -- fields. Example:-      --   f x@(Just _) True = case x of SomePatSyn _ -> ()-      -- after this clause, we want to report that-      --   * @f Nothing _@ is uncovered-      --   * @f x False@ is uncovered-      -- where @x@ will have two possibly compatible solutions, @Just y@ for-      -- some @y@ and @SomePatSyn z@ for some @z@. We must find evidence for @y@-      -- and @z@ that is valid at the same time. These constitute arg_vas below.+      -- Example for multiple solutions (must involve a PatSyn):+      --   f x@(Just _) True | SomePatSyn _ <- x = ...+      -- within the RHS, we know that+      --   * @x ~ Just y@ for some @y@+      --   * @x ~ SomePatSyn z@ for some @z@+      -- and both conditions have to hold /at the same time/. Hence we must+      -- find evidence for @y@ and @z@ that is valid at the same time. These+      -- constitute arg_vas below.       let arg_vas = concatMap paca_ids pos-      generateInhabitingPatterns (arg_vas ++ xs) n nabla+      generateInhabitingPatterns mode (arg_vas ++ xs) n nabla     []       -- When there are literals involved, just print negative info       -- instead of listing missed constructors       | notNull [ l | PmAltLit l <- pmAltConSetElems neg ]-      -> generateInhabitingPatterns xs n nabla-    [] -> try_instantiate x xs n nabla+      -> generateInhabitingPatterns mode xs n nabla+      -- When some constructors are impossible or when we don't care for a+      -- minimal cover (Note [Case split inhabiting patterns]), do a case split.+      | not (isEmptyPmAltConSet neg) || mode == CaseSplitTopLevel+      -> try_instantiate x xs n nabla+      -- Else don't do a case split on this var, just print a wildcard.+      -- But try splitting for the remaining vars, of course+      | otherwise+      -> generateInhabitingPatterns mode xs n nabla   where-    -- | Tries to instantiate a variable by possibly following the chain of+    -- Tries to instantiate a variable by possibly following the chain of     -- newtypes and then instantiating to all ConLikes of the wrapped type's     -- minimal residual COMPLETE set.     try_instantiate :: Id -> [Id] -> Int -> Nabla -> DsM [Nabla]@@ -1886,17 +1858,17 @@           case NE.nonEmpty (uniqDSetToList . cmConLikes <$> clss) of             Nothing ->               -- No COMPLETE sets ==> inhabited-              generateInhabitingPatterns xs n newty_nabla+              generateInhabitingPatterns mode xs n newty_nabla             Just clss -> do               -- Try each COMPLETE set, pick the one with the smallest number of               -- inhabitants               nablass' <- forM clss (instantiate_cons y rep_ty xs n newty_nabla)               let nablas' = minimumBy (comparing length) nablass'               if null nablas' && vi_bot vi /= IsNotBot-                then generateInhabitingPatterns xs n newty_nabla -- bot is still possible. Display a wildcard!+                then generateInhabitingPatterns mode xs n newty_nabla -- bot is still possible. Display a wildcard!                 else pure nablas' -    -- | Instantiates a chain of newtypes, beginning at @x@.+    -- Instantiates a chain of newtypes, beginning at @x@.     -- Turns @x nabla [T,U,V]@ to @(y, nabla')@, where @nabla'@ we has the fact     -- @x ~ T (U (V y))@.     instantiate_newtype_chain :: Id -> Nabla -> [(Type, DataCon, Type)] -> MaybeT DsM (Id, Nabla)@@ -1914,7 +1886,7 @@     instantiate_cons _ ty xs n nabla _       -- We don't want to expose users to GHC-specific constructors for Int etc.       | fmap (isTyConTriviallyInhabited . fst) (splitTyConApp_maybe ty) == Just True-      = generateInhabitingPatterns xs n nabla+      = generateInhabitingPatterns mode xs n nabla     instantiate_cons x ty xs n nabla (cl:cls) = do       -- The following line is where we call out to the inhabitationTest!       mb_nabla <- runMaybeT $ instCon 4 nabla x cl@@ -1929,7 +1901,7 @@         -- NB: We don't prepend arg_vars as we don't have any evidence on         -- them and we only want to split once on a data type. They are         -- inhabited, otherwise the inhabitation test would have refuted.-        Just nabla' -> generateInhabitingPatterns xs n nabla'+        Just nabla' -> generateInhabitingPatterns mode xs n nabla'       other_cons_nablas <- instantiate_cons x ty xs (n - length con_nablas) nabla cls       pure (con_nablas ++ other_cons_nablas) @@ -1955,7 +1927,7 @@   return applicable_cms  {- Note [Why inhabitationTest doesn't call generateInhabitingPatterns]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Why can't we define `inhabitationTest` (IT) in terms of `generateInhabitingPatterns` (GIP) as @@ -1975,4 +1947,36 @@ But we still need GIP to produce the Nablas as proxies for uncovered patterns that we display warnings for. It's fine to pay this price once at the end, but IT is called far more often than that.++Note [Case split inhabiting patterns]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we have an -XEmptyCase,+```hs+f :: Maybe a -> ()+f x = case x of {}+```+we want to show the different missing patterns {'Just _', 'Nothing'} to the user+instead of an uninformative wildcard pattern '_'.++But when we have a match as part of a function definition, such as+```hs+g :: (Bool, [a]) -> ()+g (_, []) = ()+```+we established in #20642 that we *do not* want to report P1={'(False, (_:_))',+'(True, (_:_))'} when we could just give the singleton set P2={'(_, (_:_))'}!+The latter set M is a "minimal cover" of the space of missing patterns S, in+that++1. The union of M is *exactly* S+2. The size of M is minimal under all such candidates.++In terms of 'g', P2 satisfies both (1) and (2). While P1 satisfies (1), it does+not satisfy (2). The set {'_'} satisfies (2), but it does not satisfy (1) as+it also covers the pattern '(_,[])' which is not part of the space of missing+patterns of 'g', so it would be a bad (too conservative) suggestion.++Note that for -XEmptyCase, we don't want to emit a minimal cover. We arrange+that by passing 'CaseSplitTopLevel' to 'generateInhabitingPatterns'. We detect+the -XEmptyCase case in 'reportWarnings' by looking for 'ReportEmptyCase'. -}
− compiler/GHC/HsToCore/Pmc/Solver/Types.hs 
@@ -1,703 +0,0 @@-{-# LANGUAGE ApplicativeDo       #-}-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE ScopedTypeVariables #-}---- | 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,--        -- ** 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--#include "GhclibHsVersions.h"--import GHC.Prelude--import GHC.Utils.Misc-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-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.Monad (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)------------------------------------------------------------------------------------- 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, [_ty, Lit n, Lit d])-    | Just dc <- isDataConWorkId_maybe x-    , dataConName dc == ratioDataConName-    -- HACK: just assume we have a literal double. This case only occurs for-    --       overloaded lits anyway, so we immediately override type information-    -> literalToPmLit (exprType e) (mkLitDouble (litValue n % litValue d))-  (Var x, args)-    -- See Note [Detecting overloaded literals with -XRebindableSyntax]-    | is_rebound_name x fromIntegerName-    , [Lit l] <- dropWhile (not . is_lit) args-    -> literalToPmLit (literalType l) l >>= overloadPmLit (exprType e)-  (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, Lit exp] <- dropWhile (not . is_ratio) args-    , (Var x, [_ty, Lit n, Lit d]) <- collectArgs r-    , Just dc <- isDataConWorkId_maybe x-    , dataConName dc == ratioDataConName-    -> do-      n' <- isLitValue_maybe n-      d' <- isLitValue_maybe d-      exp' <- isLitValue_maybe exp-      let rational = (abs n') :% d'-      let neg = if n' < 0 then 1 else 0-      let 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-    is_lit Lit{} = True-    is_lit _     = False-    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 
@@ -1,240 +0,0 @@-{-# LANGUAGE CPP                 #-}-{-# 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--#include "GhclibHsVersions.h"--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/HsToCore/Pmc/Utils.hs view
@@ -1,19 +1,17 @@-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-}  -- | Utility module for the pattern-match coverage checker. module GHC.HsToCore.Pmc.Utils ( -        tracePm, mkPmId,+        tracePm, traceWhenFailPm, mkPmId,         allPmCheckWarnings, overlapping, exhaustive, redundantBang,         exhaustiveWarningFlag,         isMatchContextPmChecked, needToRunPmCheck      ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Types.Basic (Origin(..), isGenerated)@@ -22,6 +20,7 @@ import GHC.Core.Type import GHC.Data.FastString import GHC.Data.IOEnv+import GHC.Data.Maybe import GHC.Types.Id import GHC.Types.Name import GHC.Types.Unique.Supply@@ -31,21 +30,30 @@ import GHC.Utils.Logger import GHC.HsToCore.Monad +import Control.Monad+ tracePm :: String -> SDoc -> DsM () tracePm herald doc = do-  dflags <- getDynFlags-  logger <- getLogger+  logger  <- getLogger   printer <- mkPrintUnqualifiedDs-  liftIO $ dumpIfSet_dyn_printer printer logger dflags+  liftIO $ putDumpFileMaybe' logger printer             Opt_D_dump_ec_trace "" FormatText (text herald $$ (nest 2 doc)) {-# INLINE tracePm #-}  -- see Note [INLINE conditional tracing utilities] +traceWhenFailPm :: String -> SDoc -> MaybeT DsM a -> MaybeT DsM a+traceWhenFailPm herald doc act = MaybeT $ do+  mb_a <- runMaybeT act+  when (isNothing mb_a) $ tracePm herald doc+  pure mb_a+{-# INLINE traceWhenFailPm #-}  -- see Note [INLINE conditional tracing utilities]+ -- | Generate a fresh `Id` of a given type mkPmId :: Type -> DsM Id mkPmId ty = getUniqueM >>= \unique ->   let occname = mkVarOccFS $ fsLit "pm"       name    = mkInternalName unique occname noSrcSpan   in  return (mkLocalIdOrCoVar name Many ty)+{-# NOINLINE mkPmId #-} -- We'll CPR deeply, that should be enough  -- | All warning flags that need to run the pattern match checker. allPmCheckWarnings :: [WarningFlag]@@ -74,26 +82,28 @@ -- via which 'WarningFlag' it's controlled. -- Returns 'Nothing' if check is not supported. exhaustiveWarningFlag :: HsMatchContext id -> Maybe WarningFlag-exhaustiveWarningFlag (FunRhs {})   = Just Opt_WarnIncompletePatterns-exhaustiveWarningFlag CaseAlt       = Just Opt_WarnIncompletePatterns-exhaustiveWarningFlag IfAlt         = Just Opt_WarnIncompletePatterns-exhaustiveWarningFlag LambdaExpr    = Just Opt_WarnIncompleteUniPatterns-exhaustiveWarningFlag PatBindRhs    = Just Opt_WarnIncompleteUniPatterns-exhaustiveWarningFlag PatBindGuards = Just Opt_WarnIncompletePatterns+exhaustiveWarningFlag FunRhs{}           = Just Opt_WarnIncompletePatterns+exhaustiveWarningFlag CaseAlt            = Just Opt_WarnIncompletePatterns+exhaustiveWarningFlag LamCaseAlt{}       = Just Opt_WarnIncompletePatterns+exhaustiveWarningFlag IfAlt              = Just Opt_WarnIncompletePatterns+exhaustiveWarningFlag LambdaExpr         = Just Opt_WarnIncompleteUniPatterns+exhaustiveWarningFlag PatBindRhs         = Just Opt_WarnIncompleteUniPatterns+exhaustiveWarningFlag PatBindGuards      = Just Opt_WarnIncompletePatterns exhaustiveWarningFlag (ArrowMatchCtxt c) = arrowMatchContextExhaustiveWarningFlag c-exhaustiveWarningFlag RecUpd        = Just Opt_WarnIncompletePatternsRecUpd-exhaustiveWarningFlag ThPatSplice   = Nothing-exhaustiveWarningFlag PatSyn        = Nothing-exhaustiveWarningFlag ThPatQuote    = Nothing+exhaustiveWarningFlag RecUpd             = Just Opt_WarnIncompletePatternsRecUpd+exhaustiveWarningFlag ThPatSplice        = Nothing+exhaustiveWarningFlag PatSyn             = Nothing+exhaustiveWarningFlag ThPatQuote         = Nothing -- Don't warn about incomplete patterns in list comprehensions, pattern guards -- etc. They are often *supposed* to be incomplete-exhaustiveWarningFlag (StmtCtxt {}) = Nothing+exhaustiveWarningFlag StmtCtxt{}         = Nothing  arrowMatchContextExhaustiveWarningFlag :: HsArrowMatchContext -> Maybe WarningFlag arrowMatchContextExhaustiveWarningFlag = \ case-  ProcExpr     -> Just Opt_WarnIncompleteUniPatterns-  ArrowCaseAlt -> Just Opt_WarnIncompletePatterns-  KappaExpr    -> Just Opt_WarnIncompleteUniPatterns+  ProcExpr          -> Just Opt_WarnIncompleteUniPatterns+  ArrowCaseAlt      -> Just Opt_WarnIncompletePatterns+  ArrowLamCaseAlt _ -> Just Opt_WarnIncompletePatterns+  KappaExpr         -> Just Opt_WarnIncompleteUniPatterns  -- | Check whether any part of pattern match checking is enabled for this -- 'HsMatchContext' (does not matter whether it is the redundancy check or the
compiler/GHC/HsToCore/Quote.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes    #-}-{-# LANGUAGE CPP                    #-}+ {-# LANGUAGE DataKinds              #-} {-# LANGUAGE FlexibleContexts       #-} {-# LANGUAGE FunctionalDependencies #-}@@ -29,13 +29,12 @@  module GHC.HsToCore.Quote( dsBracket ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Platform  import GHC.Driver.Session +import GHC.HsToCore.Errors.Types import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr ) import GHC.HsToCore.Match.Literal import GHC.HsToCore.Monad@@ -65,6 +64,7 @@  import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Misc import GHC.Utils.Monad @@ -129,7 +129,7 @@                           mkInvisFunTyMany (mkClassPred cls (mkTyVarTys (binderVars tyvars)))                                            (mkClassPred monad_cls (mkTyVarTys (binderVars tyvars))) -      MASSERT2( idType monad_sel `eqType` expected_ty, ppr monad_sel $$ ppr expected_ty)+      massertPpr (idType monad_sel `eqType` expected_ty) (ppr monad_sel $$ ppr expected_ty)        let m_ty = Type m_var           -- Construct the contents of MetaWrappers@@ -158,7 +158,7 @@  ----------------------------------------------------------------------------- dsBracket :: Maybe QuoteWrapper -- ^ This is Nothing only when we are dealing with a VarBr-          -> HsBracket GhcRn+          -> HsQuote GhcRn      -- See Note [The life cycle of a TH quotation]           -> [PendingTcSplice]           -> DsM CoreExpr -- See Note [Desugaring Brackets]@@ -168,7 +168,6 @@  dsBracket wrap brack splices   = do_brack brack-   where     runOverloaded act = do       -- In the overloaded case we have to get given a wrapper, it is just@@ -177,7 +176,6 @@       mw <- mkMetaWrappers (expectJust "runOverloaded" wrap)       runReaderT (mapReaderT (dsExtendMetaEnv new_bit) act) mw -     new_bit = mkNameEnv [(n, DsSplice (unLoc e))                         | PendingTcSplice n e <- splices] @@ -186,9 +184,9 @@     do_brack (PatBr _ p)   = runOverloaded $ do { MkC p1  <- repTopP p   ; return p1 }     do_brack (TypBr _ t)   = runOverloaded $ do { MkC t1  <- repLTy t    ; return t1 }     do_brack (DecBrG _ gp) = runOverloaded $ do { MkC ds1 <- repTopDs gp ; return ds1 }-    do_brack (DecBrL {})   = panic "dsBracket: unexpected DecBrL"-    do_brack (TExpBr _ e)  = runOverloaded $ do { MkC e1  <- repLE e     ; return e1 }+    do_brack (DecBrL {})   = panic "dsUntypedBracket: unexpected DecBrL" + {- Note [Desugaring Brackets] ~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -286,7 +284,7 @@                         , hs_docs    = docs })  = do { let { bndrs  = hsScopedTvBinders valds                        ++ hsGroupBinders group-                       ++ map extFieldOcc (hsPatSynSelectors valds)+                       ++ map foExt (hsPatSynSelectors valds)             ; instds = tyclds >>= group_instds } ;         ss <- mkGenSyms bndrs ; @@ -306,7 +304,7 @@                      ; inst_ds  <- mapM repInstD instds                      ; deriv_ds <- mapM repStandaloneDerivD derivds                      ; fix_ds   <- mapM repLFixD fixds-                     ; _        <- mapM no_default_decl defds+                     ; def_ds   <- mapM repDefD defds                      ; for_ds   <- mapM repForD fords                      ; _        <- mapM no_warn (concatMap (wd_warnings . unLoc)                                                            warnds)@@ -320,6 +318,7 @@                                 val_ds ++ catMaybes tycl_ds ++ role_ds                                        ++ kisig_ds                                        ++ (concat fix_ds)+                                       ++ def_ds                                        ++ inst_ds ++ rule_ds ++ for_ds                                        ++ ann_ds ++ deriv_ds) }) ; @@ -332,15 +331,12 @@       }   where     no_splice (L loc _)-      = notHandledL (locA loc) "Splices within declaration brackets" empty-    no_default_decl (L loc decl)-      = notHandledL (locA loc) "Default declarations" (ppr decl)+      = notHandledL (locA loc) ThSplicesWithinDeclBrackets     no_warn :: LWarnDecl GhcRn -> MetaM a     no_warn (L loc (Warning _ thing _))-      = notHandledL (locA loc) "WARNING and DEPRECATION pragmas" $-                    text "Pragma for declaration of" <+> ppr thing+      = notHandledL (locA loc) (ThWarningAndDeprecationPragmas thing)     no_doc (L loc _)-      = notHandledL (locA loc) "Haddock documentation" empty+      = notHandledL (locA loc) ThHaddockDocumentation  hsScopedTvBinders :: HsValBinds GhcRn -> [Name] -- See Note [Scoped type variables in quotes]@@ -464,7 +460,7 @@                                               repFamilyDecl (L loc fam)  repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs }))-  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]+  = do { tc1 <- lookupLOcc tc           -- See Note [Binders and occurrences]        ; dec <- addTyClTyVarBinds tvs $ \bndrs ->                 repSynDecl tc1 bndrs rhs        ; return (Just (locA loc, dec)) }@@ -472,7 +468,7 @@ repTyClD (L loc (DataDecl { tcdLName = tc                           , tcdTyVars = tvs                           , tcdDataDefn = defn }))-  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]+  = do { tc1 <- lookupLOcc tc           -- See Note [Binders and occurrences]        ; dec <- addTyClTyVarBinds tvs $ \bndrs ->                 repDataDefn tc1 (Left bndrs) defn        ; return (Just (locA loc, dec)) }@@ -481,7 +477,7 @@                              tcdTyVars = tvs, tcdFDs = fds,                              tcdSigs = sigs, tcdMeths = meth_binds,                              tcdATs = ats, tcdATDefs = atds }))-  = do { cls1 <- lookupLOcc cls         -- See note [Binders and occurrences]+  = do { cls1 <- lookupLOcc cls         -- See Note [Binders and occurrences]        ; dec  <- addQTyVarBinds tvs $ \bndrs ->            do { cxt1   <- repLContext cxt           -- See Note [Scoped type variables in quotes]@@ -532,9 +528,7 @@                                    ; ksig' <- repMaybeLTy ksig                                    ; repNewtype cxt1 tc opts ksig' con'                                                 derivs1 }-           (NewType, _) -> lift $ failWithDs (text "Multiple constructors for newtype:"-                                       <+> pprQuotedList-                                       (getConNames $ unLoc $ head cons))+           (NewType, _) -> lift $ failWithDs (DsMultipleConForNewtype (getConNames $ unLoc $ head cons))            (DataType, _) -> do { ksig' <- repMaybeLTy ksig                                ; consL <- mapM repC cons                                ; cons1 <- coreListM conTyConName consL@@ -555,7 +549,7 @@                                       , fdTyVars    = tvs                                       , fdResultSig = L _ resultSig                                       , fdInjectivityAnn = injectivity }))-  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]+  = do { tc1 <- lookupLOcc tc           -- See Note [Binders and occurrences]        ; let mkHsQTvs :: [LHsTyVarBndr () GhcRn] -> LHsQTyVars GhcRn              mkHsQTvs tvs = HsQTvs { hsq_ext = []                                    , hsq_explicit = tvs }@@ -566,7 +560,7 @@                 addTyClTyVarBinds resTyVar $ \_ ->            case info of              ClosedTypeFamily Nothing ->-                 notHandled "abstract closed type family" (ppr decl)+                 notHandled (ThAbstractClosedTypeFamily decl)              ClosedTypeFamily (Just eqns) ->                do { eqns1  <- mapM (repTyFamEqn . unLoc) eqns                   ; eqns2  <- coreListM tySynEqnTyConName eqns1@@ -698,7 +692,7 @@                     , feqn_pats = tys                     , feqn_fixity = fixity                     , feqn_rhs  = rhs })-  = do { tc <- lookupLOcc tc_name     -- See note [Binders and occurrences]+  = do { tc <- lookupLOcc tc_name     -- See Note [Binders and occurrences]        ; addHsOuterFamEqnTyVarBinds outer_bndrs $ \mb_exp_bndrs ->          do { tys1 <- case fixity of                         Prefix -> repTyArgs (repNamedTyCon tc) tys@@ -729,7 +723,7 @@                                              , feqn_pats  = tys                                              , feqn_fixity = fixity                                              , feqn_rhs   = defn }})-  = do { tc <- lookupLOcc tc_name         -- See note [Binders and occurrences]+  = do { tc <- lookupLOcc tc_name         -- See Note [Binders and occurrences]        ; addHsOuterFamEqnTyVarBinds outer_bndrs $ \mb_exp_bndrs ->          do { tys1 <- case fixity of                         Prefix -> repTyArgs (repNamedTyCon tc) tys@@ -757,7 +751,7 @@       return (locA loc, dec)  where     conv_cimportspec (CLabel cls)-      = notHandled "Foreign label" (doubleQuotes (ppr cls))+      = notHandled (ThForeignLabel cls)     conv_cimportspec (CFunction DynamicTarget) = return "dynamic"     conv_cimportspec (CFunction (StaticTarget _ fs _ True))                             = return (unpackFS fs)@@ -772,7 +766,7 @@     chStr = case mch of             Just (Header _ h) | not raw_cconv -> unpackFS h ++ " "             _ -> ""-repForD decl@(L _ ForeignExport{}) = notHandled "Foreign export" (ppr decl)+repForD decl@(L _ ForeignExport{}) = notHandled (ThForeignExport decl)  repCCallConv :: CCallConv -> MetaM (Core TH.Callconv) repCCallConv CCallConv          = rep2_nw cCallName []@@ -802,6 +796,12 @@                    ; return (loc,dec) }        ; mapM do_one names } +repDefD :: LDefaultDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))+repDefD (L loc (DefaultDecl _ tys)) = do { tys1 <- repLTys tys+                                         ; MkC tys2 <- coreListM typeTyConName tys1+                                         ; dec <- rep2 defaultDName [tys2]+                                         ; return (locA loc, dec)}+ repRuleD :: LRuleDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) repRuleD (L loc (HsRule { rd_name = n                         , rd_act = act@@ -999,8 +999,8 @@ rep_sig (L loc (SpecSig _ nm tys ispec))   = concatMapM (\t -> rep_specialise nm t ispec (locA loc)) tys rep_sig (L loc (SpecInstSig _ _ ty))  = rep_specialiseInst ty (locA loc)-rep_sig (L _   (MinimalSig {}))       = notHandled "MINIMAL pragmas" empty-rep_sig (L _   (SCCFunSig {}))        = notHandled "SCC pragmas" empty+rep_sig (L _   (MinimalSig {}))       = notHandled ThMinimalPragmas+rep_sig (L _   (SCCFunSig {}))        = notHandled ThSCCPragmas rep_sig (L loc (CompleteMatchSig _ _st cls mty))   = rep_complete_sig cls mty (locA loc) @@ -1084,7 +1084,14 @@            -> SrcSpan            -> MetaM [(SrcSpan, Core (M TH.Dec))] rep_inline nm ispec loc+  | Opaque {} <- inl_inline ispec   = do { nm1    <- lookupLOcc nm+       ; opq <- repPragOpaque nm1+       ; return [(loc, opq)]+       }++rep_inline nm ispec loc+  = do { nm1    <- lookupLOcc nm        ; inline <- repInline $ inl_inline ispec        ; rm     <- repRuleMatch $ inl_rule ispec        ; phases <- repPhases $ inl_act ispec@@ -1117,10 +1124,15 @@        ; return [(loc, pragma)] }  repInline :: InlineSpec -> MetaM (Core TH.Inline)-repInline NoInline         = dataCon noInlineDataConName-repInline Inline           = dataCon inlineDataConName-repInline Inlinable        = dataCon inlinableDataConName-repInline NoUserInlinePrag = notHandled "NOUSERINLINE" empty+repInline (NoInline          _ )   = dataCon noInlineDataConName+-- There is a mismatch between the TH and GHC representation because+-- OPAQUE pragmas can't have phase activation annotations (which is+-- enforced by the TH API), therefore they are desugared to OpaqueP rather than+-- InlineP, see special case in rep_inline.+repInline (Opaque            _ )   = panic "repInline: Opaque"+repInline (Inline            _ )   = dataCon inlineDataConName+repInline (Inlinable         _ )   = dataCon inlinableDataConName+repInline NoUserInlinePrag        = notHandled ThNoUserInline  repRuleMatch :: RuleMatchInfo -> MetaM (Core TH.RuleMatch) repRuleMatch ConLike = dataCon conLikeDataConName@@ -1393,7 +1405,7 @@ repTy (HsSumTy _ tys)       = do tys1 <- repLTys tys                                  tcon <- repUnboxedSumTyCon (length tys)                                  repTapps tcon tys1-repTy (HsOpTy _ ty1 n ty2)  = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)+repTy (HsOpTy _ prom ty1 n ty2) = repLTy ((nlHsTyVar prom (unLoc n) `nlHsAppTy` ty1)                                    `nlHsAppTy` ty2) repTy (HsParTy _ t)         = repLTy t repTy (HsStarTy _ _) =  repTStar@@ -1418,10 +1430,12 @@                              t' <- repLTy t                              repTImplicitParam n' t' -repTy ty                      = notHandled "Exotic form of type" (ppr ty)+repTy ty                      = notHandled (ThExoticFormOfType ty)  repTyLit :: HsTyLit -> MetaM (Core (M TH.TyLit))-repTyLit (HsNumTy _ i) = rep2 numTyLitName [mkIntegerExpr i]+repTyLit (HsNumTy _ i) = do+                         platform <- getPlatform+                         rep2 numTyLitName [mkIntegerExpr platform i] repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s                             ; rep2 strTyLitName [s']                             }@@ -1436,7 +1450,7 @@   k_ty <- wrapName kindTyConName   repMaybeT k_ty repLTy m -repRole :: Located (Maybe Role) -> MetaM (Core TH.Role)+repRole :: LocatedAn NoEpAnns (Maybe Role) -> MetaM (Core TH.Role) repRole (L _ (Just Nominal))          = rep2_nw nominalRName [] repRole (L _ (Just Representational)) = rep2_nw representationalRName [] repRole (L _ (Just Phantom))          = rep2_nw phantomRName []@@ -1488,9 +1502,7 @@ repE (HsIPVar _ n) = rep_implicit_param_name n >>= repImplicitParamVar repE (HsOverLabel _ s) = repOverLabel s -repE e@(HsRecFld _ f) = case f of-  Unambiguous x _ -> repE (HsVar noExtField (noLocA x))-  Ambiguous{}     -> notHandled "Ambiguous record selectors" (ppr e)+repE (HsRecSel _ (FieldOcc x _)) = repE (HsVar noExtField (noLocA x))          -- Remember, we're desugaring renamer output here, so         -- HsOverlit can definitely occur@@ -1498,10 +1510,14 @@ repE (HsLit _ l)     = do { a <- repLiteral l;           repLit a } repE (HsLam _ (MG { mg_alts = (L _ [m]) })) = repLambda m repE e@(HsLam _ (MG { mg_alts = (L _ _) })) = pprPanic "repE: HsLam with multiple alternatives" (ppr e)-repE (HsLamCase _ (MG { mg_alts = (L _ ms) }))+repE (HsLamCase _ LamCase (MG { mg_alts = (L _ ms) }))                    = do { ms' <- mapM repMatchTup ms                         ; core_ms <- coreListM matchTyConName ms'                         ; repLamCase core_ms }+repE (HsLamCase _ LamCases (MG { mg_alts = (L _ ms) }))+                   = do { ms' <- mapM repClauseTup ms+                        ; core_ms <- coreListM matchTyConName ms'+                        ; repLamCases core_ms } repE (HsApp _ x y)   = do {a <- repLE x; b <- repLE y; repApp a b} repE (HsAppType _ e t) = do { a <- repLE e                             ; s <- repLTy (hswc_body t)@@ -1516,7 +1532,7 @@                               a         <- repLE x                               negateVar <- lookupOcc negateName >>= repVar                               negateVar `repApp` a-repE (HsPar _ x)            = repLE x+repE (HsPar _ _ x _)        = repLE x repE (SectionL _ x y)       = do { a <- repLE x; b <- repLE y; repSectionL a b } repE (SectionR _ x y)       = do { a <- repLE x; b <- repLE y; repSectionR a b } repE (HsCase _ e (MG { mg_alts = (L _ ms) }))@@ -1533,7 +1549,7 @@   = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts        ; expr' <- repMultiIf (nonEmptyCoreList alts')        ; wrapGenSyms (concat binds) expr' }-repE (HsLet _ bs e)             = do { (ss,ds) <- repBinds bs+repE (HsLet _ _ bs _ e)         = do { (ss,ds) <- repBinds bs                                      ; e2 <- addBinds ss (repLE e)                                      ; z <- repLetE ds e2                                      ; wrapGenSyms ss z }@@ -1557,7 +1573,7 @@         wrapGenSyms ss e' }    | otherwise-  = notHandled "monad comprehension and [: :]" (ppr e)+  = notHandled (ThMonadComprehensionSyntax e)  repE (ExplicitList _ es) = do { xs <- repLEs es; repListExp xs } repE (ExplicitTuple _ es boxity) =@@ -1624,16 +1640,19 @@                                occ   <- occNameLit uv                                sname <- repNameS occ                                repUnboundVar sname-repE (HsGetField _ e (L _ (HsFieldLabel _ (L _ f)))) = do+repE (HsGetField _ e (L _ (DotFieldOcc _ (L _ f)))) = do   e1 <- repLE e   repGetField e1 f-repE (HsProjection _ xs) = repProjection (fmap (unLoc . hflLabel . unLoc) xs)+repE (HsProjection _ xs) = repProjection (fmap (unLoc . dfoLabel . unLoc) xs) repE (XExpr (HsExpanded orig_expr ds_expr))   = do { rebindable_on <- lift $ xoptM LangExt.RebindableSyntax        ; if rebindable_on  -- See Note [Quotation and rebindable syntax]          then repE ds_expr          else repE orig_expr }-repE e = notHandled "Expression form" (ppr e)+repE e@(HsPragE _ (HsPragSCC {}) _) = notHandled (ThCostCentres e)+repE e@(HsTypedBracket{})   = notHandled (ThExpressionForm e)+repE e@(HsUntypedBracket{}) = notHandled (ThExpressionForm e)+repE e@(HsProc{}) = notHandled (ThExpressionForm e)  {- Note [Quotation and rebindable syntax] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1712,19 +1731,19 @@   where     rep_fld :: LHsRecField GhcRn (LHsExpr GhcRn)             -> MetaM (Core (M TH.FieldExp))-    rep_fld (L _ fld) = do { fn <- lookupLOcc (hsRecFieldSel fld)-                           ; e  <- repLE (hsRecFieldArg fld)+    rep_fld (L _ fld) = do { fn <- lookupOcc (hsRecFieldSel fld)+                           ; e  <- repLE (hfbRHS fld)                            ; repFieldExp fn e }  repUpdFields :: [LHsRecUpdField GhcRn] -> MetaM (Core [M TH.FieldExp]) repUpdFields = repListM fieldExpTyConName rep_fld   where     rep_fld :: LHsRecUpdField GhcRn -> MetaM (Core (M TH.FieldExp))-    rep_fld (L l fld) = case unLoc (hsRecFieldLbl fld) of+    rep_fld (L l fld) = case unLoc (hfbLHS fld) of       Unambiguous sel_name _ -> do { fn <- lookupLOcc (L l sel_name)-                                   ; e  <- repLE (hsRecFieldArg fld)+                                   ; e  <- repLE (hfbRHS fld)                                    ; repFieldExp fn e }-      Ambiguous{}            -> notHandled "Ambiguous record updates" (ppr fld)+      Ambiguous{}            -> notHandled (ThAmbiguousRecordUpdates fld)   @@ -1800,12 +1819,12 @@        -- Bring all of binders in the recursive group into scope for the        -- whole group.        ; (ss1_other,rss) <- addBinds ss1 $ repSts (map unLoc (unLoc $ recS_stmts stmt))-       ; MASSERT(sort ss1 == sort ss1_other)+       ; massert (sort ss1 == sort ss1_other)        ; z <- repRecSt (nonEmptyCoreList rss)        ; (ss2,zs) <- addBinds ss1 (repSts ss)        ; return (ss1++ss2, z : zs) } repSts []    = return ([],[])-repSts other = notHandled "Exotic statement" (ppr other)+repSts other = notHandled (ThExoticStatement other)   -----------------------------------------------------------@@ -1838,11 +1857,8 @@         ; return (ss, core_list) }  rep_implicit_param_bind :: LIPBind GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))-rep_implicit_param_bind (L loc (IPBind _ ename (L _ rhs)))- = do { name <- case ename of-                    Left (L _ n) -> rep_implicit_param_name n-                    Right _ ->-                        panic "rep_implicit_param_bind: post typechecking"+rep_implicit_param_bind (L loc (IPBind _ (L _ n) (L _ rhs)))+ = do { name <- rep_implicit_param_name n       ; rhs' <- repE rhs       ; ipb <- repImplicitParamBind name rhs'       ; return (locA loc, ipb) }@@ -1908,7 +1924,6 @@         ; ans <- repVal patcore x empty_decls         ; return (srcLocSpan (getSrcLoc v), ans) } -rep_bind (L _ (AbsBinds {}))  = panic "rep_bind: AbsBinds" rep_bind (L loc (PatSynBind _ (PSB { psb_id   = syn                                    , psb_args = args                                    , psb_def  = pat@@ -1934,7 +1949,7 @@     mkGenArgSyms (InfixCon arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2]     mkGenArgSyms (RecCon fields)       = do { let pats = map (unLoc . recordPatSynPatVar) fields-                 sels = map (extFieldOcc . recordPatSynField) fields+                 sels = map (foExt . recordPatSynField) fields            ; ss <- mkGenSyms sels            ; return $ replaceNames (zip sels pats) ss } @@ -1964,7 +1979,7 @@        ; arg2' <- lookupLOcc arg2        ; repInfixPatSynArgs arg1' arg2' } repPatSynArgs (RecCon fields)-  = do { sels' <- repList nameTyConName (lookupOcc . extFieldOcc) sels+  = do { sels' <- repList nameTyConName (lookupOcc . foExt) sels        ; repRecordPatSynArgs sels' }   where sels = map recordPatSynField fields @@ -2023,7 +2038,7 @@                 do { xs <- repLPs ps; body <- repLE e; repLam xs body })       ; wrapGenSyms ss lam } -repLambda (L _ m) = notHandled "Guarded lambdas" (pprMatch m)+repLambda (L _ m) = notHandled (ThGuardedLambdas m)   -----------------------------------------------------------------------------@@ -2048,12 +2063,8 @@ repP (BangPat _ p)      = do { p1 <- repLP p; repPbang p1 } repP (AsPat _ x p)      = do { x' <- lookupNBinder x; p1 <- repLP p                              ; repPaspat x' p1 }-repP (ParPat _ p)       = repLP p-repP (ListPat Nothing ps)  = do { qs <- repLPs ps; repPlist qs }-repP (ListPat (Just (SyntaxExprRn e)) ps) = do { p <- repP (ListPat Nothing ps)-                                               ; e' <- repE e-                                               ; repPview e' p}-repP (ListPat _ ps) = pprPanic "repP missing SyntaxExprRn" (ppr ps)+repP (ParPat _ _ p _)   = repLP p+repP (ListPat _ ps)     = do { qs <- repLPs ps; repPlist qs } repP (TuplePat _ ps boxed)   | isBoxed boxed       = do { qs <- repLPs ps; repPtup qs }   | otherwise           = do { qs <- repLPs ps; repPunboxedTup qs }@@ -2073,18 +2084,25 @@    }  where    rep_fld :: LHsRecField GhcRn (LPat GhcRn) -> MetaM (Core (M (TH.Name, TH.Pat)))-   rep_fld (L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld)-                          ; MkC p <- repLP (hsRecFieldArg fld)+   rep_fld (L _ fld) = do { MkC v <- lookupOcc (hsRecFieldSel fld)+                          ; MkC p <- repLP (hfbRHS fld)                           ; rep2 fieldPatName [v,p] } repP (NPat _ (L _ l) Nothing _) = do { a <- repOverloadedLiteral l                                      ; repPlit a } repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }-repP p@(NPat _ _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)+repP p@(NPat _ (L _ l) (Just _) _)+  | OverLitRn rebindable _ <- ol_ext l+  , rebindable = notHandled (ThNegativeOverloadedPatterns p)+  | HsIntegral i <- ol_val l = do { a <- repOverloadedLiteral l{ol_val = HsIntegral (negateIntegralLit i)}+                                  ; repPlit a }+  | HsFractional i <- ol_val l = do { a <- repOverloadedLiteral l{ol_val = HsFractional (negateFractionalLit i)}+                                  ; repPlit a }+  | otherwise = notHandled (ThExoticPattern p) repP (SigPat _ p t) = do { p' <- repLP p                          ; t' <- repLTy (hsPatSigType t)                          ; repPsig p' t' } repP (SplicePat _ splice) = repSplice splice-repP other = notHandled "Exotic pattern" (ppr other)+repP other = notHandled (ThExoticPattern other)  ---------------------------------------------------------- -- Declaration ordering helpers@@ -2173,10 +2191,11 @@         ; rep2_nwDsM mk_varg [pkg,mod,occ] }   | otherwise   = do  { MkC occ <- nameLit name-        ; MkC uni <- coreIntegerLit (toInteger $ getKey (getUnique name))+        ; platform <- targetPlatform <$> getDynFlags+        ; let uni = mkIntegerExpr platform (toInteger $ getKey (getUnique name))         ; rep2_nwDsM mkNameLName [occ,uni] }   where-      mod = ASSERT( isExternalName name) nameModule name+      mod = assert (isExternalName name) nameModule name       name_mod = moduleNameString (moduleName mod)       name_pkg = unitString (moduleUnit mod)       name_occ = nameOccName name@@ -2355,6 +2374,9 @@ repLamCase :: Core [(M TH.Match)] -> MetaM (Core (M TH.Exp)) repLamCase (MkC ms) = rep2 lamCaseEName [ms] +repLamCases :: Core [(M TH.Clause)] -> MetaM (Core (M TH.Exp))+repLamCases (MkC ms) = rep2 lamCasesEName [ms]+ repTup :: Core [Maybe (M TH.Exp)] -> MetaM (Core (M TH.Exp)) repTup (MkC es) = rep2 tupEName [es] @@ -2591,6 +2613,9 @@ repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases)   = rep2 pragInlDName [nm, inline, rm, phases] +repPragOpaque :: Core TH.Name -> MetaM (Core (M TH.Dec))+repPragOpaque (MkC nm) = rep2 pragOpaqueDName [nm]+ repPragSpec :: Core TH.Name -> Core (M TH.Type) -> Core TH.Phases             -> MetaM (Core (M TH.Dec)) repPragSpec (MkC nm) (MkC ty) (MkC phases)@@ -2672,6 +2697,7 @@              arg_tys <- repPrefixConArgs ps              rep2 normalCName [unC con', unC arg_tys]            InfixCon st1 st2 -> do+             verifyLinearFields [st1, st2]              arg1 <- repBangTy (hsScaledThing st1)              arg2 <- repBangTy (hsScaledThing st2)              rep2 infixCName [unC arg1, unC con', unC arg2]@@ -2690,16 +2716,32 @@              arg_tys <- repPrefixConArgs ps              res_ty' <- repLTy res_ty              rep2 gadtCName [ unC (nonEmptyCoreList cons'), unC arg_tys, unC res_ty']-           RecConGADT ips -> do+           RecConGADT ips _ -> do              arg_vtys <- repRecConArgs ips              res_ty'  <- repLTy res_ty              rep2 recGadtCName [unC (nonEmptyCoreList cons'), unC arg_vtys,                                 unC res_ty'] +-- TH currently only supports linear constructors.+-- We also accept the (->) arrow when -XLinearTypes is off, because this+-- denotes a linear field.+-- This check is not performed in repRecConArgs, since the GADT record+-- syntax currently does not have a way to mark fields as nonlinear.+verifyLinearFields :: [HsScaled GhcRn (LHsType GhcRn)] -> MetaM ()+verifyLinearFields ps = do+  linear <- lift $ xoptM LangExt.LinearTypes+  let allGood = all (\st -> case hsMult st of+                              HsUnrestrictedArrow _ -> not linear+                              HsLinearArrow _       -> True+                              _                     -> False) ps+  unless allGood $ notHandled ThNonLinearDataCon+ -- Desugar the arguments in a data constructor declared with prefix syntax. repPrefixConArgs :: [HsScaled GhcRn (LHsType GhcRn)]                  -> MetaM (Core [M TH.BangType])-repPrefixConArgs ps = repListM bangTypeTyConName repBangTy (map hsScaledThing ps)+repPrefixConArgs ps = do+  verifyLinearFields ps+  repListM bangTypeTyConName repBangTy (map hsScaledThing ps)  -- Desugar the arguments in a data constructor declared with record syntax. repRecConArgs :: LocatedL [LConDeclField GhcRn]@@ -2711,7 +2753,7 @@       rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip)        rep_one_ip :: LBangType GhcRn -> LFieldOcc GhcRn -> MetaM (Core (M TH.VarBangType))-      rep_one_ip t n = do { MkC v  <- lookupOcc (extFieldOcc $ unLoc n)+      rep_one_ip t n = do { MkC v  <- lookupOcc (foExt $ unLoc n)                           ; MkC ty <- repBangTy  t                           ; rep2 varBangTypeName [v,ty] } @@ -2848,7 +2890,7 @@        lit_expr <- lift $ dsLit lit'        case mb_lit_name of           Just lit_name -> rep2_nw lit_name [lit_expr]-          Nothing -> notHandled "Exotic literal" (ppr lit)+          Nothing -> notHandled (ThExoticLiteral lit)   where     mb_lit_name = case lit of                  HsInteger _ _ _  -> Just integerLName@@ -3020,22 +3062,16 @@ coreIntLit i = do platform <- getPlatform                   return (MkC (mkIntExprInt platform i)) -coreIntegerLit :: MonadThings m => Integer -> m (Core Integer)-coreIntegerLit i = pure (MkC (mkIntegerExpr i))- coreVar :: Id -> Core TH.Name   -- The Id has type Name coreVar id = MkC (Var id)  ----------------- Failure ------------------------notHandledL :: SrcSpan -> String -> SDoc -> MetaM a-notHandledL loc what doc+notHandledL :: SrcSpan -> ThRejectionReason -> MetaM a+notHandledL loc reason   | isGoodSrcSpan loc-  = mapReaderT (putSrcSpanDs loc) $ notHandled what doc+  = mapReaderT (putSrcSpanDs loc) $ notHandled reason   | otherwise-  = notHandled what doc+  = notHandled reason -notHandled :: String -> SDoc -> MetaM a-notHandled what doc = lift $ failWithDs msg-  where-    msg = hang (text what <+> text "not (yet) handled by Template Haskell")-             2 doc+notHandled :: ThRejectionReason -> MetaM a+notHandled reason = lift $ failWithDs (DsNotYetHandledByTH reason)
compiler/GHC/HsToCore/Types.hs view
@@ -6,9 +6,12 @@         DsMetaEnv, DsMetaVal(..), CompleteMatches     ) where +import GHC.Prelude (Int)+ import Data.IORef  import GHC.Types.CostCentre.State+import GHC.Types.Error import GHC.Types.Name.Env import GHC.Types.SrcLoc import GHC.Types.Var@@ -16,9 +19,9 @@ import GHC.Hs (LForeignDecl, HsExpr, GhcTc) import GHC.Tc.Types (TcRnIf, IfGblEnv, IfLclEnv, CompleteMatches) import GHC.HsToCore.Pmc.Types (Nablas)+import GHC.HsToCore.Errors.Types import GHC.Core (CoreExpr) import GHC.Core.FamInstEnv-import GHC.Utils.Error import GHC.Utils.Outputable as Outputable import GHC.Unit.Module import GHC.Driver.Hooks (DsForeignsHook)@@ -47,13 +50,15 @@                                           -- constructors are in scope during                                           -- pattern-match satisfiability checking   , ds_unqual  :: PrintUnqualified-  , ds_msgs    :: IORef (Messages DecoratedSDoc) -- Warning messages+  , ds_msgs    :: IORef (Messages DsMessage) -- Diagnostic messages   , ds_if_env  :: (IfGblEnv, IfLclEnv)    -- Used for looking up global,                                           -- possibly-imported things   , ds_complete_matches :: CompleteMatches      -- Additional complete pattern matches   , ds_cc_st   :: IORef CostCentreState      -- Tracking indices for cost centre annotations+  , ds_next_wrapper_num :: IORef (ModuleEnv Int)+    -- ^ See Note [Generating fresh names for FFI wrappers]   }  instance ContainsModule DsGblEnv where@@ -65,7 +70,7 @@   { dsl_meta    :: DsMetaEnv   -- ^ Template Haskell bindings   , dsl_loc     :: RealSrcSpan -- ^ To put in pattern-matching error msgs   , dsl_nablas  :: Nablas-  -- ^ See Note [Note [Long-distance information] in "GHC.HsToCore.Pmc".+  -- ^ See Note [Long-distance information] in "GHC.HsToCore.Pmc".   -- The set of reaching values Nablas is augmented as we walk inwards, refined   -- through each pattern match in turn   }@@ -80,7 +85,7 @@                        -- The Id has type THSyntax.Var    | DsSplice (HsExpr GhcTc) -- These bindings are introduced by-                            -- the PendingSplices on a HsBracketOut+                            -- the PendingSplices on a Hs*Bracket  -- | Desugaring monad. See also 'TcM'. type DsM = TcRnIf DsGblEnv DsLclEnv
compiler/GHC/HsToCore/Usage.hs view
@@ -1,21 +1,17 @@-{-# LANGUAGE CPP #-} + {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  module GHC.HsToCore.Usage (     -- * Dependency/fingerprinting code (used by GHC.Iface.Make)-    mkUsageInfo, mkUsedNames, mkDependencies+    mkUsageInfo, mkUsedNames,     ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Driver.Env import GHC.Driver.Session -import GHC.Platform-import GHC.Platform.Ways  import GHC.Tc.Types @@ -25,29 +21,26 @@ import GHC.Utils.Panic  import GHC.Types.Name-import GHC.Types.Name.Set+import GHC.Types.Name.Set ( NameSet, allUses ) import GHC.Types.Unique.Set-import GHC.Types.Unique.FM  import GHC.Unit import GHC.Unit.External-import GHC.Unit.State-import GHC.Unit.Finder import GHC.Unit.Module.Imported import GHC.Unit.Module.ModIface import GHC.Unit.Module.Deps  import GHC.Data.Maybe -import Control.Monad (filterM)-import Data.List (sort, sortBy, nub)-import Data.IORef+import Data.List (sortBy) import Data.Map (Map) import qualified Data.Map as Map-import qualified Data.Set as Set-import System.Directory-import System.FilePath +import GHC.Linker.Types+import GHC.Unit.Finder+import GHC.Types.Unique.DFM+import GHC.Driver.Plugins+ {- Note [Module self-dependency]    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -67,75 +60,29 @@  -} --- | Extract information from the rename and typecheck phases to produce--- a dependencies information for the module being compiled.------ The second argument is additional dependencies from plugins-mkDependencies :: UnitId -> [Module] -> TcGblEnv -> IO Dependencies-mkDependencies iuid pluginModules-          (TcGblEnv{ tcg_mod = mod,-                    tcg_imports = imports,-                    tcg_th_used = th_var-                  })- = do-      -- Template Haskell used?-      let (dep_plgins, ms) = unzip [ (moduleName mn, mn) | mn <- pluginModules ]-          plugin_dep_pkgs = filter (/= iuid) (map (toUnitId . moduleUnit) ms)-      th_used <- readIORef th_var-      let dep_mods = modDepsElts (delFromUFM (imp_dep_mods imports)-                                             (moduleName mod))-                -- M.hi-boot can be in the imp_dep_mods, but we must remove-                -- it before recording the modules on which this one depends!-                -- (We want to retain M.hi-boot in imp_dep_mods so that-                --  loadHiBootInterface can see if M's direct imports depend-                --  on M.hi-boot, and hence that we should do the hi-boot consistency-                --  check.)--          dep_orphs = filter (/= mod) (imp_orphs imports)-                -- We must also remove self-references from imp_orphs. See-                -- Note [Module self-dependency]--          raw_pkgs = foldr Set.insert (imp_dep_pkgs imports) plugin_dep_pkgs--          pkgs | th_used   = Set.insert thUnitId raw_pkgs-               | otherwise = raw_pkgs--          -- Set the packages required to be Safe according to Safe Haskell.-          -- See Note [Tracking Trust Transitively] in GHC.Rename.Names-          sorted_pkgs = sort (Set.toList pkgs)-          trust_pkgs  = imp_trust_pkgs imports-          dep_pkgs'   = map (\x -> (x, x `Set.member` trust_pkgs)) sorted_pkgs--      return Deps { dep_mods   = dep_mods,-                    dep_pkgs   = dep_pkgs',-                    dep_orphs  = dep_orphs,-                    dep_plgins = dep_plgins,-                    dep_finsts = sortBy stableModuleCmp (imp_finsts imports) }-                    -- sort to get into canonical order-                    -- NB. remember to use lexicographic ordering- mkUsedNames :: TcGblEnv -> NameSet mkUsedNames TcGblEnv{ tcg_dus = dus } = allUses dus  mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> [FilePath]-            -> [(Module, Fingerprint)] -> [ModIface] -> IO [Usage]-mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files merged-  pluginModules+            -> [(Module, Fingerprint)] -> [Linkable] -> PkgsLoaded -> IO [Usage]+mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files merged needed_links needed_pkgs   = do     eps <- hscEPS hsc_env     hashes <- mapM getFileHash dependent_files-    plugin_usages <- mapM (mkPluginUsage hsc_env) pluginModules+    -- Dependencies on object files due to TH and plugins+    object_usages <- mkObjectUsage (eps_PIT eps) hsc_env needed_links needed_pkgs     let mod_usages = mk_mod_usage_info (eps_PIT eps) hsc_env this_mod                                        dir_imp_mods used_names         usages = mod_usages ++ [ UsageFile { usg_file_path = f-                                           , usg_file_hash = hash }+                                           , usg_file_hash = hash+                                           , usg_file_label = Nothing }                                | (f, hash) <- zip dependent_files hashes ]                             ++ [ UsageMergedRequirement                                     { usg_mod = mod,                                       usg_mod_hash = hash                                     }                                | (mod, hash) <- merged ]-                            ++ concat plugin_usages+                            ++ object_usages     usages `seqList` return usages     -- seq the list of Usages returned: occasionally these     -- don't get evaluated for a while and we can end up hanging on to@@ -177,80 +124,63 @@     of the module and the implementation hashes of its dependencies, and then     compare implementation hashes for recompilation. Creation of implementation     hashes is however potentially expensive.++    A serious issue with the interface hash idea is that if you include an+    interface hash, that hash also needs to depend on the hash of its+    dependencies. Therefore, if any of the transitive dependencies of a modules+    gets updated then you need to recompile the module in case the interface+    hash has changed irrespective if the module uses TH or not.++    This is important to maintain the invariant that the information in the+    interface file is always up-to-date.+++    See #20790 (comment 3) -}-mkPluginUsage :: HscEnv -> ModIface -> IO [Usage]-mkPluginUsage hsc_env pluginModule-  = case lookupPluginModuleWithSuggestions pkgs pNm Nothing of-    LookupFound _ (pkg, _) -> do-    -- The plugin is from an external package:-    -- search for the library files containing the plugin.-      let searchPaths = collectLibraryDirs (ways dflags) [pkg]-          useDyn = WayDyn `elem` ways dflags-          suffix = if useDyn then platformSOExt platform else "a"-          libLocs = [ searchPath </> "lib" ++ libLoc <.> suffix-                    | searchPath <- searchPaths-                    , libLoc     <- unitHsLibs (ghcNameVersion dflags) (ways dflags) pkg-                    ]-          -- we also try to find plugin library files by adding WayDyn way,-          -- if it isn't already present (see trac #15492)-          paths =-            if useDyn-              then libLocs-              else-                let dflags'  = dflags { targetWays_ = addWay WayDyn (targetWays_ dflags) }-                    dlibLocs = [ searchPath </> platformHsSOName platform dlibLoc-                               | searchPath <- searchPaths-                               , dlibLoc    <- unitHsLibs (ghcNameVersion dflags') (ways dflags') pkg-                               ]-                in libLocs ++ dlibLocs-      files <- filterM doesFileExist paths-      case files of-        [] ->-          pprPanic-             ( "mkPluginUsage: missing plugin library, tried:\n"-              ++ unlines paths-             )-             (ppr pNm)-        _  -> mapM hashFile (nub files)-    _ -> do-      foundM <- findPluginModule hsc_env pNm-      case foundM of-      -- The plugin was built locally: look up the object file containing-      -- the `plugin` binder, and all object files belong to modules that are-      -- transitive dependencies of the plugin that belong to the same package.-        Found ml _ -> do-          pluginObject <- hashFile (ml_obj_file ml)-          depObjects   <- catMaybes <$> mapM lookupObjectFile deps-          return (nub (pluginObject : depObjects))-        _ -> pprPanic "mkPluginUsage: no object file found" (ppr pNm)++{-+Note [Object File Dependencies]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In addition to the Note [Plugin dependencies] above, for TH we also need to record+the hashes of object files that the TH code is required to load. These are+calculated by the loader in `getLinkDeps` and are accumulated in each individual+`TcGblEnv`, in `tcg_th_needed_deps`. We read this just before compute the UsageInfo+to inject the appropriate dependencies.+-}++-- | Find object files corresponding to the transitive closure of given home+-- modules and direct object files for pkg dependencies+mkObjectUsage :: PackageIfaceTable -> HscEnv -> [Linkable] -> PkgsLoaded -> IO [Usage]+mkObjectUsage pit hsc_env th_links_needed th_pkgs_needed = do+      let ls = ordNubOn linkableModule  (th_links_needed ++ plugins_links_needed)+          ds = concatMap loaded_pkg_hs_objs $ eltsUDFM (plusUDFM th_pkgs_needed plugin_pkgs_needed) -- TODO possibly record loaded_pkg_non_hs_objs as well+          (plugins_links_needed, plugin_pkgs_needed) = loadedPluginDeps $ hsc_plugins hsc_env+      concat <$> sequence (map linkableToUsage ls ++ map librarySpecToUsage ds)   where-    dflags   = hsc_dflags hsc_env-    platform = targetPlatform dflags-    pkgs     = hsc_units hsc_env-    pNm      = moduleName $ mi_module pluginModule-    pPkg     = moduleUnit $ mi_module pluginModule-    deps     = map gwib_mod $-      dep_mods $ mi_deps pluginModule+    linkableToUsage (LM _ m uls) = mapM (unlinkedToUsage m) uls -    -- Lookup object file for a plugin dependency,-    -- from the same package as the plugin.-    lookupObjectFile nm = do-      foundM <- findImportedModule hsc_env nm Nothing-      case foundM of-        Found ml m-          | moduleUnit m == pPkg -> Just <$> hashFile (ml_obj_file ml)-          | otherwise              -> return Nothing-        _ -> pprPanic "mkPluginUsage: no object for dependency"-                      (ppr pNm <+> ppr nm)+    msg m = moduleNameString (moduleName m) ++ "[TH] changed" -    hashFile f = do-      fExist <- doesFileExist f-      if fExist-         then do-            h <- getFileHash f-            return (UsageFile f h)-         else pprPanic "mkPluginUsage: file not found" (ppr pNm <+> text f)+    fing mmsg fn = UsageFile fn <$> lookupFileCache (hsc_FC hsc_env) fn <*> pure mmsg +    unlinkedToUsage m ul =+      case nameOfObject_maybe ul of+        Just fn -> fing (Just (msg m)) fn+        Nothing ->  do+          -- This should only happen for home package things but oneshot puts+          -- home package ifaces in the PIT.+          let miface = lookupIfaceByModule (hsc_HUG hsc_env) pit m+          case miface of+            Nothing -> pprPanic "mkObjectUsage" (ppr m)+            Just iface ->+              return $ UsageHomeModuleInterface (moduleName m) (mi_iface_hash (mi_final_exts iface))++    librarySpecToUsage :: LibrarySpec -> IO [Usage]+    librarySpecToUsage (Objects os) = traverse (fing Nothing) os+    librarySpecToUsage (Archive fn) = traverse (fing Nothing) [fn]+    librarySpecToUsage (DLLPath fn) = traverse (fing Nothing) [fn]+    librarySpecToUsage _ = return []+ mk_mod_usage_info :: PackageIfaceTable               -> HscEnv               -> Module@@ -260,7 +190,7 @@ mk_mod_usage_info pit hsc_env this_mod direct_imports used_names   = mapMaybe mkUsage usage_mods   where-    hpt = hsc_HPT hsc_env+    hpt = hsc_HUG hsc_env     dflags = hsc_dflags hsc_env     home_unit = hsc_home_unit hsc_env @@ -282,7 +212,7 @@         | isWiredInName name = mv_map  -- ignore wired-in names         | otherwise         = case nameModule_maybe name of-             Nothing  -> ASSERT2( isSystemName name, ppr name ) mv_map+             Nothing  -> assertPpr (isSystemName name) (ppr name) mv_map                 -- See Note [Internal used_names]               Just mod ->
compiler/GHC/HsToCore/Utils.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeFamilies #-}@@ -45,15 +44,13 @@         isTrueLHsExpr     ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import {-# SOURCE #-} GHC.HsToCore.Match ( matchSimply ) import {-# SOURCE #-} GHC.HsToCore.Expr  ( dsLExpr, dsSyntaxExpr )  import GHC.Hs-import GHC.Tc.Utils.Zonk+import GHC.Hs.Syn.Type import GHC.Tc.Utils.TcType( tcSplitTyConApp ) import GHC.Core import GHC.HsToCore.Monad@@ -78,6 +75,7 @@ import GHC.Types.Name( isInternalName ) import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Types.SrcLoc import GHC.Types.Tickish import GHC.Utils.Misc@@ -133,10 +131,10 @@  selectMatchVar :: Mult -> Pat GhcTc -> DsM Id -- Postcondition: the returned Id has an Internal Name-selectMatchVar w (BangPat _ pat) = selectMatchVar w (unLoc pat)-selectMatchVar w (LazyPat _ pat) = selectMatchVar w (unLoc pat)-selectMatchVar w (ParPat _ pat)  = selectMatchVar w (unLoc pat)-selectMatchVar _w (VarPat _ var)  = return (localiseId (unLoc var))+selectMatchVar w (BangPat _ pat)    = selectMatchVar w (unLoc pat)+selectMatchVar w (LazyPat _ pat)    = selectMatchVar w (unLoc pat)+selectMatchVar w (ParPat _ _ pat _) = selectMatchVar w (unLoc pat)+selectMatchVar _w (VarPat _ var)    = return (localiseId (unLoc var))                                   -- Note [Localise pattern binders]                                   --                                   -- Remark: when the pattern is a variable (or@@ -144,8 +142,8 @@                                   -- multiplicity stored within the variable                                   -- itself. It's easier to pull it from the                                   -- variable, so we ignore the multiplicity.-selectMatchVar _w (AsPat _ var _) = ASSERT( isManyDataConTy _w ) (return (unLoc var))-selectMatchVar w other_pat     = newSysLocalDsNoLP w (hsPatType other_pat)+selectMatchVar _w (AsPat _ var _) = assert (isManyDataConTy _w ) (return (unLoc var))+selectMatchVar w other_pat        = newSysLocalDs w (hsPatType other_pat)  {- Note [Localise pattern binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -184,7 +182,7 @@ runs on the output of the desugarer, so all is well by the end of the desugaring pass. -See also Note [MatchIds] in GHC.HsToCore.Match+See also Note [Match Ids] in GHC.HsToCore.Match  ************************************************************************ *                                                                      *@@ -198,7 +196,7 @@ -}  firstPat :: EquationInfo -> Pat GhcTc-firstPat eqn = ASSERT( notNull (eqn_pats eqn) ) head (eqn_pats eqn)+firstPat eqn = assert (notNull (eqn_pats eqn)) $ head (eqn_pats eqn)  shiftEqns :: Functor f => f EquationInfo -> f EquationInfo -- Drop the first pattern in each equation@@ -283,7 +281,7 @@      sorted_alts = sortWith fst match_alts       -- Right order for a Case     mk_alt fail (lit, mr)-       = ASSERT( not (litIsLifted lit) )+       = assert (not (litIsLifted lit)) $          do body <- runMatchResult fail mr             return (Alt (LitAlt lit) [] body) @@ -299,7 +297,7 @@   -> MatchResult CoreExpr mkCoAlgCaseMatchResult var ty match_alts   | isNewtype  -- Newtype case; use a let-  = ASSERT( null match_alts_tail && null (tail arg_ids1) )+  = assert (null match_alts_tail && null (tail arg_ids1)) $     mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1    | otherwise@@ -313,7 +311,7 @@     alt1@MkCaseAlt{ alt_bndrs = arg_ids1, alt_result = match_result1 } :| match_alts_tail       = match_alts     -- Stuff for newtype-    arg_id1       = ASSERT( notNull arg_ids1 ) head arg_ids1+    arg_id1       = assert (notNull arg_ids1) $ head arg_ids1     var_ty        = idType var     (tc, ty_args) = tcSplitTyConApp var_ty      -- Don't look through newtypes                                                 -- (not that splitTyConApp does, these days)@@ -406,11 +404,10 @@ mkErrorAppDs err_id ty msg = do     src_loc <- getSrcSpanDs     dflags <- getDynFlags-    let-        full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg])-        core_msg = Lit (mkLitString full_msg)-        -- mkLitString returns a result of type String#-    return (mkApps (Var err_id) [Type (getRuntimeRep ty), Type ty, core_msg])+    let full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg])+        fail_expr = mkRuntimeErrorApp err_id unitTy full_msg+    return $ mkWildCase fail_expr (unrestricted unitTy) ty []+    -- See Note [Incompleteness and linearity]  {- Note [Incompleteness and linearity]@@ -427,15 +424,15 @@ Instead, we use 'f x False = case error "Non-exhausive pattern..." :: () of {}'. This case expression accounts for linear variables by assigning bottom usage (See Note [Bottom as a usage] in GHC.Core.Multiplicity).-This is done in mkFailExpr.+This is done in mkErrorAppDs, called from mkFailExpr. We use '()' instead of the original return type ('a' in this case)-because there might be levity polymorphism, e.g. in+because there might be representation polymorphism, e.g. in  g :: forall (a :: TYPE r). (() -> a) %1 -> Bool -> a g x True = x ()  adding 'g x False = case error "Non-exhaustive pattern" :: a of {}'-would create an illegal levity-polymorphic case binder.+would create an illegal representation-polymorphic case binder. This is important for pattern synonym matchers, which often look like this 'g'.  Similarly, a hole@@ -459,9 +456,7 @@  mkFailExpr :: HsMatchContext GhcRn -> Type -> DsM CoreExpr mkFailExpr ctxt ty-  = do fail_expr <- mkErrorAppDs pAT_ERROR_ID unitTy (matchContextErrString ctxt)-       return $ mkWildCase fail_expr (unrestricted unitTy) ty []-       -- See Note [Incompleteness and linearity]+  = mkErrorAppDs pAT_ERROR_ID ty (matchContextErrString ctxt)  {- 'mkCoreAppDs' and 'mkCoreAppsDs' handle the special-case desugaring of 'seq'.@@ -530,14 +525,14 @@   3. (as described in #2409) -    The isLocalId ensures that we don't turn+    The isInternalName ensures that we don't turn             True `seq` e     into             case True of True { ... }     which stupidly tries to bind the datacon 'True'. -} --- NB: Make sure the argument is not levity polymorphic+-- NB: Make sure the argument is not representation-polymorphic mkCoreAppDs  :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr mkCoreAppDs _ (Var f `App` Type _r `App` Type ty1 `App` Type ty2 `App` arg1) arg2   | f `hasKey` seqIdKey            -- Note [Desugaring seq], points (1) and (2)@@ -557,7 +552,7 @@  mkCoreAppDs s fun arg = mkCoreApp s fun arg  -- The rest is done in GHC.Core.Make --- NB: No argument can be levity polymorphic+-- NB: No argument can be representation-polymorphic mkCoreAppsDs :: SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr mkCoreAppsDs s fun args = foldl' (mkCoreAppDs s) fun args @@ -744,7 +739,7 @@    | is_flat_prod_lpat pat'           -- Special case (B)   = do { let pat_ty = hsLPatType pat'-       ; val_var <- newSysLocalDsNoLP Many pat_ty+       ; val_var <- newSysLocalDs Many pat_ty         ; let mk_bind tick bndr_var                -- (mk_bind sv bv)  generates  bv = case sv of { pat -> bv }@@ -786,7 +781,7 @@  strip_bangs :: LPat (GhcPass p) -> LPat (GhcPass p) -- Remove outermost bangs and parens-strip_bangs (L _ (ParPat _ p))  = strip_bangs p+strip_bangs (L _ (ParPat _ _ p _))  = strip_bangs p strip_bangs (L _ (BangPat _ p)) = strip_bangs p strip_bangs lp                  = lp @@ -795,7 +790,7 @@ is_flat_prod_lpat = is_flat_prod_pat . unLoc  is_flat_prod_pat :: Pat GhcTc -> Bool-is_flat_prod_pat (ParPat _ p)          = is_flat_prod_lpat p+is_flat_prod_pat (ParPat _ _ p _)      = is_flat_prod_lpat p is_flat_prod_pat (TuplePat _ ps Boxed) = all is_triv_lpat ps is_flat_prod_pat (ConPat { pat_con  = L _ pcon                          , pat_args = ps})@@ -812,7 +807,7 @@ is_triv_pat :: Pat (GhcPass p) -> Bool is_triv_pat (VarPat {})  = True is_triv_pat (WildPat{})  = True-is_triv_pat (ParPat _ p) = is_triv_lpat p+is_triv_pat (ParPat _ _ p _) = is_triv_lpat p is_triv_pat _            = False  @@ -964,7 +959,7 @@ the tail call property.  For example, see #3403. -} -dsHandleMonadicFailure :: HsStmtContext GhcRn -> LPat GhcTc -> MatchResult CoreExpr -> FailOperator GhcTc -> DsM CoreExpr+dsHandleMonadicFailure :: HsDoFlavour -> LPat GhcTc -> MatchResult CoreExpr -> FailOperator GhcTc -> DsM CoreExpr     -- In a do expression, pattern-match failure just calls     -- the monadic 'fail' rather than throwing an exception dsHandleMonadicFailure ctx pat match m_fail_op =@@ -985,9 +980,9 @@       fail_expr <- dsSyntaxExpr fail_op [fail_msg]       body fail_expr -mk_fail_msg :: DynFlags -> HsStmtContext GhcRn -> LocatedA e -> String+mk_fail_msg :: DynFlags -> HsDoFlavour -> LocatedA e -> String mk_fail_msg dflags ctx pat-  = showPpr dflags $ text "Pattern match failure in" <+> pprStmtContext ctx+  = showPpr dflags $ text "Pattern match failure in" <+> pprHsDoFlavour ctx                    <+> text "at" <+> ppr (getLocA pat)  {- *********************************************************************@@ -1062,7 +1057,7 @@   where     go lp@(L l p)       = case p of-           ParPat x p    -> L l (ParPat x (go p))+           ParPat x lpar p rpar -> L l (ParPat x lpar (go p) rpar)            LazyPat _ lp' -> lp'            BangPat _ _   -> lp            _             -> L l (BangPat noExtField lp)@@ -1080,19 +1075,19 @@      || v `hasKey` getUnique trueDataConId                                               = Just return         -- trueDataConId doesn't have the same unique as trueDataCon-isTrueLHsExpr (L _ (HsConLikeOut _ con))+isTrueLHsExpr (L _ (XExpr (ConLikeTc con _ _)))   | con `hasKey` getUnique trueDataCon = Just return-isTrueLHsExpr (L _ (HsTick _ tickish e))+isTrueLHsExpr (L _ (XExpr (HsTick tickish e)))     | Just ticks <- isTrueLHsExpr e     = Just (\x -> do wrapped <- ticks x                      return (Tick tickish wrapped))    -- This encodes that the result is constant True for Hpc tick purposes;    -- which is specifically what isTrueLHsExpr is trying to find out.-isTrueLHsExpr (L _ (HsBinTick _ ixT _ e))+isTrueLHsExpr (L _ (XExpr (HsBinTick ixT _ e)))     | Just ticks <- isTrueLHsExpr e     = Just (\x -> do e <- ticks x                      this_mod <- getModule                      return (Tick (HpcTick this_mod ixT) e)) -isTrueLHsExpr (L _ (HsPar _ e))   = isTrueLHsExpr e-isTrueLHsExpr _                   = Nothing+isTrueLHsExpr (L _ (HsPar _ _ e _)) = isTrueLHsExpr e+isTrueLHsExpr _                     = Nothing
compiler/GHC/Iface/Binary.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE BinaryLiterals, CPP, ScopedTypeVariables, BangPatterns #-}+{-# LANGUAGE BinaryLiterals, ScopedTypeVariables, BangPatterns #-}  -- --  (c) The University of Glasgow 2002-2006@@ -13,7 +13,7 @@         -- * Public API for interface file serialisation         writeBinIface,         readBinIface,-        readBinIface_,+        readBinIfaceHeader,         getSymtabName,         getDictFastString,         CheckHiWay(..),@@ -29,46 +29,36 @@         putSymbolTable,         BinSymbolTable(..),         BinDictionary(..)-     ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Tc.Utils.Monad import GHC.Builtin.Utils   ( isKnownKeyName, lookupKnownKeyName )-import GHC.Iface.Env import GHC.Unit import GHC.Unit.Module.ModIface import GHC.Types.Name-import GHC.Driver.Session import GHC.Platform.Profile import GHC.Types.Unique.FM-import GHC.Types.Unique.Supply import GHC.Utils.Panic import GHC.Utils.Binary as Binary-import GHC.Types.SrcLoc import GHC.Data.FastMutInt import GHC.Types.Unique import GHC.Utils.Outputable import GHC.Types.Name.Cache+import GHC.Types.SrcLoc import GHC.Platform import GHC.Data.FastString import GHC.Settings.Constants-import GHC.Utils.Misc+import GHC.Utils.Fingerprint  import Data.Array-import Data.Array.ST+import Data.Array.IO import Data.Array.Unsafe import Data.Char import Data.Word import Data.IORef-import Data.Foldable import Control.Monad-import Control.Monad.ST-import Control.Monad.Trans.Class-import qualified Control.Monad.Trans.State.Strict as State  -- --------------------------------------------------------------------------- -- Reading and writing binary interface files@@ -81,20 +71,17 @@    = TraceBinIFace (SDoc -> IO ())    | QuietBinIFace --- | Read an interface file-readBinIface :: CheckHiWay -> TraceBinIFace -> FilePath-             -> TcRnIf a b ModIface-readBinIface checkHiWay traceBinIFaceReading hi_path = do-    ncu <- mkNameCacheUpdater-    dflags <- getDynFlags-    let profile = targetProfile dflags-    liftIO $ readBinIface_ profile checkHiWay traceBinIFaceReading hi_path ncu---- | Read an interface file in 'IO'.-readBinIface_ :: Profile -> CheckHiWay -> TraceBinIFace -> FilePath-              -> NameCacheUpdater-              -> IO ModIface-readBinIface_ profile checkHiWay traceBinIFace hi_path ncu = do+-- | Read an interface file header, checking the magic number, version, and+-- way. Returns the hash of the source file and a BinHandle which points at the+-- start of the rest of the interface file data.+readBinIfaceHeader+  :: Profile+  -> NameCache+  -> CheckHiWay+  -> TraceBinIFace+  -> FilePath+  -> IO (Fingerprint, BinHandle)+readBinIfaceHeader profile _name_cache checkHiWay traceBinIFace hi_path = do     let platform = profilePlatform profile          wantedGot :: String -> a -> a -> (a -> SDoc) -> IO ()@@ -135,21 +122,37 @@     when (checkHiWay == CheckHiWay) $         errorOnMismatch "mismatched interface file profile tag" tag check_tag +    src_hash <- get bh+    pure (src_hash, bh)++-- | Read an interface file.+readBinIface+  :: Profile+  -> NameCache+  -> CheckHiWay+  -> TraceBinIFace+  -> FilePath+  -> IO ModIface+readBinIface profile name_cache checkHiWay traceBinIface hi_path = do+    (src_hash, bh) <- readBinIfaceHeader profile name_cache checkHiWay traceBinIface hi_path+     extFields_p <- get bh -    mod_iface <- getWithUserData ncu bh+    mod_iface <- getWithUserData name_cache bh      seekBin bh extFields_p     extFields <- get bh -    return mod_iface{mi_ext_fields = extFields}-+    return mod_iface+      { mi_ext_fields = extFields+      , mi_src_hash = src_hash+      }  -- | This performs a get action after reading the dictionary and symbol -- table. It is necessary to run this before trying to deserialise any -- Names or FastStrings.-getWithUserData :: Binary a => NameCacheUpdater -> BinHandle -> IO a-getWithUserData ncu bh = do+getWithUserData :: Binary a => NameCache -> BinHandle -> IO a+getWithUserData name_cache bh = do     -- Read the dictionary     -- The next word in the file is a pointer to where the dictionary is     -- (probably at the end of the file)@@ -166,11 +169,11 @@         symtab_p <- Binary.get bh     -- Get the symtab ptr         data_p <- tellBin bh          -- Remember where we are now         seekBin bh symtab_p-        symtab <- getSymbolTable bh ncu+        symtab <- getSymbolTable bh name_cache         seekBin bh data_p             -- Back to where we were before          -- It is only now that we know how to get a Name-        return $ setUserData bh $ newReadState (getSymtabName ncu dict symtab)+        return $ setUserData bh $ newReadState (getSymtabName name_cache dict symtab)                                                (getDictFastString dict)      -- Read the interface file@@ -183,10 +186,11 @@     let platform = profilePlatform profile     put_ bh (binaryInterfaceMagic platform) -    -- The version and profile tag go next+    -- The version, profile tag, and source hash go next     put_ bh (show hiVersion)     let tag = profileBuildTag profile     put_  bh tag+    put_  bh (mi_src_hash mod_iface)      extFields_p_p <- tellBin bh     put_ bh extFields_p_p@@ -290,42 +294,31 @@       -- indices that array uses to create order     mapM_ (\n -> serialiseName bh n symtab) names -getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable-getSymbolTable bh ncu = do-    sz <- get bh-    od_names <- sequence (replicate sz (get bh))-    updateNameCache ncu $ \namecache ->-        runST $ flip State.evalStateT namecache $ do-            mut_arr <- lift $ newSTArray_ (0, sz-1)-            for_ (zip [0..] od_names) $ \(i, odn) -> do-                (nc, !n) <- State.gets $ \nc -> fromOnDiskName nc odn-                lift $ writeArray mut_arr i n-                State.put nc-            arr <- lift $ unsafeFreeze mut_arr-            namecache' <- State.get-            return (namecache', arr)-  where-    -- This binding is required because the type of newArray_ cannot be inferred-    newSTArray_ :: forall s. (Int, Int) -> ST s (STArray s Int Name)-    newSTArray_ = newArray_ -type OnDiskName = (Unit, ModuleName, OccName)--fromOnDiskName :: NameCache -> OnDiskName -> (NameCache, Name)-fromOnDiskName nc (pid, mod_name, occ) =-    let mod   = mkModule pid mod_name-        cache = nsNames nc-    in case lookupOrigNameCache cache  mod occ of-           Just name -> (nc, name)-           Nothing   ->-               let (uniq, us) = takeUniqFromSupply (nsUniqs nc)-                   name       = mkExternalName uniq mod occ noSrcSpan-                   new_cache  = extendNameCache cache mod occ name-               in ( nc{ nsUniqs = us, nsNames = new_cache }, name )+getSymbolTable :: BinHandle -> NameCache -> IO SymbolTable+getSymbolTable bh name_cache = do+    sz <- get bh :: IO Int+    -- create an array of Names for the symbols and add them to the NameCache+    updateNameCache' name_cache $ \cache0 -> do+        mut_arr <- newArray_ (0, sz-1) :: IO (IOArray Int Name)+        cache <- foldGet (fromIntegral sz) bh cache0 $ \i (uid, mod_name, occ) cache -> do+          let mod = mkModule uid mod_name+          case lookupOrigNameCache cache mod occ of+            Just name -> do+              writeArray mut_arr (fromIntegral i) name+              return cache+            Nothing   -> do+              uniq <- takeUniqFromNameCache name_cache+              let name      = mkExternalName uniq mod occ noSrcSpan+                  new_cache = extendOrigNameCache cache mod occ name+              writeArray mut_arr (fromIntegral i) name+              return new_cache+        arr <- unsafeFreeze mut_arr+        return (cache, arr)  serialiseName :: BinHandle -> Name -> UniqFM key (Int,Name) -> IO () serialiseName bh name _ = do-    let mod = ASSERT2( isExternalName name, ppr name ) nameModule name+    let mod = assertPpr (isExternalName name) (ppr name) (nameModule name)     put_ bh (moduleUnit mod, moduleName mod, nameOccName name)  @@ -354,7 +347,7 @@         bh name   | isKnownKeyName name   , let (c, u) = unpkUnique (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits-  = -- ASSERT(u < 2^(22 :: Int))+  = -- assert (u < 2^(22 :: Int))     put_ bh (0x80000000              .|. (fromIntegral (ord c) `shiftL` 22)              .|. (fromIntegral u :: Word32))@@ -365,17 +358,17 @@          Just (off,_) -> put_ bh (fromIntegral off :: Word32)          Nothing -> do             off <- readFastMutInt symtab_next-            -- MASSERT(off < 2^(30 :: Int))+            -- massert (off < 2^(30 :: Int))             writeFastMutInt symtab_next (off+1)             writeIORef symtab_map_ref                 $! addToUFM symtab_map name (off,name)             put_ bh (fromIntegral off :: Word32)  -- See Note [Symbol table representation of names]-getSymtabName :: NameCacheUpdater+getSymtabName :: NameCache               -> Dictionary -> SymbolTable               -> BinHandle -> IO Name-getSymtabName _ncu _dict symtab bh = do+getSymtabName _name_cache _dict symtab bh = do     i :: Word32 <- get bh     case i .&. 0xC0000000 of       0x00000000 -> return $! symtab ! fromIntegral i
compiler/GHC/Iface/Env.hs view
@@ -1,12 +1,12 @@ -- (c) The University of Glasgow 2002-2006 -{-# LANGUAGE CPP, RankNTypes, BangPatterns #-}+{-# LANGUAGE RankNTypes #-}  module GHC.Iface.Env (         newGlobalBinder, newInteractiveBinder,         externaliseName,         lookupIfaceTop,-        lookupOrig, lookupOrigIO, lookupOrigNameCache, extendNameCache,+        lookupOrig, lookupNameCache, lookupOrigNameCache,         newIfaceName, newIfaceNames,         extendIfaceIdEnv, extendIfaceTyVarEnv,         tcIfaceLclId, tcIfaceTyVar, lookupIfaceVar,@@ -15,16 +15,16 @@          ifaceExportNames, +        trace_if, trace_hi_diffs,+         -- Name-cache stuff-        allocateGlobalBinder, updNameCacheTc, updNameCache,-        mkNameCacheUpdater, NameCacheUpdater(..),+        allocateGlobalBinder,    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Driver.Env+import GHC.Driver.Session  import GHC.Tc.Utils.Monad import GHC.Core.Type@@ -45,8 +45,11 @@ import GHC.Types.SrcLoc  import GHC.Utils.Outputable+import GHC.Utils.Error+import GHC.Utils.Logger+ import Data.List     ( partition )-import Data.IORef+import Control.Monad  {- *********************************************************@@ -68,8 +71,8 @@ -- moment when we know its Module and SrcLoc in their full glory  newGlobalBinder mod occ loc-  = do { name <- updNameCacheTc mod occ $ \name_cache ->-                 allocateGlobalBinder name_cache mod occ loc+  = do { hsc_env <- getTopEnv+       ; name <- liftIO $ allocateGlobalBinder (hsc_NC hsc_env) mod occ loc        ; traceIf (text "newGlobalBinder" <+>                   (vcat [ ppr mod <+> ppr occ <+> ppr loc, ppr name]))        ; return name }@@ -77,18 +80,18 @@ newInteractiveBinder :: HscEnv -> OccName -> SrcSpan -> IO Name -- Works in the IO monad, and gets the Module -- from the interactive context-newInteractiveBinder hsc_env occ loc- = do { let mod = icInteractiveModule (hsc_IC hsc_env)-       ; updNameCacheIO hsc_env mod occ $ \name_cache ->-         allocateGlobalBinder name_cache mod occ loc }+newInteractiveBinder hsc_env occ loc = do+  let mod = icInteractiveModule (hsc_IC hsc_env)+  allocateGlobalBinder (hsc_NC hsc_env) mod occ loc  allocateGlobalBinder   :: NameCache   -> Module -> OccName -> SrcSpan-  -> (NameCache, Name)+  -> IO Name -- See Note [The Name Cache] in GHC.Types.Name.Cache-allocateGlobalBinder name_supply mod occ loc-  = case lookupOrigNameCache (nsNames name_supply) mod occ of+allocateGlobalBinder nc mod occ loc+  = updateNameCache nc mod occ $ \cache0 -> do+      case lookupOrigNameCache cache0 mod occ of         -- A hit in the cache!  We are at the binding site of the name.         -- This is the moment when we know the SrcLoc         -- of the Name, so we set this field in the Name we return.@@ -106,62 +109,26 @@         --            and their Module is correct.          Just name | isWiredInName name-                  -> (name_supply, name)+                  -> pure (cache0, name)                   | otherwise-                  -> (new_name_supply, name')+                  -> pure (new_cache, name')                   where-                    uniq            = nameUnique name-                    name'           = mkExternalName uniq mod occ loc-                                      -- name' is like name, but with the right SrcSpan-                    new_cache       = extendNameCache (nsNames name_supply) mod occ name'-                    new_name_supply = name_supply {nsNames = new_cache}+                    uniq      = nameUnique name+                    name'     = mkExternalName uniq mod occ loc+                                -- name' is like name, but with the right SrcSpan+                    new_cache = extendOrigNameCache cache0 mod occ name'          -- Miss in the cache!         -- Build a completely new Name, and put it in the cache-        _ -> (new_name_supply, name)-                  where-                    (uniq, us')     = takeUniqFromSupply (nsUniqs name_supply)-                    name            = mkExternalName uniq mod occ loc-                    new_cache       = extendNameCache (nsNames name_supply) mod occ name-                    new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}+        _ -> do+              uniq <- takeUniqFromNameCache nc+              let name      = mkExternalName uniq mod occ loc+              let new_cache = extendOrigNameCache cache0 mod occ name+              pure (new_cache, name)  ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo] ifaceExportNames exports = return exports --- | A function that atomically updates the name cache given a modifier--- function.  The second result of the modifier function will be the result--- of the IO action.-newtype NameCacheUpdater-      = NCU { updateNameCache :: forall c. (NameCache -> (NameCache, c)) -> IO c }--mkNameCacheUpdater :: TcRnIf a b NameCacheUpdater-mkNameCacheUpdater = do { hsc_env <- getTopEnv-                        ; let !ncRef = hsc_NC hsc_env-                        ; return (NCU (updNameCache ncRef)) }--updNameCacheTc :: Module -> OccName -> (NameCache -> (NameCache, c))-               -> TcRnIf a b c-updNameCacheTc mod occ upd_fn = do {-    hsc_env <- getTopEnv-  ; liftIO $ updNameCacheIO hsc_env mod occ upd_fn }---updNameCacheIO ::  HscEnv -> Module -> OccName-               -> (NameCache -> (NameCache, c))-               -> IO c-updNameCacheIO hsc_env mod occ upd_fn = do {--    -- First ensure that mod and occ are evaluated-    -- If not, chaos can ensue:-    --      we read the name-cache-    --      then pull on mod (say)-    --      which does some stuff that modifies the name cache-    -- This did happen, with tycon_mod in GHC.IfaceToCore.tcIfaceAlt (DataAlt..)--    mod `seq` occ `seq` return ()-  ; updNameCache (hsc_NC hsc_env) upd_fn }-- {- ************************************************************************ *                                                                      *@@ -174,32 +141,26 @@ -- Consider alternatively using 'lookupIfaceTop' if you're in the 'IfL' monad -- and 'Module' is simply that of the 'ModIface' you are typechecking. lookupOrig :: Module -> OccName -> TcRnIf a b Name-lookupOrig mod occ-  = do  { traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ)--        ; updNameCacheTc mod occ $ lookupNameCache mod occ }--lookupOrigIO :: HscEnv -> Module -> OccName -> IO Name-lookupOrigIO hsc_env mod occ-  = updNameCacheIO hsc_env mod occ $ lookupNameCache mod occ+lookupOrig mod occ = do+  hsc_env <- getTopEnv+  traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ)+  liftIO $ lookupNameCache (hsc_NC hsc_env) mod occ -lookupNameCache :: Module -> OccName -> NameCache -> (NameCache, Name)+lookupNameCache :: NameCache -> Module -> OccName -> IO Name -- Lookup up the (Module,OccName) in the NameCache -- If you find it, return it; if not, allocate a fresh original name and extend -- the NameCache. -- Reason: this may the first occurrence of (say) Foo.bar we have encountered. -- If we need to explore its value we will load Foo.hi; but meanwhile all we -- need is a Name for it.-lookupNameCache mod occ name_cache =-  case lookupOrigNameCache (nsNames name_cache) mod occ of {-    Just name -> (name_cache, name);-    Nothing   ->-        case takeUniqFromSupply (nsUniqs name_cache) of {-          (uniq, us) ->-              let-                name      = mkExternalName uniq mod occ noSrcSpan-                new_cache = extendNameCache (nsNames name_cache) mod occ name-              in (name_cache{ nsUniqs = us, nsNames = new_cache }, name) }}+lookupNameCache nc mod occ = updateNameCache nc mod occ $ \cache0 ->+  case lookupOrigNameCache cache0 mod occ of+    Just name -> pure (cache0, name)+    Nothing   -> do+      uniq <- takeUniqFromNameCache nc+      let name      = mkExternalName uniq mod occ noSrcSpan+      let new_cache = extendOrigNameCache cache0 mod occ name+      pure (new_cache, name)  externaliseName :: Module -> Name -> TcRnIf m n Name -- Take an Internal Name and make it an External one,@@ -209,10 +170,11 @@              loc = nameSrcSpan name              uniq = nameUnique name        ; occ `seq` return ()  -- c.f. seq in newGlobalBinder-       ; updNameCacheTc mod occ $ \ ns ->-         let name' = mkExternalName uniq mod occ loc-             ns'   = ns { nsNames = extendNameCache (nsNames ns) mod occ name' }-         in (ns', name') }+       ; hsc_env <- getTopEnv+       ; liftIO $ updateNameCache (hsc_NC hsc_env) mod occ $ \cache -> do+         let name'  = mkExternalName uniq mod occ loc+             cache' = extendOrigNameCache cache mod occ name'+         pure (cache', name') }  -- | Set the 'Module' of a 'Name'. setNameModule :: Maybe Module -> Name -> TcRnIf m n Name@@ -237,11 +199,11 @@         }  extendIfaceIdEnv :: [Id] -> IfL a -> IfL a-extendIfaceIdEnv ids thing_inside-  = do  { env <- getLclEnv-        ; let { id_env' = extendFsEnvList (if_id_env env) pairs-              ; pairs   = [(occNameFS (getOccName id), id) | id <- ids] }-        ; setLclEnv (env { if_id_env = id_env' }) thing_inside }+extendIfaceIdEnv ids+  = updLclEnv $ \env ->+    let { id_env' = extendFsEnvList (if_id_env env) pairs+        ; pairs   = [(occNameFS (getOccName id), id) | id <- ids] }+    in env { if_id_env = id_env' }   tcIfaceTyVar :: FastString -> IfL TyVar@@ -266,11 +228,11 @@         ; return (lookupFsEnv (if_tv_env lcl) occ) }  extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a-extendIfaceTyVarEnv tyvars thing_inside-  = do  { env <- getLclEnv-        ; let { tv_env' = extendFsEnvList (if_tv_env env) pairs-              ; pairs   = [(occNameFS (getOccName tv), tv) | tv <- tyvars] }-        ; setLclEnv (env { if_tv_env = tv_env' }) thing_inside }+extendIfaceTyVarEnv tyvars+  = updLclEnv $ \env ->+    let { tv_env' = extendFsEnvList (if_tv_env env) pairs+        ; pairs   = [(occNameFS (getOccName tv), tv) | tv <- tyvars] }+    in env { if_tv_env = tv_env' }  extendIfaceEnvs :: [TyCoVar] -> IfL a -> IfL a extendIfaceEnvs tcvs thing_inside@@ -304,19 +266,10 @@         ; return [ mkInternalName uniq occ noSrcSpan                  | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] } -{--Names in a NameCache are always stored as a Global, and have the SrcLoc-of their binding locations.--Actually that's not quite right.  When we first encounter the original-name, we might not be at its binding site (e.g. we are reading an-interface file); so we give it 'noSrcLoc' then.  Later, when we find-its binding site, we fix it up.--}--updNameCache :: IORef NameCache-             -> (NameCache -> (NameCache, c))  -- The updating function-             -> IO c-updNameCache ncRef upd_fn-  = atomicModifyIORef' ncRef upd_fn+trace_if :: Logger -> SDoc -> IO ()+{-# INLINE trace_if #-}+trace_if logger doc = when (logHasDumpFlag logger Opt_D_dump_if_trace) $ putMsg logger doc +trace_hi_diffs :: Logger -> SDoc -> IO ()+{-# INLINE trace_hi_diffs #-}+trace_hi_diffs logger doc = when (logHasDumpFlag logger Opt_D_dump_hi_diffs) $ putMsg logger doc
+ compiler/GHC/Iface/Errors.hs view
@@ -0,0 +1,335 @@++{-# LANGUAGE FlexibleContexts #-}++module GHC.Iface.Errors+  ( badIfaceFile+  , hiModuleNameMismatchWarn+  , homeModError+  , cannotFindInterface+  , cantFindInstalledErr+  , cannotFindModule+  , cantFindErr+  -- * Utility functions+  , mayShowLocations+  ) where++import GHC.Platform.Profile+import GHC.Platform.Ways+import GHC.Utils.Panic.Plain+import GHC.Driver.Session+import GHC.Driver.Env+import GHC.Driver.Errors.Types+import GHC.Data.Maybe+import GHC.Prelude+import GHC.Unit+import GHC.Unit.Env+import GHC.Unit.Finder.Types+import GHC.Utils.Outputable as Outputable+++badIfaceFile :: String -> SDoc -> SDoc+badIfaceFile file err+  = vcat [text "Bad interface file:" <+> text file,+          nest 4 err]++hiModuleNameMismatchWarn :: Module -> Module -> SDoc+hiModuleNameMismatchWarn requested_mod read_mod+ | moduleUnit requested_mod == moduleUnit read_mod =+    sep [text "Interface file contains module" <+> quotes (ppr read_mod) <> comma,+         text "but we were expecting module" <+> quotes (ppr requested_mod),+         sep [text "Probable cause: the source code which generated interface file",+             text "has an incompatible module name"+            ]+        ]+ | otherwise =+  -- ToDo: This will fail to have enough qualification when the package IDs+  -- are the same+  withPprStyle (mkUserStyle alwaysQualify AllTheWay) $+    -- we want the Modules below to be qualified with package names,+    -- so reset the PrintUnqualified setting.+    hsep [ text "Something is amiss; requested module "+         , ppr requested_mod+         , text "differs from name found in the interface file"+         , ppr read_mod+         , parens (text "if these names look the same, try again with -dppr-debug")+         ]++homeModError :: InstalledModule -> ModLocation -> SDoc+-- See Note [Home module load error]+homeModError mod location+  = text "attempting to use module " <> quotes (ppr mod)+    <> (case ml_hs_file location of+           Just file -> space <> parens (text file)+           Nothing   -> Outputable.empty)+    <+> text "which is not loaded"+++-- -----------------------------------------------------------------------------+-- Error messages++cannotFindInterface :: UnitState -> Maybe HomeUnit -> Profile -> ([FilePath] -> SDoc) -> ModuleName -> InstalledFindResult -> SDoc+cannotFindInterface = cantFindInstalledErr (text "Failed to load interface for")+                                           (text "Ambiguous interface for")++cantFindInstalledErr+    :: SDoc+    -> SDoc+    -> UnitState+    -> Maybe HomeUnit+    -> Profile+    -> ([FilePath] -> SDoc)+    -> ModuleName+    -> InstalledFindResult+    -> SDoc+cantFindInstalledErr cannot_find _ unit_state mhome_unit profile tried_these mod_name find_result+  = cannot_find <+> quotes (ppr mod_name)+    $$ more_info+  where+    build_tag  = waysBuildTag (profileWays profile)++    more_info+      = case find_result of+            InstalledNoPackage pkg+                -> text "no unit id matching" <+> quotes (ppr pkg) <+>+                   text "was found" $$ looks_like_srcpkgid pkg++            InstalledNotFound files mb_pkg+                | Just pkg <- mb_pkg+                , notHomeUnitId mhome_unit pkg+                -> not_found_in_package pkg files++                | null files+                -> text "It is not a module in the current program, or in any known package."++                | otherwise+                -> tried_these files++            _ -> panic "cantFindInstalledErr"++    looks_like_srcpkgid :: UnitId -> SDoc+    looks_like_srcpkgid pk+     -- Unsafely coerce a unit id (i.e. an installed package component+     -- identifier) into a PackageId and see if it means anything.+     | (pkg:pkgs) <- searchPackageId unit_state (PackageId (unitIdFS pk))+     = parens (text "This unit ID looks like the source package ID;" $$+       text "the real unit ID is" <+> quotes (ftext (unitIdFS (unitId pkg))) $$+       (if null pkgs then Outputable.empty+        else text "and" <+> int (length pkgs) <+> text "other candidates"))+     -- Todo: also check if it looks like a package name!+     | otherwise = Outputable.empty++    not_found_in_package pkg files+       | build_tag /= ""+       = let+            build = if build_tag == "p" then "profiling"+                                        else "\"" ++ build_tag ++ "\""+         in+         text "Perhaps you haven't installed the " <> text build <>+         text " libraries for package " <> quotes (ppr pkg) <> char '?' $$+         tried_these files++       | otherwise+       = text "There are files missing in the " <> quotes (ppr pkg) <>+         text " package," $$+         text "try running 'ghc-pkg check'." $$+         tried_these files++mayShowLocations :: DynFlags -> [FilePath] -> SDoc+mayShowLocations dflags files+    | null files = Outputable.empty+    | verbosity dflags < 3 =+          text "Use -v (or `:set -v` in ghci) " <>+              text "to see a list of the files searched for."+    | otherwise =+          hang (text "Locations searched:") 2 $ vcat (map text files)++cannotFindModule :: HscEnv -> ModuleName -> FindResult -> SDoc+cannotFindModule hsc_env = cannotFindModule'+    (hsc_dflags   hsc_env)+    (hsc_unit_env hsc_env)+    (targetProfile (hsc_dflags hsc_env))+++cannotFindModule' :: DynFlags -> UnitEnv -> Profile -> ModuleName -> FindResult -> SDoc+cannotFindModule' dflags unit_env profile mod res = pprWithUnitState (ue_units unit_env) $+  cantFindErr (checkBuildingCabalPackage dflags)+              cannotFindMsg+              (text "Ambiguous module name")+              unit_env+              profile+              (mayShowLocations dflags)+              mod+              res+  where+    cannotFindMsg =+      case res of+        NotFound { fr_mods_hidden = hidden_mods+                 , fr_pkgs_hidden = hidden_pkgs+                 , fr_unusables = unusables }+          | not (null hidden_mods && null hidden_pkgs && null unusables)+          -> text "Could not load module"+        _ -> text "Could not find module"++cantFindErr+    :: BuildingCabalPackage -- ^ Using Cabal?+    -> SDoc+    -> SDoc+    -> UnitEnv+    -> Profile+    -> ([FilePath] -> SDoc)+    -> ModuleName+    -> FindResult+    -> SDoc+cantFindErr _ _ multiple_found _ _ _ mod_name (FoundMultiple mods)+  | Just pkgs <- unambiguousPackages+  = hang (multiple_found <+> quotes (ppr mod_name) <> colon) 2 (+       sep [text "it was found in multiple packages:",+                hsep (map ppr pkgs) ]+    )+  | otherwise+  = hang (multiple_found <+> quotes (ppr mod_name) <> colon) 2 (+       vcat (map pprMod mods)+    )+  where+    unambiguousPackages = foldl' unambiguousPackage (Just []) mods+    unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _)+        = Just (moduleUnit m : xs)+    unambiguousPackage _ _ = Nothing++    pprMod (m, o) = text "it is bound as" <+> ppr m <+>+                                text "by" <+> pprOrigin m o+    pprOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden"+    pprOrigin _ (ModUnusable _) = panic "cantFindErr: bound by mod unusable"+    pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma (+      if e == Just True+          then [text "package" <+> ppr (moduleUnit m)]+          else [] +++      map ((text "a reexport in package" <+>)+                .ppr.mkUnit) res +++      if f then [text "a package flag"] else []+      )++cantFindErr using_cabal cannot_find _ unit_env profile tried_these mod_name find_result+  = cannot_find <+> quotes (ppr mod_name)+    $$ more_info+  where+    mhome_unit = ue_homeUnit unit_env+    more_info+      = case find_result of+            NoPackage pkg+                -> text "no unit id matching" <+> quotes (ppr pkg) <+>+                   text "was found"++            NotFound { fr_paths = files, fr_pkg = mb_pkg+                     , fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens+                     , fr_unusables = unusables, fr_suggestions = suggest }+                | Just pkg <- mb_pkg+                , Nothing <- mhome_unit           -- no home-unit+                -> not_found_in_package pkg files++                | Just pkg <- mb_pkg+                , Just home_unit <- mhome_unit    -- there is a home-unit but the+                , not (isHomeUnit home_unit pkg)  -- module isn't from it+                -> not_found_in_package pkg files++                | not (null suggest)+                -> pp_suggestions suggest $$ tried_these files++                | null files && null mod_hiddens &&+                  null pkg_hiddens && null unusables+                -> text "It is not a module in the current program, or in any known package."++                | otherwise+                -> vcat (map pkg_hidden pkg_hiddens) $$+                   vcat (map mod_hidden mod_hiddens) $$+                   vcat (map unusable unusables) $$+                   tried_these files++            _ -> panic "cantFindErr"++    build_tag = waysBuildTag (profileWays profile)++    not_found_in_package pkg files+       | build_tag /= ""+       = let+            build = if build_tag == "p" then "profiling"+                                        else "\"" ++ build_tag ++ "\""+         in+         text "Perhaps you haven't installed the " <> text build <>+         text " libraries for package " <> quotes (ppr pkg) <> char '?' $$+         tried_these files++       | otherwise+       = text "There are files missing in the " <> quotes (ppr pkg) <>+         text " package," $$+         text "try running 'ghc-pkg check'." $$+         tried_these files++    pkg_hidden :: Unit -> SDoc+    pkg_hidden uid =+        text "It is a member of the hidden package"+        <+> quotes (ppr uid)+        --FIXME: we don't really want to show the unit id here we should+        -- show the source package id or installed package id if it's ambiguous+        <> dot $$ pkg_hidden_hint uid++    pkg_hidden_hint uid+     | using_cabal == YesBuildingCabalPackage+        = let pkg = expectJust "pkg_hidden" (lookupUnit (ue_units unit_env) uid)+           in text "Perhaps you need to add" <+>+              quotes (ppr (unitPackageName pkg)) <+>+              text "to the build-depends in your .cabal file."+     | Just pkg <- lookupUnit (ue_units unit_env) uid+         = text "You can run" <+>+           quotes (text ":set -package " <> ppr (unitPackageName pkg)) <+>+           text "to expose it." $$+           text "(Note: this unloads all the modules in the current scope.)"+     | otherwise = Outputable.empty++    mod_hidden pkg =+        text "it is a hidden module in the package" <+> quotes (ppr pkg)++    unusable (pkg, reason)+      = text "It is a member of the package"+      <+> quotes (ppr pkg)+      $$ pprReason (text "which is") reason++    pp_suggestions :: [ModuleSuggestion] -> SDoc+    pp_suggestions sugs+      | null sugs = Outputable.empty+      | otherwise = hang (text "Perhaps you meant")+                       2 (vcat (map pp_sugg sugs))++    -- NB: Prefer the *original* location, and then reexports, and then+    -- package flags when making suggestions.  ToDo: if the original package+    -- also has a reexport, prefer that one+    pp_sugg (SuggestVisible m mod o) = ppr m <+> provenance o+      where provenance ModHidden = Outputable.empty+            provenance (ModUnusable _) = Outputable.empty+            provenance (ModOrigin{ fromOrigUnit = e,+                                   fromExposedReexport = res,+                                   fromPackageFlag = f })+              | Just True <- e+                 = parens (text "from" <+> ppr (moduleUnit mod))+              | f && moduleName mod == m+                 = parens (text "from" <+> ppr (moduleUnit mod))+              | (pkg:_) <- res+                 = parens (text "from" <+> ppr (mkUnit pkg)+                    <> comma <+> text "reexporting" <+> ppr mod)+              | f+                 = parens (text "defined via package flags to be"+                    <+> ppr mod)+              | otherwise = Outputable.empty+    pp_sugg (SuggestHidden m mod o) = ppr m <+> provenance o+      where provenance ModHidden =  Outputable.empty+            provenance (ModUnusable _) = Outputable.empty+            provenance (ModOrigin{ fromOrigUnit = e,+                                   fromHiddenReexport = rhs })+              | Just False <- e+                 = parens (text "needs flag -package-id"+                    <+> ppr (moduleUnit mod))+              | (pkg:_) <- rhs+                 = parens (text "needs flag -package-id"+                    <+> ppr (mkUnit pkg))+              | otherwise = Outputable.empty+
compiler/GHC/Iface/Ext/Ast.hs view
@@ -19,8 +19,6 @@ Main functions for .hie file generation -} -#include "GhclibHsVersions.h"- module GHC.Iface.Ext.Ast ( mkHieFile, mkHieFileWithSource, getCompressedAsts, enrichHie) where  import GHC.Utils.Outputable(ppr)@@ -32,24 +30,21 @@ import GHC.Types.Basic import GHC.Data.BooleanFormula import GHC.Core.Class             ( className, classSCSelIds )-import GHC.Core.Utils             ( exprType )-import GHC.Core.ConLike           ( conLikeName, ConLike(RealDataCon) )+import GHC.Core.ConLike           ( conLikeName ) import GHC.Core.TyCon             ( TyCon, tyConClass_maybe ) import GHC.Core.FVs import GHC.Core.DataCon           ( dataConNonlinearType ) import GHC.Types.FieldLabel import GHC.Hs-import GHC.Driver.Env-import GHC.Utils.Monad            ( concatMapM, liftIO )+import GHC.Hs.Syn.Type+import GHC.Utils.Monad            ( concatMapM, MonadIO(liftIO) ) import GHC.Types.Id               ( isDataConId_maybe ) import GHC.Types.Name             ( Name, nameSrcSpan, nameUnique ) import GHC.Types.Name.Env         ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv ) import GHC.Types.SrcLoc-import GHC.Tc.Utils.Zonk          ( hsLitType, hsPatType )-import GHC.Core.Type              ( mkVisFunTys, Type )+import GHC.Core.Type              ( Type ) import GHC.Core.Predicate import GHC.Core.InstEnv-import GHC.Builtin.Types          ( mkListTy, mkSumTy ) import GHC.Tc.Types import GHC.Tc.Types.Evidence import GHC.Types.Var              ( Id, Var, EvId, varName, varType, varUnique )@@ -57,9 +52,11 @@ import GHC.Builtin.Uniques import GHC.Iface.Make             ( mkIfaceExports ) import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Misc import GHC.Data.Maybe import GHC.Data.FastString+import qualified GHC.Data.Strict as Strict  import GHC.Iface.Ext.Types import GHC.Iface.Ext.Utils@@ -72,17 +69,16 @@ import qualified Data.Map as M import qualified Data.Set as S import Data.Data                  ( Data, Typeable )+import Data.Functor.Identity      ( Identity(..) ) import Data.Void                  ( Void, absurd ) import Control.Monad              ( forM_ ) import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Reader import Control.Monad.Trans.Class  ( lift )-import GHC.HsToCore.Types-import GHC.HsToCore.Expr-import GHC.HsToCore.Monad+import Control.Applicative        ( (<|>) )  {- Note [Updating HieAst for changes in the GHC AST]-+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When updating the code in this file for changes in the GHC AST, you need to pay attention to the following things: @@ -175,9 +171,6 @@         [ toHie $ C Use (L mspan var)              -- Patch up var location since typechecker removes it         ]-      HsConLikeOut _ con ->-        [ toHie $ C Use $ L mspan $ conLikeName con-        ]       ...       HsApp _ a b ->         [ toHie a@@ -212,11 +205,12 @@ -- These synonyms match those defined in compiler/GHC.hs type RenamedSource     = ( HsGroup GhcRn, [LImportDecl GhcRn]                          , Maybe [(LIE GhcRn, Avails)]-                         , Maybe LHsDocString )+                         , Maybe (LHsDoc GhcRn) ) type TypecheckedSource = LHsBinds GhcTc   {- Note [Name Remapping]+   ~~~~~~~~~~~~~~~~~~~~~ The Typechecker introduces new names for mono names in AbsBinds. We don't care about the distinction between mono and poly bindings, so we replace all occurrences of the mono name with the poly name.@@ -273,23 +267,23 @@   addSubstitution mono poly hs =     hs{name_remapping = extendNameEnv (name_remapping hs) (varName mono) poly} -modifyState :: ModifyState (IdP p) => [ABExport p] -> HieState -> HieState+modifyState :: [ABExport] -> HieState -> HieState modifyState = foldr go id   where     go ABE{abe_poly=poly,abe_mono=mono} f       = addSubstitution mono poly . f-    go _ f = f -type HieM = ReaderT NodeOrigin (StateT HieState DsM)+type HieM = ReaderT NodeOrigin (State HieState)  -- | Construct an 'HieFile' from the outputs of the typechecker.-mkHieFile :: ModSummary+mkHieFile :: MonadIO m+          => ModSummary           -> TcGblEnv-          -> RenamedSource -> Hsc HieFile+          -> RenamedSource -> m HieFile mkHieFile ms ts rs = do   let src_file = expectJust "mkHieFile" (ml_hs_file $ ms_location ms)   src <- liftIO $ BS.readFile src_file-  mkHieFileWithSource src_file src ms ts rs+  pure $ mkHieFileWithSource src_file src ms ts rs  -- | Construct an 'HieFile' from the outputs of the typechecker but don't -- read the source file again from disk.@@ -297,16 +291,14 @@                     -> BS.ByteString                     -> ModSummary                     -> TcGblEnv-                    -> RenamedSource -> Hsc HieFile-mkHieFileWithSource src_file src ms ts rs = do+                    -> RenamedSource -> HieFile+mkHieFileWithSource src_file src ms ts rs =   let tc_binds = tcg_binds ts       top_ev_binds = tcg_ev_binds ts       insts = tcg_insts ts       tcs = tcg_tcs ts-  hsc_env <- Hsc $ \e w -> return (e, w)-  (_msgs, res) <- liftIO $ initDs hsc_env ts $ getCompressedAsts tc_binds rs top_ev_binds insts tcs-  let (asts',arr) = expectJust "mkHieFileWithSource" res-  return $ HieFile+      (asts',arr) = getCompressedAsts tc_binds rs top_ev_binds insts tcs in+  HieFile       { hie_hs_file = src_file       , hie_module = ms_mod ms       , hie_types = arr@@ -317,19 +309,20 @@       }  getCompressedAsts :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon]-  -> DsM (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)-getCompressedAsts ts rs top_ev_binds insts tcs = do-  asts <- enrichHie ts rs top_ev_binds insts tcs-  return $ compressTypes asts+  -> (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)+getCompressedAsts ts rs top_ev_binds insts tcs =+  let asts = enrichHie ts rs top_ev_binds insts tcs in+  compressTypes asts  enrichHie :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon]-  -> DsM (HieASTs Type)-enrichHie ts (hsGrp, imports, exports, _) ev_bs insts tcs =-  flip evalStateT initState $ flip runReaderT SourceInfo $ do+  -> HieASTs Type+enrichHie ts (hsGrp, imports, exports, docs) ev_bs insts tcs =+  runIdentity $ flip evalStateT initState $ flip runReaderT SourceInfo $ do     tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts     rasts <- processGrp hsGrp     imps <- toHie $ filter (not . ideclImplicit . unLoc) imports     exps <- toHie $ fmap (map $ IEC Export . fst) exports+    docs <- toHie docs     -- Add Instance bindings     forM_ insts $ \i ->       addUnlocatedEvBind (is_dfun i) (EvidenceVarBind (EvInstBind False (is_cls_nm i)) ModuleScope Nothing)@@ -349,6 +342,7 @@           , rasts           , imps           , exps+          , docs           ]          modulify (HiePath file) xs' = do@@ -356,7 +350,7 @@           top_ev_asts :: [HieAST Type] <- do             let               l :: SrcSpanAnnA-              l = noAnnSrcSpan (RealSrcSpan (realSrcLocSpan $ mkRealSrcLoc file 1 1) Nothing)+              l = noAnnSrcSpan (RealSrcSpan (realSrcLocSpan $ mkRealSrcLoc file 1 1) Strict.Nothing)             toHie $ EvBindContext ModuleScope Nothing                   $ L l (EvBinds ev_bs) @@ -395,6 +389,7 @@       , toHie $ hs_warnds grp       , toHie $ hs_annds grp       , toHie $ hs_ruleds grp+      , toHie $ hs_docs grp       ]  getRealSpanA :: SrcSpanAnn' ann -> Maybe Span@@ -404,10 +399,9 @@ getRealSpan (RealSrcSpan sp _) = Just sp getRealSpan _ = Nothing -grhss_span :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpan-              , Data (HsLocalBinds (GhcPass p)))+grhss_span :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcAnn NoEpAnns)            => GRHSs (GhcPass p) (LocatedA (body (GhcPass p))) -> SrcSpan-grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (spanHsLocaLBinds bs) (map getLoc xs)+grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (spanHsLocaLBinds bs) (map getLocA xs)  bindingsOnly :: [Context Name] -> HieM [HieAST a] bindingsOnly [] = pure []@@ -424,6 +418,7 @@ concatM xs = concat <$> sequence xs  {- Note [Capturing Scopes and other non local information]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ toHie is a local transformation, but scopes of bindings cannot be known locally, hence we have to push the relevant info down into the binding nodes. We use the following types (*Context and *Scoped) to wrap things and@@ -468,6 +463,7 @@   deriving (Typeable, Data) -- Pattern Scope  {- Note [TyVar Scopes]+   ~~~~~~~~~~~~~~~~~~~ Due to -XScopedTypeVariables, type variables can be in scope quite far from their original binding. We resolve the scope of these type variables in a separate pass@@ -521,6 +517,7 @@   map (\(RS sc a)-> TVS tvScope sc a) $ listScopes rhsScope xs  {- Note [Scoping Rules for SigPat]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Explicitly quantified variables in pattern type signatures are not brought into scope in the rhs, but implicitly quantified variables are (HsWC and HsIB).@@ -689,7 +686,7 @@         (WpLet bs)      -> toHie $ EvBindContext (mkScopeA osp) (getRealSpanA osp) (L osp bs)         (WpCompose a b) -> concatM $           [toHie (L osp a), toHie (L osp b)]-        (WpFun a b _ _) -> concatM $+        (WpFun a b _)   -> concatM $           [toHie (L osp a), toHie (L osp b)]         (WpEvLam a) ->           toHie $ C (EvidenceVarBind EvWrapperBind (mkScopeA osp) (getRealSpanA osp))@@ -716,78 +713,81 @@ -- the expression. It is not yet possible to do this efficiently for all -- expression forms, so we skip filling in the type for those inputs. ----- 'HsApp', for example, doesn't have any type information available directly on--- the node. Our next recourse would be to desugar it into a 'CoreExpr' then--- query the type of that. Yet both the desugaring call and the type query both--- involve recursive calls to the function and argument! This is particularly--- problematic when you realize that the HIE traversal will eventually visit--- those nodes too and ask for their types again.------ Since the above is quite costly, we just skip cases where computing the--- expression's type is going to be expensive.------ See #16233+-- See Note [Computing the type of every node in the tree] instance HiePass p => HasType (LocatedA (HsExpr (GhcPass p))) where-  getTypeNode e@(L spn e') =+  getTypeNode (L spn e) =     case hiePass @p of-      HieRn -> makeNodeA e' spn-      HieTc ->-        -- Some expression forms have their type immediately available-        let tyOpt = case e' of-              HsUnboundVar (HER _ ty _) _ -> Just ty-              HsLit _ l -> Just (hsLitType l)-              HsOverLit _ o -> Just (overLitType o)+      HieRn -> fallback+      HieTc -> case computeType e of+          Just ty -> makeTypeNodeA e spn ty+          Nothing -> fallback+    where+      fallback :: HieM [HieAST Type]+      fallback = makeNodeA e spn -              HsConLikeOut _ (RealDataCon con) -> Just (dataConNonlinearType con)+      -- Skip computing the type of some expressions for performance reasons.+      --+      -- See impact on Haddock output (esp. missing type annotations or links)+      -- before skipping more kinds of expressions. See impact on Haddock+      -- performance before computing the types of more expressions.+      --+      -- See Note [Computing the type of every node in the tree]+      computeType :: HsExpr GhcTc -> Maybe Type+      computeType e = case e of+        HsApp{} -> Nothing+        HsAppType{} -> Nothing+        NegApp{} -> Nothing+        HsPar _ _ e _ -> computeLType e+        ExplicitTuple{} -> Nothing+        HsIf _ _ t f -> computeLType t <|> computeLType f+        HsLet _ _ _ _ body -> computeLType body+        RecordCon con_expr _ _ -> computeType con_expr+        ExprWithTySig _ e _ -> computeLType e+        HsPragE _ _ e -> computeLType e+        XExpr (ExpansionExpr (HsExpanded (HsGetField _ _ _) e)) -> Just (hsExprType e) -- for record-dot-syntax+        XExpr (ExpansionExpr (HsExpanded _ e)) -> computeType e+        XExpr (HsTick _ e) -> computeLType e+        XExpr (HsBinTick _ _ e) -> computeLType e+        e -> Just (hsExprType e) -              HsLam     _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)-              HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)-              HsCase _  _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy)+      computeLType :: LHsExpr GhcTc -> Maybe Type+      computeLType (L _ e) = computeType e -              ExplicitList  ty _     -> Just (mkListTy ty)-              ExplicitSum   ty _ _ _ -> Just (mkSumTy ty)-              HsDo          ty _ _   -> Just ty-              HsMultiIf     ty _     -> Just ty+{- Note [Computing the type of every node in the tree]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In GHC.Iface.Ext.Ast we decorate every node in the AST with its+type, computed by `hsExprType` applied to that node.  So it's+important that `hsExprType` takes roughly constant time per node.+There are three cases to consider: -              _ -> Nothing+1. For many nodes (e.g. HsVar, HsDo, HsCase) it is easy to get their+   type -- e.g. it is stored in the node, or in sub-node thereof. -        in-        case tyOpt of-          Just t -> makeTypeNodeA e' spn t-          Nothing-            | skipDesugaring e' -> fallback-            | otherwise -> do-                (e, no_errs) <- lift $ lift $ discardWarningsDs $ askNoErrsDs $ dsLExpr e-                if no_errs-                  then makeTypeNodeA e' spn . exprType $ e-                  else fallback-        where-          fallback = makeNodeA e' spn+2. For some nodes (e.g. HsPar, HsTick, HsIf) the type of the node is+   the type of a child, so we can recurse, fast.  We don't expect the+   nesting to be very deep, so while this is theoretically non-linear,+   we don't expect it to be a problem in practice. -          matchGroupType :: MatchGroupTc -> Type-          matchGroupType (MatchGroupTc args res) = mkVisFunTys args res+3. A very few nodes (e.g. HsApp) are more troublesome because we need to+   take the type of a child, and then do some non-trivial processing.+   To be conservative on computation, we decline to decorate these+   nodes, using `fallback` instead. -          -- | Skip desugaring of these expressions for performance reasons.-          ---          -- See impact on Haddock output (esp. missing type annotations or links)-          -- before marking more things here as 'False'. See impact on Haddock-          -- performance before marking more things as 'True'.-          skipDesugaring :: HsExpr GhcTc -> Bool-          skipDesugaring e = case e of-            HsVar{}             -> False-            HsConLikeOut{}      -> False-            HsRecFld{}          -> False-            HsOverLabel{}       -> False-            HsIPVar{}           -> False-            XExpr (ExpansionExpr {}) -> False-            _                   -> True+The function `computeType e` returns `Just t` if we can find the type+of `e` cheaply, and `Nothing` otherwise.  The base `Nothing` cases+are the troublesome ones in (3) above. Hopefully we can ultimately+get rid of them all. +See #16233++-}+ data HiePassEv p where   HieRn :: HiePassEv 'Renamed   HieTc :: HiePassEv 'Typechecked -class ( IsPass p-      , HiePass (NoGhcTcPass p)+class ( HiePass (NoGhcTcPass p)+      , NoGhcTcPass p ~ 'Renamed       , ModifyState (IdGhcP p)       , Data (GRHS  (GhcPass p) (LocatedA (HsExpr (GhcPass p))))       , Data (Match (GhcPass p) (LocatedA (HsExpr (GhcPass p))))@@ -805,10 +805,6 @@       , Data (HsTupArg (GhcPass p))       , Data (IPBind (GhcPass p))       , ToHie (Context (Located (IdGhcP p)))-      , ToHie (RFContext (Located (AmbiguousFieldOcc (GhcPass p))))-      , ToHie (RFContext (Located (FieldOcc (GhcPass p))))-      , ToHie (TScoped (LHsWcType (GhcPass (NoGhcTcPass p))))-      , ToHie (TScoped (LHsSigWcType (GhcPass (NoGhcTcPass p))))       , Anno (IdGhcP p) ~ SrcSpanAnnN       )       => HiePass p where@@ -828,15 +824,13 @@     , Anno [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]                    ~ SrcSpanAnnL     , Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))-                   ~ SrcSpan+                   ~ SrcAnn NoEpAnns     , Anno (StmtLR (GhcPass p) (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA      , Data (body (GhcPass p))     , Data (Match (GhcPass p) (LocatedA (body (GhcPass p))))     , Data (GRHS  (GhcPass p) (LocatedA (body (GhcPass p))))     , Data (Stmt  (GhcPass p) (LocatedA (body (GhcPass p))))--    , IsPass p     )  instance HiePass p => ToHie (BindContext (LocatedA (HsBind (GhcPass p)))) where@@ -856,21 +850,27 @@       VarBind{var_rhs = expr} ->         [ toHie expr         ]-      AbsBinds{ abs_exports = xs, abs_binds = binds-              , abs_ev_binds = ev_binds-              , abs_ev_vars = ev_vars } ->-        [  lift (modify (modifyState xs)) >> -- Note [Name Remapping]-                (toHie $ fmap (BC context scope) binds)-        , toHie $ map (L span . abe_wrap) xs-        , toHie $-            map (EvBindContext (mkScopeA span) (getRealSpanA span)-                . L span) ev_binds-        , toHie $-            map (C (EvidenceVarBind EvSigBind-                                    (mkScopeA span)-                                    (getRealSpanA span))-                . L span) ev_vars-        ]+      XHsBindsLR ext -> case hiePass @p of+#if __GLASGOW_HASKELL__ < 811+        HieRn -> dataConCantHappen ext+#endif+        HieTc+          | AbsBinds{ abs_exports = xs, abs_binds = binds+                    , abs_ev_binds = ev_binds+                    , abs_ev_vars = ev_vars } <- ext+          ->+            [  lift (modify (modifyState xs)) >> -- Note [Name Remapping]+                    (toHie $ fmap (BC context scope) binds)+            , toHie $ map (L span . abe_wrap) xs+            , toHie $+                map (EvBindContext (mkScopeA span) (getRealSpanA span)+                    . L span) ev_binds+            , toHie $+                map (C (EvidenceVarBind EvSigBind+                                        (mkScopeA span)+                                        (getRealSpanA span))+                    . L span) ev_vars+            ]       PatSynBind _ psb ->         [ toHie $ L (locA span) psb -- PatSynBinds only occur at the top level         ]@@ -907,11 +907,11 @@             (InfixCon a b) -> combineScopes (mkLScopeN a) (mkLScopeN b)             (RecCon r) -> foldr go NoScope r           go (RecordPatSynField a b) c = combineScopes c-            $ combineScopes (mkLScopeN (rdrNameFieldOcc a)) (mkLScopeN b)+            $ combineScopes (mkLScopeN (foLabel a)) (mkLScopeN b)           detSpan = case detScope of             LocalScope a -> Just a             _ -> Nothing-          toBind (PrefixCon ts args) = ASSERT(null ts) PrefixCon ts $ map (C Use) args+          toBind (PrefixCon ts args) = assert (null ts) $ PrefixCon ts $ map (C Use) args           toBind (InfixCon a b) = InfixCon (C Use a) (C Use b)           toBind (RecCon r) = RecCon $ map (PSC detSpan) r @@ -925,20 +925,22 @@          , AnnoBody p body          , ToHie (LocatedA (body (GhcPass p)))          ) => ToHie (LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))) where-  toHie (L span m ) = concatM $ node : case m of+  toHie (L span m ) = concatM $ makeNodeA m span : case m of     Match{m_ctxt=mctx, m_pats = pats, m_grhss =  grhss } ->       [ toHie mctx       , let rhsScope = mkScope $ grhss_span grhss           in toHie $ patScopes Nothing rhsScope NoScope pats       , toHie grhss       ]-    where-      node = case hiePass @p of-        HieTc -> makeNodeA m span-        HieRn -> makeNodeA m span  instance HiePass p => ToHie (HsMatchContext (GhcPass p)) where-  toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name+  toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name'+    where+      -- See a paragraph about Haddock in #20415.+      name' :: LocatedN Name+      name' = case hiePass @p of+        HieRn -> name+        HieTc -> mapLoc varName name   toHie (StmtCtxt a) = toHie a   toHie _ = pure [] @@ -966,7 +968,7 @@                     lname         , toHie $ PS rsp scope pscope pat         ]-      ParPat _ pat ->+      ParPat _ _ pat _ ->         [ toHie $ PS rsp scope pscope pat         ]       BangPat _ pat ->@@ -1025,17 +1027,17 @@         ]       XPat e ->         case hiePass @p of-          HieTc ->-            let CoPat wrap pat _ = e-              in [ toHie $ L ospan wrap-                 , toHie $ PS rsp scope pscope $ (L ospan pat)-                 ]-#if __GLASGOW_HASKELL__ < 811-          HieRn -> []-#endif+          HieRn -> case e of+            HsPatExpanded _ p -> [ toHie $ PS rsp scope pscope (L ospan p) ]+          HieTc -> case e of+            CoPat wrap pat _ ->+              [ toHie $ L ospan wrap+              , toHie $ PS rsp scope pscope $ (L ospan pat)+              ]+            ExpansionPat _ p -> [ toHie $ PS rsp scope pscope (L ospan p) ]     where-      contextify :: a ~ LPat (GhcPass p) => HsConDetails (HsPatSigType (NoGhcTc (GhcPass p))) a (HsRecFields (GhcPass p) a)-                 -> HsConDetails (TScoped (HsPatSigType (NoGhcTc (GhcPass p)))) (PScoped a) (RContext (HsRecFields (GhcPass p) (PScoped a)))+      contextify :: a ~ LPat (GhcPass p) => HsConDetails (HsPatSigType GhcRn) a (HsRecFields (GhcPass p) a)+                 -> HsConDetails (TScoped (HsPatSigType GhcRn)) (PScoped a) (RContext (HsRecFields (GhcPass p) (PScoped a)))       contextify (PrefixCon tyargs args) = PrefixCon (tScopes scope argscope tyargs) (patScopes rsp scope pscope args)         where argscope = foldr combineScopes NoScope $ map mkLScopeA args       contextify (InfixCon a b) = InfixCon a' b'@@ -1043,10 +1045,10 @@       contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r       contextify_rec (HsRecFields fds a) = HsRecFields (map go scoped_fds) a         where-          go :: RScoped (LocatedA (HsRecField' id a1))-                      -> LocatedA (HsRecField' id (PScoped a1)) -- AZ-          go (RS fscope (L spn (HsRecField x lbl pat pun))) =-            L spn $ HsRecField x lbl (PS rsp scope fscope pat) pun+          go :: RScoped (LocatedA (HsFieldBind id a1))+                      -> LocatedA (HsFieldBind id (PScoped a1)) -- AZ+          go (RS fscope (L spn (HsFieldBind x lbl pat pun))) =+            L spn $ HsFieldBind x lbl (PS rsp scope fscope pat) pun           scoped_fds = listScopes pscope fds  instance ToHie (TScoped (HsPatSigType GhcRn)) where@@ -1069,16 +1071,12 @@ instance ( ToHie (LocatedA (body (GhcPass p)))          , HiePass p          , AnnoBody p body-         ) => ToHie (Located (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))) where-  toHie (L span g) = concatM $ node : case g of+         ) => ToHie (LocatedAn NoEpAnns (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))) where+  toHie (L span g) = concatM $ makeNodeA g span : case g of     GRHS _ guards body ->       [ toHie $ listScopes (mkLScopeA body) guards       , toHie body       ]-    where-      node = case hiePass @p of-        HieRn -> makeNode g span-        HieTc -> makeNode g span  instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where   toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of@@ -1087,11 +1085,8 @@              -- Patch up var location since typechecker removes it         ]       HsUnboundVar _ _ -> []  -- there is an unbound name here, but that causes trouble-      HsConLikeOut _ con ->-        [ toHie $ C Use $ L mspan $ conLikeName con-        ]-      HsRecFld _ fld ->-        [ toHie $ RFC RecFieldOcc Nothing (L (locA mspan) fld)+      HsRecSel _ fld ->+        [ toHie $ RFC RecFieldOcc Nothing (L (l2l mspan:: SrcAnn NoEpAnns) fld)         ]       HsOverLabel {} -> []       HsIPVar _ _ -> []@@ -1100,7 +1095,7 @@       HsLam _ mg ->         [ toHie mg         ]-      HsLamCase _ mg ->+      HsLamCase _ _ mg ->         [ toHie mg         ]       HsApp _ a b ->@@ -1119,7 +1114,7 @@       NegApp _ a _ ->         [ toHie a         ]-      HsPar _ a ->+      HsPar _ _ a _ ->         [ toHie a         ]       SectionL _ a b ->@@ -1148,7 +1143,7 @@       HsMultiIf _ grhss ->         [ toHie grhss         ]-      HsLet _ binds expr ->+      HsLet _ _ binds _ expr ->         [ toHie $ RS (mkLScopeA expr) binds         , toHie expr         ]@@ -1186,44 +1181,50 @@         [ toHie expr         ]       HsProc _ pat cmdtop ->-        [ toHie $ PS Nothing (mkLScope cmdtop) NoScope pat+        [ toHie $ PS Nothing (mkLScopeA cmdtop) NoScope pat         , toHie cmdtop         ]       HsStatic _ expr ->         [ toHie expr         ]-      HsTick _ _ expr ->-        [ toHie expr-        ]-      HsBinTick _ _ _ expr ->-        [ toHie expr-        ]-      HsBracket _ b ->-        [ toHie b-        ]-      HsRnBracketOut _ b p ->-        [ toHie b-        , toHie p-        ]-      HsTcBracketOut _ _wrap b p ->-        [ toHie b-        , toHie p-        ]+      HsTypedBracket xbracket b -> case hiePass @p of+        HieRn ->+          [ toHie b+          ]+        HieTc | HsBracketTc _ _ _ p <- xbracket ->+          [ toHie b+          , toHie p+          ]+      HsUntypedBracket xbracket b -> case hiePass @p of+        HieRn ->+            [ toHie b+            , toHie xbracket+            ]+        HieTc | HsBracketTc _ _ _ p <- xbracket ->+          [ toHie b+          , toHie p+          ]       HsSpliceE _ x ->         [ toHie $ L mspan x         ]       HsGetField {} -> []       HsProjection {} -> []       XExpr x-        | GhcTc <- ghcPass @p-        , WrapExpr (HsWrap w a) <- x-        -> [ toHie $ L mspan a-           , toHie (L mspan w)-           ]-        | GhcTc <- ghcPass @p-        , ExpansionExpr (HsExpanded _ b) <- x-        -> [ toHie (L mspan b)-           ]+        | HieTc <- hiePass @p+        -> case x of+             WrapExpr (HsWrap w a)+               -> [ toHie $ L mspan a+                  , toHie (L mspan w) ]+             ExpansionExpr (HsExpanded _ b)+               -> [ toHie (L mspan b) ]+             ConLikeTc con _ _+               -> [ toHie $ C Use $ L mspan $ conLikeName con ]+             HsTick _ expr+               -> [ toHie expr+                  ]+             HsBinTick _ _ expr+               -> [ toHie expr+                  ]         | otherwise -> []  -- NOTE: no longer have the location@@ -1292,7 +1293,6 @@                       valBinds         ] - scopeHsLocaLBinds :: HsLocalBinds (GhcPass p) -> Scope scopeHsLocaLBinds (HsValBinds _ (ValBinds _ bs sigs))   = foldr combineScopes NoScope (bsScope ++ sigsScope)@@ -1313,15 +1313,13 @@   = foldr combineScopes NoScope (map (mkScopeA . getLoc) bs) scopeHsLocaLBinds (EmptyLocalBinds _) = NoScope - instance HiePass p => ToHie (RScoped (LocatedA (IPBind (GhcPass p)))) where-  toHie (RS scope (L sp bind)) = concatM $ makeNodeA bind sp : case bind of-    IPBind _ (Left _) expr -> [toHie expr]-    IPBind _ (Right v) expr ->-      [ toHie $ C (EvidenceVarBind EvImplicitBind scope (getRealSpanA sp))-                  $ L sp v-      , toHie expr-      ]+  toHie (RS scope (L sp bind@(IPBind v _ expr))) = concatM $ makeNodeA bind sp : case hiePass @p of+    HieRn -> [toHie expr]+    HieTc -> [ toHie $ C (EvidenceVarBind EvImplicitBind scope (getRealSpanA sp))+                       $ L sp v+             , toHie expr+             ]  instance HiePass p => ToHie (RScoped (HsValBindsLR (GhcPass p) (GhcPass p))) where   toHie (RS sc v) = concatM $ case v of@@ -1341,44 +1339,33 @@          , HiePass p ) => ToHie (RContext (HsRecFields (GhcPass p) arg)) where   toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields -instance ( ToHie (RFContext (Located label))+instance ( ToHie (RFContext label)          , ToHie arg, HasLoc arg, Data arg          , Data label-         ) => ToHie (RContext (LocatedA (HsRecField' label arg))) where+         ) => ToHie (RContext (LocatedA (HsFieldBind label arg))) where   toHie (RC c (L span recfld)) = concatM $ makeNode recfld (locA span) : case recfld of-    HsRecField _ label expr _ ->+    HsFieldBind _ label expr _ ->       [ toHie $ RFC c (getRealSpan $ loc expr) label       , toHie expr       ] -instance ToHie (RFContext (Located (FieldOcc GhcRn))) where-  toHie (RFC c rhs (L nspan f)) = concatM $ case f of-    FieldOcc name _ ->-      [ toHie $ C (RecField c rhs) (L nspan name)-      ]--instance ToHie (RFContext (Located (FieldOcc GhcTc))) where+instance HiePass p => ToHie (RFContext (LocatedAn NoEpAnns (FieldOcc (GhcPass p)))) where   toHie (RFC c rhs (L nspan f)) = concatM $ case f of-    FieldOcc var _ ->-      [ toHie $ C (RecField c rhs) (L nspan var)-      ]--instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where-  toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of-    Unambiguous name _ ->-      [ toHie $ C (RecField c rhs) $ L nspan name-      ]-    Ambiguous _name _ ->-      [ ]+    FieldOcc fld _ ->+      case hiePass @p of+        HieRn -> [toHie $ C (RecField c rhs) (L (locA nspan) fld)]+        HieTc -> [toHie $ C (RecField c rhs) (L (locA nspan) fld)] -instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where+instance HiePass p => ToHie (RFContext (LocatedAn NoEpAnns (AmbiguousFieldOcc (GhcPass p)))) where   toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of-    Unambiguous var _ ->-      [ toHie $ C (RecField c rhs) (L nspan var)-      ]-    Ambiguous var _ ->-      [ toHie $ C (RecField c rhs) (L nspan var)-      ]+    Unambiguous fld _ ->+      case hiePass @p of+        HieRn -> [toHie $ C (RecField c rhs) $ L (locA nspan) fld]+        HieTc -> [toHie $ C (RecField c rhs) $ L (locA nspan) fld]+    Ambiguous fld _ ->+      case hiePass @p of+        HieRn -> []+        HieTc -> [ toHie $ C (RecField c rhs) (L (locA nspan) fld) ]  instance HiePass p => ToHie (RScoped (ApplicativeArg (GhcPass p))) where   toHie (RS sc (ApplicativeArgOne _ pat expr _)) = concatM@@ -1397,10 +1384,10 @@  instance ToHie (HsConDeclGADTDetails GhcRn) where   toHie (PrefixConGADT args) = toHie args-  toHie (RecConGADT rec) = toHie rec+  toHie (RecConGADT rec _) = toHie rec -instance HiePass p => ToHie (Located (HsCmdTop (GhcPass p))) where-  toHie (L span top) = concatM $ makeNode top span : case top of+instance HiePass p => ToHie (LocatedAn NoEpAnns (HsCmdTop (GhcPass p))) where+  toHie (L span top) = concatM $ makeNodeA top span : case top of     HsCmdTop _ cmd ->       [ toHie cmd       ]@@ -1422,14 +1409,14 @@       HsCmdLam _ mg ->         [ toHie mg         ]-      HsCmdPar _ a ->+      HsCmdPar _ _ a _ ->         [ toHie a         ]       HsCmdCase _ expr alts ->         [ toHie expr         , toHie alts         ]-      HsCmdLamCase _ alts ->+      HsCmdLamCase _ _ alts ->         [ toHie alts         ]       HsCmdIf _ _ a b c ->@@ -1437,7 +1424,7 @@         , toHie b         , toHie c         ]-      HsCmdLet _ binds cmd' ->+      HsCmdLet _ _ binds _ cmd' ->         [ toHie $ RS (mkLScopeA cmd') binds         , toHie cmd'         ]@@ -1479,7 +1466,7 @@           rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc           sig_sc = maybe NoScope mkLScopeA $ dd_kindSig defn           con_sc = foldr combineScopes NoScope $ map mkLScopeA $ dd_cons defn-          deriv_sc = foldr combineScopes NoScope $ map mkLScope $ dd_derivs defn+          deriv_sc = foldr combineScopes NoScope $ map mkLScopeA $ dd_derivs defn       ClassDecl { tcdCtxt = context                 , tcdLName = name                 , tcdTyVars = vars@@ -1515,8 +1502,8 @@         ]         where           rhsSpan = sigSpan `combineScopes` injSpan-          sigSpan = mkScope $ getLoc sig-          injSpan = maybe NoScope (mkScope . getLoc) inj+          sigSpan = mkScope $ getLocA sig+          injSpan = maybe NoScope (mkScope . getLocA) inj  instance ToHie (FamilyInfo GhcRn) where   toHie (ClosedTypeFamily (Just eqns)) = concatM $@@ -1527,8 +1514,8 @@       go (L l ib) = TS (ResolvedScopes [mkScopeA l]) ib   toHie _ = pure [] -instance ToHie (RScoped (Located (FamilyResultSig GhcRn))) where-  toHie (RS sc (L span sig)) = concatM $ makeNode sig span : case sig of+instance ToHie (RScoped (LocatedAn NoEpAnns (FamilyResultSig GhcRn))) where+  toHie (RS sc (L span sig)) = concatM $ makeNodeA sig span : case sig of       NoSig _ ->         []       KindSig _ k ->@@ -1564,8 +1551,8 @@           patsScope = mkScope (loc pats)           rhsScope = mkScope (loc rhs) -instance ToHie (Located (InjectivityAnn GhcRn)) where-  toHie (L span ann) = concatM $ makeNode ann span : case ann of+instance ToHie (LocatedAn NoEpAnns (InjectivityAnn GhcRn)) where+  toHie (L span ann) = concatM $ makeNodeA ann span : case ann of       InjectivityAnn _ lhs rhs ->         [ toHie $ C Use lhs         , toHie $ map (C Use) rhs@@ -1579,16 +1566,16 @@     , toHie derivs     ] -instance ToHie (Located [Located (HsDerivingClause GhcRn)]) where+instance ToHie (Located [LocatedAn NoEpAnns (HsDerivingClause GhcRn)]) where   toHie (L span clauses) = concatM     [ locOnly span     , toHie clauses     ] -instance ToHie (Located (HsDerivingClause GhcRn)) where-  toHie (L span cl) = concatM $ makeNode cl span : case cl of+instance ToHie (LocatedAn NoEpAnns (HsDerivingClause GhcRn)) where+  toHie (L span cl) = concatM $ makeNodeA cl span : case cl of       HsDerivingClause _ strat dct ->-        [ toHie strat+        [ toHie (RS (mkLScopeA dct) <$> strat)         , toHie dct         ] @@ -1597,12 +1584,12 @@       DctSingle _ ty -> [ toHie $ TS (ResolvedScopes []) ty ]       DctMulti _ tys -> [ toHie $ map (TS (ResolvedScopes [])) tys ] -instance ToHie (Located (DerivStrategy GhcRn)) where-  toHie (L span strat) = concatM $ makeNode strat span : case strat of+instance ToHie (RScoped (LocatedAn NoEpAnns (DerivStrategy GhcRn))) where+  toHie (RS sc (L span strat)) = concatM $ makeNodeA strat span : case strat of       StockStrategy _ -> []       AnyclassStrategy _ -> []       NewtypeStrategy _ -> []-      ViaStrategy s -> [ toHie (TS (ResolvedScopes []) s) ]+      ViaStrategy s -> [ toHie (TS (ResolvedScopes [sc]) s) ]  instance ToHie (LocatedP OverlapMode) where   toHie (L span _) = locOnly (locA span)@@ -1613,7 +1600,8 @@ instance ToHie (LocatedA (ConDecl GhcRn)) where   toHie (L span decl) = concatM $ makeNode decl (locA span) : case decl of       ConDeclGADT { con_names = names, con_bndrs = L outer_bndrs_loc outer_bndrs-                  , con_mb_cxt = ctx, con_g_args = args, con_res_ty = typ } ->+                  , con_mb_cxt = ctx, con_g_args = args, con_res_ty = typ+                  , con_doc = doc} ->         [ toHie $ map (C (Decl ConDec $ getRealSpanA span)) names         , case outer_bndrs of             HsOuterImplicit{hso_ximplicit = imp_vars} ->@@ -1624,21 +1612,24 @@         , toHie ctx         , toHie args         , toHie typ+        , toHie doc         ]         where           rhsScope = combineScopes argsScope tyScope           ctxScope = maybe NoScope mkLScopeA ctx           argsScope = case args of             PrefixConGADT xs -> scaled_args_scope xs-            RecConGADT x     -> mkLScopeA x+            RecConGADT x _   -> mkLScopeA x           tyScope = mkLScopeA typ           resScope = ResolvedScopes [ctxScope, rhsScope]       ConDeclH98 { con_name = name, con_ex_tvs = qvars-                 , con_mb_cxt = ctx, con_args = dets } ->+                 , con_mb_cxt = ctx, con_args = dets+                 , con_doc = doc} ->         [ toHie $ C (Decl ConDec $ getRealSpan (locA span)) name         , toHie $ tvScopes (ResolvedScopes []) rhsScope qvars         , toHie ctx         , toHie dets+        , toHie doc         ]         where           rhsScope = combineScopes ctxScope argsScope@@ -1718,7 +1709,7 @@           ]         SCCFunSig _ _ name mtxt ->           [ toHie $ (C Use) name-          , maybe (pure []) (locOnly . getLoc) mtxt+          , maybe (pure []) (locOnly . getLocA) mtxt           ]         CompleteMatchSig _ _ (L ispan names) typ ->           [ locOnly ispan@@ -1778,7 +1769,7 @@       HsSumTy _ tys ->         [ toHie tys         ]-      HsOpTy _ a op b ->+      HsOpTy _ _prom a op b ->         [ toHie a         , toHie $ C Use op         , toHie b@@ -1797,8 +1788,9 @@       HsSpliceTy _ a ->         [ toHie $ L span a         ]-      HsDocTy _ a _ ->+      HsDocTy _ a doc ->         [ toHie a+        , toHie doc         ]       HsBangTy _ _ ty ->         [ toHie ty@@ -1849,9 +1841,10 @@  instance ToHie (LocatedA (ConDeclField GhcRn)) where   toHie (L span field) = concatM $ makeNode field (locA span) : case field of-      ConDeclField _ fields typ _ ->+      ConDeclField _ fields typ doc ->         [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields         , toHie typ+        , toHie doc         ]  instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where@@ -1876,7 +1869,7 @@         [ toHie splice         ] -instance ToHie (HsBracket a) where+instance ToHie (HsQuote a) where   toHie _ = pure []  instance ToHie PendingRnSplice where@@ -1900,8 +1893,8 @@         [ toHie f         ] -instance ToHie (Located HsIPName) where-  toHie (L span e) = makeNode e span+instance ToHie (LocatedAn NoEpAnns HsIPName) where+  toHie (L span e) = makeNodeA e span  instance HiePass p => ToHie (LocatedA (HsSplice (GhcPass p))) where   toHie (L span sp) = concatM $ makeNodeA sp span : case sp of@@ -1916,19 +1909,18 @@         ]       HsSpliced _ _ _ ->         []-      XSplice x -> case ghcPass @p of+      XSplice x -> case hiePass @p of #if __GLASGOW_HASKELL__ < 811-                     GhcPs -> noExtCon x-                     GhcRn -> noExtCon x+                     HieRn -> dataConCantHappen x #endif-                     GhcTc -> case x of+                     HieTc -> case x of                                 HsSplicedT _ -> []  instance ToHie (LocatedA (RoleAnnotDecl GhcRn)) where   toHie (L span annot) = concatM $ makeNodeA annot span : case annot of       RoleAnnotDecl _ var roles ->         [ toHie $ C Use var-        , concatMapM (locOnly . getLoc) roles+        , concatMapM (locOnly . getLocA) roles         ]  instance ToHie (LocatedA (InstDecl GhcRn)) where@@ -1976,7 +1968,7 @@   toHie (L span decl) = concatM $ makeNodeA decl span : case decl of       DerivDecl _ typ strat overlap ->         [ toHie $ TS (ResolvedScopes []) typ-        , toHie strat+        , toHie $ (RS (mkScopeA span) <$> strat)         , toHie overlap         ] @@ -2051,19 +2043,19 @@ instance ToHie (LocatedA (RuleDecl GhcRn)) where   toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM         [ makeNodeA r span-        , locOnly $ getLoc rname+        , locOnly $ getLocA rname         , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs         , toHie $ map (RS $ mkScope (locA span)) bndrs         , toHie exprA         , toHie exprB         ]     where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc-          bndrs_sc = maybe NoScope mkLScope (listToMaybe bndrs)+          bndrs_sc = maybe NoScope mkLScopeA (listToMaybe bndrs)           exprA_sc = mkLScopeA exprA           exprB_sc = mkLScopeA exprB -instance ToHie (RScoped (Located (RuleBndr GhcRn))) where-  toHie (RS sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of+instance ToHie (RScoped (LocatedAn NoEpAnns (RuleBndr GhcRn))) where+  toHie (RS sc (L span bndr)) = concatM $ makeNodeA bndr span : case bndr of       RuleBndr _ var ->         [ toHie $ C (ValBind RegularBind sc Nothing) var         ]@@ -2106,8 +2098,8 @@       IEModuleContents _ n ->         [ toHie $ IEC c n         ]-      IEGroup _ _ _ -> []-      IEDoc _ _ -> []+      IEGroup _ _ d -> [toHie d]+      IEDoc _ d -> [toHie d]       IEDocNamed _ _ -> []  instance ToHie (IEContext (LIEWrappedName Name)) where@@ -2127,3 +2119,13 @@       [ makeNode lbl span       , toHie $ C (IEThing c) $ L span (flSelector lbl)       ]++instance ToHie (LocatedA (DocDecl GhcRn)) where+  toHie (L span d) = concatM $ makeNodeA d span : case d of+    DocCommentNext d -> [ toHie d ]+    DocCommentPrev d -> [ toHie d ]+    DocCommentNamed _ d -> [ toHie d ]+    DocGroup _ d -> [ toHie d ]++instance ToHie (LHsDoc GhcRn) where+  toHie (L span d@(WithHsDocIdentifiers _ ids)) = concatM $ makeNode d span : [toHie $ map (C Use) ids]
compiler/GHC/Iface/Ext/Binary.hs view
@@ -14,7 +14,6 @@    , HieFileResult(..)    , hieMagic    , hieNameOcc-   , NameCacheUpdater(..)    ) where @@ -31,19 +30,18 @@ import GHC.Utils.Panic import GHC.Builtin.Utils import GHC.Types.SrcLoc as SrcLoc-import GHC.Types.Unique.Supply    ( takeUniqFromSupply ) import GHC.Types.Unique import GHC.Types.Unique.FM-import GHC.Iface.Env (NameCacheUpdater(..)) -import qualified Data.Array as A+import qualified Data.Array        as A+import qualified Data.Array.IO     as A+import qualified Data.Array.Unsafe as A import Data.IORef import Data.ByteString            ( ByteString ) import qualified Data.ByteString  as BS import qualified Data.ByteString.Char8 as BSC-import Data.List                  ( mapAccumR ) import Data.Word                  ( Word8, Word32 )-import Control.Monad              ( replicateM, when )+import Control.Monad              ( replicateM, when, forM_ ) import System.Directory           ( createDirectoryIfMissing ) import System.FilePath            ( takeDirectory ) @@ -153,23 +151,23 @@ -- an existing `NameCache`. Allows you to specify -- which versions of hieFile to attempt to read. -- `Left` case returns the failing header versions.-readHieFileWithVersion :: (HieHeader -> Bool) -> NameCacheUpdater -> FilePath -> IO (Either HieHeader HieFileResult)-readHieFileWithVersion readVersion ncu file = do+readHieFileWithVersion :: (HieHeader -> Bool) -> NameCache -> FilePath -> IO (Either HieHeader HieFileResult)+readHieFileWithVersion readVersion name_cache file = do   bh0 <- readBinMem file    (hieVersion, ghcVersion) <- readHieFileHeader file bh0    if readVersion (hieVersion, ghcVersion)   then do-    hieFile <- readHieFileContents bh0 ncu+    hieFile <- readHieFileContents bh0 name_cache     return $ Right (HieFileResult hieVersion ghcVersion hieFile)   else return $ Left (hieVersion, ghcVersion)   -- | Read a `HieFile` from a `FilePath`. Can use -- an existing `NameCache`.-readHieFile :: NameCacheUpdater -> FilePath -> IO HieFileResult-readHieFile ncu file = do+readHieFile :: NameCache -> FilePath -> IO HieFileResult+readHieFile name_cache file = do    bh0 <- readBinMem file @@ -183,7 +181,7 @@                     , show hieVersion                     , "but got", show readHieVersion                     ]-  hieFile <- readHieFileContents bh0 ncu+  hieFile <- readHieFileContents bh0 name_cache   return $ HieFileResult hieVersion ghcVersion hieFile  readBinLine :: BinHandle -> IO ByteString@@ -218,8 +216,8 @@                         ]       return (readHieVersion, ghcVersion) -readHieFileContents :: BinHandle -> NameCacheUpdater -> IO HieFile-readHieFileContents bh0 ncu = do+readHieFileContents :: BinHandle -> NameCache -> IO HieFile+readHieFileContents bh0 name_cache = do   dict <- get_dictionary bh0   -- read the symbol table so we are capable of reading the actual data   bh1 <- do@@ -246,7 +244,7 @@       symtab_p <- get bh1       data_p'  <- tellBin bh1       seekBin bh1 symtab_p-      symtab <- getSymbolTable bh1 ncu+      symtab <- getSymbolTable bh1 name_cache       seekBin bh1 data_p'       return symtab @@ -270,14 +268,15 @@   let names = A.elems (A.array (0,next_off-1) (nonDetEltsUFM symtab))   mapM_ (putHieName bh) names -getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable-getSymbolTable bh ncu = do+getSymbolTable :: BinHandle -> NameCache -> IO SymbolTable+getSymbolTable bh name_cache = do   sz <- get bh-  od_names <- replicateM sz (getHieName bh)-  updateNameCache ncu $ \nc ->-    let arr = A.listArray (0,sz-1) names-        (nc', names) = mapAccumR fromHieName nc od_names-        in (nc',arr)+  mut_arr <- A.newArray_ (0, sz-1) :: IO (A.IOArray Int Name)+  forM_ [0..(sz-1)] $ \i -> do+    od_name <- getHieName bh+    name <- fromHieName name_cache od_name+    A.writeArray mut_arr i name+  A.unsafeFreeze mut_arr  getSymTabName :: SymbolTable -> BinHandle -> IO Name getSymTabName st bh = do@@ -312,24 +311,28 @@  -- ** Converting to and from `HieName`'s -fromHieName :: NameCache -> HieName -> (NameCache, Name)-fromHieName nc (ExternalName mod occ span) =-    let cache = nsNames nc-    in case lookupOrigNameCache cache mod occ of-         Just name -> (nc, name)-         Nothing ->-           let (uniq, us) = takeUniqFromSupply (nsUniqs nc)-               name       = mkExternalName uniq mod occ span-               new_cache  = extendNameCache cache mod occ name-           in ( nc{ nsUniqs = us, nsNames = new_cache }, name )-fromHieName nc (LocalName occ span) =-    let (uniq, us) = takeUniqFromSupply (nsUniqs nc)-        name       = mkInternalName uniq occ span-    in ( nc{ nsUniqs = us }, name )-fromHieName nc (KnownKeyName u) = case lookupKnownKeyName u of-    Nothing -> pprPanic "fromHieName:unknown known-key unique"-                        (ppr (unpkUnique u))-    Just n -> (nc, n)+fromHieName :: NameCache -> HieName -> IO Name+fromHieName nc hie_name = do++  case hie_name of+    ExternalName mod occ span -> updateNameCache nc mod occ $ \cache -> do+      case lookupOrigNameCache cache mod occ of+        Just name -> pure (cache, name)+        Nothing   -> do+          uniq <- takeUniqFromNameCache nc+          let name       = mkExternalName uniq mod occ span+              new_cache  = extendOrigNameCache cache mod occ name+          pure (new_cache, name)++    LocalName occ span -> do+      uniq <- takeUniqFromNameCache nc+      -- don't update the NameCache for local names+      pure $ mkInternalName uniq occ span++    KnownKeyName u -> case lookupKnownKeyName u of+      Nothing -> pprPanic "fromHieName:unknown known-key unique"+                          (ppr (unpkUnique u))+      Just n -> pure n  -- ** Reading and writing `HieName`'s
compiler/GHC/Iface/Ext/Types.hs view
@@ -155,6 +155,7 @@  -- | Roughly isomorphic to the original core 'Type'. newtype HieTypeFix = Roll (HieType (HieTypeFix))+  deriving Eq  instance Binary (HieType TypeIndex) where   put_ bh (HTyVarTy n) = do@@ -305,7 +306,7 @@  instance Ord NodeAnnotation where    compare (NodeAnnotation c0 t0) (NodeAnnotation c1 t1)-      = mconcat [uniqCompareFS c0 c1, uniqCompareFS t0 t1]+      = mconcat [lexicalCompareFS c0 c1, lexicalCompareFS t0 t1]  instance Outputable NodeAnnotation where    ppr (NodeAnnotation c t) = ppr (c,t)@@ -780,5 +781,5 @@   | isKnownKeyName name = KnownKeyName (nameUnique name)   | isExternalName name = ExternalName (nameModule name)                                        (nameOccName name)-                                       (removeBufSpan $ nameSrcSpan name)-  | otherwise = LocalName (nameOccName name) (removeBufSpan $ nameSrcSpan name)+                                       (nameSrcSpan name)+  | otherwise = LocalName (nameOccName name) (nameSrcSpan name)
compiler/GHC/Iface/Ext/Utils.hs view
@@ -26,6 +26,7 @@ import GHC.Types.Var import GHC.Types.Var.Env import GHC.Parser.Annotation+import qualified GHC.Data.Strict as Strict  import GHC.Iface.Ext.Types @@ -39,7 +40,7 @@ import Data.List                  (find) import Data.Traversable           ( for ) import Data.Coerce-import Control.Monad.Trans.State.Strict hiding (get)+import GHC.Utils.Monad.State.Strict hiding (get) import Control.Monad.Trans.Reader import qualified Data.Tree as Tree @@ -186,7 +187,7 @@ freshTypeIndex :: State HieTypeState TypeIndex freshTypeIndex = do   index <- gets freshIndex-  modify' $ \hts -> hts { freshIndex = index+1 }+  modify $ \hts -> hts { freshIndex = index+1 }   return index  compressTypes@@ -216,7 +217,7 @@   where     extendHTS t ht = do       i <- freshTypeIndex-      modify' $ \(HTS tm tt fi) ->+      modify $ \(HTS tm tt fi) ->         HTS (extendTypeMap tm t i) (IM.insert i ht tt) fi       return i @@ -295,8 +296,9 @@   -> Maybe Span getNameBindingInClass n sp asts = do   ast <- M.lookup (HiePath (srcSpanFile sp)) asts+  clsNode <- selectLargestContainedBy sp ast   getFirst $ foldMap First $ do-    child <- flattenAst ast+    child <- flattenAst clsNode     dets <- maybeToList       $ M.lookup (Right n) $ sourcedNodeIdents $ sourcedNodeInfo child     let binding = foldMap (First . getBindSiteFromContext) (identInfo dets)@@ -546,7 +548,7 @@ combineScopes NoScope x = x combineScopes x NoScope = x combineScopes (LocalScope a) (LocalScope b) =-  mkScope $ combineSrcSpans (RealSrcSpan a Nothing) (RealSrcSpan b Nothing)+  mkScope $ combineSrcSpans (RealSrcSpan a Strict.Nothing) (RealSrcSpan b Strict.Nothing)  mkSourcedNodeInfo :: NodeOrigin -> NodeInfo a -> SourcedNodeInfo a mkSourcedNodeInfo org ni = SourcedNodeInfo $ M.singleton org ni
compiler/GHC/Iface/Load.hs view
@@ -4,12 +4,13 @@  -} -{-# LANGUAGE CPP, BangPatterns, RecordWildCards, NondecreasingIndentation #-}+{-# LANGUAGE BangPatterns, NondecreasingIndentation #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE FlexibleContexts #-}  {-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE ViewPatterns #-}  -- | Loading interface files module GHC.Iface.Load (@@ -20,36 +21,33 @@         -- RnM/TcM functions         loadModuleInterface, loadModuleInterfaces,         loadSrcInterface, loadSrcInterface_maybe,-        loadInterfaceForName, loadInterfaceForNameMaybe, loadInterfaceForModule,+        loadInterfaceForName, loadInterfaceForModule,          -- IfM functions         loadInterface,         loadSysInterface, loadUserInterface, loadPluginInterface,         findAndReadIface, readIface, writeIface,-        initExternalPackageState,         moduleFreeHolesPrecise,         needWiredInHomeIface, loadWiredInHomeIface,          pprModIfaceSimple,         ifaceStats, pprModIface, showIface, -        cannotFindModule+        module Iface_Errors -- avoids boot files in Ppr modules    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude-import GHC.Platform.Ways+ import GHC.Platform.Profile  import {-# SOURCE #-} GHC.IfaceToCore    ( tcIfaceDecls, tcIfaceRules, tcIfaceInst, tcIfaceFamInst    , tcIfaceAnnotations, tcIfaceCompleteMatches ) +import GHC.Driver.Config.Finder import GHC.Driver.Env+import GHC.Driver.Errors.Types import GHC.Driver.Session-import GHC.Driver.Backend-import GHC.Driver.Ppr import GHC.Driver.Hooks import GHC.Driver.Plugins @@ -57,15 +55,20 @@ import GHC.Iface.Ext.Fields import GHC.Iface.Binary import GHC.Iface.Rename+import GHC.Iface.Env+import GHC.Iface.Errors as Iface_Errors +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad  import GHC.Utils.Binary   ( BinData(..) ) import GHC.Utils.Error import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic-import GHC.Utils.Misc+import GHC.Utils.Panic.Plain+import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Logger+import GHC.Utils.Trace  import GHC.Settings.Constants @@ -81,6 +84,7 @@ import GHC.Types.Id.Make      ( seqId ) import GHC.Types.Annotations import GHC.Types.Name+import GHC.Types.Name.Cache import GHC.Types.Name.Env import GHC.Types.Avail import GHC.Types.Fixity@@ -90,10 +94,10 @@ import GHC.Types.SourceFile import GHC.Types.SafeHaskell import GHC.Types.TypeEnv-import GHC.Types.Unique.FM import GHC.Types.Unique.DSet import GHC.Types.SrcLoc import GHC.Types.TyThing+import GHC.Types.PkgQual  import GHC.Unit.External import GHC.Unit.Module@@ -107,13 +111,12 @@ import GHC.Unit.Env  import GHC.Data.Maybe-import GHC.Data.FastString  import Control.Monad-import Control.Exception import Data.Map ( toList ) import System.FilePath import System.Directory+import GHC.Driver.Env.KnotVars  {- ************************************************************************@@ -165,11 +168,12 @@ -- Get the TyThing for this Name from an interface file -- It's not a wired-in thing -- the caller caught that importDecl name-  = ASSERT( not (isWiredInName name) )-    do  { traceIf nd_doc+  = assert (not (isWiredInName name)) $+    do  { logger <- getLogger+        ; liftIO $ trace_if logger nd_doc          -- Load the interface, which should populate the PTE-        ; mb_iface <- ASSERT2( isExternalName name, ppr name )+        ; mb_iface <- assertPpr (isExternalName name) (ppr name) $                       loadInterface nd_doc (nameModule name) ImportBySystem         ; case mb_iface of {                 Failed err_msg  -> return (Failed err_msg) ;@@ -191,7 +195,7 @@                                 text "Use -ddump-if-trace to get an idea of which file caused the error"])     found_things_msg eps =         hang (text "Found the following declarations in" <+> ppr (nameModule name) <> colon)-           2 (vcat (map ppr $ filter is_interesting $ nameEnvElts $ eps_PTE eps))+           2 (vcat (map ppr $ filter is_interesting $ nonDetNameEnvElts $ eps_PTE eps))       where         is_interesting thing = nameModule name == nameModule (getName thing) @@ -240,8 +244,9 @@   = return ()   | otherwise   = do  { mod <- getModule-        ; traceIf (text "checkWiredInTyCon" <+> ppr tc_name $$ ppr mod)-        ; ASSERT( isExternalName tc_name )+        ; logger <- getLogger+        ; liftIO $ trace_if logger (text "checkWiredInTyCon" <+> ppr tc_name $$ ppr mod)+        ; assert (isExternalName tc_name )           when (mod /= nameModule tc_name)                (initIfaceTcRn (loadWiredInHomeIface tc_name))                 -- Don't look for (non-existent) Float.hi when@@ -264,7 +269,7 @@                 -- the HPT, so without the test we'll demand-load it into the PIT!                 -- C.f. the same test in checkWiredInTyCon above         ; let name = getName thing-        ; ASSERT2( isExternalName name, ppr name )+        ; assertPpr (isExternalName name) (ppr name) $           when (needWiredInHomeIface thing && mod /= nameModule name)                (loadWiredInHomeIface name) } @@ -289,20 +294,20 @@ loadSrcInterface :: SDoc                  -> ModuleName                  -> IsBootInterface     -- {-# SOURCE #-} ?-                 -> Maybe FastString    -- "package", if any+                 -> PkgQual             -- "package", if any                  -> RnM ModIface  loadSrcInterface doc mod want_boot maybe_pkg   = do { res <- loadSrcInterface_maybe doc mod want_boot maybe_pkg        ; case res of-           Failed err      -> failWithTc err+           Failed err      -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints err)            Succeeded iface -> return iface }  -- | Like 'loadSrcInterface', but returns a 'MaybeErr'. loadSrcInterface_maybe :: SDoc                        -> ModuleName                        -> IsBootInterface     -- {-# SOURCE #-} ?-                       -> Maybe FastString    -- "package", if any+                       -> PkgQual             -- "package", if any                        -> RnM (MaybeErr SDoc ModIface)  loadSrcInterface_maybe doc mod want_boot maybe_pkg@@ -311,12 +316,12 @@   -- and create a ModLocation.  If successful, loadIface will read the   -- interface; it will call the Finder again, but the ModLocation will be   -- cached from the first search.-  = do { hsc_env <- getTopEnv-       ; res <- liftIO $ findImportedModule hsc_env mod maybe_pkg-       ; case res of+  = do hsc_env <- getTopEnv+       res <- liftIO $ findImportedModule hsc_env mod maybe_pkg+       case res of            Found _ mod -> initIfaceTcRn $ loadInterface doc mod (ImportByUser want_boot)            -- TODO: Make sure this error message is good-           err         -> return (Failed (cannotFindModule hsc_env mod err)) }+           err         -> return (Failed (cannotFindModule hsc_env mod err))  -- | Load interface directly for a fully qualified 'Module'.  (This is a fairly -- rare operation, but in particular it is used to load orphan modules@@ -340,19 +345,10 @@ loadInterfaceForName doc name   = do { when debugIsOn $  -- Check pre-condition          do { this_mod <- getModule-            ; MASSERT2( not (nameIsLocalOrFrom this_mod name), ppr name <+> parens doc ) }-      ; ASSERT2( isExternalName name, ppr name )+            ; massertPpr (not (nameIsLocalOrFrom this_mod name)) (ppr name <+> parens doc) }+      ; assertPpr (isExternalName name) (ppr name) $         initIfaceTcRn $ loadSysInterface doc (nameModule name) } --- | Only loads the interface for external non-local names.-loadInterfaceForNameMaybe :: SDoc -> Name -> TcRn (Maybe ModIface)-loadInterfaceForNameMaybe doc name-  = do { this_mod <- getModule-       ; if nameIsLocalOrFrom this_mod name || not (isExternalName name)-         then return Nothing-         else Just <$> (initIfaceTcRn $ loadSysInterface doc (nameModule name))-       }- -- | Loads the interface for a given Module. loadInterfaceForModule :: SDoc -> Module -> TcRn ModIface loadInterfaceForModule doc m@@ -360,7 +356,7 @@     -- Should not be called with this module     when debugIsOn $ do       this_mod <- getModule-      MASSERT2( this_mod /= m, ppr m <+> parens doc )+      massertPpr (this_mod /= m) (ppr m <+> parens doc)     initIfaceTcRn $ loadSysInterface doc m  {-@@ -380,7 +376,7 @@ -- See Note [Loading instances for wired-in things] loadWiredInHomeIface :: Name -> IfM lcl () loadWiredInHomeIface name-  = ASSERT( isWiredInName name )+  = assert (isWiredInName name) $     do _ <- loadSysInterface doc (nameModule name); return ()   where     doc = text "Need home interface for wired-in thing" <+> ppr name@@ -405,7 +401,10 @@ -- | A wrapper for 'loadInterface' that throws an exception if it fails loadInterfaceWithException :: SDoc -> Module -> WhereFrom -> IfM lcl ModIface loadInterfaceWithException doc mod_name where_from-  = withException (loadInterface doc mod_name where_from)+  = do+    dflags <- getDynFlags+    let ctx = initSDocContext dflags defaultUserStyle+    withException ctx (loadInterface doc mod_name where_from)  ------------------ loadInterface :: SDoc -> Module -> WhereFrom@@ -433,18 +432,17 @@   | otherwise   = do     logger <- getLogger-    dflags <- getDynFlags-    withTimingSilent logger dflags (text "loading interface") (pure ()) $ do+    withTimingSilent logger (text "loading interface") (pure ()) $ do         {       -- Read the state-          (eps,hpt) <- getEpsAndHpt+          (eps,hug) <- getEpsAndHug         ; gbl_env <- getGblEnv -        ; traceIf (text "Considering whether to load" <+> ppr mod <+> ppr from)+        ; liftIO $ trace_if logger (text "Considering whether to load" <+> ppr mod <+> ppr from)                  -- Check whether we have the interface already         ; hsc_env <- getTopEnv-        ; let home_unit = hsc_home_unit hsc_env-        ; case lookupIfaceByModule hpt (eps_PIT eps) mod of {+        ; let mhome_unit = ue_homeUnit (hsc_unit_env hsc_env)+        ; case lookupIfaceByModule hug (eps_PIT eps) mod of {             Just iface                 -> return (Succeeded iface) ;   -- Already loaded                         -- The (src_imp == mi_boot iface) test checks that the already-loaded@@ -453,9 +451,11 @@             _ -> do {          -- READ THE MODULE IN-        ; read_result <- case (wantHiBootFile home_unit eps mod from) of+        ; read_result <- case wantHiBootFile mhome_unit eps mod from of                            Failed err             -> return (Failed err)-                           Succeeded hi_boot_file -> computeInterface doc_str hi_boot_file mod+                           Succeeded hi_boot_file -> do+                             hsc_env <- getTopEnv+                             liftIO $ computeInterface hsc_env doc_str hi_boot_file mod         ; case read_result of {             Failed err -> do                 { let fake_iface = emptyFullModIface mod@@ -482,7 +482,7 @@         in         initIfaceLcl (mi_semantic_module iface) loc_doc (mi_boot iface) $ -        dontLeakTheHPT $ do+        dontLeakTheHUG $ do          --      Load the new ModIface into the External Package State         -- Even home-package interfaces loaded by loadInterface@@ -500,6 +500,14 @@         --     If we do loadExport first the wrong info gets into the cache (unless we         --      explicitly tag each export which seems a bit of a bore) +        -- Crucial assertion that checks if you are trying to load a HPT module into the EPS.+        -- If you start loading HPT modules into the EPS then you get strange errors about+        -- overlapping instances.+        ; massertPpr+              ((isOneShot (ghcMode (hsc_dflags hsc_env)))+                || moduleUnitId mod `notElem` hsc_all_home_unit_ids hsc_env+                || mod == gHC_PRIM)+                (text "Attempting to load home package interface into the EPS" $$ ppr hug $$ doc_str $$ ppr mod $$ ppr (moduleUnitId mod))         ; ignore_prags      <- goptM Opt_IgnoreInterfacePragmas         ; new_eps_decls     <- tcIfaceDecls ignore_prags (mi_decls iface)         ; new_eps_insts     <- mapM tcIfaceInst (mi_insts iface)@@ -517,14 +525,15 @@                               }                } -        ; let bad_boot = mi_boot iface == IsBoot && fmap fst (if_rec_types gbl_env) == Just mod+        ; let bad_boot = mi_boot iface == IsBoot+                          && isJust (lookupKnotVars (if_rec_types gbl_env) mod)                             -- Warn against an EPS-updating import                             -- of one's own boot file! (one-shot only)                             -- See Note [Loading your own hi-boot file] -        ; WARN( bad_boot, ppr mod )+        ; warnPprTrace bad_boot "loadInterface" (ppr mod) $           updateEps_  $ \ eps ->-           if elemModuleEnv mod (eps_PIT eps) || is_external_sig home_unit iface+           if elemModuleEnv mod (eps_PIT eps) || is_external_sig mhome_unit iface                 then eps            else if bad_boot                 -- See Note [Loading your own hi-boot file]@@ -559,7 +568,7 @@          ; -- invoke plugins with *full* interface, not final_iface, to ensure           -- that plugins have access to declarations, etc.-          res <- withPlugins hsc_env (\p -> interfaceLoadAction p) iface+          res <- withPlugins (hsc_plugins hsc_env) (\p -> interfaceLoadAction p) iface         ; return (Succeeded res)     }}}} @@ -613,54 +622,64 @@ home-package modules however, so it's safe for the HPT to be empty. -} -dontLeakTheHPT :: IfL a -> IfL a-dontLeakTheHPT thing_inside = do-  dflags <- getDynFlags+-- Note [GHC Heap Invariants]+dontLeakTheHUG :: IfL a -> IfL a+dontLeakTheHUG thing_inside = do+  env <- getTopEnv   let-    cleanTopEnv HscEnv{..} =+    inOneShot =+      isOneShot (ghcMode (hsc_dflags env))+    cleanGblEnv gbl_env+      | inOneShot = gbl_env+      | otherwise = gbl_env { if_rec_types = emptyKnotVars }+    cleanTopEnv hsc_env =+        let+         !maybe_type_vars | inOneShot = Just (hsc_type_env_vars env)+                          | otherwise = Nothing          -- wrinkle: when we're typechecking in --backpack mode, the          -- instantiation of a signature might reside in the HPT, so          -- this case breaks the assumption that EPS interfaces only-         -- refer to other EPS interfaces. We can detect when we're in-         -- typechecking-only mode by using backend==NoBackend, and-         -- in that case we don't empty the HPT.  (admittedly this is-         -- a bit of a hack, better suggestions welcome). A number of-         -- tests in testsuite/tests/backpack break without this+         -- refer to other EPS interfaces.+         -- As a temporary (MP Oct 2021 #20509) we only keep the HPT if it+         -- contains any hole modules.+         -- Quite a few tests in testsuite/tests/backpack break without this          -- tweak.+         old_unit_env = hsc_unit_env hsc_env          keepFor20509 hmi           | isHoleModule (mi_semantic_module (hm_iface hmi)) = True           | otherwise = False-         !hpt | backend hsc_dflags == NoBackend = if anyHpt keepFor20509 hsc_HPT then hsc_HPT-                                                                     else emptyHomePackageTable-              | otherwise = emptyHomePackageTable+         pruneHomeUnitEnv hme = hme { homeUnitEnv_hpt = emptyHomePackageTable }+         !unit_env+          = old_unit_env+             { ue_home_unit_graph = if anyHpt keepFor20509 (ue_hpt old_unit_env) then ue_home_unit_graph old_unit_env+                                                                                 else unitEnv_map pruneHomeUnitEnv (ue_home_unit_graph old_unit_env)+             }        in-       HscEnv {  hsc_targets      = panic "cleanTopEnv: hsc_targets"-              ,  hsc_mod_graph    = panic "cleanTopEnv: hsc_mod_graph"-              ,  hsc_IC           = panic "cleanTopEnv: hsc_IC"-              ,  hsc_HPT          = hpt-              , .. }--    cleanGblEnv gbl-      | ghcMode dflags == OneShot = gbl-      | otherwise = gbl { if_rec_types = Nothing }+       hsc_env {  hsc_targets      = panic "cleanTopEnv: hsc_targets"+               ,  hsc_mod_graph    = panic "cleanTopEnv: hsc_mod_graph"+               ,  hsc_IC           = panic "cleanTopEnv: hsc_IC"+               ,  hsc_type_env_vars = case maybe_type_vars of+                                          Just vars -> vars+                                          Nothing -> panic "cleanTopEnv: hsc_type_env_vars"+               ,  hsc_unit_env     = unit_env+               } -  updGblEnv cleanGblEnv $-    updTopEnv cleanTopEnv $ do-      !_ <- getTopEnv        -- force the updTopEnv-      !_ <- getGblEnv-      thing_inside+  updTopEnv cleanTopEnv $ updGblEnv cleanGblEnv $ do+  !_ <- getTopEnv        -- force the updTopEnv+  !_ <- getGblEnv+  thing_inside   -- | Returns @True@ if a 'ModIface' comes from an external package. -- In this case, we should NOT load it into the EPS; the entities -- should instead come from the local merged signature interface.-is_external_sig :: HomeUnit -> ModIface -> Bool-is_external_sig home_unit iface =+is_external_sig :: Maybe HomeUnit -> ModIface -> Bool+is_external_sig mhome_unit iface =     -- It's a signature iface...     mi_semantic_module iface /= mi_module iface &&     -- and it's not from the local package-    not (isHomeModule home_unit (mi_module iface))+    notHomeModuleMaybe mhome_unit (mi_module iface)  -- | This is an improved version of 'findAndReadIface' which can also -- handle the case when a user requests @p[A=<B>]:M@ but we only@@ -676,28 +695,28 @@ -- apply to the requirement itself; e.g., @p[A=<A>]:A@ does not require -- A.hi to be up-to-date (and indeed, we MUST NOT attempt to read A.hi, unless -- we are actually typechecking p.)-computeInterface ::-       SDoc -> IsBootInterface -> Module-    -> TcRnIf gbl lcl (MaybeErr SDoc (ModIface, FilePath))-computeInterface doc_str hi_boot_file mod0 = do-    MASSERT( not (isHoleModule mod0) )-    hsc_env <- getTopEnv-    let home_unit = hsc_home_unit hsc_env-    case getModuleInstantiation mod0 of-        (imod, Just indef) | isHomeUnitIndefinite home_unit -> do-            r <- findAndReadIface doc_str imod mod0 hi_boot_file-            case r of-                Succeeded (iface0, path) -> do-                    hsc_env <- getTopEnv-                    r <- liftIO $-                        rnModIface hsc_env (instUnitInsts (moduleUnit indef))-                                   Nothing iface0-                    case r of-                        Right x -> return (Succeeded (x, path))-                        Left errs -> liftIO . throwIO . mkSrcErr $ errs-                Failed err -> return (Failed err)-        (mod, _) ->-            findAndReadIface doc_str mod mod0 hi_boot_file+computeInterface+  :: HscEnv+  -> SDoc+  -> IsBootInterface+  -> Module+  -> IO (MaybeErr SDoc (ModIface, FilePath))+computeInterface hsc_env doc_str hi_boot_file mod0 = do+  massert (not (isHoleModule mod0))+  let mhome_unit  = hsc_home_unit_maybe hsc_env+  let find_iface m = findAndReadIface hsc_env doc_str+                                      m mod0 hi_boot_file+  case getModuleInstantiation mod0 of+      (imod, Just indef)+        | Just home_unit <- mhome_unit+        , isHomeUnitIndefinite home_unit ->+          find_iface imod >>= \case+            Succeeded (iface0, path) ->+              rnModIface hsc_env (instUnitInsts (moduleUnit indef)) Nothing iface0 >>= \case+                Right x   -> return (Succeeded (x, path))+                Left errs -> throwErrors (GhcTcRnMessage <$> errs)+            Failed err -> return (Failed err)+      (mod, _) -> find_iface mod  -- | Compute the signatures which must be compiled in order to -- load the interface for a 'Module'.  The output of this function@@ -716,10 +735,11 @@  | otherwise =    case getModuleInstantiation mod of     (imod, Just indef) -> do+        logger <- getLogger         let insts = instUnitInsts (moduleUnit indef)-        traceIf (text "Considering whether to load" <+> ppr mod <+>+        liftIO $ trace_if logger (text "Considering whether to load" <+> ppr mod <+>                  text "to compute precise free module holes")-        (eps, hpt) <- getEpsAndHpt+        (eps, hpt) <- getEpsAndHug         case tryEpsAndHpt eps hpt `firstJust` tryDepsCache eps imod insts of             Just r -> return (Succeeded r)             Nothing -> readAndCache imod insts@@ -732,7 +752,10 @@             Just ifhs  -> Just (renameFreeHoles ifhs insts)             _otherwise -> Nothing     readAndCache imod insts = do-        mb_iface <- findAndReadIface (text "moduleFreeHolesPrecise" <+> doc_str) imod mod NotBoot+        hsc_env <- getTopEnv+        mb_iface <- liftIO $ findAndReadIface hsc_env+                                              (text "moduleFreeHolesPrecise" <+> doc_str)+                                              imod mod NotBoot         case mb_iface of             Succeeded (iface, _) -> do                 let ifhs = mi_free_holes iface@@ -742,13 +765,13 @@                 return (Succeeded (renameFreeHoles ifhs insts))             Failed err -> return (Failed err) -wantHiBootFile :: HomeUnit -> ExternalPackageState -> Module -> WhereFrom+wantHiBootFile :: Maybe HomeUnit -> ExternalPackageState -> Module -> WhereFrom                -> MaybeErr SDoc IsBootInterface -- Figure out whether we want Foo.hi or Foo.hi-boot-wantHiBootFile home_unit eps mod from+wantHiBootFile mhome_unit eps mod from   = case from of        ImportByUser usr_boot-          | usr_boot == IsBoot && notHomeModule home_unit mod+          | usr_boot == IsBoot && notHomeModuleMaybe mhome_unit mod           -> Failed (badSourceImport mod)           | otherwise -> Succeeded usr_boot @@ -756,7 +779,7 @@           -> Succeeded NotBoot         ImportBySystem-          | notHomeModule home_unit mod+          | notHomeModuleMaybe mhome_unit mod           -> Succeeded NotBoot              -- If the module to be imported is not from this package              -- don't look it up in eps_is_boot, because that is keyed@@ -764,7 +787,7 @@              -- We never import boot modules from other packages!            | otherwise-          -> case lookupUFM (eps_is_boot eps) (moduleName mod) of+          -> case lookupInstalledModuleEnv (eps_is_boot eps) (toUnitId <$> mod) of                 Just (GWIB { gwib_isBoot = is_boot }) ->                   Succeeded is_boot                 Nothing ->@@ -775,7 +798,7 @@ badSourceImport :: Module -> SDoc badSourceImport mod   = hang (text "You cannot {-# SOURCE #-} import a module from another package")-       2 (text "but" <+> quotes (ppr mod) <+> ptext (sLit "is from package")+       2 (text "but" <+> quotes (ppr mod) <+> text "is from package"           <+> quotes (ppr (moduleUnit mod)))  -----------------------------------------------------@@ -821,24 +844,29 @@ See #8320. -} -findAndReadIface :: SDoc-                 -- The unique identifier of the on-disk module we're-                 -- looking for-                 -> InstalledModule-                 -- The *actual* module we're looking for.  We use-                 -- this to check the consistency of the requirements-                 -- of the module we read out.-                 -> Module-                 -> IsBootInterface     -- True  <=> Look for a .hi-boot file-                                        -- False <=> Look for .hi file-                 -> TcRnIf gbl lcl (MaybeErr SDoc (ModIface, FilePath))-        -- Nothing <=> file not found, or unreadable, or illegible-        -- Just x  <=> successfully found and parsed+findAndReadIface+  :: HscEnv+  -> SDoc            -- ^ Reason for loading the iface (used for tracing)+  -> InstalledModule -- ^ The unique identifier of the on-disk module we're looking for+  -> Module          -- ^ The *actual* module we're looking for.  We use+                     -- this to check the consistency of the requirements of the+                     -- module we read out.+  -> IsBootInterface -- ^ Looking for .hi-boot or .hi file+  -> IO (MaybeErr SDoc (ModIface, FilePath))+findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do -        -- It *doesn't* add an error to the monad, because-        -- sometimes it's ok to fail... see notes with loadInterface-findAndReadIface doc_str mod wanted_mod_with_insts hi_boot_file-  = do traceIf (sep [hsep [text "Reading",+  let profile = targetProfile dflags+      unit_state = hsc_units hsc_env+      fc         = hsc_FC hsc_env+      name_cache = hsc_NC hsc_env+      mhome_unit  = hsc_home_unit_maybe hsc_env+      dflags     = hsc_dflags hsc_env+      logger     = hsc_logger hsc_env+      hooks      = hsc_hooks hsc_env+      other_fopts = initFinderOpts . homeUnitEnv_dflags <$> (hsc_HUG hsc_env)+++  trace_if logger (sep [hsep [text "Reading",                            if hi_boot_file == IsBoot                              then text "[boot]"                              else Outputable.empty,@@ -846,151 +874,131 @@                            ppr mod <> semi],                      nest 4 (text "reason:" <+> doc_str)]) -       -- Check for GHC.Prim, and return its static interface-       -- See Note [GHC.Prim] in primops.txt.pp.-       -- TODO: make this check a function-       if mod `installedModuleEq` gHC_PRIM-           then do-               hooks <- getHooks-               let iface = case ghcPrimIfaceHook hooks of-                            Nothing -> ghcPrimIface-                            Just h  -> h-               return (Succeeded (iface, "<built in interface for GHC.Prim>"))-           else do-               dflags <- getDynFlags-               -- Look for the file-               hsc_env <- getTopEnv-               mb_found <- liftIO (findExactModule hsc_env mod)-               let home_unit  = hsc_home_unit hsc_env-               case mb_found of-                   InstalledFound loc mod -> do-                       -- Found file, so read it-                       let file_path = addBootSuffix_maybe hi_boot_file-                                                           (ml_hi_file loc)+  -- Check for GHC.Prim, and return its static interface+  -- See Note [GHC.Prim] in primops.txt.pp.+  -- TODO: make this check a function+  if mod `installedModuleEq` gHC_PRIM+      then do+          let iface = case ghcPrimIfaceHook hooks of+                       Nothing -> ghcPrimIface+                       Just h  -> h+          return (Succeeded (iface, "<built in interface for GHC.Prim>"))+      else do+          let fopts = initFinderOpts dflags+          -- Look for the file+          mb_found <- liftIO (findExactModule fc fopts other_fopts unit_state mhome_unit mod)+          case mb_found of+              InstalledFound (addBootSuffixLocn_maybe hi_boot_file -> loc) mod -> do+                  -- See Note [Home module load error]+                  case mhome_unit of+                    Just home_unit+                      | isHomeInstalledModule home_unit mod+                      , not (isOneShot (ghcMode dflags))+                      -> return (Failed (homeModError mod loc))+                    _ -> do+                        r <- read_file logger name_cache unit_state dflags wanted_mod (ml_hi_file loc)+                        case r of+                          Failed _+                            -> return r+                          Succeeded (iface,_fp)+                            -> do+                                r2 <- load_dynamic_too_maybe logger name_cache unit_state+                                                         (setDynamicNow dflags) wanted_mod+                                                         iface loc+                                case r2 of+                                  Failed sdoc -> return (Failed sdoc)+                                  Succeeded {} -> return r+              err -> do+                  trace_if logger (text "...not found")+                  return $ Failed $ cannotFindInterface+                                      unit_state+                                      mhome_unit+                                      profile+                                      (Iface_Errors.mayShowLocations dflags)+                                      (moduleName mod)+                                      err -                       -- See Note [Home module load error]-                       if isHomeInstalledModule home_unit mod &&-                          not (isOneShot (ghcMode dflags))-                           then return (Failed (homeModError mod loc))-                           else do r <- read_file file_path-                                   checkBuildDynamicToo r-                                   return r-                   err -> do-                       traceIf (text "...not found")-                       hsc_env <- getTopEnv-                       let profile = Profile (targetPlatform dflags) (ways dflags)-                       return $ Failed $ cannotFindInterface-                                           (hsc_unit_env hsc_env)-                                           profile-                                           (may_show_locations (hsc_dflags hsc_env))-                                           (moduleName mod)-                                           err-    where read_file file_path = do-              traceIf (text "readIFace" <+> text file_path)-              -- Figure out what is recorded in mi_module.  If this is-              -- a fully definite interface, it'll match exactly, but-              -- if it's indefinite, the inside will be uninstantiated!-              unit_state <- hsc_units <$> getTopEnv-              let wanted_mod =-                    case getModuleInstantiation wanted_mod_with_insts of-                        (_, Nothing) -> wanted_mod_with_insts-                        (_, Just indef_mod) ->-                          instModuleToModule unit_state-                            (uninstantiateInstantiatedModule indef_mod)-              read_result <- readIface wanted_mod file_path-              case read_result of-                Failed err -> return (Failed (badIfaceFile file_path err))-                Succeeded iface -> return (Succeeded (iface, file_path))-                            -- Don't forget to fill in the package name...+-- | Check if we need to try the dynamic interface for -dynamic-too+load_dynamic_too_maybe :: Logger -> NameCache -> UnitState -> DynFlags -> Module -> ModIface -> ModLocation -> IO (MaybeErr SDoc ())+load_dynamic_too_maybe logger name_cache unit_state dflags wanted_mod iface loc+  -- Indefinite interfaces are ALWAYS non-dynamic.+  | not (moduleIsDefinite (mi_module iface)) = return (Succeeded ())+  | gopt Opt_BuildDynamicToo dflags = load_dynamic_too logger name_cache unit_state dflags wanted_mod iface loc+  | otherwise = return (Succeeded ()) -          -- Indefinite interfaces are ALWAYS non-dynamic.-          checkBuildDynamicToo (Succeeded (iface, _filePath))-            | not (moduleIsDefinite (mi_module iface)) = return ()+load_dynamic_too :: Logger -> NameCache -> UnitState -> DynFlags -> Module -> ModIface -> ModLocation -> IO (MaybeErr SDoc ())+load_dynamic_too logger name_cache unit_state dflags wanted_mod iface loc = do+  read_file logger name_cache unit_state dflags wanted_mod (ml_dyn_hi_file loc) >>= \case+    Succeeded (dynIface, _)+     | mi_mod_hash (mi_final_exts iface) == mi_mod_hash (mi_final_exts dynIface)+     -> return (Succeeded ())+     | otherwise ->+        do return $ (Failed $ dynamicHashMismatchError wanted_mod loc)+    Failed err ->+        do return $ (Failed $ ((text "Failed to load dynamic interface file for" <+> ppr wanted_mod <> colon) $$ err)) -          checkBuildDynamicToo (Succeeded (iface, filePath)) = do-              let load_dynamic = do-                     dflags <- getDynFlags-                     let dynFilePath = addBootSuffix_maybe hi_boot_file-                                     $ replaceExtension filePath (hiSuf dflags)-                     r <- read_file dynFilePath-                     case r of-                         Succeeded (dynIface, _)-                          | mi_mod_hash (mi_final_exts iface) == mi_mod_hash (mi_final_exts dynIface) ->-                             return ()-                          | otherwise ->-                             do traceIf (text "Dynamic hash doesn't match")-                                setDynamicTooFailed dflags-                         Failed err ->-                             do traceIf (text "Failed to load dynamic interface file:" $$ err)-                                setDynamicTooFailed dflags -              dflags <- getDynFlags-              dynamicTooState dflags >>= \case-                DT_Dont   -> return ()-                DT_Failed -> return ()-                DT_Dyn    -> load_dynamic-                DT_OK     -> withDynamicNow load_dynamic+dynamicHashMismatchError :: Module -> ModLocation -> SDoc+dynamicHashMismatchError wanted_mod loc  =+  vcat [ text "Dynamic hash doesn't match for" <+> quotes (ppr wanted_mod)+       , text "Normal interface file from"  <+> text (ml_hi_file loc)+       , text "Dynamic interface file from" <+> text (ml_dyn_hi_file loc)+       , text "You probably need to recompile" <+> quotes (ppr wanted_mod) ] -          checkBuildDynamicToo _ = return () --- | Write interface file-writeIface :: Logger -> DynFlags -> FilePath -> ModIface -> IO ()-writeIface logger dflags hi_file_path new_iface-    = do createDirectoryIfMissing True (takeDirectory hi_file_path)-         let printer = TraceBinIFace (debugTraceMsg logger dflags 3)-             profile = targetProfile dflags-         writeBinIface profile printer hi_file_path new_iface+read_file :: Logger -> NameCache -> UnitState -> DynFlags -> Module -> FilePath -> IO (MaybeErr SDoc (ModIface, FilePath))+read_file logger name_cache unit_state dflags wanted_mod file_path = do+  trace_if logger (text "readIFace" <+> text file_path) --- @readIface@ tries just the one file.-readIface :: Module -> FilePath-          -> TcRnIf gbl lcl (MaybeErr SDoc ModIface)-        -- Failed err    <=> file not found, or unreadable, or illegible-        -- Succeeded iface <=> successfully found and parsed+  -- Figure out what is recorded in mi_module.  If this is+  -- a fully definite interface, it'll match exactly, but+  -- if it's indefinite, the inside will be uninstantiated!+  let wanted_mod' =+        case getModuleInstantiation wanted_mod of+            (_, Nothing) -> wanted_mod+            (_, Just indef_mod) ->+              instModuleToModule unit_state+                (uninstantiateInstantiatedModule indef_mod)+  read_result <- readIface dflags name_cache wanted_mod' file_path+  case read_result of+    Failed err -> return (Failed (badIfaceFile file_path err))+    Succeeded iface -> return (Succeeded (iface, file_path))+                -- Don't forget to fill in the package name... -readIface wanted_mod file_path-  = do  { res <- tryMostM $-                 readBinIface CheckHiWay QuietBinIFace file_path-        ; case res of-            Right iface-                -- NB: This check is NOT just a sanity check, it is-                -- critical for correctness of recompilation checking-                -- (it lets us tell when -this-unit-id has changed.)-                | wanted_mod == actual_mod-                                -> return (Succeeded iface)-                | otherwise     -> return (Failed err)-                where-                  actual_mod = mi_module iface-                  err = hiModuleNameMismatchWarn wanted_mod actual_mod -            Left exn    -> return (Failed (text (showException exn)))-    }+-- | Write interface file+writeIface :: Logger -> Profile -> FilePath -> ModIface -> IO ()+writeIface logger profile hi_file_path new_iface+    = do createDirectoryIfMissing True (takeDirectory hi_file_path)+         let printer = TraceBinIFace (debugTraceMsg logger 3)+         writeBinIface profile printer hi_file_path new_iface -{--*********************************************************-*                                                       *-        Wired-in interface for GHC.Prim-*                                                       *-*********************************************************--}+-- | @readIface@ tries just the one file.+--+-- Failed err    <=> file not found, or unreadable, or illegible+-- Succeeded iface <=> successfully found and parsed+readIface+  :: DynFlags+  -> NameCache+  -> Module+  -> FilePath+  -> IO (MaybeErr SDoc ModIface)+readIface dflags name_cache wanted_mod file_path = do+  let profile = targetProfile dflags+  res <- tryMost $ readBinIface profile name_cache CheckHiWay QuietBinIFace file_path+  case res of+    Right iface+        -- NB: This check is NOT just a sanity check, it is+        -- critical for correctness of recompilation checking+        -- (it lets us tell when -this-unit-id has changed.)+        | wanted_mod == actual_mod+                        -> return (Succeeded iface)+        | otherwise     -> return (Failed err)+        where+          actual_mod = mi_module iface+          err = hiModuleNameMismatchWarn wanted_mod actual_mod -initExternalPackageState :: ExternalPackageState-initExternalPackageState-  = EPS {-      eps_is_boot          = emptyUFM,-      eps_PIT              = emptyPackageIfaceTable,-      eps_free_holes       = emptyInstalledModuleEnv,-      eps_PTE              = emptyTypeEnv,-      eps_inst_env         = emptyInstEnv,-      eps_fam_inst_env     = emptyFamInstEnv,-      eps_rule_base        = mkRuleBase builtinRules,-        -- Initialise the EPS rule pool with the built-in rules-      eps_mod_fam_inst_env = emptyModuleEnv,-      eps_complete_matches = [],-      eps_ann_env          = emptyAnnEnv,-      eps_stats = EpsStats { n_ifaces_in = 0, n_decls_in = 0, n_decls_out = 0-                           , n_insts_in = 0, n_insts_out = 0-                           , n_rules_in = length builtinRules, n_rules_out = 0 }-    }+    Left exn    -> return (Failed (text (showException exn)))  {- *********************************************************@@ -1008,7 +1016,7 @@         mi_decls    = [],         mi_fixities = fixities,         mi_final_exts = (mi_final_exts empty_iface){ mi_fix_fn = mkIfaceFixCache fixities },-        mi_decl_docs = ghcPrimDeclDocs -- See Note [GHC.Prim Docs]+        mi_docs = Just ghcPrimDeclDocs -- See Note [GHC.Prim Docs]         }   where     empty_iface = emptyFullModIface gHC_PRIM@@ -1060,17 +1068,14 @@ -}  -- | Read binary interface, and print it out-showIface :: HscEnv -> FilePath -> IO ()-showIface hsc_env filename = do-   let dflags  = hsc_dflags hsc_env-   let logger  = hsc_logger hsc_env-       unit_state = hsc_units hsc_env-       printer = putLogMsg logger dflags NoReason SevOutput noSrcSpan . withPprStyle defaultDumpStyle+showIface :: Logger -> DynFlags -> UnitState -> NameCache -> FilePath -> IO ()+showIface logger dflags unit_state name_cache filename = do+   let profile = targetProfile dflags+       printer = logMsg logger MCOutput noSrcSpan . withPprStyle defaultDumpStyle     -- skip the hi way check; we don't want to worry about profiled vs.    -- non-profiled interfaces, for example.-   iface <- initTcRnIf 's' hsc_env () () $-       readBinIface IgnoreHiWay (TraceBinIFace printer) filename+   iface <- readBinIface profile name_cache IgnoreHiWay (TraceBinIFace printer) filename     let -- See Note [Name qualification with --show-iface]        qualifyImportedNames mod _@@ -1079,7 +1084,7 @@        print_unqual = QueryQualify qualifyImportedNames                                    neverQualifyModules                                    neverQualifyPackages-   putLogMsg logger dflags NoReason SevDump noSrcSpan+   logMsg logger MCDump noSrcSpan       $ withPprStyle (mkDumpStyle print_unqual)       $ pprModIface unit_state iface @@ -1110,6 +1115,7 @@         , nest 2 (text "opt_hash:" <+> ppr (mi_opt_hash exts))         , nest 2 (text "hpc_hash:" <+> ppr (mi_hpc_hash exts))         , nest 2 (text "plugin_hash:" <+> ppr (mi_plugin_hash exts))+        , nest 2 (text "src_hash:" <+> ppr (mi_src_hash iface))         , nest 2 (text "sig of:" <+> ppr (mi_sig_of iface))         , nest 2 (text "used TH splices:" <+> ppr (mi_used_th iface))         , nest 2 (text "where")@@ -1127,9 +1133,7 @@         , pprTrustInfo (mi_trust iface)         , pprTrustPkg (mi_trust_pkg iface)         , vcat (map ppr (mi_complete_matches iface))-        , text "module header:" $$ nest 2 (ppr (mi_doc_hdr iface))-        , text "declaration docs:" $$ nest 2 (ppr (mi_decl_docs iface))-        , text "arg docs:" $$ nest 2 (ppr (mi_arg_docs iface))+        , text "docs:" $$ nest 2 (ppr (mi_docs iface))         , text "extensible fields:" $$ nest 2 (pprExtensibleFields (mi_ext_fields iface))         ]   where@@ -1171,6 +1175,8 @@           ppr (usg_file_hash usage)] pprUsage usage@UsageMergedRequirement{}   = hsep [text "merged", ppr (usg_mod usage), ppr (usg_mod_hash usage)]+pprUsage usage@UsageHomeModuleInterface{}+  = hsep [text "implementation", ppr (usg_mod_name usage), ppr (usg_iface_hash usage)]  pprUsageImport :: Outputable a => Usage -> (Usage -> a) -> SDoc pprUsageImport usage usg_mod'@@ -1180,23 +1186,6 @@         safe | usg_safe usage = text "safe"              | otherwise      = text " -/ " --- | Pretty-print unit dependencies-pprDeps :: UnitState -> Dependencies -> SDoc-pprDeps unit_state (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs,-                           dep_finsts = finsts })-  = pprWithUnitState unit_state $-    vcat [text "module dependencies:" <+> fsep (map ppr_mod mods),-          text "package dependencies:" <+> fsep (map ppr_pkg pkgs),-          text "orphans:" <+> fsep (map ppr orphs),-          text "family instance modules:" <+> fsep (map ppr finsts)-        ]-  where-    ppr_mod (GWIB { gwib_mod = mod_name, gwib_isBoot = boot }) = ppr mod_name <+> ppr_boot boot-    ppr_pkg (pkg,trust_req)  = ppr pkg <>-                               (if trust_req then text "*" else Outputable.empty)-    ppr_boot IsBoot  = text "[boot]"-    ppr_boot NotBoot = Outputable.empty- pprFixities :: [(OccName, Fixity)] -> SDoc pprFixities []    = Outputable.empty pprFixities fixes = text "fixities" <+> pprWithCommas pprFix fixes@@ -1209,13 +1198,13 @@ pprTrustPkg :: Bool -> SDoc pprTrustPkg tpkg = text "require own pkg trusted:" <+> ppr tpkg -instance Outputable Warnings where+instance Outputable (Warnings pass) where     ppr = pprWarns -pprWarns :: Warnings -> SDoc+pprWarns :: Warnings pass -> SDoc pprWarns NoWarnings         = Outputable.empty pprWarns (WarnAll txt)  = text "Warn all" <+> ppr txt-pprWarns (WarnSome prs) = text "Warnings"+pprWarns (WarnSome prs) = text "Warnings:"                         <+> vcat (map pprWarning prs)     where pprWarning (name, txt) = ppr name <+> ppr txt @@ -1227,311 +1216,3 @@ pprExtensibleFields (ExtensibleFields fs) = vcat . map pprField $ toList fs   where     pprField (name, (BinData size _data)) = text name <+> text "-" <+> ppr size <+> text "bytes"--{--*********************************************************-*                                                       *-\subsection{Errors}-*                                                       *-*********************************************************--}--badIfaceFile :: String -> SDoc -> SDoc-badIfaceFile file err-  = vcat [text "Bad interface file:" <+> text file,-          nest 4 err]--hiModuleNameMismatchWarn :: Module -> Module -> SDoc-hiModuleNameMismatchWarn requested_mod read_mod- | moduleUnit requested_mod == moduleUnit read_mod =-    sep [text "Interface file contains module" <+> quotes (ppr read_mod) <> comma,-         text "but we were expecting module" <+> quotes (ppr requested_mod),-         sep [text "Probable cause: the source code which generated interface file",-             text "has an incompatible module name"-            ]-        ]- | otherwise =-  -- ToDo: This will fail to have enough qualification when the package IDs-  -- are the same-  withPprStyle (mkUserStyle alwaysQualify AllTheWay) $-    -- we want the Modules below to be qualified with package names,-    -- so reset the PrintUnqualified setting.-    hsep [ text "Something is amiss; requested module "-         , ppr requested_mod-         , text "differs from name found in the interface file"-         , ppr read_mod-         , parens (text "if these names look the same, try again with -dppr-debug")-         ]--homeModError :: InstalledModule -> ModLocation -> SDoc--- See Note [Home module load error]-homeModError mod location-  = text "attempting to use module " <> quotes (ppr mod)-    <> (case ml_hs_file location of-           Just file -> space <> parens (text file)-           Nothing   -> Outputable.empty)-    <+> text "which is not loaded"----- -------------------------------------------------------------------------------- Error messages--cannotFindInterface :: UnitEnv -> Profile -> ([FilePath] -> SDoc) -> ModuleName -> InstalledFindResult -> SDoc-cannotFindInterface = cantFindInstalledErr (sLit "Failed to load interface for")-                                           (sLit "Ambiguous interface for")--cantFindInstalledErr-    :: PtrString-    -> PtrString-    -> UnitEnv-    -> Profile-    -> ([FilePath] -> SDoc)-    -> ModuleName-    -> InstalledFindResult-    -> SDoc-cantFindInstalledErr cannot_find _ unit_env profile tried_these mod_name find_result-  = ptext cannot_find <+> quotes (ppr mod_name)-    $$ more_info-  where-    home_unit  = ue_home_unit unit_env-    unit_state = ue_units unit_env-    build_tag  = waysBuildTag (profileWays profile)--    more_info-      = case find_result of-            InstalledNoPackage pkg-                -> text "no unit id matching" <+> quotes (ppr pkg) <+>-                   text "was found" $$ looks_like_srcpkgid pkg--            InstalledNotFound files mb_pkg-                | Just pkg <- mb_pkg, not (isHomeUnitId home_unit pkg)-                -> not_found_in_package pkg files--                | null files-                -> text "It is not a module in the current program, or in any known package."--                | otherwise-                -> tried_these files--            _ -> panic "cantFindInstalledErr"--    looks_like_srcpkgid :: UnitId -> SDoc-    looks_like_srcpkgid pk-     -- Unsafely coerce a unit id (i.e. an installed package component-     -- identifier) into a PackageId and see if it means anything.-     | (pkg:pkgs) <- searchPackageId unit_state (PackageId (unitIdFS pk))-     = parens (text "This unit ID looks like the source package ID;" $$-       text "the real unit ID is" <+> quotes (ftext (unitIdFS (unitId pkg))) $$-       (if null pkgs then Outputable.empty-        else text "and" <+> int (length pkgs) <+> text "other candidates"))-     -- Todo: also check if it looks like a package name!-     | otherwise = Outputable.empty--    not_found_in_package pkg files-       | build_tag /= ""-       = let-            build = if build_tag == "p" then "profiling"-                                        else "\"" ++ build_tag ++ "\""-         in-         text "Perhaps you haven't installed the " <> text build <>-         text " libraries for package " <> quotes (ppr pkg) <> char '?' $$-         tried_these files--       | otherwise-       = text "There are files missing in the " <> quotes (ppr pkg) <>-         text " package," $$-         text "try running 'ghc-pkg check'." $$-         tried_these files--may_show_locations :: DynFlags -> [FilePath] -> SDoc-may_show_locations dflags files-    | null files = Outputable.empty-    | verbosity dflags < 3 =-          text "Use -v (or `:set -v` in ghci) " <>-              text "to see a list of the files searched for."-    | otherwise =-          hang (text "Locations searched:") 2 $ vcat (map text files)--cannotFindModule :: HscEnv -> ModuleName -> FindResult -> SDoc-cannotFindModule hsc_env = cannotFindModule'-    (hsc_dflags   hsc_env)-    (hsc_unit_env hsc_env)-    (targetProfile (hsc_dflags hsc_env))---cannotFindModule' :: DynFlags -> UnitEnv -> Profile -> ModuleName -> FindResult -> SDoc-cannotFindModule' dflags unit_env profile mod res = pprWithUnitState (ue_units unit_env) $-  cantFindErr (gopt Opt_BuildingCabalPackage dflags)-              (sLit cannotFindMsg)-              (sLit "Ambiguous module name")-              unit_env-              profile-              (may_show_locations dflags)-              mod-              res-  where-    cannotFindMsg =-      case res of-        NotFound { fr_mods_hidden = hidden_mods-                 , fr_pkgs_hidden = hidden_pkgs-                 , fr_unusables = unusables }-          | not (null hidden_mods && null hidden_pkgs && null unusables)-          -> "Could not load module"-        _ -> "Could not find module"--cantFindErr-    :: Bool -- ^ Using Cabal?-    -> PtrString-    -> PtrString-    -> UnitEnv-    -> Profile-    -> ([FilePath] -> SDoc)-    -> ModuleName-    -> FindResult-    -> SDoc-cantFindErr _ _ multiple_found _ _ _ mod_name (FoundMultiple mods)-  | Just pkgs <- unambiguousPackages-  = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 (-       sep [text "it was found in multiple packages:",-                hsep (map ppr pkgs) ]-    )-  | otherwise-  = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 (-       vcat (map pprMod mods)-    )-  where-    unambiguousPackages = foldl' unambiguousPackage (Just []) mods-    unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _)-        = Just (moduleUnit m : xs)-    unambiguousPackage _ _ = Nothing--    pprMod (m, o) = text "it is bound as" <+> ppr m <+>-                                text "by" <+> pprOrigin m o-    pprOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden"-    pprOrigin _ (ModUnusable _) = panic "cantFindErr: bound by mod unusable"-    pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma (-      if e == Just True-          then [text "package" <+> ppr (moduleUnit m)]-          else [] ++-      map ((text "a reexport in package" <+>)-                .ppr.mkUnit) res ++-      if f then [text "a package flag"] else []-      )--cantFindErr using_cabal cannot_find _ unit_env profile tried_these mod_name find_result-  = ptext cannot_find <+> quotes (ppr mod_name)-    $$ more_info-  where-    home_unit  = ue_home_unit unit_env-    more_info-      = case find_result of-            NoPackage pkg-                -> text "no unit id matching" <+> quotes (ppr pkg) <+>-                   text "was found"--            NotFound { fr_paths = files, fr_pkg = mb_pkg-                     , fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens-                     , fr_unusables = unusables, fr_suggestions = suggest }-                | Just pkg <- mb_pkg, not (isHomeUnit home_unit pkg)-                -> not_found_in_package pkg files--                | not (null suggest)-                -> pp_suggestions suggest $$ tried_these files--                | null files && null mod_hiddens &&-                  null pkg_hiddens && null unusables-                -> text "It is not a module in the current program, or in any known package."--                | otherwise-                -> vcat (map pkg_hidden pkg_hiddens) $$-                   vcat (map mod_hidden mod_hiddens) $$-                   vcat (map unusable unusables) $$-                   tried_these files--            _ -> panic "cantFindErr"--    build_tag = waysBuildTag (profileWays profile)--    not_found_in_package pkg files-       | build_tag /= ""-       = let-            build = if build_tag == "p" then "profiling"-                                        else "\"" ++ build_tag ++ "\""-         in-         text "Perhaps you haven't installed the " <> text build <>-         text " libraries for package " <> quotes (ppr pkg) <> char '?' $$-         tried_these files--       | otherwise-       = text "There are files missing in the " <> quotes (ppr pkg) <>-         text " package," $$-         text "try running 'ghc-pkg check'." $$-         tried_these files--    pkg_hidden :: Unit -> SDoc-    pkg_hidden uid =-        text "It is a member of the hidden package"-        <+> quotes (ppr uid)-        --FIXME: we don't really want to show the unit id here we should-        -- show the source package id or installed package id if it's ambiguous-        <> dot $$ pkg_hidden_hint uid--    pkg_hidden_hint uid-     | using_cabal-        = let pkg = expectJust "pkg_hidden" (lookupUnit (ue_units unit_env) uid)-           in text "Perhaps you need to add" <+>-              quotes (ppr (unitPackageName pkg)) <+>-              text "to the build-depends in your .cabal file."-     | Just pkg <- lookupUnit (ue_units unit_env) uid-         = text "You can run" <+>-           quotes (text ":set -package " <> ppr (unitPackageName pkg)) <+>-           text "to expose it." $$-           text "(Note: this unloads all the modules in the current scope.)"-     | otherwise = Outputable.empty--    mod_hidden pkg =-        text "it is a hidden module in the package" <+> quotes (ppr pkg)--    unusable (pkg, reason)-      = text "It is a member of the package"-      <+> quotes (ppr pkg)-      $$ pprReason (text "which is") reason--    pp_suggestions :: [ModuleSuggestion] -> SDoc-    pp_suggestions sugs-      | null sugs = Outputable.empty-      | otherwise = hang (text "Perhaps you meant")-                       2 (vcat (map pp_sugg sugs))--    -- NB: Prefer the *original* location, and then reexports, and then-    -- package flags when making suggestions.  ToDo: if the original package-    -- also has a reexport, prefer that one-    pp_sugg (SuggestVisible m mod o) = ppr m <+> provenance o-      where provenance ModHidden = Outputable.empty-            provenance (ModUnusable _) = Outputable.empty-            provenance (ModOrigin{ fromOrigUnit = e,-                                   fromExposedReexport = res,-                                   fromPackageFlag = f })-              | Just True <- e-                 = parens (text "from" <+> ppr (moduleUnit mod))-              | f && moduleName mod == m-                 = parens (text "from" <+> ppr (moduleUnit mod))-              | (pkg:_) <- res-                 = parens (text "from" <+> ppr (mkUnit pkg)-                    <> comma <+> text "reexporting" <+> ppr mod)-              | f-                 = parens (text "defined via package flags to be"-                    <+> ppr mod)-              | otherwise = Outputable.empty-    pp_sugg (SuggestHidden m mod o) = ppr m <+> provenance o-      where provenance ModHidden =  Outputable.empty-            provenance (ModUnusable _) = Outputable.empty-            provenance (ModOrigin{ fromOrigUnit = e,-                                   fromHiddenReexport = rhs })-              | Just False <- e-                 = parens (text "needs flag -package-id"-                    <+> ppr (moduleUnit mod))-              | (pkg:_) <- rhs-                 = parens (text "needs flag -package-id"-                    <+> ppr (mkUnit pkg))-              | otherwise = Outputable.empty
compiler/GHC/Iface/Make.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                      #-}+ {-# LANGUAGE NondecreasingIndentation #-}  {-@@ -19,8 +19,6 @@    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Hs@@ -48,13 +46,13 @@ import GHC.Core.Multiplicity import GHC.Core.InstEnv import GHC.Core.FamInstEnv+import GHC.Core.Ppr import GHC.Core.Unify( RoughMatchTc(..) )  import GHC.Driver.Env import GHC.Driver.Backend import GHC.Driver.Session-import GHC.Driver.Ppr-import GHC.Driver.Plugins (LoadedPlugin(..))+import GHC.Driver.Plugins  import GHC.Types.Id import GHC.Types.Fixity.Env@@ -77,20 +75,23 @@  import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Misc  hiding ( eqListBy ) import GHC.Utils.Logger+import GHC.Utils.Trace  import GHC.Data.FastString import GHC.Data.Maybe  import GHC.HsToCore.Docs-import GHC.HsToCore.Usage ( mkUsageInfo, mkUsedNames, mkDependencies )+import GHC.HsToCore.Usage ( mkUsageInfo, mkUsedNames )  import GHC.Unit import GHC.Unit.Module.Warnings import GHC.Unit.Module.ModIface import GHC.Unit.Module.ModDetails import GHC.Unit.Module.ModGuts+import GHC.Unit.Module.ModSummary import GHC.Unit.Module.Deps  import Data.Function@@ -98,6 +99,7 @@ import Data.Ord import Data.IORef + {- ************************************************************************ *                                                                      *@@ -108,9 +110,10 @@  mkPartialIface :: HscEnv                -> ModDetails+               -> ModSummary                -> ModGuts                -> PartialModIface-mkPartialIface hsc_env mod_details+mkPartialIface hsc_env mod_details mod_summary   ModGuts{ mg_module       = this_mod          , mg_hsc_src      = hsc_src          , mg_usages       = usages@@ -122,12 +125,10 @@          , mg_hpc_info     = hpc_info          , mg_safe_haskell = safe_mode          , mg_trust_pkg    = self_trust-         , mg_doc_hdr      = doc_hdr-         , mg_decl_docs    = decl_docs-         , mg_arg_docs     = arg_docs+         , mg_docs         = docs          }   = mkIface_ hsc_env this_mod hsc_src used_th deps rdr_env fix_env warns hpc_info self_trust-             safe_mode usages doc_hdr decl_docs arg_docs mod_details+             safe_mode usages docs mod_summary mod_details  -- | Fully instantiate an interface. Adds fingerprints and potentially code -- generator produced information.@@ -149,23 +150,26 @@      -- Debug printing     let unit_state = hsc_units hsc_env-    dumpIfSet_dyn (hsc_logger hsc_env) (hsc_dflags hsc_env) Opt_D_dump_hi "FINAL INTERFACE" FormatText+    putDumpFileMaybe (hsc_logger hsc_env) Opt_D_dump_hi "FINAL INTERFACE" FormatText       (pprModIface unit_state full_iface)      return full_iface  updateDecl :: [IfaceDecl] -> Maybe CgInfos -> [IfaceDecl] updateDecl decls Nothing = decls-updateDecl decls (Just CgInfos{ cgNonCafs = NonCaffySet non_cafs, cgLFInfos = lf_infos }) = map update_decl decls+updateDecl decls (Just CgInfos{ cgNonCafs = NonCaffySet non_cafs, cgLFInfos = lf_infos, cgTagSigs = tag_sigs })+  = map update_decl decls   where     update_decl (IfaceId nm ty details infos)       | let not_caffy = elemNameSet nm non_cafs       , let mb_lf_info = lookupNameEnv lf_infos nm-      , WARN( isNothing mb_lf_info, text "Name without LFInfo:" <+> ppr nm ) True+      , let sig = lookupNameEnv tag_sigs nm+      , warnPprTrace (isNothing mb_lf_info) "updateDecl" (text "Name without LFInfo:" <+> ppr nm) True         -- Only allocate a new IfaceId if we're going to update the infos-      , isJust mb_lf_info || not_caffy+      , isJust mb_lf_info || not_caffy || isJust sig       = IfaceId nm ty details $-          (if not_caffy then (HsNoCafRefs :) else id)+          (if not_caffy then (HsNoCafRefs :) else id) $+          (if isJust sig then (HsTagSig (fromJust sig):) else id) $           (case mb_lf_info of              Nothing -> infos -- LFInfos not available when building .cmm files              Just lf_info -> HsLFInfo (toIfaceLFInfo nm lf_info) : infos)@@ -179,9 +183,10 @@ mkIfaceTc :: HscEnv           -> SafeHaskellMode    -- The safe haskell mode           -> ModDetails         -- gotten from mkBootModDetails, probably+          -> ModSummary           -> TcGblEnv           -- Usages, deprecations, etc           -> IO ModIface-mkIfaceTc hsc_env safe_mode mod_details+mkIfaceTc hsc_env safe_mode mod_details mod_summary   tc_result@TcGblEnv{ tcg_mod = this_mod,                       tcg_src = hsc_src,                       tcg_imports = imports,@@ -195,13 +200,16 @@                     }   = do           let used_names = mkUsedNames tc_result-          let pluginModules = map lpModule (hsc_plugins hsc_env)+          let pluginModules = map lpModule (loadedPlugins (hsc_plugins hsc_env))           let home_unit = hsc_home_unit hsc_env-          deps <- mkDependencies (homeUnitId home_unit)-                    (map mi_module pluginModules) tc_result+          let deps = mkDependencies home_unit+                                    (tcg_mod tc_result)+                                    (tcg_imports tc_result)+                                    (map mi_module pluginModules)           let hpc_info = emptyHpcInfo other_hpc_info           used_th <- readIORef tc_splice_used           dep_files <- (readIORef dependent_files)+          (needed_links, needed_pkgs) <- readIORef (tcg_th_needed_deps tc_result)           -- Do NOT use semantic module here; this_mod in mkUsageInfo           -- is used solely to decide if we should record a dependency           -- or not.  When we instantiate a signature, the semantic@@ -210,35 +218,34 @@           -- module and does not need to be recorded as a dependency.           -- See Note [Identity versus semantic module]           usages <- mkUsageInfo hsc_env this_mod (imp_mods imports) used_names-                      dep_files merged pluginModules+                      dep_files merged needed_links needed_pkgs -          (doc_hdr', doc_map, arg_map) <- extractDocs tc_result+          docs <- extractDocs (ms_hspp_opts mod_summary) tc_result            let partial_iface = mkIface_ hsc_env                    this_mod hsc_src                    used_th deps rdr_env                    fix_env warns hpc_info                    (imp_trust_own_pkg imports) safe_mode usages-                   doc_hdr' doc_map arg_map+                   docs mod_summary                    mod_details            mkFullIface hsc_env partial_iface Nothing  mkIface_ :: HscEnv -> Module -> HscSource          -> Bool -> Dependencies -> GlobalRdrEnv-         -> NameEnv FixItem -> Warnings -> HpcInfo+         -> NameEnv FixItem -> Warnings GhcRn -> HpcInfo          -> Bool          -> SafeHaskellMode          -> [Usage]-         -> Maybe HsDocString-         -> DeclDocMap-         -> ArgDocMap+         -> Maybe Docs+         -> ModSummary          -> ModDetails          -> PartialModIface mkIface_ hsc_env          this_mod hsc_src used_th deps rdr_env fix_env src_warns          hpc_info pkg_trust_req safe_mode usages-         doc_hdr decl_docs arg_docs+         docs mod_summary          ModDetails{  md_insts     = insts,                       md_fam_insts = fam_insts,                       md_rules     = rules,@@ -271,13 +278,13 @@                       -- See Note [Identity versus semantic module]          fixities    = sortBy (comparing fst)-          [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env]-          -- The order of fixities returned from nameEnvElts is not+          [(occ,fix) | FixItem occ fix <- nonDetNameEnvElts fix_env]+          -- The order of fixities returned from nonDetNameEnvElts is not           -- deterministic, so we sort by OccName to canonicalize it.           -- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for more details.         warns       = src_warns         iface_rules = map coreRuleToIfaceRule rules-        iface_insts = map instanceToIfaceInst $ fixSafeInstances safe_mode insts+        iface_insts = map instanceToIfaceInst $ fixSafeInstances safe_mode (instEnvElts insts)         iface_fam_insts = map famInstToIfaceFamInst fam_insts         trust_info  = setSafeMode safe_mode         annotations = map mkIfaceAnnotation anns@@ -311,11 +318,11 @@           mi_trust       = trust_info,           mi_trust_pkg   = pkg_trust_req,           mi_complete_matches = icomplete_matches,-          mi_doc_hdr     = doc_hdr,-          mi_decl_docs   = decl_docs,-          mi_arg_docs    = arg_docs,+          mi_docs        = docs,           mi_final_exts  = (),-          mi_ext_fields  = emptyExtensibleFields }+          mi_ext_fields  = emptyExtensibleFields,+          mi_src_hash = ms_hs_hash mod_summary+          }   where      cmp_rule     = lexicalCompareFS `on` ifRuleName      -- Compare these lexicographically by OccName, *not* by unique,@@ -646,7 +653,7 @@         (env2, if_decl) = tyConToIfaceDecl env1 tc      toIfaceClassOp (sel_id, def_meth)-        = ASSERT( sel_tyvars == binderVars tc_binders )+        = assert (sel_tyvars == binderVars tc_binders) $           IfaceClassOp (getName sel_id)                        (tidyToIfaceType env1 op_ty)                        (fmap toDmSpec def_meth)@@ -689,11 +696,13 @@                              , is_cls_nm = cls_name, is_cls = cls                              , is_tcs = rough_tcs                              , is_orphan = orph })-  = ASSERT( cls_name == className cls )+  = assert (cls_name == className cls) $     IfaceClsInst { ifDFun     = idName dfun_id                  , ifOFlag    = oflag                  , ifInstCls  = cls_name-                 , ifInstTys  = ifaceRoughMatchTcs rough_tcs+                 , ifInstTys  = ifaceRoughMatchTcs $ tail rough_tcs+                   -- N.B. Drop the class name from the rough match template+                   --      It is put back by GHC.Core.InstEnv.mkImportedInstance                  , ifInstOrph = orph }  --------------------------@@ -707,7 +716,7 @@                  , ifFamInstOrph     = orph }   where     fam_decl = tyConName $ coAxiomTyCon axiom-    mod = ASSERT( isExternalName (coAxiomName axiom) )+    mod = assert (isExternalName (coAxiomName axiom)) $           nameModule (coAxiomName axiom)     is_local name = nameIsLocalOrFrom mod name @@ -721,14 +730,17 @@ ifaceRoughMatchTcs :: [RoughMatchTc] -> [Maybe IfaceTyCon] ifaceRoughMatchTcs tcs = map do_rough tcs   where-    do_rough OtherTc     = Nothing-    do_rough (KnownTc n) = Just (toIfaceTyCon_name n)+    do_rough RM_WildCard     = Nothing+    do_rough (RM_KnownTc n) = Just (toIfaceTyCon_name n)  -------------------------- coreRuleToIfaceRule :: CoreRule -> IfaceRule-coreRuleToIfaceRule (BuiltinRule { ru_fn = fn})-  = pprTrace "toHsRule: builtin" (ppr fn) $-    bogusIfaceRule fn+-- A plugin that installs a BuiltinRule in a CoreDoPluginPass should+-- ensure that there's another CoreDoPluginPass that removes the rule.+-- Otherwise a module using the plugin and compiled with -fno-omit-interface-pragmas+-- would cause panic when the rule is attempted to be written to the interface file.+coreRuleToIfaceRule rule@(BuiltinRule {})+  = pprPanic "toHsRule:" (pprRule rule)  coreRuleToIfaceRule (Rule { ru_name = name, ru_fn = fn,                             ru_act = act, ru_bndrs = bndrs,@@ -749,10 +761,3 @@     do_arg (Type ty)     = IfaceType (toIfaceType (deNoteType ty))     do_arg (Coercion co) = IfaceCo   (toIfaceCoercion co)     do_arg arg           = toIfaceExpr arg--bogusIfaceRule :: Name -> IfaceRule-bogusIfaceRule id_name-  = IfaceRule { ifRuleName = fsLit "bogus", ifActivation = NeverActive,-        ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [],-        ifRuleRhs = IfaceExt id_name, ifRuleOrph = IsOrphan,-        ifRuleAuto = True }
compiler/GHC/Iface/Recomp.hs view
@@ -1,29 +1,37 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE LambdaCase #-}  -- | Module for detecting if recompilation is required module GHC.Iface.Recomp    ( checkOldIface    , RecompileRequired(..)+   , needsRecompileBecause+   , recompThen+   , MaybeValidated(..)+   , outOfDateItemBecause+   , RecompReason (..)+   , CompileReason(..)    , recompileRequired    , addFingerprints    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Driver.Backend+import GHC.Driver.Config.Finder import GHC.Driver.Env import GHC.Driver.Session import GHC.Driver.Ppr-import GHC.Driver.Plugins ( PluginRecompile(..), PluginWithArgs(..), pluginRecompile', plugins )+import GHC.Driver.Plugins  import GHC.Iface.Syntax import GHC.Iface.Recomp.Binary import GHC.Iface.Load import GHC.Iface.Recomp.Flags+import GHC.Iface.Env  import GHC.Core import GHC.Tc.Utils.Monad@@ -31,15 +39,18 @@  import GHC.Data.Graph.Directed import GHC.Data.Maybe-import GHC.Data.FastString  import GHC.Utils.Error import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Outputable as Outputable import GHC.Utils.Misc as Utils hiding ( eqListBy ) import GHC.Utils.Binary import GHC.Utils.Fingerprint import GHC.Utils.Exception+import GHC.Utils.Logger+import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.Trace  import GHC.Types.Annotations import GHC.Types.Name@@ -48,8 +59,6 @@ import GHC.Types.Unique import GHC.Types.Unique.Set import GHC.Types.Fixity.Env-import GHC.Types.SourceFile- import GHC.Unit.External import GHC.Unit.Finder import GHC.Unit.State@@ -61,15 +70,19 @@ import GHC.Unit.Module.Deps  import Control.Monad-import Data.Function-import Data.List (find, sortBy, sort)+import Data.List (sortBy, sort) import qualified Data.Map as Map import qualified Data.Set as Set import Data.Word (Word64)+import Data.Either  --Qualified import so we can define a Semigroup instance -- but it doesn't clash with Outputable.<> import qualified Data.Semigroup+import GHC.List (uncons)+import Data.Ord+import Data.Containers.ListUtils+import Data.Bifunctor  {-   -----------------------------------------------@@ -104,15 +117,45 @@ -}  data RecompileRequired+  -- | everything is up to date, recompilation is not required   = UpToDate-       -- ^ everything is up to date, recompilation is not required-  | MustCompile-       -- ^ The .hs file has been touched, or the .o/.hi file does not exist-  | RecompBecause String-       -- ^ The .o/.hi files are up to date, but something else has changed-       -- to force recompilation; the String says what (one-line summary)-   deriving Eq+  -- | Need to compile the module+  | NeedsRecompile !CompileReason+   deriving (Eq) +needsRecompileBecause :: RecompReason -> RecompileRequired+needsRecompileBecause = NeedsRecompile . RecompBecause++data MaybeValidated a+  -- | The item contained is validated to be up to date+  = UpToDateItem a+  -- | The item is are absent altogether or out of date, for the reason given.+  | OutOfDateItem+      !CompileReason+      -- ^ the reason we need to recompile.+      (Maybe a)+      -- ^ The old item, if it exists+  deriving (Functor)++outOfDateItemBecause :: RecompReason -> Maybe a -> MaybeValidated a+outOfDateItemBecause reason item = OutOfDateItem (RecompBecause reason) item++data CompileReason+  -- | The .hs file has been touched, or the .o/.hi file does not exist+  = MustCompile+  -- | The .o/.hi files are up to date, but something else has changed+  -- to force recompilation; the String says what (one-line summary)+  | RecompBecause !RecompReason+   deriving (Eq)++instance Outputable RecompileRequired where+  ppr UpToDate = text "UpToDate"+  ppr (NeedsRecompile reason) = ppr reason++instance Outputable CompileReason where+  ppr MustCompile = text "MustCompile"+  ppr (RecompBecause r) = text "RecompBecause" <+> ppr r+ instance Semigroup RecompileRequired where   UpToDate <> r = r   mc <> _       = mc@@ -120,94 +163,187 @@ instance Monoid RecompileRequired where   mempty = UpToDate +data RecompReason+  = UnitDepRemoved UnitId+  | ModulePackageChanged String+  | SourceFileChanged+  | ThisUnitIdChanged+  | ImpurePlugin+  | PluginsChanged+  | PluginFingerprintChanged+  | ModuleInstChanged+  | HieMissing+  | HieOutdated+  | SigsMergeChanged+  | ModuleChanged ModuleName+  | ModuleRemoved (UnitId, ModuleName)+  | ModuleAdded (UnitId, ModuleName)+  | ModuleChangedRaw ModuleName+  | ModuleChangedIface ModuleName+  | FileChanged FilePath+  | CustomReason String+  | FlagsChanged+  | OptimFlagsChanged+  | HpcFlagsChanged+  | MissingBytecode+  | MissingObjectFile+  | MissingDynObjectFile+  | MissingDynHiFile+  | MismatchedDynHiFile+  | ObjectsChanged+  | LibraryChanged+  deriving (Eq)++instance Outputable RecompReason where+  ppr = \case+    UnitDepRemoved uid       -> ppr uid <+> text "removed"+    ModulePackageChanged s   -> text s <+> text "package changed"+    SourceFileChanged        -> text "Source file changed"+    ThisUnitIdChanged        -> text "-this-unit-id changed"+    ImpurePlugin             -> text "Impure plugin forced recompilation"+    PluginsChanged           -> text "Plugins changed"+    PluginFingerprintChanged -> text "Plugin fingerprint changed"+    ModuleInstChanged        -> text "Implementing module changed"+    HieMissing               -> text "HIE file is missing"+    HieOutdated              -> text "HIE file is out of date"+    SigsMergeChanged         -> text "Signatures to merge in changed"+    ModuleChanged m          -> ppr m <+> text "changed"+    ModuleChangedRaw m       -> ppr m <+> text "changed (raw)"+    ModuleChangedIface m     -> ppr m <+> text "changed (interface)"+    ModuleRemoved (_uid, m)   -> ppr m <+> text "removed"+    ModuleAdded (_uid, m)     -> ppr m <+> text "added"+    FileChanged fp           -> text fp <+> text "changed"+    CustomReason s           -> text s+    FlagsChanged             -> text "Flags changed"+    OptimFlagsChanged        -> text "Optimisation flags changed"+    HpcFlagsChanged          -> text "HPC flags changed"+    MissingBytecode          -> text "Missing bytecode"+    MissingObjectFile        -> text "Missing object file"+    MissingDynObjectFile     -> text "Missing dynamic object file"+    MissingDynHiFile         -> text "Missing dynamic interface file"+    MismatchedDynHiFile     -> text "Mismatched dynamic interface file"+    ObjectsChanged          -> text "Objects changed"+    LibraryChanged          -> text "Library changed"+ recompileRequired :: RecompileRequired -> Bool recompileRequired UpToDate = False recompileRequired _ = True +recompThen :: Monad m => m RecompileRequired -> m RecompileRequired -> m RecompileRequired+recompThen ma mb = ma >>= \case+  UpToDate              -> mb+  rr@(NeedsRecompile _) -> pure rr++checkList :: Monad m => [m RecompileRequired] -> m RecompileRequired+checkList = \case+  []               -> return UpToDate+  (check : checks) -> check `recompThen` checkList checks++----------------------+ -- | Top level function to check if the version of an old interface file -- is equivalent to the current source file the user asked us to compile.--- If the same, we can avoid recompilation. We return a tuple where the--- first element is a bool saying if we should recompile the object file--- and the second is maybe the interface file, where Nothing means to--- rebuild the interface file and not use the existing one.+-- If the same, we can avoid recompilation.+--+-- We return on the outside whether the interface file is up to date, providing+-- evidence that is with a `ModIface`. In the case that it isn't, we may also+-- return a found or provided `ModIface`. Why we don't always return the old+-- one, if it exists, is unclear to me, except that I tried it and some tests+-- failed (see #18205). checkOldIface   :: HscEnv   -> ModSummary-  -> SourceModified   -> Maybe ModIface         -- Old interface from compilation manager, if any-  -> IO (RecompileRequired, Maybe ModIface)+  -> IO (MaybeValidated ModIface) -checkOldIface hsc_env mod_summary source_modified maybe_iface+checkOldIface hsc_env mod_summary maybe_iface   = do  let dflags = hsc_dflags hsc_env         let logger = hsc_logger hsc_env-        showPass logger dflags $+        showPass logger $             "Checking old interface for " ++               (showPpr dflags $ ms_mod mod_summary) ++               " (use -ddump-hi-diffs for more details)"         initIfaceCheck (text "checkOldIface") hsc_env $-            check_old_iface hsc_env mod_summary source_modified maybe_iface+            check_old_iface hsc_env mod_summary maybe_iface  check_old_iface   :: HscEnv   -> ModSummary-  -> SourceModified   -> Maybe ModIface-  -> IfG (RecompileRequired, Maybe ModIface)+  -> IfG (MaybeValidated ModIface) -check_old_iface hsc_env mod_summary src_modified maybe_iface+check_old_iface hsc_env mod_summary maybe_iface   = let dflags = hsc_dflags hsc_env+        logger = hsc_logger hsc_env         getIface =             case maybe_iface of                 Just _  -> do-                    traceIf (text "We already have the old interface for" <+>+                    trace_if logger (text "We already have the old interface for" <+>                       ppr (ms_mod mod_summary))                     return maybe_iface-                Nothing -> loadIface+                Nothing -> loadIface dflags (msHiFilePath mod_summary) -        loadIface = do-             let iface_path = msHiFilePath mod_summary-             read_result <- readIface (ms_mod mod_summary) iface_path+        loadIface read_dflags iface_path = do+             let ncu        = hsc_NC hsc_env+             read_result <- readIface read_dflags ncu (ms_mod mod_summary) iface_path              case read_result of                  Failed err -> do-                     traceIf (text "FYI: cannot read old interface file:" $$ nest 4 err)-                     traceHiDiffs (text "Old interface file was invalid:" $$ nest 4 err)+                     trace_if logger (text "FYI: cannot read old interface file:" $$ nest 4 err)+                     trace_hi_diffs logger (text "Old interface file was invalid:" $$ nest 4 err)                      return Nothing                  Succeeded iface -> do-                     traceIf (text "Read the interface file" <+> text iface_path)+                     trace_if logger (text "Read the interface file" <+> text iface_path)                      return $ Just iface+        check_dyn_hi :: ModIface+                  -> IfG (MaybeValidated ModIface)+                  -> IfG (MaybeValidated ModIface)+        check_dyn_hi normal_iface recomp_check | gopt Opt_BuildDynamicToo dflags = do+          res <- recomp_check+          case res of+            UpToDateItem _ -> do+              maybe_dyn_iface <- liftIO $ loadIface (setDynamicNow dflags) (msDynHiFilePath mod_summary)+              case maybe_dyn_iface of+                Nothing -> return $ outOfDateItemBecause MissingDynHiFile Nothing+                Just dyn_iface | mi_iface_hash (mi_final_exts dyn_iface)+                                    /= mi_iface_hash (mi_final_exts normal_iface)+                  -> return $ outOfDateItemBecause MismatchedDynHiFile Nothing+                Just {} -> return res+            _ -> return res+        check_dyn_hi _ recomp_check = recomp_check +         src_changed-            | gopt Opt_ForceRecomp (hsc_dflags hsc_env) = True-            | SourceModified <- src_modified = True+            | gopt Opt_ForceRecomp dflags    = True             | otherwise = False     in do         when src_changed $-            traceHiDiffs (nest 4 $ text "Source file changed or recompilation check turned off")+            liftIO $ trace_hi_diffs logger (nest 4 $ text "Recompilation check turned off")          case src_changed of             -- If the source has changed and we're in interactive mode,             -- avoid reading an interface; just return the one we might             -- have been supplied with.             True | not (backendProducesObject $ backend dflags) ->-                return (MustCompile, maybe_iface)+                return $ OutOfDateItem MustCompile maybe_iface              -- Try and read the old interface for the current module             -- from the .hi file left from the last time we compiled it             True -> do-                maybe_iface' <- getIface-                return (MustCompile, maybe_iface')+                maybe_iface' <- liftIO $ getIface+                return $ OutOfDateItem MustCompile maybe_iface'              False -> do-                maybe_iface' <- getIface+                maybe_iface' <- liftIO $ getIface                 case maybe_iface' of                     -- We can't retrieve the iface-                    Nothing    -> return (MustCompile, Nothing)+                    Nothing    -> return $ OutOfDateItem MustCompile Nothing                      -- We have got the old iface; check its versions                     -- even in the SourceUnmodifiedAndStable case we                     -- should check versions because some packages                     -- might have changed or gone away.-                    Just iface -> checkVersions hsc_env mod_summary iface+                    Just iface ->+                      check_dyn_hi iface $ checkVersions hsc_env mod_summary iface  -- | Check if a module is still the same 'version'. --@@ -223,32 +359,31 @@ checkVersions :: HscEnv               -> ModSummary               -> ModIface       -- Old interface-              -> IfG (RecompileRequired, Maybe ModIface)+              -> IfG (MaybeValidated ModIface) checkVersions hsc_env mod_summary iface-  = do { traceHiDiffs (text "Considering whether compilation is required for" <+>+  = do { liftIO $ trace_hi_diffs logger+                        (text "Considering whether compilation is required for" <+>                         ppr (mi_module iface) <> colon)         -- readIface will have verified that the UnitId matches,        -- but we ALSO must make sure the instantiation matches up.  See        -- test case bkpcabal04!+       ; hsc_env <- getTopEnv+       ; if mi_src_hash iface /= ms_hs_hash mod_summary+            then return $ outOfDateItemBecause SourceFileChanged Nothing else do {        ; if not (isHomeModule home_unit (mi_module iface))-            then return (RecompBecause "-this-unit-id changed", Nothing) else do {-       ; recomp <- checkFlagHash hsc_env iface-       ; if recompileRequired recomp then return (recomp, Nothing) else do {-       ; recomp <- checkOptimHash hsc_env iface-       ; if recompileRequired recomp then return (recomp, Nothing) else do {-       ; recomp <- checkHpcHash hsc_env iface-       ; if recompileRequired recomp then return (recomp, Nothing) else do {-       ; recomp <- checkMergedSignatures mod_summary iface-       ; if recompileRequired recomp then return (recomp, Nothing) else do {-       ; recomp <- checkHsig mod_summary iface-       ; if recompileRequired recomp then return (recomp, Nothing) else do {-       ; recomp <- checkHie mod_summary-       ; if recompileRequired recomp then return (recomp, Nothing) else do {+            then return $ outOfDateItemBecause ThisUnitIdChanged Nothing else do {+       ; recomp <- liftIO $ checkFlagHash hsc_env iface+                             `recompThen` checkOptimHash hsc_env iface+                             `recompThen` checkHpcHash hsc_env iface+                             `recompThen` checkMergedSignatures hsc_env mod_summary iface+                             `recompThen` checkHsig logger home_unit mod_summary iface+                             `recompThen` pure (checkHie dflags mod_summary)+       ; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason Nothing ; _ -> do {        ; recomp <- checkDependencies hsc_env mod_summary iface-       ; if recompileRequired recomp then return (recomp, Just iface) else do {-       ; recomp <- checkPlugins hsc_env iface-       ; if recompileRequired recomp then return (recomp, Nothing) else do {+       ; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason (Just iface) ; _ -> do {+       ; recomp <- checkPlugins (hsc_plugins hsc_env) iface+       ; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason Nothing ; _ -> do {          -- Source code unchanged and no errors yet... carry on@@ -260,46 +395,46 @@        -- It's just temporary because either the usage check will succeed        -- (in which case we are done with this module) or it'll fail (in which        -- case we'll compile the module from scratch anyhow).-       ---       -- We do this regardless of compilation mode, although in --make mode-       -- all the dependent modules should be in the HPT already, so it's-       -- quite redundant-       ; updateEps_ $ \eps  -> eps { eps_is_boot = mod_deps }-       ; recomp <- checkList [checkModUsage (homeUnitAsUnit home_unit) u++       when (isOneShot (ghcMode (hsc_dflags hsc_env))) $ do {+          ; updateEps_ $ \eps  -> eps { eps_is_boot = mkModDeps $ dep_boot_mods (mi_deps iface) }+       }+       ; recomp <- checkList [checkModUsage (hsc_FC hsc_env) (homeUnitAsUnit home_unit) u                              | u <- mi_usages iface]-       ; return (recomp, Just iface)-    }}}}}}}}}}+       ; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason (Just iface) ; _ -> do {+       ; return $ UpToDateItem iface+    }}}}}}}   where+    logger = hsc_logger hsc_env+    dflags = hsc_dflags hsc_env     home_unit = hsc_home_unit hsc_env-    -- This is a bit of a hack really-    mod_deps :: ModuleNameEnv ModuleNameWithIsBoot-    mod_deps = mkModDeps (dep_mods (mi_deps iface)) ++ -- | Check if any plugins are requesting recompilation-checkPlugins :: HscEnv -> ModIface -> IfG RecompileRequired-checkPlugins hsc_env iface = liftIO $ do-  new_fingerprint <- fingerprintPlugins hsc_env+checkPlugins :: Plugins -> ModIface -> IfG RecompileRequired+checkPlugins plugins iface = liftIO $ do+  recomp <- recompPlugins plugins+  let new_fingerprint = fingerprintPluginRecompile recomp   let old_fingerprint = mi_plugin_hash (mi_final_exts iface)-  pr <- mconcat <$> mapM pluginRecompile' (plugins hsc_env)-  return $-    pluginRecompileToRecompileRequired old_fingerprint new_fingerprint pr+  return $ pluginRecompileToRecompileRequired old_fingerprint new_fingerprint recomp -fingerprintPlugins :: HscEnv -> IO Fingerprint-fingerprintPlugins hsc_env =-  fingerprintPlugins' $ plugins hsc_env+recompPlugins :: Plugins -> IO PluginRecompile+recompPlugins plugins = mconcat <$> mapM pluginRecompile' (pluginsWithArgs plugins) -fingerprintPlugins' :: [PluginWithArgs] -> IO Fingerprint-fingerprintPlugins' plugins = do-  res <- mconcat <$> mapM pluginRecompile' plugins-  return $ case res of-      NoForceRecompile -> fingerprintString "NoForceRecompile"-      ForceRecompile   -> fingerprintString "ForceRecompile"-      -- is the chance of collision worth worrying about?-      -- An alternative is to fingerprintFingerprints [fingerprintString-      -- "maybeRecompile", fp]-      (MaybeRecompile fp) -> fp+fingerprintPlugins :: Plugins -> IO Fingerprint+fingerprintPlugins plugins = fingerprintPluginRecompile <$> recompPlugins plugins +fingerprintPluginRecompile :: PluginRecompile -> Fingerprint+fingerprintPluginRecompile recomp = case recomp of+  NoForceRecompile  -> fingerprintString "NoForceRecompile"+  ForceRecompile    -> fingerprintString "ForceRecompile"+  -- is the chance of collision worth worrying about?+  -- An alternative is to fingerprintFingerprints [fingerprintString+  -- "maybeRecompile", fp]+  MaybeRecompile fp -> fp + pluginRecompileToRecompileRequired     :: Fingerprint -> Fingerprint -> PluginRecompile -> RecompileRequired pluginRecompileToRecompileRequired old_fp new_fp pr@@ -314,7 +449,7 @@       -- when we have an impure plugin in the stack we have to unconditionally       -- recompile since it might integrate all sorts of crazy IO results into       -- its compilation output.-      ForceRecompile    -> RecompBecause "Impure plugin forced recompilation"+      ForceRecompile    -> needsRecompileBecause ImpurePlugin    | old_fp `elem` magic_fingerprints ||     new_fp `elem` magic_fingerprints@@ -326,17 +461,16 @@     -- For example when we go from ForceRecomp to NoForceRecomp     -- recompilation is triggered since the old impure plugins could have     -- changed the build output which is now back to normal.-    = RecompBecause "Plugins changed"+    = needsRecompileBecause PluginsChanged    | otherwise =-    let reason = "Plugin fingerprint changed" in     case pr of       -- even though a plugin is forcing recompilation the fingerprint changed       -- which would cause recompilation anyways so we report the fingerprint       -- change instead.-      ForceRecompile   -> RecompBecause reason+      ForceRecompile   -> needsRecompileBecause PluginFingerprintChanged -      _                -> RecompBecause reason+      _                -> needsRecompileBecause PluginFingerprintChanged   where    magic_fingerprints =@@ -347,89 +481,87 @@  -- | Check if an hsig file needs recompilation because its -- implementing module has changed.-checkHsig :: ModSummary -> ModIface -> IfG RecompileRequired-checkHsig mod_summary iface = do-    hsc_env <- getTopEnv-    let home_unit = hsc_home_unit hsc_env-        outer_mod = ms_mod mod_summary+checkHsig :: Logger -> HomeUnit -> ModSummary -> ModIface -> IO RecompileRequired+checkHsig logger home_unit mod_summary iface = do+    let outer_mod = ms_mod mod_summary         inner_mod = homeModuleNameInstantiation home_unit (moduleName outer_mod)-    MASSERT( isHomeModule home_unit outer_mod )+    massert (isHomeModule home_unit outer_mod)     case inner_mod == mi_semantic_module iface of-        True -> up_to_date (text "implementing module unchanged")-        False -> return (RecompBecause "implementing module changed")+        True -> up_to_date logger (text "implementing module unchanged")+        False -> return $ needsRecompileBecause ModuleInstChanged  -- | Check if @.hie@ file is out of date or missing.-checkHie :: ModSummary -> IfG RecompileRequired-checkHie mod_summary = do-    dflags <- getDynFlags+checkHie :: DynFlags -> ModSummary -> RecompileRequired+checkHie dflags mod_summary =     let hie_date_opt = ms_hie_date mod_summary-        hs_date = ms_hs_date mod_summary-    pure $ case gopt Opt_WriteHie dflags of-               False -> UpToDate-               True -> case hie_date_opt of-                           Nothing -> RecompBecause "HIE file is missing"-                           Just hie_date-                               | hie_date < hs_date-                               -> RecompBecause "HIE file is out of date"-                               | otherwise-                               -> UpToDate+        hi_date = ms_iface_date mod_summary+    in if not (gopt Opt_WriteHie dflags)+      then UpToDate+      else case (hie_date_opt, hi_date) of+             (Nothing, _) -> needsRecompileBecause HieMissing+             (Just hie_date, Just hi_date)+                 | hie_date < hi_date+                 -> needsRecompileBecause HieOutdated+             _ -> UpToDate  -- | Check the flags haven't changed-checkFlagHash :: HscEnv -> ModIface -> IfG RecompileRequired+checkFlagHash :: HscEnv -> ModIface -> IO RecompileRequired checkFlagHash hsc_env iface = do+    let logger   = hsc_logger hsc_env     let old_hash = mi_flag_hash (mi_final_exts iface)-    new_hash <- liftIO $ fingerprintDynFlags hsc_env-                                             (mi_module iface)-                                             putNameLiterally+    new_hash <- fingerprintDynFlags hsc_env (mi_module iface) putNameLiterally     case old_hash == new_hash of-        True  -> up_to_date (text "Module flags unchanged")-        False -> out_of_date_hash "flags changed"+        True  -> up_to_date logger (text "Module flags unchanged")+        False -> out_of_date_hash logger FlagsChanged                      (text "  Module flags have changed")                      old_hash new_hash  -- | Check the optimisation flags haven't changed-checkOptimHash :: HscEnv -> ModIface -> IfG RecompileRequired+checkOptimHash :: HscEnv -> ModIface -> IO RecompileRequired checkOptimHash hsc_env iface = do+    let logger   = hsc_logger hsc_env     let old_hash = mi_opt_hash (mi_final_exts iface)-    new_hash <- liftIO $ fingerprintOptFlags (hsc_dflags hsc_env)+    new_hash <- fingerprintOptFlags (hsc_dflags hsc_env)                                                putNameLiterally     if | old_hash == new_hash-         -> up_to_date (text "Optimisation flags unchanged")+         -> up_to_date logger (text "Optimisation flags unchanged")        | gopt Opt_IgnoreOptimChanges (hsc_dflags hsc_env)-         -> up_to_date (text "Optimisation flags changed; ignoring")+         -> up_to_date logger (text "Optimisation flags changed; ignoring")        | otherwise-         -> out_of_date_hash "Optimisation flags changed"+         -> out_of_date_hash logger OptimFlagsChanged                      (text "  Optimisation flags have changed")                      old_hash new_hash  -- | Check the HPC flags haven't changed-checkHpcHash :: HscEnv -> ModIface -> IfG RecompileRequired+checkHpcHash :: HscEnv -> ModIface -> IO RecompileRequired checkHpcHash hsc_env iface = do+    let logger   = hsc_logger hsc_env     let old_hash = mi_hpc_hash (mi_final_exts iface)-    new_hash <- liftIO $ fingerprintHpcFlags (hsc_dflags hsc_env)+    new_hash <- fingerprintHpcFlags (hsc_dflags hsc_env)                                                putNameLiterally     if | old_hash == new_hash-         -> up_to_date (text "HPC flags unchanged")+         -> up_to_date logger (text "HPC flags unchanged")        | gopt Opt_IgnoreHpcChanges (hsc_dflags hsc_env)-         -> up_to_date (text "HPC flags changed; ignoring")+         -> up_to_date logger (text "HPC flags changed; ignoring")        | otherwise-         -> out_of_date_hash "HPC flags changed"+         -> out_of_date_hash logger HpcFlagsChanged                      (text "  HPC flags have changed")                      old_hash new_hash  -- Check that the set of signatures we are merging in match. -- If the -unit-id flags change, this can change too.-checkMergedSignatures :: ModSummary -> ModIface -> IfG RecompileRequired-checkMergedSignatures mod_summary iface = do-    unit_state <- hsc_units <$> getTopEnv+checkMergedSignatures :: HscEnv -> ModSummary -> ModIface -> IO RecompileRequired+checkMergedSignatures hsc_env mod_summary iface = do+    let logger     = hsc_logger hsc_env+    let unit_state = hsc_units hsc_env     let old_merged = sort [ mod | UsageMergedRequirement{ usg_mod = mod } <- mi_usages iface ]         new_merged = case Map.lookup (ms_mod_name mod_summary)                                      (requirementContext unit_state) of                         Nothing -> []                         Just r -> sort $ map (instModuleToModule unit_state) r     if old_merged == new_merged-        then up_to_date (text "signatures to merge in unchanged" $$ ppr new_merged)-        else return (RecompBecause "signatures to merge in changed")+        then up_to_date logger (text "signatures to merge in unchanged" $$ ppr new_merged)+        else return $ needsRecompileBecause SigsMergeChanged  -- If the direct imports of this module are resolved to targets that -- are not among the dependencies of the previous interface file,@@ -440,130 +572,114 @@ --   - a new home module has been added that shadows a package module -- See bug #1372. ----- In addition, we also check if the union of dependencies of the imported--- modules has any difference to the previous set of dependencies. We would need--- to recompile in that case also since the `mi_deps` field of ModIface needs--- to be updated to match that information. This is one of the invariants--- of interface files (see https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance#interface-file-invariants).--- See bug #16511.------ Returns (RecompBecause <textual reason>) if recompilation is required.+-- Returns (RecompBecause <reason>) if recompilation is required. checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired checkDependencies hsc_env summary iface- =-   checkList $-     [ checkList (map dep_missing (ms_imps summary ++ ms_srcimps summary))-     , do-         (recomp, mnames_seen) <- runUntilRecompRequired $ map-           checkForNewHomeDependency-           (ms_home_imps summary)-         case recomp of-           UpToDate -> do-             let-               seen_home_deps = Set.unions $ map Set.fromList mnames_seen-             checkIfAllOldHomeDependenciesAreSeen seen_home_deps-           _ -> return recomp]+ = do+    res_normal <- classify_import (findImportedModule hsc_env) (ms_textual_imps summary ++ ms_srcimps summary)+    res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units mhome_unit mod) (ms_plugin_imps summary)+    case sequence (res_normal ++ res_plugin ++ [Right (fake_ghc_prim_import)| ms_ghc_prim_import summary]) of+      Left recomp -> return $ NeedsRecompile recomp+      Right es -> do+        let (hs, ps) = partitionEithers es+        liftIO $+          check_mods (sort hs) prev_dep_mods+          `recompThen`+            let allPkgDeps = sortBy (comparing snd) $ nubOrdOn snd (ps ++ implicit_deps ++ bkpk_units)+            in check_packages allPkgDeps prev_dep_pkgs  where-   prev_dep_mods = dep_mods (mi_deps iface)-   prev_dep_plgn = dep_plgins (mi_deps iface)-   prev_dep_pkgs = dep_pkgs (mi_deps iface)-   home_unit     = hsc_home_unit hsc_env -   dep_missing (mb_pkg, L _ mod) = do-     find_res <- liftIO $ findImportedModule hsc_env mod (mb_pkg)-     let reason = moduleNameString mod ++ " changed"-     case find_res of-        Found _ mod-          | isHomeUnit home_unit pkg-           -> if moduleName mod `notElem` map gwib_mod prev_dep_mods ++ prev_dep_plgn-                 then do traceHiDiffs $-                           text "imported module " <> quotes (ppr mod) <>-                           text " not among previous dependencies"-                         return (RecompBecause reason)-                 else-                         return UpToDate-          | otherwise-           -> if toUnitId pkg `notElem` (map fst prev_dep_pkgs)-                 then do traceHiDiffs $-                           text "imported module " <> quotes (ppr mod) <>-                           text " is from package " <> quotes (ppr pkg) <>-                           text ", which is not among previous dependencies"-                         return (RecompBecause reason)-                 else-                         return UpToDate-           where pkg = moduleUnit mod-        _otherwise  -> return (RecompBecause reason)+   classify_import :: (ModuleName -> t -> IO FindResult)+                      -> [(t, GenLocated l ModuleName)]+                    -> IfG+                       [Either+                          CompileReason (Either (UnitId, ModuleName) (String, UnitId))]+   classify_import find_import imports =+    liftIO $ traverse (\(mb_pkg, L _ mod) ->+           let reason = ModuleChanged mod+           in classify reason <$> find_import mod mb_pkg)+           imports+   dflags        = hsc_dflags hsc_env+   fopts         = initFinderOpts dflags+   logger        = hsc_logger hsc_env+   fc            = hsc_FC hsc_env+   mhome_unit    = hsc_home_unit_maybe hsc_env+   all_home_units = hsc_all_home_unit_ids hsc_env+   units         = hsc_units hsc_env+   prev_dep_mods = map (second gwib_mod) $ Set.toAscList $ dep_direct_mods (mi_deps iface)+   prev_dep_pkgs = Set.toAscList (Set.union (dep_direct_pkgs (mi_deps iface))+                                            (dep_plugin_pkgs (mi_deps iface)))+   bkpk_units    = map (("Signature",) . instUnitInstanceOf . moduleUnit) (requirementMerges units (moduleName (mi_module iface))) -   projectNonBootNames = map gwib_mod . filter ((== NotBoot) . gwib_isBoot)-   old_deps = Set.fromList-     $ projectNonBootNames prev_dep_mods-   isOldHomeDeps = flip Set.member old_deps-   checkForNewHomeDependency (L _ mname) = do-     let-       mod = mkHomeModule home_unit mname-       str_mname = moduleNameString mname-       reason = str_mname ++ " changed"-     -- We only want to look at home modules to check if any new home dependency-     -- pops in and thus here, skip modules that are not home. Checking-     -- membership in old home dependencies suffice because the `dep_missing`-     -- check already verified that all imported home modules are present there.-     if not (isOldHomeDeps mname)-       then return (UpToDate, [])-       else do-         mb_result <- getFromModIface "need mi_deps for" mod $ \imported_iface -> do-           let mnames = mname:(map gwib_mod $ filter ((== NotBoot) . gwib_isBoot) $-                 dep_mods $ mi_deps imported_iface)-           case find (not . isOldHomeDeps) mnames of-             Nothing -> return (UpToDate, mnames)-             Just new_dep_mname -> do-               traceHiDiffs $-                 text "imported home module " <> quotes (ppr mod) <>-                 text " has a new dependency " <> quotes (ppr new_dep_mname)-               return (RecompBecause reason, [])-         return $ fromMaybe (MustCompile, []) mb_result+   implicit_deps = map ("Implicit",) (implicitPackageDeps dflags) -   -- Performs all recompilation checks in the list until a check that yields-   -- recompile required is encountered. Returns the list of the results of-   -- all UpToDate checks.-   runUntilRecompRequired []             = return (UpToDate, [])-   runUntilRecompRequired (check:checks) = do-     (recompile, value) <- check-     if recompileRequired recompile-       then return (recompile, [])-       else do-         (recomp, values) <- runUntilRecompRequired checks-         return (recomp, value:values)+   -- GHC.Prim is very special and doesn't appear in ms_textual_imps but+   -- ghc-prim will appear in the package dependencies still. In order to not confuse+   -- the recompilation logic we need to not forget we imported GHC.Prim.+   fake_ghc_prim_import =  case mhome_unit of+                              Just home_unit+                                | homeUnitId home_unit == primUnitId+                                -> Left (primUnitId, mkModuleName "GHC.Prim")+                              _ -> Right ("GHC.Prim", primUnitId) -   checkIfAllOldHomeDependenciesAreSeen seen_deps = do-     let unseen_old_deps = Set.difference-          old_deps-          seen_deps-     if not (null unseen_old_deps)-       then do-         let missing_dep = Set.elemAt 0 unseen_old_deps-         traceHiDiffs $-           text "missing old home dependency " <> quotes (ppr missing_dep)-         return $ RecompBecause "missing old dependency"-       else return UpToDate -needInterface :: Module -> (ModIface -> IfG RecompileRequired)+   classify _ (Found _ mod)+    | (toUnitId $ moduleUnit mod) `elem` all_home_units = Right (Left ((toUnitId $ moduleUnit mod), moduleName mod))+    | otherwise = Right (Right (moduleNameString (moduleName mod), toUnitId $ moduleUnit mod))+   classify reason _ = Left (RecompBecause reason)++   check_mods :: [(UnitId, ModuleName)] -> [(UnitId, ModuleName)] -> IO RecompileRequired+   check_mods [] [] = return UpToDate+   check_mods [] (old:_) = do+     -- This case can happen when a module is change from HPT to package import+     trace_hi_diffs logger $+      text "module no longer" <+> quotes (ppr old) <+>+        text "in dependencies"++     return $ needsRecompileBecause $ ModuleRemoved old+   check_mods (new:news) olds+    | Just (old, olds') <- uncons olds+    , new == old = check_mods (dropWhile (== new) news) olds'+    | otherwise = do+        trace_hi_diffs logger $+           text "imported module " <> quotes (ppr new) <>+           text " not among previous dependencies"+        return $ needsRecompileBecause $ ModuleAdded new++   check_packages :: [(String, UnitId)] -> [UnitId] -> IO RecompileRequired+   check_packages [] [] = return UpToDate+   check_packages [] (old:_) = do+     trace_hi_diffs logger $+      text "package " <> quotes (ppr old) <>+        text "no longer in dependencies"+     return $ needsRecompileBecause $ UnitDepRemoved old+   check_packages (new:news) olds+    | Just (old, olds') <- uncons olds+    , snd new == old = check_packages (dropWhile ((== (snd new)) . snd) news) olds'+    | otherwise = do+        trace_hi_diffs logger $+         text "imported package " <> quotes (ppr new) <>+           text " not among previous dependencies"+        return $ needsRecompileBecause $ ModulePackageChanged $ fst new+++needInterface :: Module -> (ModIface -> IO RecompileRequired)              -> IfG RecompileRequired needInterface mod continue   = do-      mb_recomp <- getFromModIface+      mb_recomp <- tryGetModIface         "need version info for"         mod-        continue       case mb_recomp of-        Nothing -> return MustCompile-        Just recomp -> return recomp+        Nothing -> return $ NeedsRecompile MustCompile+        Just iface -> liftIO $ continue iface -getFromModIface :: String -> Module -> (ModIface -> IfG a)-              -> IfG (Maybe a)-getFromModIface doc_msg mod getter+tryGetModIface :: String -> Module -> IfG (Maybe ModIface)+tryGetModIface doc_msg mod   = do  -- Load the imported interface if possible+    logger <- getLogger     let doc_str = sep [text doc_msg, ppr mod]-    traceHiDiffs (text "Checking innterface for module" <+> ppr mod)+    liftIO $ trace_hi_diffs logger (text "Checking interface for module" <+> ppr mod)      mb_iface <- loadInterface doc_str mod ImportBySystem         -- Load the interface, but don't complain on failure;@@ -571,141 +687,159 @@      case mb_iface of       Failed _ -> do-        traceHiDiffs (sep [text "Couldn't load interface for module",-                           ppr mod])+        liftIO $ trace_hi_diffs logger (sep [text "Couldn't load interface for module", ppr mod])         return Nothing                   -- Couldn't find or parse a module mentioned in the                   -- old interface file.  Don't complain: it might                   -- just be that the current module doesn't need that                   -- import and it's been deleted-      Succeeded iface -> Just <$> getter iface+      Succeeded iface -> pure $ Just iface  -- | Given the usage information extracted from the old -- M.hi file for the module being compiled, figure out -- whether M needs to be recompiled.-checkModUsage :: Unit -> Usage -> IfG RecompileRequired-checkModUsage _this_pkg UsagePackageModule{+checkModUsage :: FinderCache -> Unit -> Usage -> IfG RecompileRequired+checkModUsage _ _this_pkg UsagePackageModule{                                 usg_mod = mod,-                                usg_mod_hash = old_mod_hash }-  = needInterface mod $ \iface -> do-    let reason = moduleNameString (moduleName mod) ++ " changed"-    checkModuleFingerprint reason old_mod_hash (mi_mod_hash (mi_final_exts iface))+                                usg_mod_hash = old_mod_hash } = do+  logger <- getLogger+  needInterface mod $ \iface -> do+    let reason = ModuleChanged (moduleName mod)+    checkModuleFingerprint logger reason old_mod_hash (mi_mod_hash (mi_final_exts iface))         -- We only track the ABI hash of package modules, rather than         -- individual entity usages, so if the ABI hash changes we must         -- recompile.  This is safe but may entail more recompilation when         -- a dependent package has changed. -checkModUsage _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash }-  = needInterface mod $ \iface -> do-    let reason = moduleNameString (moduleName mod) ++ " changed (raw)"-    checkModuleFingerprint reason old_mod_hash (mi_mod_hash (mi_final_exts iface))+checkModUsage _ _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash } = do+  logger <- getLogger+  needInterface mod $ \iface -> do+    let reason = ModuleChangedRaw (moduleName mod)+    checkModuleFingerprint logger reason old_mod_hash (mi_mod_hash (mi_final_exts iface))+checkModUsage _ this_pkg UsageHomeModuleInterface{ usg_mod_name = mod_name, usg_iface_hash = old_mod_hash } = do+  let mod = mkModule this_pkg mod_name+  logger <- getLogger+  needInterface mod $ \iface -> do+    let reason = ModuleChangedIface mod_name+    checkIfaceFingerprint logger reason old_mod_hash (mi_iface_hash (mi_final_exts iface)) -checkModUsage this_pkg UsageHomeModule{+checkModUsage _ this_pkg UsageHomeModule{                                 usg_mod_name = mod_name,                                 usg_mod_hash = old_mod_hash,                                 usg_exports = maybe_old_export_hash,                                 usg_entities = old_decl_hash }   = do     let mod = mkModule this_pkg mod_name+    logger <- getLogger     needInterface mod $ \iface -> do--       let-           new_mod_hash    = mi_mod_hash (mi_final_exts iface)-           new_decl_hash   = mi_hash_fn  (mi_final_exts iface)-           new_export_hash = mi_exp_hash (mi_final_exts iface)+     let+         new_mod_hash    = mi_mod_hash (mi_final_exts iface)+         new_decl_hash   = mi_hash_fn  (mi_final_exts iface)+         new_export_hash = mi_exp_hash (mi_final_exts iface) -           reason = moduleNameString mod_name ++ " changed"+         reason = ModuleChanged (moduleName mod) +     liftIO $ do            -- CHECK MODULE-       recompile <- checkModuleFingerprint reason old_mod_hash new_mod_hash+       recompile <- checkModuleFingerprint logger reason old_mod_hash new_mod_hash        if not (recompileRequired recompile)          then return UpToDate-         else-           -- CHECK EXPORT LIST-           checkMaybeHash reason maybe_old_export_hash new_export_hash-               (text "  Export list changed") $ do--                 -- CHECK ITEMS ONE BY ONE-                 recompile <- checkList [ checkEntityUsage reason new_decl_hash u-                                        | u <- old_decl_hash]-                 if recompileRequired recompile-                   then return recompile     -- This one failed, so just bail out now-                   else up_to_date (text "  Great!  The bits I use are up to date")-+         else checkList+           [ -- CHECK EXPORT LIST+             checkMaybeHash logger reason maybe_old_export_hash new_export_hash+               (text "  Export list changed")+           , -- CHECK ITEMS ONE BY ONE+             checkList [ checkEntityUsage logger reason new_decl_hash u+                       | u <- old_decl_hash]+           , up_to_date logger (text "  Great!  The bits I use are up to date")+           ] -checkModUsage _this_pkg UsageFile{ usg_file_path = file,-                                   usg_file_hash = old_hash } =+checkModUsage fc _this_pkg UsageFile{ usg_file_path = file,+                                   usg_file_hash = old_hash,+                                   usg_file_label = mlabel } =   liftIO $     handleIO handler $ do-      new_hash <- getFileHash file+      new_hash <- lookupFileCache fc file       if (old_hash /= new_hash)          then return recomp          else return UpToDate  where-   recomp  = RecompBecause (file ++ " changed")-   handler =-#if defined(DEBUG)-       \e -> pprTrace "UsageFile" (text (show e)) $ return recomp-#else-       \_ -> return recomp -- if we can't find the file, just recompile, don't fail-#endif+   reason = FileChanged file+   recomp  = needsRecompileBecause $ fromMaybe reason $ fmap CustomReason mlabel+   handler = if debugIsOn+      then \e -> pprTrace "UsageFile" (text (show e)) $ return recomp+      else \_ -> return recomp -- if we can't find the file, just recompile, don't fail  -------------------------checkModuleFingerprint :: String -> Fingerprint -> Fingerprint-                       -> IfG RecompileRequired-checkModuleFingerprint reason old_mod_hash new_mod_hash+checkModuleFingerprint+  :: Logger+  -> RecompReason+  -> Fingerprint+  -> Fingerprint+  -> IO RecompileRequired+checkModuleFingerprint logger reason old_mod_hash new_mod_hash   | new_mod_hash == old_mod_hash-  = up_to_date (text "Module fingerprint unchanged")+  = up_to_date logger (text "Module fingerprint unchanged")    | otherwise-  = out_of_date_hash reason (text "  Module fingerprint has changed")+  = out_of_date_hash logger reason (text "  Module fingerprint has changed")                      old_mod_hash new_mod_hash +checkIfaceFingerprint+  :: Logger+  -> RecompReason+  -> Fingerprint+  -> Fingerprint+  -> IO RecompileRequired+checkIfaceFingerprint logger reason old_mod_hash new_mod_hash+  | new_mod_hash == old_mod_hash+  = up_to_date logger (text "Iface fingerprint unchanged")++  | otherwise+  = out_of_date_hash logger reason (text "  Iface fingerprint has changed")+                     old_mod_hash new_mod_hash+ -------------------------checkMaybeHash :: String -> Maybe Fingerprint -> Fingerprint -> SDoc-               -> IfG RecompileRequired -> IfG RecompileRequired-checkMaybeHash reason maybe_old_hash new_hash doc continue+checkMaybeHash+  :: Logger+  -> RecompReason+  -> Maybe Fingerprint+  -> Fingerprint+  -> SDoc+  -> IO RecompileRequired+checkMaybeHash logger reason maybe_old_hash new_hash doc   | Just hash <- maybe_old_hash, hash /= new_hash-  = out_of_date_hash reason doc hash new_hash+  = out_of_date_hash logger reason doc hash new_hash   | otherwise-  = continue+  = return UpToDate  -------------------------checkEntityUsage :: String+checkEntityUsage :: Logger+                 -> RecompReason                  -> (OccName -> Maybe (OccName, Fingerprint))                  -> (OccName, Fingerprint)-                 -> IfG RecompileRequired-checkEntityUsage reason new_hash (name,old_hash)-  = case new_hash name of--        Nothing       ->        -- We used it before, but it ain't there now-                          out_of_date reason (sep [text "No longer exported:", ppr name])--        Just (_, new_hash)      -- It's there, but is it up to date?-          | new_hash == old_hash -> do traceHiDiffs (text "  Up to date" <+> ppr name <+> parens (ppr new_hash))-                                       return UpToDate-          | otherwise            -> out_of_date_hash reason (text "  Out of date:" <+> ppr name)-                                                     old_hash new_hash--up_to_date :: SDoc -> IfG RecompileRequired-up_to_date  msg = traceHiDiffs msg >> return UpToDate--out_of_date :: String -> SDoc -> IfG RecompileRequired-out_of_date reason msg = traceHiDiffs msg >> return (RecompBecause reason)+                 -> IO RecompileRequired+checkEntityUsage logger reason new_hash (name,old_hash) = do+  case new_hash name of+    -- We used it before, but it ain't there now+    Nothing       -> out_of_date logger reason (sep [text "No longer exported:", ppr name])+    -- It's there, but is it up to date?+    Just (_, new_hash)+      | new_hash == old_hash+      -> do trace_hi_diffs logger (text "  Up to date" <+> ppr name <+> parens (ppr new_hash))+            return UpToDate+      | otherwise+      -> out_of_date_hash logger reason (text "  Out of date:" <+> ppr name) old_hash new_hash -out_of_date_hash :: String -> SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired-out_of_date_hash reason msg old_hash new_hash-  = out_of_date reason (hsep [msg, ppr old_hash, text "->", ppr new_hash])+up_to_date :: Logger -> SDoc -> IO RecompileRequired+up_to_date logger msg = trace_hi_diffs logger msg >> return UpToDate ------------------------checkList :: [IfG RecompileRequired] -> IfG RecompileRequired--- This helper is used in two places-checkList []             = return UpToDate-checkList (check:checks) = do recompile <- check-                              if recompileRequired recompile-                                then return recompile-                                else checkList checks+out_of_date :: Logger -> RecompReason -> SDoc -> IO RecompileRequired+out_of_date logger reason msg = trace_hi_diffs logger msg >> return (needsRecompileBecause reason) +out_of_date_hash :: Logger -> RecompReason -> SDoc -> Fingerprint -> Fingerprint -> IO RecompileRequired+out_of_date_hash logger reason msg old_hash new_hash+  = out_of_date logger reason (hsep [msg, ppr old_hash, text "->", ppr new_hash])  -- --------------------------------------------------------------------------- -- Compute fingerprints for the interface@@ -846,7 +980,7 @@                , let out = localOccs $ freeNamesDeclABI abi                ] -       name_module n = ASSERT2( isExternalName n, ppr n ) nameModule n+       name_module n = assertPpr (isExternalName n) (ppr n) (nameModule n)        localOccs =          map (getUnique . getParent . getOccName)                         -- NB: names always use semantic module, so@@ -889,7 +1023,7 @@           | isWiredInName name  =  putNameLiterally bh name            -- wired-in names don't have fingerprints           | otherwise-          = ASSERT2( isExternalName name, ppr name )+          = assertPpr (isExternalName name) (ppr name) $             let hash | nameModule name /= semantic_mod =  global_hash_fn name                      -- Get it from the REAL interface!!                      -- This will trigger when we compile an hsig file@@ -963,11 +1097,11 @@    (local_env, decls_w_hashes) <-        foldM fingerprint_group (emptyOccEnv, []) groups -   -- when calculating fingerprints, we always need to use canonical-   -- ordering for lists of things.  In particular, the mi_deps has various-   -- lists of modules and suchlike, so put these all in canonical order:+   -- when calculating fingerprints, we always need to use canonical ordering+   -- for lists of things. The mi_deps has various lists of modules and+   -- suchlike, which are stored in canonical order:    let sorted_deps :: Dependencies-       sorted_deps = sortDependencies (mi_deps iface0)+       sorted_deps = mi_deps iface0     -- The export hash of a module depends on the orphan hashes of the    -- orphan modules below us in the dependency tree.  This is the way@@ -1011,17 +1145,22 @@    orphan_hash <- computeFingerprint (mk_put_name local_env)                                      (map ifDFun orph_insts, orph_rules, orph_fis) +   -- Hash of the transitive things in dependencies+   dep_hash <- computeFingerprint putNameLiterally+                       (dep_sig_mods (mi_deps iface0),+                        dep_boot_mods (mi_deps iface0),+                        -- Trusted packages are like orphans+                        dep_trusted_pkgs (mi_deps iface0),+                       -- See Note [Export hash depends on non-orphan family instances]+                        dep_finsts (mi_deps iface0) )+    -- the export list hash doesn't depend on the fingerprints of    -- the Names it mentions, only the Names themselves, hence putNameLiterally.    export_hash <- computeFingerprint putNameLiterally                       (mi_exports iface0,                        orphan_hash,+                       dep_hash,                        dep_orphan_hashes,-                       dep_pkgs (mi_deps iface0),-                       -- See Note [Export hash depends on non-orphan family instances]-                       dep_finsts (mi_deps iface0),-                        -- dep_pkgs: see "Package Version Changes" on-                        -- wiki/commentary/compiler/recompilation-avoidance                        mi_trust iface0)                         -- Make sure change of Safe Haskell mode causes recomp. @@ -1068,7 +1207,7 @@     hpc_hash <- fingerprintHpcFlags dflags putNameLiterally -   plugin_hash <- fingerprintPlugins hsc_env+   plugin_hash <- fingerprintPlugins (hsc_plugins hsc_env)     -- the ABI hash depends on:    --   - decls@@ -1083,12 +1222,14 @@     -- The interface hash depends on:    --   - the ABI hash, plus+   --   - the source file hash,    --   - the module level annotations,    --   - usages    --   - deps (home and external packages, dependent files)    --   - hpc    iface_hash <- computeFingerprint putNameLiterally                       (mod_hash,+                       mi_src_hash iface0,                        ann_fn (mkVarOcc "module"),  -- See mkIfaceAnnCache                        mi_usages iface0,                        sorted_deps,@@ -1158,30 +1299,17 @@ -- to recompile C and everything else. getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint] getOrphanHashes hsc_env mods = do-  eps <- hscEPS hsc_env   let-    hpt        = hsc_HPT hsc_env-    pit        = eps_PIT eps-    get_orph_hash mod =-          case lookupIfaceByModule hpt pit mod of-            Just iface -> return (mi_orphan_hash (mi_final_exts iface))-            Nothing    -> do -- similar to 'mkHashFun'-                iface <- initIfaceLoad hsc_env . withException+    dflags     = hsc_dflags hsc_env+    ctx        = initSDocContext dflags defaultUserStyle+    get_orph_hash mod = do+          iface <- initIfaceLoad hsc_env . withException ctx                             $ loadInterface (text "getOrphanHashes") mod ImportBySystem-                return (mi_orphan_hash (mi_final_exts iface))+          return (mi_orphan_hash (mi_final_exts iface)) -  --   mapM get_orph_hash mods  -sortDependencies :: Dependencies -> Dependencies-sortDependencies d- = Deps { dep_mods   = sortBy (lexicalCompareFS `on` (moduleNameFS . gwib_mod)) (dep_mods d),-          dep_pkgs   = sortBy (compare `on` fst) (dep_pkgs d),-          dep_orphs  = sortBy stableModuleCmp (dep_orphs d),-          dep_finsts = sortBy stableModuleCmp (dep_finsts d),-          dep_plgins = sortBy (lexicalCompareFS `on` moduleNameFS) (dep_plgins d) }- {- ************************************************************************ *                                                                      *@@ -1373,6 +1501,7 @@   {- Note [default method Name] (see also #15970)+   ~~~~~~~~~~~~~~~~~~~~~~~~~~  The Names for the default methods aren't available in Iface syntax. @@ -1454,12 +1583,14 @@   = lookup orig_mod   where       home_unit = hsc_home_unit hsc_env-      hpt = hsc_HPT hsc_env+      dflags = hsc_dflags hsc_env+      hpt = hsc_HUG hsc_env       pit = eps_PIT eps+      ctx = initSDocContext dflags defaultUserStyle       occ = nameOccName name       orig_mod = nameModule name       lookup mod = do-        MASSERT2( isExternalName name, ppr name )+        massertPpr (isExternalName name) (ppr name)         iface <- case lookupIfaceByModule hpt pit mod of                   Just iface -> return iface                   Nothing ->@@ -1467,12 +1598,19 @@                       -- requirements; we didn't do any /real/ typechecking                       -- so there's no guarantee everything is loaded.                       -- Kind of a heinous hack.-                      initIfaceLoad hsc_env . withException+                      initIfaceLoad hsc_env . withException ctx                           $ withoutDynamicNow-                            -- For some unknown reason, we need to reset the-                            -- dynamicNow bit, otherwise only dynamic-                            -- interfaces are looked up and some tests fail-                            -- (e.g. T16219).+                            -- If you try and load interfaces when dynamic-too+                            -- enabled then it attempts to load the dyn_hi and hi+                            -- interface files. Backpack doesn't really care about+                            -- dynamic object files as it isn't doing any code+                            -- generation so -dynamic-too is turned off.+                            -- Some tests fail without doing this (such as T16219),+                            -- but they fail because dyn_hi files are not found for+                            -- one of the dependencies (because they are deliberately turned off)+                            -- Why is this check turned off here? That is unclear but+                            -- just one of the many horrible hacks in the backpack+                            -- implementation.                           $ loadInterface (text "lookupVers2") mod ImportBySystem         return $ snd (mi_hash_fn (mi_final_exts iface) occ `orElse`                   pprPanic "lookupVers1" (ppr mod <+> ppr occ))
compiler/GHC/Iface/Recomp/Flags.hs view
@@ -28,27 +28,26 @@ -- the finger print on important fields in @DynFlags@ so that -- the recompilation checker can use this fingerprint. ----- NB: The 'Module' parameter is the 'Module' recorded by the--- *interface* file, not the actual 'Module' according to our--- 'DynFlags'.+-- NB: The 'Module' parameter is the 'Module' recorded by the *interface*+-- file, not the actual 'Module' according to our 'DynFlags'. fingerprintDynFlags :: HscEnv -> Module                     -> (BinHandle -> Name -> IO ())                     -> IO Fingerprint  fingerprintDynFlags hsc_env this_mod nameio =     let dflags@DynFlags{..} = hsc_dflags hsc_env-        mainis   = if mainModIs hsc_env == this_mod then Just mainFunIs else Nothing+        mainis   = if mainModIs (hsc_HUE hsc_env) == this_mod then Just mainFunIs else Nothing                       -- see #5878         -- pkgopts  = (homeUnit home_unit, sort $ packageFlags dflags)         safeHs   = setSafeMode safeHaskell         -- oflags   = sort $ filter filterOFlags $ flags dflags -        -- *all* the extension flags and the language+        -- all the extension flags and the language         lang = (fmap fromEnum language,                 map fromEnum $ EnumSet.toList extensionFlags)          -- avoid fingerprinting the absolute path to the directory of the source file-        -- see note [Implicit include paths]+        -- see Note [Implicit include paths]         includePathsMinusImplicit = includePaths { includePathsQuoteImplicit = [] }          -- -I, -D and -U flags affect CPP@@ -66,7 +65,7 @@          -- Ticky         ticky =-          map (`gopt` dflags) [Opt_Ticky, Opt_Ticky_Allocd, Opt_Ticky_LNE, Opt_Ticky_Dyn_Thunk]+          map (`gopt` dflags) [Opt_Ticky, Opt_Ticky_Allocd, Opt_Ticky_LNE, Opt_Ticky_Dyn_Thunk, Opt_Ticky_Tag]          flags = ((mainis, safeHs, lang, cpp), (paths, prof, ticky, debugLevel, callerCcFilters)) @@ -109,7 +108,7 @@   {- Note [path flags and recompilation]-+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ There are several flags that we deliberately omit from the recompilation check; here we explain why. @@ -140,7 +139,6 @@  {- Note [Ignoring some flag changes]    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- Normally, --make tries to reuse only compilation products that are the same as those that would have been produced compiling from scratch. Sometimes, however, users would like to be more aggressive@@ -159,7 +157,6 @@  {- Note [Repeated -optP hashing]    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- We invoke fingerprintDynFlags for each compiled module to include the hash of relevant DynFlags in the resulting interface file. -optP (preprocessor) flags are part of that hash.
compiler/GHC/Iface/Rename.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}  -- | This module implements interface renaming, which is@@ -14,8 +14,6 @@     tcRnModExports,     ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Driver.Env@@ -27,10 +25,10 @@ import {-# SOURCE #-} GHC.Iface.Load -- a bit vexing  import GHC.Unit-import GHC.Unit.State import GHC.Unit.Module.ModIface import GHC.Unit.Module.Deps +import GHC.Tc.Errors.Types import GHC.Types.SrcLoc import GHC.Types.Unique.FM import GHC.Types.Avail@@ -43,21 +41,20 @@  import GHC.Utils.Outputable import GHC.Utils.Misc+import GHC.Utils.Error import GHC.Utils.Fingerprint import GHC.Utils.Panic -import GHC.Data.Bag- import qualified Data.Traversable as T  import Data.IORef -tcRnMsgMaybe :: IO (Either ErrorMessages a) -> TcM a+tcRnMsgMaybe :: IO (Either (Messages TcRnMessage) a) -> TcM a tcRnMsgMaybe do_this = do     r <- liftIO $ do_this     case r of-        Left errs -> do-            addMessages (mkMessages errs)+        Left msgs -> do+            addMessages msgs             failM         Right x -> return x @@ -71,12 +68,13 @@     hsc_env <- getTopEnv     tcRnMsgMaybe $ rnModExports hsc_env x y -failWithRn :: SDoc -> ShIfM a-failWithRn doc = do+failWithRn :: TcRnMessage -> ShIfM a+failWithRn tcRnMessage = do     errs_var <- fmap sh_if_errs getGblEnv     errs <- readTcRef errs_var     -- TODO: maybe associate this with a source location?-    writeTcRef errs_var (errs `snocBag` mkPlainMsgEnvelope noSrcSpan doc)+    let msg = mkPlainErrorMsgEnvelope noSrcSpan tcRnMessage+    writeTcRef errs_var (msg `addMessage` errs)     failM  -- | What we have is a generalized ModIface, which corresponds to@@ -100,7 +98,7 @@ -- should be Foo.T; then we'll also rename this (this is used -- when loading an interface to merge it into a requirement.) rnModIface :: HscEnv -> [(ModuleName, Module)] -> Maybe NameShape-           -> ModIface -> IO (Either ErrorMessages ModIface)+           -> ModIface -> IO (Either (Messages TcRnMessage) ModIface) rnModIface hsc_env insts nsubst iface =     initRnIface hsc_env iface insts nsubst $ do         mod <- rnModule (mi_module iface)@@ -124,25 +122,24 @@  -- | Rename just the exports of a 'ModIface'.  Useful when we're doing -- shaping prior to signature merging.-rnModExports :: HscEnv -> [(ModuleName, Module)] -> ModIface -> IO (Either ErrorMessages [AvailInfo])+rnModExports :: HscEnv -> [(ModuleName, Module)] -> ModIface -> IO (Either (Messages TcRnMessage) [AvailInfo]) rnModExports hsc_env insts iface     = initRnIface hsc_env iface insts Nothing     $ mapM rnAvailInfo (mi_exports iface)  rnDependencies :: Rename Dependencies-rnDependencies deps = do-    orphs  <- rnDepModules dep_orphs deps-    finsts <- rnDepModules dep_finsts deps-    return deps { dep_orphs = orphs, dep_finsts = finsts }+rnDependencies deps0 = do+    deps1  <- dep_orphs_update deps0 (rnDepModules dep_orphs)+    dep_finsts_update deps1 (rnDepModules dep_finsts) -rnDepModules :: (Dependencies -> [Module]) -> Dependencies -> ShIfM [Module]-rnDepModules sel deps = do+rnDepModules :: (Dependencies -> [Module]) -> [Module] -> ShIfM [Module]+rnDepModules sel mods = do     hsc_env <- getTopEnv     hmap <- getHoleSubst     -- NB: It's not necessary to test if we're doing signature renaming,     -- because ModIface will never contain module reference for itself     -- in these dependencies.-    fmap (nubSort . concat) . T.forM (sel deps) $ \mod -> do+    fmap (nubSort . concat) . T.forM mods $ \mod -> do         -- For holes, its necessary to "see through" the instantiation         -- of the hole to get accurate family instance dependencies.         -- For example, if B imports <A>, and <A> is instantiated with@@ -184,9 +181,9 @@  -- | Run a computation in the 'ShIfM' monad. initRnIface :: HscEnv -> ModIface -> [(ModuleName, Module)] -> Maybe NameShape-            -> ShIfM a -> IO (Either ErrorMessages a)+            -> ShIfM a -> IO (Either (Messages TcRnMessage) a) initRnIface hsc_env iface insts nsubst do_this = do-    errs_var <- newIORef emptyBag+    errs_var <- newIORef emptyMessages     let hsubst = listToUFM insts         rn_mod = renameHoleModule (hsc_units hsc_env) hsubst         env = ShIfEnv {@@ -200,9 +197,9 @@     res <- initTcRnIf 'c' hsc_env env () $ tryM do_this     msgs <- readIORef errs_var     case res of-        Left _                          -> return (Left msgs)-        Right r | not (isEmptyBag msgs) -> return (Left msgs)-                | otherwise             -> return (Right r)+        Left _                               -> return (Left msgs)+        Right r | not (isEmptyMessages msgs) -> return (Left msgs)+                | otherwise                  -> return (Right r)  -- | Environment for 'ShIfM' monads. data ShIfEnv = ShIfEnv {@@ -220,8 +217,8 @@         -- we just load the target interface and look at the export         -- list to determine the renaming.         sh_if_shape :: Maybe NameShape,-        -- Mutable reference to keep track of errors (similar to 'tcl_errs')-        sh_if_errs :: IORef ErrorMessages+        -- Mutable reference to keep track of diagnostics (similar to 'tcl_errs')+        sh_if_errs :: IORef (Messages TcRnMessage)     }  getHoleSubst :: ShIfM ShHoleSubst@@ -248,7 +245,8 @@     ns' <- mapM rnGreName ns     case ns' of         [] -> panic "rnAvailInfoEmpty AvailInfo"-        (rep:rest) -> ASSERT2( all ((== childModule rep) . childModule) rest, ppr rep $$ hcat (map ppr rest) ) do+        (rep:rest) -> assertPpr (all ((== childModule rep) . childModule) rest)+                                (ppr rep $$ hcat (map ppr rest)) $ do                          n' <- setNameModule (Just (childModule rep)) n                          return (AvailTC n' ns')   where@@ -328,11 +326,8 @@                         -- TODO: This will give an unpleasant message if n'                         -- is a constructor; then we'll suggest adding T                         -- but it won't work.-                        Nothing -> failWithRn $ vcat [-                            text "The identifier" <+> ppr (occName n') <+>-                                text "does not exist in the local signature.",-                            parens (text "Try adding it to the export list of the hsig file.")-                            ]+                        Nothing ->+                          failWithRn $ TcRnIdNotExportedFromLocalSig n'                         Just n'' -> return n''        -- Fastpath: we are renaming p[H=<H>]:A.T, in which case the        -- export list is irrelevant.@@ -355,12 +350,8 @@                             $ loadSysInterface (text "rnIfaceGlobal") m''             let nsubst = mkNameShape (moduleName m) (mi_exports iface)             case maybeSubstNameShape nsubst n of-                Nothing -> failWithRn $ vcat [-                    text "The identifier" <+> ppr (occName n) <+>-                        -- NB: report m' because it's more user-friendly-                        text "does not exist in the signature for" <+> ppr m',-                    parens (text "Try adding it to the export list in that hsig file.")-                    ]+                -- NB: report m' because it's more user-friendly+                Nothing -> failWithRn $ TcRnIdNotExportedFromModuleSig n m'                 Just n' -> return n'  -- | Rename an implicit name, e.g., a DFun or coercion axiom.@@ -373,7 +364,7 @@     iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv     let m = renameHoleModule unit_state hmap $ nameModule name     -- Doublecheck that this DFun/coercion axiom was, indeed, locally defined.-    MASSERT2( iface_semantic_mod == m, ppr iface_semantic_mod <+> ppr m )+    massertPpr (iface_semantic_mod == m) (ppr iface_semantic_mod <+> ppr m)     setNameModule (Just m) name  -- Note [rnIfaceNeverExported]
compiler/GHC/Iface/Tidy.hs view
@@ -1,39 +1,33 @@-{-# LANGUAGE CPP           #-}+ {-# LANGUAGE DeriveFunctor #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-# LANGUAGE NamedFieldPuns #-}  {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998--\section{Tidying up Core} -} -module GHC.Iface.Tidy (-       mkBootModDetailsTc, tidyProgram-   ) where--#include "GhclibHsVersions.h"+-- | Tidying up Core+module GHC.Iface.Tidy+  ( TidyOpts (..)+  , UnfoldingExposure (..)+  , tidyProgram+  , mkBootModDetailsTc+  )+where  import GHC.Prelude -import GHC.Driver.Session-import GHC.Driver.Backend-import GHC.Driver.Ppr-import GHC.Driver.Env- import GHC.Tc.Types+import GHC.Tc.Utils.Env  import GHC.Core import GHC.Core.Unfold import GHC.Core.Unfold.Make import GHC.Core.FVs import GHC.Core.Tidy-import GHC.Core.Opt.Monad-import GHC.Core.Stats   (coreBindsStats, CoreStats(..)) import GHC.Core.Seq     (seqBinds)-import GHC.Core.Lint-import GHC.Core.Rules import GHC.Core.Opt.Arity   ( exprArity, exprBotStrictness_maybe ) import GHC.Core.InstEnv import GHC.Core.Type     ( tidyTopType )@@ -44,12 +38,10 @@ import GHC.Iface.Tidy.StaticPtrTable import GHC.Iface.Env -import GHC.Tc.Utils.Env-import GHC.Tc.Utils.Monad- import GHC.Utils.Outputable import GHC.Utils.Misc( filterOut ) import GHC.Utils.Panic+import GHC.Utils.Trace import GHC.Utils.Logger as Logger import qualified GHC.Utils.Error as Err @@ -66,9 +58,7 @@ import GHC.Types.Name hiding (varName) import GHC.Types.Name.Set import GHC.Types.Name.Cache-import GHC.Types.Name.Ppr import GHC.Types.Avail-import GHC.Types.Unique.Supply import GHC.Types.Tickish import GHC.Types.TypeEnv @@ -82,7 +72,8 @@ import Control.Monad import Data.Function import Data.List        ( sortBy, mapAccumL )-import Data.IORef       ( atomicModifyIORef' )+import qualified Data.Set as S+import GHC.Types.CostCentre  {- Constructing the TypeEnv, Instances, Rules from which the@@ -150,8 +141,8 @@ -- We don't look at the bindings at all -- there aren't any -- for hs-boot files -mkBootModDetailsTc :: HscEnv -> TcGblEnv -> IO ModDetails-mkBootModDetailsTc hsc_env+mkBootModDetailsTc :: Logger -> TcGblEnv -> IO ModDetails+mkBootModDetailsTc logger         TcGblEnv{ tcg_exports          = exports,                   tcg_type_env         = type_env, -- just for the Ids                   tcg_tcs              = tcs,@@ -163,7 +154,7 @@                 }   = -- This timing isn't terribly useful since the result isn't forced, but     -- the message is useful to locating oneself in the compilation process.-    Err.withTiming logger dflags+    Err.withTiming logger                    (text "CoreTidy"<+>brackets (ppr this_mod))                    (const ()) $     return (ModDetails { md_types            = type_env'@@ -175,9 +166,6 @@                        , md_complete_matches = complete_matches                        })   where-    dflags = hsc_dflags hsc_env-    logger = hsc_logger hsc_env-     -- Find the LocalIds in the type env that are exported     -- Make them into GlobalIds, and tidy their types     --@@ -196,7 +184,7 @@     final_tcs  = filterOut isWiredIn tcs                  -- See Note [Drop wired-in things]     type_env'  = typeEnvFromEntities final_ids final_tcs pat_syns fam_insts-    insts'     = mkFinalClsInsts type_env' insts+    insts'     = mkFinalClsInsts type_env' $ mkInstEnv insts      -- Default methods have their export flag set (isExportedId),     -- but everything else doesn't (yet), because this is@@ -217,8 +205,8 @@       Just (AnId id') -> id'       _ -> pprPanic "lookup_final_id" (ppr id) -mkFinalClsInsts :: TypeEnv -> [ClsInst] -> [ClsInst]-mkFinalClsInsts env = map (updateClsInstDFun (lookupFinalId env))+mkFinalClsInsts :: TypeEnv -> InstEnv -> InstEnv+mkFinalClsInsts env = updateClsInstDFuns (lookupFinalId env)  globaliseAndTidyBootId :: Id -> Id -- For a LocalId with an External Name,@@ -307,8 +295,7 @@     [Even non-exported things need system-wide Uniques because the     byte-code generator builds a single Name->BCO symbol table.] -    We use the NameCache kept in the HscEnv as the-    source of such system-wide uniques.+    We use the given NameCache as the source of such system-wide uniques.      For external Ids, use the original-name cache in the NameCache     to ensure that the unique assigned is the same as the Id had@@ -352,145 +339,181 @@   load a compulsory unfolding -} -tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)-tidyProgram hsc_env  (ModGuts { mg_module           = mod-                              , mg_exports          = exports-                              , mg_rdr_env          = rdr_env-                              , mg_tcs              = tcs-                              , mg_insts            = cls_insts-                              , mg_fam_insts        = fam_insts-                              , mg_binds            = binds-                              , mg_patsyns          = patsyns-                              , mg_rules            = imp_rules-                              , mg_anns             = anns-                              , mg_complete_matches = complete_matches-                              , mg_deps             = deps-                              , mg_foreign          = foreign_stubs-                              , mg_foreign_files    = foreign_files-                              , mg_hpc_info         = hpc_info-                              , mg_modBreaks        = modBreaks-                              })+data UnfoldingExposure+  = ExposeNone -- ^ Don't expose unfoldings+  | ExposeSome -- ^ Only expose required unfoldings+  | ExposeAll  -- ^ Expose all unfoldings+  deriving (Show,Eq,Ord) -  = Err.withTiming logger dflags-                   (text "CoreTidy"<+>brackets (ppr mod))-                   (const ()) $-    do  { let { omit_prags = gopt Opt_OmitInterfacePragmas dflags-              ; expose_all = gopt Opt_ExposeAllUnfoldings  dflags-              ; print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env-              ; implicit_binds = concatMap getImplicitBinds tcs-              }+data TidyOpts = TidyOpts+  { opt_name_cache        :: !NameCache+  , opt_collect_ccs       :: !Bool -- ^ Always true if we compile with -prof+  , opt_unfolding_opts    :: !UnfoldingOpts+  , opt_expose_unfoldings :: !UnfoldingExposure+      -- ^ Which unfoldings to expose+  , opt_trim_ids :: !Bool+      -- ^ trim off the arity, one-shot-ness, strictness etc which were+      -- retained for the benefit of the code generator+  , opt_expose_rules :: !Bool+      -- ^ Are rules exposed or not?+  , opt_static_ptr_opts :: !(Maybe StaticPtrOpts)+      -- ^ Options for generated static pointers, if enabled (/= Nothing).+  } -        ; (unfold_env, tidy_occ_env)-              <- chooseExternalIds hsc_env mod omit_prags expose_all-                                   binds implicit_binds imp_rules-        ; let { (trimmed_binds, trimmed_rules)-                    = findExternalRules omit_prags binds imp_rules unfold_env }+tidyProgram :: TidyOpts -> ModGuts -> IO (CgGuts, ModDetails)+tidyProgram opts (ModGuts { mg_module           = mod+                          , mg_exports          = exports+                          , mg_tcs              = tcs+                          , mg_insts            = cls_insts+                          , mg_fam_insts        = fam_insts+                          , mg_binds            = binds+                          , mg_patsyns          = patsyns+                          , mg_rules            = imp_rules+                          , mg_anns             = anns+                          , mg_complete_matches = complete_matches+                          , mg_deps             = deps+                          , mg_foreign          = foreign_stubs+                          , mg_foreign_files    = foreign_files+                          , mg_hpc_info         = hpc_info+                          , mg_modBreaks        = modBreaks+                          , mg_boot_exports     = boot_exports+                          }) = do -        ; let uf_opts = unfoldingOpts dflags-        ; (tidy_env, tidy_binds)-                 <- tidyTopBinds uf_opts unfold_env tidy_occ_env trimmed_binds+  let implicit_binds = concatMap getImplicitBinds tcs -          -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.-        ; (spt_entries, tidy_binds') <--             sptCreateStaticBinds hsc_env mod tidy_binds-        ; let { platform = targetPlatform (hsc_dflags hsc_env)-              ; spt_init_code = sptModuleInitCode platform mod spt_entries-              ; add_spt_init_code =-                  case backend dflags of-                    -- If we are compiling for the interpreter we will insert-                    -- any necessary SPT entries dynamically-                    Interpreter -> id-                    -- otherwise add a C stub to do so-                    _              -> (`appendStubC` spt_init_code)+  (unfold_env, tidy_occ_env) <- chooseExternalIds opts mod binds implicit_binds imp_rules+  let (trimmed_binds, trimmed_rules) = findExternalRules opts binds imp_rules unfold_env -              -- The completed type environment is gotten from-              --      a) the types and classes defined here (plus implicit things)-              --      b) adding Ids with correct IdInfo, including unfoldings,-              --              gotten from the bindings-              -- From (b) we keep only those Ids with External names;-              --          the CoreTidy pass makes sure these are all and only-              --          the externally-accessible ones-              -- This truncates the type environment to include only the-              -- exported Ids and things needed from them, which saves space-              ---              -- See Note [Don't attempt to trim data types]-              ; final_ids  = [ trimId omit_prags id-                             | id <- bindersOfBinds tidy_binds-                             , isExternalName (idName id)-                             , not (isWiredIn id)-                             ]   -- See Note [Drop wired-in things]+  let uf_opts = opt_unfolding_opts opts+  (tidy_env, tidy_binds) <- tidyTopBinds uf_opts unfold_env boot_exports tidy_occ_env trimmed_binds -              ; final_tcs      = filterOut isWiredIn tcs-                                 -- See Note [Drop wired-in things]-              ; tidy_type_env  = typeEnvFromEntities final_ids final_tcs patsyns fam_insts-              ; tidy_cls_insts = mkFinalClsInsts tidy_type_env cls_insts-              ; tidy_rules     = tidyRules tidy_env trimmed_rules+  -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.+  (spt_entries, mcstub, tidy_binds') <- case opt_static_ptr_opts opts of+    Nothing    -> pure ([], Nothing, tidy_binds)+    Just sopts -> sptCreateStaticBinds sopts mod tidy_binds -              ; -- See Note [Injecting implicit bindings]-                all_tidy_binds = implicit_binds ++ tidy_binds'+  let all_foreign_stubs = case mcstub of+        Nothing    -> foreign_stubs+        Just cstub -> foreign_stubs `appendStubC` cstub -              -- Get the TyCons to generate code for.  Careful!  We must use-              -- the untidied TyCons here, because we need-              --  (a) implicit TyCons arising from types and classes defined-              --      in this module-              --  (b) wired-in TyCons, which are normally removed from the-              --      TypeEnv we put in the ModDetails-              --  (c) Constructors even if they are not exported (the-              --      tidied TypeEnv has trimmed these away)-              ; alg_tycons = filter isAlgTyCon tcs-              }+      -- The completed type environment is gotten from+      --      a) the types and classes defined here (plus implicit things)+      --      b) adding Ids with correct IdInfo, including unfoldings,+      --              gotten from the bindings+      -- From (b) we keep only those Ids with External names;+      --          the CoreTidy pass makes sure these are all and only+      --          the externally-accessible ones+      -- This truncates the type environment to include only the+      -- exported Ids and things needed from them, which saves space+      --+      -- See Note [Don't attempt to trim data types]+      final_ids  = [ trimId (opt_trim_ids opts) id+                   | id <- bindersOfBinds tidy_binds+                   , isExternalName (idName id)+                   , not (isWiredIn id)+                   ]   -- See Note [Drop wired-in things] -        ; endPassIO hsc_env print_unqual CoreTidy all_tidy_binds tidy_rules+      final_tcs      = filterOut isWiredIn tcs+                       -- See Note [Drop wired-in things]+      tidy_type_env  = typeEnvFromEntities final_ids final_tcs patsyns fam_insts+      tidy_cls_insts = mkFinalClsInsts tidy_type_env $ mkInstEnv cls_insts+      tidy_rules     = tidyRules tidy_env trimmed_rules -          -- If the endPass didn't print the rules, but ddump-rules is-          -- on, print now-        ; unless (dopt Opt_D_dump_simpl dflags) $-            Logger.dumpIfSet_dyn logger dflags Opt_D_dump_rules-              (showSDoc dflags (ppr CoreTidy <+> text "rules"))-              FormatText-              (pprRulesForUser tidy_rules)+      -- See Note [Injecting implicit bindings]+      all_tidy_binds = implicit_binds ++ tidy_binds' -          -- Print one-line size info-        ; let cs = coreBindsStats tidy_binds-        ; Logger.dumpIfSet_dyn logger dflags Opt_D_dump_core_stats "Core Stats"-            FormatText-            (text "Tidy size (terms,types,coercions)"-             <+> ppr (moduleName mod) <> colon-             <+> int (cs_tm cs)-             <+> int (cs_ty cs)-             <+> int (cs_co cs) )+      -- Get the TyCons to generate code for.  Careful!  We must use+      -- the untidied TyCons here, because we need+      --  (a) implicit TyCons arising from types and classes defined+      --      in this module+      --  (b) wired-in TyCons, which are normally removed from the+      --      TypeEnv we put in the ModDetails+      --  (c) Constructors even if they are not exported (the+      --      tidied TypeEnv has trimmed these away)+      alg_tycons = filter isAlgTyCon tcs -        ; return (CgGuts { cg_module   = mod,-                           cg_tycons   = alg_tycons,-                           cg_binds    = all_tidy_binds,-                           cg_foreign  = add_spt_init_code foreign_stubs,-                           cg_foreign_files = foreign_files,-                           cg_dep_pkgs = map fst $ dep_pkgs deps,-                           cg_hpc_info = hpc_info,-                           cg_modBreaks = modBreaks,-                           cg_spt_entries = spt_entries },+      local_ccs+        | opt_collect_ccs opts+              = collectCostCentres mod all_tidy_binds tidy_rules+        | otherwise+              = S.empty -                   ModDetails { md_types            = tidy_type_env,-                                md_rules            = tidy_rules,-                                md_insts            = tidy_cls_insts,-                                md_fam_insts        = fam_insts,-                                md_exports          = exports,-                                md_anns             = anns,      -- are already tidy-                                md_complete_matches = complete_matches-                              })-        }+  return (CgGuts { cg_module        = mod+                 , cg_tycons        = alg_tycons+                 , cg_binds         = all_tidy_binds+                 , cg_ccs           = S.toList local_ccs+                 , cg_foreign       = all_foreign_stubs+                 , cg_foreign_files = foreign_files+                 , cg_dep_pkgs      = dep_direct_pkgs deps+                 , cg_hpc_info      = hpc_info+                 , cg_modBreaks     = modBreaks+                 , cg_spt_entries   = spt_entries+                 }+         , ModDetails { md_types            = tidy_type_env+                      , md_rules            = tidy_rules+                      , md_insts            = tidy_cls_insts+                      , md_fam_insts        = fam_insts+                      , md_exports          = exports+                      , md_anns             = anns      -- are already tidy+                      , md_complete_matches = complete_matches+                      }+         )+++------------------------------------------------------------------------------+-- Collecting cost centres+-- ---------------------------------------------------------------------------++-- | Collect cost centres defined in the current module, including those in+-- unfoldings.+collectCostCentres :: Module -> CoreProgram -> [CoreRule] -> S.Set CostCentre+collectCostCentres mod_name binds rules+  = {-# SCC collectCostCentres #-} foldl' go_bind (go_rules S.empty) binds   where-    dflags = hsc_dflags hsc_env-    logger = hsc_logger hsc_env+    go cs e = case e of+      Var{} -> cs+      Lit{} -> cs+      App e1 e2 -> go (go cs e1) e2+      Lam _ e -> go cs e+      Let b e -> go (go_bind cs b) e+      Case scrt _ _ alts -> go_alts (go cs scrt) alts+      Cast e _ -> go cs e+      Tick (ProfNote cc _ _) e ->+        go (if ccFromThisModule cc mod_name then S.insert cc cs else cs) e+      Tick _ e -> go cs e+      Type{} -> cs+      Coercion{} -> cs +    go_alts = foldl' (\cs (Alt _con _bndrs e) -> go cs e)++    go_bind :: S.Set CostCentre -> CoreBind -> S.Set CostCentre+    go_bind cs (NonRec b e) =+      go (do_binder cs b) e+    go_bind cs (Rec bs) =+      foldl' (\cs' (b, e) -> go (do_binder cs' b) e) cs bs++    do_binder cs b = maybe cs (go cs) (get_unf b)+++    -- Unfoldings may have cost centres that in the original definion are+    -- optimized away, see #5889.+    get_unf = maybeUnfoldingTemplate . realIdUnfolding++    -- Have to look at the RHS of rules as well, as these may contain ticks which+    -- don't appear anywhere else. See #19894+    go_rules cs = foldl' go cs (mapMaybe get_rhs rules)++    get_rhs Rule { ru_rhs } = Just ru_rhs+    get_rhs BuiltinRule {} = Nothing+ -------------------------- trimId :: Bool -> Id -> Id -- With -O0 we now trim off the arity, one-shot-ness, strictness -- etc which tidyTopIdInfo retains for the benefit of the code generator -- but which we don't want in the interface file or ModIface for -- downstream compilations-trimId omit_prags id-  | omit_prags, not (isImplicitId id)+trimId do_trim id+  | do_trim, not (isImplicitId id)   = id `setIdInfo`      vanillaIdInfo        `setIdUnfolding` idUnfolding id        -- We respect the final unfolding chosen by tidyTopIdInfo.@@ -621,21 +644,20 @@   --   -- Bool => expose unfolding or not. -chooseExternalIds :: HscEnv+chooseExternalIds :: TidyOpts                   -> Module-                  -> Bool -> Bool                   -> [CoreBind]                   -> [CoreBind]                   -> [CoreRule]                   -> IO (UnfoldEnv, TidyOccEnv)                   -- Step 1 from the notes above -chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_rules+chooseExternalIds opts mod binds implicit_binds imp_id_rules   = do { (unfold_env1,occ_env1) <- search init_work_list emptyVarEnv init_occ_env        ; let internal_ids = filter (not . (`elemVarEnv` unfold_env1)) binders        ; tidy_internal internal_ids unfold_env1 occ_env1 }  where-  nc_var = hsc_NC hsc_env+  name_cache = opt_name_cache opts    -- init_ext_ids is the initial list of Ids that should be   -- externalised.  It serves as the starting point for finding a@@ -649,11 +671,14 @@   init_ext_ids   = sortBy (compare `on` getOccName) $ filter is_external binders    -- An Id should be external if either (a) it is exported,-  -- (b) it appears in the RHS of a local rule for an imported Id, or-  -- See Note [Which rules to expose]-  is_external id = isExportedId id || id `elemVarSet` rule_rhs_vars+  -- (b) local rules are exposed and it appears in the RHS of a local rule for+  -- an imported Id, or See Note [Which rules to expose]+  is_external id+    | isExportedId id       = True+    | opt_expose_rules opts = id `elemVarSet` rule_rhs_vars+    | otherwise             = False -  rule_rhs_vars  = mapUnionVarSet ruleRhsFreeVars imp_id_rules+  rule_rhs_vars = mapUnionVarSet ruleRhsFreeVars imp_id_rules    binders          = map fst $ flattenBinds binds   implicit_binders = bindersOfBinds implicit_binds@@ -697,15 +722,15 @@   search ((idocc,referrer) : rest) unfold_env occ_env     | idocc `elemVarEnv` unfold_env = search rest unfold_env occ_env     | otherwise = do-      (occ_env', name') <- tidyTopName mod nc_var (Just referrer) occ_env idocc+      (occ_env', name') <- tidyTopName mod name_cache (Just referrer) occ_env idocc       let-          (new_ids, show_unfold) = addExternal omit_prags expose_all refined_id+          (new_ids, show_unfold) = addExternal opts refined_id                  -- 'idocc' is an *occurrence*, but we need to see the                 -- unfolding in the *definition*; so look up in binder_set           refined_id = case lookupVarSet binder_set idocc of                          Just id -> id-                         Nothing -> WARN( True, ppr idocc ) idocc+                         Nothing -> warnPprTrace True "chooseExternalIds" (ppr idocc) idocc            unfold_env' = extendVarEnv unfold_env idocc (name',show_unfold)           referrer' | isExportedId refined_id = refined_id@@ -717,13 +742,13 @@                 -> IO (UnfoldEnv, TidyOccEnv)   tidy_internal []       unfold_env occ_env = return (unfold_env,occ_env)   tidy_internal (id:ids) unfold_env occ_env = do-      (occ_env', name') <- tidyTopName mod nc_var Nothing occ_env id+      (occ_env', name') <- tidyTopName mod name_cache Nothing occ_env id       let unfold_env' = extendVarEnv unfold_env id (name',False)       tidy_internal ids unfold_env' occ_env' -addExternal :: Bool -> Bool -> Id -> ([Id], Bool)-addExternal omit_prags expose_all id-  | omit_prags+addExternal :: TidyOpts -> Id -> ([Id], Bool)+addExternal opts id+  | ExposeNone <- opt_expose_unfoldings opts   , not (isCompulsoryUnfolding unfolding)   = ([], False)  -- See Note [Always expose compulsory unfoldings]                  -- in GHC.HsToCore@@ -734,27 +759,38 @@   where     new_needed_ids = bndrFvsInOrder show_unfold id     idinfo         = idInfo id-    unfolding      = unfoldingInfo idinfo+    unfolding      = realUnfoldingInfo idinfo     show_unfold    = show_unfolding unfolding     never_active   = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo))     loop_breaker   = isStrongLoopBreaker (occInfo idinfo)-    bottoming_fn   = isDeadEndSig (strictnessInfo idinfo)+    bottoming_fn   = isDeadEndSig (dmdSigInfo idinfo)          -- Stuff to do with the Id's unfolding         -- We leave the unfolding there even if there is a worker         -- In GHCi the unfolding is used by importers      show_unfolding (CoreUnfolding { uf_src = src, uf_guidance = guidance })-       =  expose_all         -- 'expose_all' says to expose all-                             -- unfoldings willy-nilly+       = opt_expose_unfoldings opts == ExposeAll+            -- 'ExposeAll' says to expose all+            -- unfoldings willy-nilly         || isStableSource src     -- Always expose things whose                                  -- source is an inline rule -       || not (bottoming_fn      -- No need to inline bottom functions-           || never_active       -- Or ones that say not to-           || loop_breaker       -- Or that are loop breakers-           || neverUnfoldGuidance guidance)+       || not dont_inline+       where+         dont_inline+            | never_active = True   -- Will never inline+            | loop_breaker = True   -- Ditto+            | otherwise    = case guidance of+                                UnfWhen {}       -> False+                                UnfIfGoodArgs {} -> bottoming_fn+                                UnfNever {}      -> True+         -- bottoming_fn: don't inline bottoming functions, unless the+         -- RHS is very small or trivial (UnfWhen), in which case we+         -- may as well do so For example, a cast might cancel with+         -- the call site.+     show_unfolding (DFunUnfolding {}) = True     show_unfolding _                  = False @@ -848,7 +884,7 @@ -- For top-level bindings (call from addExternal, via bndrFvsInOrder) --       we say "True" if we are exposing that unfolding dffvLetBndr vanilla_unfold id-  = do { go_unf (unfoldingInfo idinfo)+  = do { go_unf (realUnfoldingInfo idinfo)        ; mapM_ go_rule (ruleInfoRules (ruleInfo idinfo)) }   where     idinfo = idInfo id@@ -931,13 +967,13 @@ This stuff is the only reason for the ru_auto field in a Rule. -} -findExternalRules :: Bool       -- Omit pragmas+findExternalRules :: TidyOpts                   -> [CoreBind]                   -> [CoreRule] -- Local rules for imported fns                   -> UnfoldEnv  -- Ids that are exported, so we need their rules                   -> ([CoreBind], [CoreRule]) -- See Note [Finding external rules]-findExternalRules omit_prags binds imp_id_rules unfold_env+findExternalRules opts binds imp_id_rules unfold_env   = (trimmed_binds, filter keep_rule all_rules)   where     imp_rules         = filter expose_rule imp_id_rules@@ -962,7 +998,7 @@         --      been discarded; see Note [Trimming auto-rules]      expose_rule rule-        | omit_prags = False+        | not (opt_expose_rules opts) = False         | otherwise  = all is_external_id (ruleLhsFreeIdsList rule)                 -- Don't expose a rule whose LHS mentions a locally-defined                 -- Id that is completely internal (i.e. not visible to an@@ -1024,9 +1060,9 @@ we intend to externalise it. -} -tidyTopName :: Module -> IORef NameCache -> Maybe Id -> TidyOccEnv+tidyTopName :: Module -> NameCache -> Maybe Id -> TidyOccEnv             -> Id -> IO (TidyOccEnv, Name)-tidyTopName mod nc_var maybe_ref occ_env id+tidyTopName mod name_cache maybe_ref occ_env id   | global && internal = return (occ_env, localiseName name)    | global && external = return (occ_env, name)@@ -1037,16 +1073,23 @@   -- Now we get to the real reason that all this is in the IO Monad:   -- we have to update the name cache in a nice atomic fashion -  | local  && internal = do { new_local_name <- atomicModifyIORef' nc_var mk_new_local-                            ; return (occ_env', new_local_name) }+  | local  && internal = do uniq <- takeUniqFromNameCache name_cache+                            let new_local_name = mkInternalName uniq occ' loc+                            return (occ_env', new_local_name)         -- Even local, internal names must get a unique occurrence, because         -- if we do -split-objs we externalise the name later, in the code generator         --         -- Similarly, we must make sure it has a system-wide Unique, because         -- the byte-code generator builds a system-wide Name->BCO symbol table -  | local  && external = do { new_external_name <- atomicModifyIORef' nc_var mk_new_external-                            ; return (occ_env', new_external_name) }+  | local  && external = do new_external_name <- allocateGlobalBinder name_cache mod occ' loc+                            return (occ_env', new_external_name)+        -- If we want to externalise a currently-local name, check+        -- whether we have already assigned a unique for it.+        -- If so, use it; if not, extend the table.+        -- All this is done by allocateGlobalBinder.+        -- This is needed when *re*-compiling a module in GHCi; we must+        -- use the same name for externally-visible things as we did before.    | otherwise = panic "tidyTopName"   where@@ -1080,18 +1123,7 @@      (occ_env', occ') = tidyOccName occ_env new_occ -    mk_new_local nc = (nc { nsUniqs = us }, mkInternalName uniq occ' loc)-                    where-                      (uniq, us) = takeUniqFromSupply (nsUniqs nc) -    mk_new_external nc = allocateGlobalBinder nc mod occ' loc-        -- If we want to externalise a currently-local name, check-        -- whether we have already assigned a unique for it.-        -- If so, use it; if not, extend the table.-        -- All this is done by allcoateGlobalBinder.-        -- This is needed when *re*-compiling a module in GHCi; we must-        -- use the same name for externally-visible things as we did before.- {- ************************************************************************ *                                                                      *@@ -1101,7 +1133,7 @@ -}  -- TopTidyEnv: when tidying we need to know---   * nc_var: The NameCache, containing a unique supply and any pre-ordained Names.+--   * name_cache: The NameCache, containing a unique supply and any pre-ordained Names. --        These may have arisen because the --        renamer read in an interface file mentioning M.$wf, say, --        and assigned it unique r77.  If, on this compilation, we've@@ -1116,39 +1148,41 @@  tidyTopBinds :: UnfoldingOpts              -> UnfoldEnv+             -> NameSet              -> TidyOccEnv              -> CoreProgram              -> IO (TidyEnv, CoreProgram) -tidyTopBinds uf_opts unfold_env init_occ_env binds+tidyTopBinds uf_opts unfold_env boot_exports init_occ_env binds   = do let result = tidy init_env binds        seqBinds (snd result) `seq` return result        -- This seqBinds avoids a spike in space usage (see #13564)   where     init_env = (init_occ_env, emptyVarEnv) -    tidy = mapAccumL (tidyTopBind uf_opts unfold_env)+    tidy = mapAccumL (tidyTopBind uf_opts unfold_env boot_exports)  ------------------------ tidyTopBind  :: UnfoldingOpts              -> UnfoldEnv+             -> NameSet              -> TidyEnv              -> CoreBind              -> (TidyEnv, CoreBind) -tidyTopBind uf_opts unfold_env+tidyTopBind uf_opts unfold_env boot_exports             (occ_env,subst1) (NonRec bndr rhs)   = (tidy_env2,  NonRec bndr' rhs')   where     Just (name',show_unfold) = lookupVarEnv unfold_env bndr-    (bndr', rhs') = tidyTopPair uf_opts show_unfold tidy_env2 name' (bndr, rhs)+    (bndr', rhs') = tidyTopPair uf_opts show_unfold boot_exports tidy_env2 name' (bndr, rhs)     subst2        = extendVarEnv subst1 bndr bndr'     tidy_env2     = (occ_env, subst2) -tidyTopBind uf_opts unfold_env (occ_env, subst1) (Rec prs)+tidyTopBind uf_opts unfold_env boot_exports (occ_env, subst1) (Rec prs)   = (tidy_env2, Rec prs')   where-    prs' = [ tidyTopPair uf_opts show_unfold tidy_env2 name' (id,rhs)+    prs' = [ tidyTopPair uf_opts show_unfold boot_exports tidy_env2 name' (id,rhs)            | (id,rhs) <- prs,              let (name',show_unfold) =                     expectJust "tidyTopBind" $ lookupVarEnv unfold_env id@@ -1162,6 +1196,7 @@ ----------------------------------------------------------- tidyTopPair :: UnfoldingOpts             -> Bool  -- show unfolding+            -> NameSet             -> TidyEnv  -- The TidyEnv is used to tidy the IdInfo                         -- It is knot-tied: don't look at it!             -> Name             -- New name@@ -1173,14 +1208,17 @@         -- group, a variable late in the group might be mentioned         -- in the IdInfo of one early in the group -tidyTopPair uf_opts show_unfold rhs_tidy_env name' (bndr, rhs)-  = (bndr1, rhs1)+tidyTopPair uf_opts show_unfold boot_exports rhs_tidy_env name' (bndr, rhs)+  = -- pprTrace "tidyTop" (ppr name' <+> ppr details <+> ppr rhs) $+    (bndr1, rhs1)+   where+    !cbv_bndr = tidyCbvInfoTop boot_exports bndr rhs     bndr1    = mkGlobalId details name' ty' idinfo'-    details  = idDetails bndr   -- Preserve the IdDetails-    ty'      = tidyTopType (idType bndr)+    details  = idDetails cbv_bndr -- Preserve the IdDetails+    ty'      = tidyTopType (idType cbv_bndr)     rhs1     = tidyExpr rhs_tidy_env rhs-    idinfo'  = tidyTopIdInfo uf_opts rhs_tidy_env name' rhs rhs1 (idInfo bndr)+    idinfo'  = tidyTopIdInfo uf_opts rhs_tidy_env name' rhs rhs1 (idInfo cbv_bndr)                              show_unfold  -- tidyTopIdInfo creates the final IdInfo for top-level@@ -1198,16 +1236,16 @@                         -- Arity and strictness info are enough;                         --      c.f. GHC.Core.Tidy.tidyLetBndr         `setArityInfo`      arity-        `setStrictnessInfo` final_sig-        `setCprInfo`        final_cpr-        `setUnfoldingInfo`  minimal_unfold_info  -- See note [Preserve evaluatedness]+        `setDmdSigInfo` final_sig+        `setCprSigInfo`        final_cpr+        `setUnfoldingInfo`  minimal_unfold_info  -- See Note [Preserve evaluatedness]                                                  -- in GHC.Core.Tidy    | otherwise           -- Externally-visible Ids get the whole lot   = vanillaIdInfo         `setArityInfo`         arity-        `setStrictnessInfo`    final_sig-        `setCprInfo`           final_cpr+        `setDmdSigInfo`    final_sig+        `setCprSigInfo`           final_cpr         `setOccInfo`           robust_occ_info         `setInlinePragInfo`    (inlinePragInfo idinfo)         `setUnfoldingInfo`     unfold_info@@ -1224,14 +1262,14 @@     --------- Strictness ------------     mb_bot_str = exprBotStrictness_maybe orig_rhs -    sig = strictnessInfo idinfo+    sig = dmdSigInfo idinfo     final_sig | not $ isTopSig sig-              = WARN( _bottom_hidden sig , ppr name ) sig+              = warnPprTrace (_bottom_hidden sig) "tidyTopIdInfo" (ppr name) sig               -- try a cheap-and-cheerful bottom analyser               | Just (_, nsig) <- mb_bot_str = nsig               | otherwise                    = sig -    cpr = cprInfo idinfo+    cpr = cprSigInfo idinfo     final_cpr | Just _ <- mb_bot_str               = mkCprSig arity botCpr               | otherwise@@ -1242,13 +1280,13 @@                                   Just (arity, _) -> not (isDeadEndAppSig id_sig arity)      --------- Unfolding -------------    unf_info = unfoldingInfo idinfo+    unf_info = realUnfoldingInfo idinfo     unfold_info       | isCompulsoryUnfolding unf_info || show_unfold       = tidyUnfolding rhs_tidy_env unf_info unf_from_rhs       | otherwise       = minimal_unfold_info-    minimal_unfold_info = zapUnfolding unf_info+    minimal_unfold_info = trimUnfolding unf_info     unf_from_rhs = mkFinalUnfolding uf_opts InlineRhs final_sig tidy_rhs     -- NB: do *not* expose the worker if show_unfold is off,     --     because that means this thing is a loop breaker or@@ -1262,7 +1300,7 @@     --    the function returns bottom     -- In this case, show_unfold will be false (we don't expose unfoldings     -- for bottoming functions), but we might still have a worker/wrapper-    -- split (see Note [Worker-wrapper for bottoming functions] in+    -- split (see Note [Worker/wrapper for bottoming functions] in     -- GHC.Core.Opt.WorkWrap)  @@ -1274,106 +1312,3 @@     -- it to the top level. So it seems more robust just to     -- fix it here.     arity = exprArity orig_rhs--{--************************************************************************-*                                                                      *-                  Old, dead, type-trimming code-*                                                                      *-************************************************************************--We used to try to "trim off" the constructors of data types that are-not exported, to reduce the size of interface files, at least without--O.  But that is not always possible: see the old Note [When we can't-trim types] below for exceptions.--Then (#7445) I realised that the TH problem arises for any data type-that we have deriving( Data ), because we can invoke-   Language.Haskell.TH.Quote.dataToExpQ-to get a TH Exp representation of a value built from that data type.-You don't even need {-# LANGUAGE TemplateHaskell #-}.--At this point I give up. The pain of trimming constructors just-doesn't seem worth the gain.  So I've dumped all the code, and am just-leaving it here at the end of the module in case something like this-is ever resurrected.---Note [When we can't trim types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The basic idea of type trimming is to export algebraic data types-abstractly (without their data constructors) when compiling without--O, unless of course they are explicitly exported by the user.--We always export synonyms, because they can be mentioned in the type-of an exported Id.  We could do a full dependency analysis starting-from the explicit exports, but that's quite painful, and not done for-now.--But there are some times we can't do that, indicated by the 'no_trim_types' flag.--First, Template Haskell.  Consider (#2386) this-        module M(T, makeOne) where-          data T = Yay String-          makeOne = [| Yay "Yep" |]-Notice that T is exported abstractly, but makeOne effectively exports it too!-A module that splices in $(makeOne) will then look for a declaration of Yay,-so it'd better be there.  Hence, brutally but simply, we switch off type-constructor trimming if TH is enabled in this module.--Second, data kinds.  Consider (#5912)-     {-# LANGUAGE DataKinds #-}-     module M() where-     data UnaryTypeC a = UnaryDataC a-     type Bug = 'UnaryDataC-We always export synonyms, so Bug is exposed, and that means that-UnaryTypeC must be too, even though it's not explicitly exported.  In-effect, DataKinds means that we'd need to do a full dependency analysis-to see what data constructors are mentioned.  But we don't do that yet.--In these two cases we just switch off type trimming altogether.--mustExposeTyCon :: Bool         -- Type-trimming flag-                -> NameSet      -- Exports-                -> TyCon        -- The tycon-                -> Bool         -- Can its rep be hidden?--- We are compiling without -O, and thus trying to write as little as--- possible into the interface file.  But we must expose the details of--- any data types whose constructors or fields are exported-mustExposeTyCon no_trim_types exports tc-  | no_trim_types               -- See Note [When we can't trim types]-  = True--  | not (isAlgTyCon tc)         -- Always expose synonyms (otherwise we'd have to-                                -- figure out whether it was mentioned in the type-                                -- of any other exported thing)-  = True--  | isEnumerationTyCon tc       -- For an enumeration, exposing the constructors-  = True                        -- won't lead to the need for further exposure--  | isFamilyTyCon tc            -- Open type family-  = True--  -- Below here we just have data/newtype decls or family instances--  | null data_cons              -- Ditto if there are no data constructors-  = True                        -- (NB: empty data types do not count as enumerations-                                -- see Note [Enumeration types] in GHC.Core.TyCon--  | any exported_con data_cons  -- Expose rep if any datacon or field is exported-  = True--  | isNewTyCon tc && isFFITy (snd (newTyConRhs tc))-  = True   -- Expose the rep for newtypes if the rep is an FFI type.-           -- For a very annoying reason.  'Foreign import' is meant to-           -- be able to look through newtypes transparently, but it-           -- can only do that if it can "see" the newtype representation--  | otherwise-  = False-  where-    data_cons = tyConDataCons tc-    exported_con con = any (`elemNameSet` exports)-                           (dataConName con : dataConFieldLabels con)--}
compiler/GHC/Iface/Tidy/StaticPtrTable.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ViewPatterns  #-}+{-# LANGUAGE ViewPatterns #-}  -- | Code generation for the Static Pointer Table --@@ -48,9 +48,11 @@ --  module GHC.Iface.Tidy.StaticPtrTable-    ( sptCreateStaticBinds-    , sptModuleInitCode-    ) where+  ( sptCreateStaticBinds+  , sptModuleInitCode+  , StaticPtrOpts (..)+  )+where  {- Note [Grand plan for static forms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -126,37 +128,35 @@ import GHC.Prelude import GHC.Platform -import GHC.Driver.Session-import GHC.Driver.Env- import GHC.Core import GHC.Core.Utils (collectMakeStaticArgs) import GHC.Core.DataCon-import GHC.Core.Make (mkStringExprFSWith)+import GHC.Core.Make (mkStringExprFSWith,MkStringIds(..)) import GHC.Core.Type  import GHC.Cmm.CLabel  import GHC.Unit.Module import GHC.Utils.Outputable as Outputable-import GHC.Utils.Panic-import GHC.Builtin.Names-import GHC.Tc.Utils.Env (lookupGlobal)  import GHC.Linker.Types -import GHC.Types.Name import GHC.Types.Id-import GHC.Types.TyThing import GHC.Types.ForeignStubs+import GHC.Data.Maybe -import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.State+import Control.Monad.Trans.State.Strict import Data.List (intercalate)-import Data.Maybe import GHC.Fingerprint-import qualified GHC.LanguageExtensions as LangExt +data StaticPtrOpts = StaticPtrOpts+  { opt_platform                :: !Platform    -- ^ Target platform+  , opt_gen_cstub               :: !Bool        -- ^ Generate CStub or not+  , opt_mk_string               :: !MkStringIds -- ^ Ids for `unpackCString[Utf8]#`+  , opt_static_ptr_info_datacon :: !DataCon          -- ^ `StaticPtrInfo` datacon+  , opt_static_ptr_datacon      :: !DataCon          -- ^ `StaticPtr` datacon+  }+ -- | Replaces all bindings of the form -- -- > b = /\ ... -> makeStatic location value@@ -170,16 +170,13 @@ -- -- It also yields the C stub that inserts these bindings into the static -- pointer table.-sptCreateStaticBinds :: HscEnv -> Module -> CoreProgram-                     -> IO ([SptEntry], CoreProgram)-sptCreateStaticBinds hsc_env this_mod binds-    | not (xopt LangExt.StaticPointers dflags) =-      return ([], binds)-    | otherwise = do-      -- Make sure the required interface files are loaded.-      _ <- lookupGlobal hsc_env unpackCStringName+sptCreateStaticBinds :: StaticPtrOpts -> Module -> CoreProgram -> IO ([SptEntry], Maybe CStub, CoreProgram)+sptCreateStaticBinds opts this_mod binds = do       (fps, binds') <- evalStateT (go [] [] binds) 0-      return (fps, binds')+      let cstub+            | opt_gen_cstub opts = Just (sptModuleInitCode (opt_platform opts) this_mod fps)+            | otherwise          = Nothing+      return (fps, cstub, binds')   where     go fps bs xs = case xs of       []        -> return (reverse fps, reverse bs)@@ -187,9 +184,6 @@         (fps', bnd') <- replaceStaticBind bnd         go (reverse fps' ++ fps) (bnd' : bs) xs' -    dflags = hsc_dflags hsc_env-    platform = targetPlatform dflags-     -- Generates keys and replaces 'makeStatic' with 'StaticPtr'.     --     -- The 'Int' state is used to produce a different key for each binding.@@ -215,23 +209,20 @@     mkStaticBind t srcLoc e = do       i <- get       put (i + 1)-      staticPtrInfoDataCon <--        lift $ lookupDataConHscEnv staticPtrInfoDataConName+      let staticPtrInfoDataCon = opt_static_ptr_info_datacon opts       let fp@(Fingerprint w0 w1) = mkStaticPtrFingerprint i-      info <- mkConApp staticPtrInfoDataCon <$>-            (++[srcLoc]) <$>-            mapM (mkStringExprFSWith (lift . lookupIdHscEnv))-                 [ unitFS $ moduleUnit this_mod-                 , moduleNameFS $ moduleName this_mod-                 ]+      let mk_string_fs = mkStringExprFSWith (opt_mk_string opts)+      let info = mkConApp staticPtrInfoDataCon+                  [ mk_string_fs $ unitFS $ moduleUnit this_mod+                  , mk_string_fs $ moduleNameFS $ moduleName this_mod+                  , srcLoc+                  ] -      -- The module interface of GHC.StaticPtr should be loaded at least-      -- when looking up 'fromStatic' during type-checking.-      staticPtrDataCon <- lift $ lookupDataConHscEnv staticPtrDataConName+      let staticPtrDataCon = opt_static_ptr_datacon opts       return (fp, mkConApp staticPtrDataCon                                [ Type t-                               , mkWord64LitWordRep platform w0-                               , mkWord64LitWordRep platform w1+                               , mkWord64LitWord64 w0+                               , mkWord64LitWord64 w1                                , info                                , e ]) @@ -242,24 +233,6 @@         , show n         ] -    -- Choose either 'Word64#' or 'Word#' to represent the arguments of the-    -- 'Fingerprint' data constructor.-    mkWord64LitWordRep platform =-      case platformWordSize platform of-        PW4 -> mkWord64LitWord64-        PW8 -> mkWordLit platform . toInteger--    lookupIdHscEnv :: Name -> IO Id-    lookupIdHscEnv n = lookupType hsc_env n >>=-                         maybe (getError n) (return . tyThingId)--    lookupDataConHscEnv :: Name -> IO DataCon-    lookupDataConHscEnv n = lookupType hsc_env n >>=-                              maybe (getError n) (return . tyThingDataCon)--    getError n = pprPanic "sptCreateStaticBinds.get: not found" $-      text "Couldn't find" <+> ppr n- -- | @sptModuleInitCode module fps@ is a C stub to insert the static entries -- of @module@ into the static pointer table. --@@ -267,11 +240,12 @@ -- its fingerprint. sptModuleInitCode :: Platform -> Module -> [SptEntry] -> CStub sptModuleInitCode _        _        [] = mempty-sptModuleInitCode platform this_mod entries = CStub $ vcat-    [ text "static void hs_spt_init_" <> ppr this_mod-           <> text "(void) __attribute__((constructor));"-    , text "static void hs_spt_init_" <> ppr this_mod <> text "(void)"-    , braces $ vcat $+sptModuleInitCode platform this_mod entries =+    initializerCStub platform init_fn_nm empty init_fn_body `mappend`+    finalizerCStub platform fini_fn_nm empty fini_fn_body+  where+    init_fn_nm = mkInitializerStubLabel this_mod "spt"+    init_fn_body = vcat         [  text "static StgWord64 k" <> int i <> text "[2] = "            <> pprFingerprint fp <> semi         $$ text "extern StgPtr "@@ -285,17 +259,15 @@         <> semi         |  (i, SptEntry n fp) <- zip [0..] entries         ]-    , text "static void hs_spt_fini_" <> ppr this_mod-           <> text "(void) __attribute__((destructor));"-    , text "static void hs_spt_fini_" <> ppr this_mod <> text "(void)"-    , braces $ vcat $++    fini_fn_nm = mkFinalizerStubLabel this_mod "spt"+    fini_fn_body = vcat         [  text "StgWord64 k" <> int i <> text "[2] = "            <> pprFingerprint fp <> semi         $$ text "hs_spt_remove" <> parens (char 'k' <> int i) <> semi         | (i, (SptEntry _ fp)) <- zip [0..] entries         ]-    ]-  where+     pprFingerprint :: Fingerprint -> SDoc     pprFingerprint (Fingerprint w1 w2) =       braces $ hcat $ punctuate comma
compiler/GHC/IfaceToCore.hs view
@@ -6,8 +6,9 @@ Type checking of type signatures in interface files -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE FlexibleContexts #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -24,8 +25,6 @@         tcIfaceOneShot  ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Driver.Env@@ -39,7 +38,9 @@ import GHC.Iface.Env  import GHC.StgToCmm.Types+import GHC.Runtime.Heap.Layout +import GHC.Tc.Errors.Types import GHC.Tc.TyCl.Build import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType@@ -65,6 +66,7 @@ import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr ) import GHC.Core.Ppr +import GHC.Unit.Env import GHC.Unit.External import GHC.Unit.Module import GHC.Unit.Module.ModDetails@@ -74,6 +76,8 @@ import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Logger  import GHC.Data.Bag@@ -102,12 +106,14 @@ import GHC.Types.Id.Info import GHC.Types.Tickish import GHC.Types.TyThing+import GHC.Types.Error  import GHC.Fingerprint import qualified GHC.Data.BooleanFormula as BF  import Control.Monad import GHC.Parser.Annotation+import GHC.Driver.Env.KnotVars  {- This module takes@@ -156,7 +162,7 @@     internal TyCons to MATCH the ones that we just constructed     during typechecking: the knot is thus tied through if_rec_types. -    2) retypecheckLoop in GHC.Driver.Make: We are retypechecking a+    2) rehydrate in GHC.Driver.Make: We are rehydrating a     mutually recursive cluster of hi files, in order to ensure     that all of the references refer to each other correctly.     In this case, the knot is tied through the HPT passed in,@@ -215,7 +221,7 @@                          -- an example where this would cause non-termination.                          text "Type envt:" <+> ppr (map fst names_w_things)])         ; return $ ModDetails { md_types     = type_env-                              , md_insts     = insts+                              , md_insts     = mkInstEnv insts                               , md_fam_insts = fam_insts                               , md_rules     = rules                               , md_anns      = anns@@ -234,7 +240,7 @@  -- | Returns true if an 'IfaceDecl' is for @data T@ (an abstract data type) isAbstractIfaceDecl :: IfaceDecl -> Bool-isAbstractIfaceDecl IfaceData{ ifCons = IfAbstractTyCon } = True+isAbstractIfaceDecl IfaceData{ ifCons = IfAbstractTyCon {} } = True isAbstractIfaceDecl IfaceClass{ ifBody = IfAbstractClass } = True isAbstractIfaceDecl IfaceFamily{ ifFamFlav = IfaceAbstractClosedSynFamilyTyCon } = True isAbstractIfaceDecl _ = False@@ -254,7 +260,7 @@     | isAbstractIfaceDecl d2 = d1 `withRolesFrom` d2     | IfaceClass{ ifBody = IfConcreteClass { ifSigs = ops1, ifMinDef = bf1 } } <- d1     , IfaceClass{ ifBody = IfConcreteClass { ifSigs = ops2, ifMinDef = bf2 } } <- d2-    = let ops = nameEnvElts $+    = let ops = nonDetNameEnvElts $                   plusNameEnv_C mergeIfaceClassOp                     (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops1 ])                     (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops2 ])@@ -379,8 +385,8 @@ -- type synonym.  Perhaps this should be relaxed, where a type synonym -- in a signature is considered implemented by a data type declaration -- which matches the reference of the type synonym.-typecheckIfacesForMerging :: Module -> [ModIface] -> IORef TypeEnv -> IfM lcl (TypeEnv, [ModDetails])-typecheckIfacesForMerging mod ifaces tc_env_var =+typecheckIfacesForMerging :: Module -> [ModIface] -> (KnotVars (IORef TypeEnv)) -> IfM lcl (TypeEnv, [ModDetails])+typecheckIfacesForMerging mod ifaces tc_env_vars =   -- cannot be boot (False)   initIfaceLcl mod (text "typecheckIfacesForMerging") NotBoot $ do     ignore_prags <- goptM Opt_IgnoreInterfacePragmas@@ -400,9 +406,11 @@                         ::  OccEnv IfaceDecl     -- TODO: change tcIfaceDecls to accept w/o Fingerprint     names_w_things <- tcIfaceDecls ignore_prags (map (\x -> (fingerprint0, x))-                                                  (occEnvElts decl_env))+                                                  (nonDetOccEnvElts decl_env))     let global_type_env = mkNameEnv names_w_things-    writeMutVar tc_env_var global_type_env+    case lookupKnotVars tc_env_vars mod of+      Just tc_env_var -> writeMutVar tc_env_var global_type_env+      Nothing -> return ()      -- OK, now typecheck each ModIface using this environment     details <- forM ifaces $ \iface -> do@@ -421,7 +429,7 @@         exports   <- ifaceExportNames (mi_exports iface)         complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface)         return $ ModDetails { md_types     = type_env-                            , md_insts     = insts+                            , md_insts     = mkInstEnv insts                             , md_fam_insts = fam_insts                             , md_rules     = rules                             , md_anns      = anns@@ -460,7 +468,7 @@     exports   <- ifaceExportNames (mi_exports iface)     complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface)     return $ ModDetails { md_types     = type_env-                        , md_insts     = insts+                        , md_insts     = mkInstEnv insts                         , md_fam_insts = fam_insts                         , md_rules     = rules                         , md_anns      = anns@@ -532,8 +540,8 @@                 -- (it's been replaced by the mother module) so we can't check it.                 -- And that's fine, because if M's ModInfo is in the HPT, then                 -- it's been compiled once, and we don't need to check the boot iface-          then do { hpt <- getHpt-                 ; case lookupHpt hpt (moduleName mod) of+          then do { (_, hug) <- getEpsAndHug+                 ; case lookupHugByModule mod hug  of                       Just info | mi_boot (hm_iface info) == IsBoot                                 -> mkSelfBootInfo (hm_iface info) (hm_details info)                       _ -> return NoSelfBoot }@@ -543,7 +551,8 @@         -- Re #9245, we always check if there is an hi-boot interface         -- to check consistency against, rather than just when we notice         -- that an hi-boot is necessary due to a circular import.-        { read_result <- findAndReadIface+        { hsc_env <- getTopEnv+        ; read_result <- liftIO $ findAndReadIface hsc_env                                 need (fst (getModuleInstantiation mod)) mod                                 IsBoot  -- Hi-boot file @@ -560,14 +569,14 @@         -- a SOURCE import) or that our hi-boot file has mysteriously         -- disappeared.     do  { eps <- getEps-        ; case lookupUFM (eps_is_boot eps) (moduleName mod) of+        ; case lookupInstalledModuleEnv (eps_is_boot eps) (toUnitId <$> mod) of             -- The typical case             Nothing -> return NoSelfBoot             -- error cases             Just (GWIB { gwib_isBoot = is_boot }) -> case is_boot of-              IsBoot -> failWithTc (elaborate err)+              IsBoot -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints (elaborate err))               -- The hi-boot file has mysteriously disappeared.-              NotBoot -> failWithTc moduleLoop+              NotBoot -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints moduleLoop)               -- Someone below us imported us!               -- This is a loop with no hi-boot in the way     }}}}@@ -594,7 +603,7 @@        return $ SelfBoot { sb_mds = mds                          , sb_tcs = mkNameSet tcs }   where-    -- | Retuerns @True@ if, when you call 'tcIfaceDecl' on+    -- Retuerns @True@ if, when you call 'tcIfaceDecl' on     -- this 'IfaceDecl', an ATyCon would be returned.     -- NB: This code assumes that a TyCon cannot be implicit.     isIfaceTyCon IfaceId{}      = False@@ -1021,11 +1030,17 @@ tcIfaceDataCons :: Name -> TyCon -> [TyConBinder] -> IfaceConDecls -> IfL AlgTyConRhs tcIfaceDataCons tycon_name tycon tc_tybinders if_cons   = case if_cons of-        IfAbstractTyCon  -> return AbstractTyCon-        IfDataTyCon cons -> do  { data_cons  <- mapM tc_con_decl cons-                                ; return (mkDataTyConRhs data_cons) }-        IfNewTyCon  con  -> do  { data_con  <- tc_con_decl con-                                ; mkNewTyConRhs tycon_name tycon data_con }+        IfAbstractTyCon+          -> return AbstractTyCon+        IfDataTyCon cons+          -> do  { data_cons  <- mapM tc_con_decl cons+                 ; return $+                     mkLevPolyDataTyConRhs+                       (isFixedRuntimeRepKind $ tyConResKind tycon)+                       data_cons }+        IfNewTyCon con+          -> do  { data_con  <- tc_con_decl con+                 ; mkNewTyConRhs tycon_name tycon data_con }   where     univ_tvs :: [TyVar]     univ_tvs = binderVars tc_tybinders@@ -1088,15 +1103,15 @@          ; prom_rep_name <- newTyConRepName dc_name +        ; let bang_opts = FixedBangOpts stricts+            -- Pass the HsImplBangs (i.e. final decisions) to buildDataCon;+            -- it'll use these to guide the construction of a worker.+            -- See Note [Bangs on imported data constructors] in GHC.Types.Id.Make+         ; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr dc_name))+                       bang_opts                        dc_name is_infix prom_rep_name                        (map src_strict if_src_stricts)-                       (Just stricts)-                       -- Pass the HsImplBangs (i.e. final-                       -- decisions) to buildDataCon; it'll use-                       -- these to guide the construction of a-                       -- worker.-                       -- See Note [Bangs on imported data constructors] in GHC.Types.Id.Make                        lbl_names                        univ_tvs ex_tvs user_tv_bndrs                        eq_spec theta@@ -1150,8 +1165,8 @@ -}  tcRoughTyCon :: Maybe IfaceTyCon -> RoughMatchTc-tcRoughTyCon (Just tc) = KnownTc (ifaceTyConName tc)-tcRoughTyCon Nothing   = OtherTc+tcRoughTyCon (Just tc) = RM_KnownTc (ifaceTyConName tc)+tcRoughTyCon Nothing   = RM_WildCard  tcIfaceInst :: IfaceClsInst -> IfL ClsInst tcIfaceInst (IfaceClsInst { ifDFun = dfun_name, ifOFlag = oflag@@ -1213,7 +1228,7 @@                           Nothing   -> return ()                           Just errs -> do                             logger <- getLogger-                            liftIO $ displayLintResults logger dflags False doc+                            liftIO $ displayLintResults logger False doc                                                (pprCoreExpr rhs')                                                (emptyBag, errs) }                    ; return (bndrs', args', rhs') }@@ -1294,11 +1309,10 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We need to be lazy when type checking the interface, since these functions are called when the interface itself is being loaded, which means it is not in the-PIT yet. If we are not lazy enough, in certain cases we might recursively try to-load the same interface in an infinite loop.--For this reason, the forkM should be around as much of the computation as-possible.+PIT yet. In particular, the `tcIfaceTCon` must be inside the forkM, otherwise+we'll try to look it up the TyCon, find it's not there, and so initiate the+process (again) of loading the (very same) interface file. Result: infinite+loop. See #19744. -}  {-@@ -1458,8 +1472,7 @@ tcIfaceExpr (IfaceFCall cc ty) = do     ty' <- tcIfaceType ty     u <- newUnique-    dflags <- getDynFlags-    return (Var (mkFCallId dflags u cc ty'))+    return (Var (mkFCallId u cc ty'))  tcIfaceExpr (IfaceTuple sort args)   = do { args' <- mapM tcIfaceExpr args@@ -1564,12 +1577,12 @@            -> IfaceAlt            -> IfL CoreAlt tcIfaceAlt _ _ _ (IfaceAlt IfaceDefault names rhs)-  = ASSERT( null names ) do+  = assert (null names) $ do     rhs' <- tcIfaceExpr rhs     return (Alt DEFAULT [] rhs')  tcIfaceAlt _ _ _ (IfaceAlt (IfaceLitAlt lit) names rhs)-  = ASSERT( null names ) do+  = assert (null names) $ do     lit' <- tcIfaceLit lit     rhs' <- tcIfaceExpr rhs     return (Alt (LitAlt lit') [] rhs')@@ -1606,6 +1619,7 @@  tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails tcIdDetails _  IfVanillaId = return VanillaId+tcIdDetails _  (IfWorkerLikeId dmds) = return $ WorkerLikeId dmds tcIdDetails ty IfDFunId   = return (DFunId (isNewTyCon (classTyCon cls)))   where@@ -1645,14 +1659,17 @@     tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo     tcPrag info HsNoCafRefs        = return (info `setCafInfo`   NoCafRefs)     tcPrag info (HsArity arity)    = return (info `setArityInfo` arity)-    tcPrag info (HsStrictness str) = return (info `setStrictnessInfo` str)-    tcPrag info (HsCpr cpr)        = return (info `setCprInfo` cpr)+    tcPrag info (HsDmdSig str)     = return (info `setDmdSigInfo` str)+    tcPrag info (HsCprSig cpr)     = return (info `setCprSigInfo` cpr)     tcPrag info (HsInline prag)    = return (info `setInlinePragInfo` prag)-    tcPrag info HsLevity           = return (info `setNeverLevPoly` ty)+    tcPrag info HsLevity           = return (info `setNeverRepPoly` ty)     tcPrag info (HsLFInfo lf_info) = do       lf_info <- tcLFInfo lf_info       return (info `setLFInfo` lf_info) +    tcPrag info (HsTagSig sig) = do+      return (info `setTagSig` sig)+         -- The next two are lazy, so they don't transitively suck stuff in     tcPrag info (HsUnfold lb if_unf)       = do { unf <- tcUnfolding toplvl name ty info if_unf@@ -1697,53 +1714,67 @@       return (LFUnknown fun_flag)  tcUnfolding :: TopLevelFlag -> Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding+-- See Note [Lazily checking Unfoldings] tcUnfolding toplvl name _ info (IfCoreUnfold stable if_expr)   = do  { uf_opts <- unfoldingOpts <$> getDynFlags-        ; mb_expr <- tcPragExpr False toplvl name if_expr+        ; expr <- tcUnfoldingRhs False toplvl name if_expr         ; let unf_src | stable    = InlineStable                       | otherwise = InlineRhs-        ; return $ case mb_expr of-            Nothing -> NoUnfolding-            Just expr -> mkFinalUnfolding uf_opts unf_src strict_sig expr-        }+        ; return $ mkFinalUnfolding uf_opts unf_src strict_sig expr }   where     -- Strictness should occur before unfolding!-    strict_sig = strictnessInfo info+    strict_sig = dmdSigInfo info  tcUnfolding toplvl name _ _ (IfCompulsory if_expr)-  = do  { mb_expr <- tcPragExpr True toplvl name if_expr-        ; return (case mb_expr of-                    Nothing   -> NoUnfolding-                    Just expr -> mkCompulsoryUnfolding' expr) }+  = do  { expr <- tcUnfoldingRhs True toplvl name if_expr+        ; return $ mkCompulsoryUnfolding' expr }  tcUnfolding toplvl name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)-  = do  { mb_expr <- tcPragExpr False toplvl name if_expr-        ; return (case mb_expr of-                    Nothing   -> NoUnfolding-                    Just expr -> mkCoreUnfolding InlineStable True expr guidance )}+  = do  { expr <- tcUnfoldingRhs False toplvl name if_expr+        ; return $ mkCoreUnfolding InlineStable True expr guidance }   where     guidance = UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }  tcUnfolding _toplvl name dfun_ty _ (IfDFunUnfold bs ops)   = bindIfaceBndrs bs $ \ bs' ->-    do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops-       ; return (case mb_ops1 of-                    Nothing   -> noUnfolding-                    Just ops1 -> mkDFunUnfolding bs' (classDataCon cls) ops1) }+    do { ops1 <- forkM doc $ mapM tcIfaceExpr ops+       ; return $ mkDFunUnfolding bs' (classDataCon cls) ops1 }   where     doc = text "Class ops for dfun" <+> ppr name     (_, _, cls, _) = tcSplitDFunTy dfun_ty -{--For unfoldings we try to do the job lazily, so that we never type check+{- Note [Lazily checking Unfoldings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For unfoldings, we try to do the job lazily, so that we never typecheck an unfolding that isn't going to be looked at.++The main idea is that if M.hi has a declaration+   f :: Int -> Int+   f = \x. ...A.g...   -- The unfolding for f++then we don't even want to /read/ A.hi unless f's unfolding is actually used; say,+if f is inlined. But we need to be careful. Even if we don't inline f, we might ask+hasNoBinding of it (Core Lint does this in GHC.Core.Lint.checkCanEtaExpand),+and hasNoBinding looks to see if f has a compulsory unfolding.+So the root Unfolding constructor must be visible: we want to be able to read the 'uf_src'+field which says whether it is a compulsory unfolding, without forcing the unfolding RHS+which is stored in 'uf_tmpl'. This matters for efficiency, but not only: if g's unfolding+mentions f, we must not look at the unfolding RHS for f, as this is precisely what we are+in the middle of checking (so looking at it would cause a loop).++Conclusion: `tcUnfolding` must return an `Unfolding` whose `uf_src` field is readable without+forcing the `uf_tmpl` field. In particular, all the functions used at the end of+`tcUnfolding` (such as `mkFinalUnfolding`, `mkCompulsoryUnfolding'`, `mkCoreUnfolding`) must be+lazy in `expr`.++Ticket #21139 -} -tcPragExpr :: Bool  -- Is this unfolding compulsory?-                    -- See Note [Checking for levity polymorphism] in GHC.Core.Lint-           -> TopLevelFlag -> Name -> IfaceExpr -> IfL (Maybe CoreExpr)-tcPragExpr is_compulsory toplvl name expr-  = forkM_maybe doc $ do+tcUnfoldingRhs :: Bool -- ^ Is this unfolding compulsory?+                       -- See Note [Checking for representation polymorphism] in GHC.Core.Lint+               -> TopLevelFlag -> Name -> IfaceExpr -> IfL CoreExpr+tcUnfoldingRhs is_compulsory toplvl name expr+  = forkM doc $ do     core_expr' <- tcIfaceExpr expr      -- Check for type consistency in the unfolding@@ -1756,7 +1787,7 @@         case lintUnfolding is_compulsory dflags noSrcLoc in_scope core_expr' of           Nothing   -> return ()           Just errs -> liftIO $-            displayLintResults logger dflags False doc+            displayLintResults logger False doc                                (pprCoreExpr core_expr') (emptyBag, errs)     return core_expr'   where@@ -1766,14 +1797,11 @@     get_in_scope :: IfL VarSet -- Totally disgusting; but just for linting     get_in_scope         = do { (gbl_env, lcl_env) <- getEnvs-             ; rec_ids <- case if_rec_types gbl_env of-                            Nothing -> return []-                            Just (_, get_env) -> do-                               { type_env <- setLclEnv () get_env-                               ; return (typeEnvIds type_env) }+             ; let type_envs = knotVarElems (if_rec_types gbl_env)+             ; top_level_vars <- concat <$> mapM (fmap typeEnvIds . setLclEnv ())  type_envs              ; return (bindingsVars (if_tv_env lcl_env) `unionVarSet`                        bindingsVars (if_id_env lcl_env) `unionVarSet`-                       mkVarSet rec_ids) }+                       mkVarSet top_level_vars) }      bindingsVars :: FastStringEnv Var -> VarSet     bindingsVars ufm = mkVarSet $ nonDetEltsUFM ufm@@ -1803,10 +1831,10 @@    | otherwise   = do  { env <- getGblEnv-        ; case if_rec_types env of {    -- Note [Tying the knot]-            Just (mod, get_type_env)-                | nameIsLocalOrFrom mod name-                -> do           -- It's defined in the module being compiled+        ; cur_mod <- if_mod <$> getLclEnv+        ; case lookupKnotVars (if_rec_types env) (fromMaybe cur_mod (nameModule_maybe name))  of     -- Note [Tying the knot]+            Just get_type_env+                -> do           -- It's defined in a module in the hs-boot loop                 { type_env <- setLclEnv () get_type_env         -- yuk                 ; case lookupNameEnv type_env name of                     Just thing -> return thing@@ -1814,7 +1842,7 @@                     Nothing   -> via_external                 } -          ; _ -> via_external }}+            _ -> via_external }   where     via_external =  do         { hsc_env <- getTopEnv@@ -1843,6 +1871,7 @@ --      * Note [DFun knot-tying] --      * Note [hsc_type_env_var hack] --      * Note [Knot-tying fallback on boot]+--      * Note [Hydrating Modules] -- -- There is also a wiki page on the subject, see: --@@ -1899,13 +1928,15 @@   tcIfaceCoAxiomRule :: IfLclName -> IfL CoAxiomRule--- Unlike CoAxioms, which arise form user 'type instance' declarations,--- there are a fixed set of CoAxiomRules,--- currently enumerated in typeNatCoAxiomRules+-- Unlike CoAxioms, which arise from user 'type instance' declarations,+-- there are a fixed set of CoAxiomRules:+--   - axioms for type-level literals (Nat and Symbol),+--     enumerated in typeNatCoAxiomRules tcIfaceCoAxiomRule n-  = case lookupUFM typeNatCoAxiomRules n of-        Just ax -> return ax-        _  -> pprPanic "tcIfaceCoAxiomRule" (ppr n)+  | Just ax <- lookupUFM typeNatCoAxiomRules n+  = return ax+  | otherwise+  = pprPanic "tcIfaceCoAxiomRule" (ppr n)  tcIfaceDataCon :: Name -> IfL DataCon tcIfaceDataCon name = do { thing <- tcIfaceGlobal name
+ compiler/GHC/Linker.hs view
@@ -0,0 +1,36 @@+module GHC.Linker+   (+   )+where++import GHC.Prelude ()+   -- We need this dummy dependency for the make build system. Otherwise it+   -- tries to load GHC.Types which may not be built yet.++-- Note [Linkers and loaders]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Linkers are used to produce linked objects (.so, executables); loaders are+-- used to link in memory (e.g., in GHCi) with the already loaded libraries+-- (ghc-lib, rts, etc.).+--+-- Linking can usually be done with an external linker program ("ld"), but+-- loading is more tricky:+--+--    * Fully dynamic:+--       when GHC is built as a set of dynamic libraries (ghc-lib, rts, etc.)+--       and the modules to load are also compiled for dynamic linking, a+--       solution is to fully rely on external tools:+--+--       1) link a .so with the external linker+--       2) load the .so with POSIX's "dlopen"+--+--    * When GHC is built as a static program or when libraries we want to load+--    aren't compiled for dynamic linking, GHC uses its own loader ("runtime+--    linker"). The runtime linker is part of the rts (rts/Linker.c).+--+-- Note that within GHC's codebase we often use the word "linker" to refer to+-- the static object loader in the runtime system.+--+-- Loading can be delegated to an external interpreter ("iserv") when+-- -fexternal-interpreter is used.
compiler/GHC/Linker/Dynamic.hs view
@@ -8,8 +8,6 @@    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Platform import GHC.Platform.Ways@@ -25,7 +23,6 @@ import GHC.Utils.Logger import GHC.Utils.TmpFs -import qualified Data.Set as Set import System.FilePath  linkDynLib :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO ()@@ -47,7 +44,7 @@                = dflags0          verbFlags = getVerbFlags dflags-        o_file = outputFile dflags+        o_file = outputFile_ dflags      pkgs_with_rts <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_packages) @@ -57,7 +54,7 @@          | osElfTarget os || osMachOTarget os          , dynLibLoader dflags == SystemDependent          , -- Only if we want dynamic libraries-           WayDyn `Set.member` ways dflags+           ways dflags `hasWay` WayDyn            -- Only use RPath if we explicitly asked for it          , useXLinkerRPath dflags os             = ["-L" ++ l, "-Xlinker", "-rpath", "-Xlinker", l]@@ -200,7 +197,8 @@             -------------------------------------------------------------------              let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }-                unregisterised = platformUnregisterised (targetPlatform dflags)+                platform  = targetPlatform dflags+                unregisterised = platformUnregisterised platform             let bsymbolicFlag = -- we need symbolic linking to resolve                                 -- non-PIC intra-package-relocations for                                 -- performance (where symbolic linking works)@@ -209,7 +207,7 @@              runLink logger tmpfs dflags (                     map Option verbFlags-                 ++ libmLinkOpts+                 ++ libmLinkOpts platform                  ++ [ Option "-o"                     , FileOption "" output_fn                     ]@@ -227,13 +225,10 @@  -- | Some platforms require that we explicitly link against @libm@ if any -- math-y things are used (which we assume to include all programs). See #14022.-libmLinkOpts :: [Option]-libmLinkOpts =-#if defined(HAVE_LIBM)-  [Option "-lm"]-#else-  []-#endif+libmLinkOpts :: Platform -> [Option]+libmLinkOpts platform+  | platformHasLibm platform = [Option "-lm"]+  | otherwise                = []  {- Note [-Bsymbolic assumptions by GHC]
compiler/GHC/Linker/ExtraObj.hs view
@@ -25,7 +25,6 @@  import GHC.Unit import GHC.Unit.Env-import GHC.Unit.State  import GHC.Utils.Asm import GHC.Utils.Error@@ -50,8 +49,8 @@  mkExtraObj :: Logger -> TmpFs -> DynFlags -> UnitState -> Suffix -> String -> IO FilePath mkExtraObj logger tmpfs dflags unit_state extn xs- = do cFile <- newTempName logger tmpfs dflags TFL_CurrentModule extn-      oFile <- newTempName logger tmpfs dflags TFL_GhcSession "o"+ = do cFile <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule extn+      oFile <- newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession "o"       writeFile cFile xs       ccInfo <- liftIO $ getCompilerInfo logger dflags       runCc Nothing logger tmpfs dflags@@ -90,7 +89,7 @@ mkExtraObjToLinkIntoBinary :: Logger -> TmpFs -> DynFlags -> UnitState -> IO (Maybe FilePath) mkExtraObjToLinkIntoBinary logger tmpfs dflags unit_state = do   when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $-     logInfo logger dflags $ withPprStyle defaultUserStyle+     logInfo logger $ withPprStyle defaultUserStyle          (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$           text "    Call hs_init_ghc() from your main() function to set these options.") @@ -238,11 +237,11 @@  | otherwise  = do    link_info <- getLinkInfo dflags unit_env pkg_deps-   debugTraceMsg logger dflags 3 $ text ("Link info: " ++ link_info)-   m_exe_link_info <- readElfNoteAsString logger dflags exe_file+   debugTraceMsg logger 3 $ text ("Link info: " ++ link_info)+   m_exe_link_info <- readElfNoteAsString logger exe_file                           ghcLinkInfoSectionName ghcLinkInfoNoteName    let sameLinkInfo = (Just link_info == m_exe_link_info)-   debugTraceMsg logger dflags 3 $ case m_exe_link_info of+   debugTraceMsg logger 3 $ case m_exe_link_info of      Nothing -> text "Exe link info: Not found"      Just s        | sameLinkInfo -> text ("Exe link info is the same")
compiler/GHC/Linker/Loader.hs view
@@ -1,5 +1,7 @@-{-# LANGUAGE CPP, TupleSections, RecordWildCards #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TupleSections, RecordWildCards #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LambdaCase #-}  -- --  (c) The University of Glasgow 2002-2006@@ -14,6 +16,7 @@    , initLoaderState    , uninitializedLoader    , showLoaderState+   , getLoaderState    -- * Load & Unload    , loadExpr    , loadDecls@@ -26,13 +29,9 @@    , withExtendedLoadedEnv    , extendLoadedEnv    , deleteFromLoadedEnv-   -- * Misc-   , extendLoadedPkgs    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Settings@@ -44,13 +43,15 @@ import GHC.Driver.Env import GHC.Driver.Session import GHC.Driver.Ppr+import GHC.Driver.Config+import GHC.Driver.Config.Diagnostic+import GHC.Driver.Config.Finder  import GHC.Tc.Utils.Monad  import GHC.Runtime.Interpreter import GHCi.RemoteTypes -import GHC.Iface.Load  import GHC.ByteCode.Linker import GHC.ByteCode.Asm@@ -63,10 +64,11 @@ import GHC.Types.Name.Env import GHC.Types.SrcLoc import GHC.Types.Unique.DSet+import GHC.Types.Unique.DFM  import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Misc+import GHC.Utils.Panic.Plain import GHC.Utils.Error import GHC.Utils.Logger import GHC.Utils.TmpFs@@ -76,14 +78,12 @@ import GHC.Unit.Module import GHC.Unit.Module.ModIface import GHC.Unit.Module.Deps-import GHC.Unit.Home import GHC.Unit.Home.ModInfo import GHC.Unit.State as Packages  import qualified GHC.Data.ShortText as ST import qualified GHC.Data.Maybe as Maybes import GHC.Data.FastString-import GHC.Data.List.SetOps  import GHC.Linker.MacOS import GHC.Linker.Dynamic@@ -93,8 +93,8 @@ import Control.Monad  import qualified Data.Set as Set+import qualified Data.Map as M import Data.Char (isSpace)-import Data.Function ((&)) import Data.IORef import Data.List (intercalate, isPrefixOf, isSuffixOf, nub, partition) import Data.Maybe@@ -112,6 +112,14 @@  import GHC.Utils.Exception +import GHC.Unit.Module.Graph+import GHC.Types.SourceFile+import GHC.Utils.Misc+import GHC.Iface.Load+import GHC.Unit.Home+import Data.Either+import Control.Applicative+ uninitialised :: a uninitialised = panic "Loader not initialised" @@ -126,13 +134,17 @@     (fmapFst pure . f . fromMaybe uninitialised)   where fmapFst f = fmap (\(x, y) -> (f x, y)) +getLoaderState :: Interp -> IO (Maybe LoaderState)+getLoaderState interp = readMVar (loader_state (interpLoader interp))++ emptyLoaderState :: LoaderState emptyLoaderState = LoaderState    { closure_env = emptyNameEnv    , itbl_env    = emptyNameEnv    , pkgs_loaded = init_pkgs-   , bcos_loaded = []-   , objs_loaded = []+   , bcos_loaded = emptyModuleEnv+   , objs_loaded = emptyModuleEnv    , temp_sos = []    }   -- Packages that don't need loading, because the compiler@@ -140,12 +152,7 @@   --   -- The linker's symbol table is populated with RTS symbols using an   -- explicit list.  See rts/Linker.c for details.-  where init_pkgs = [rtsUnitId]--extendLoadedPkgs :: Interp -> [UnitId] -> IO ()-extendLoadedPkgs interp pkgs =-  modifyLoaderState_ interp $ \s ->-      return s{ pkgs_loaded = pkgs ++ pkgs_loaded s }+  where init_pkgs = unitUDFM rtsUnitId (LoadedPkgInfo rtsUnitId [] [] emptyUniqDSet)  extendLoadedEnv :: Interp -> [(Name,ForeignHValue)] -> IO () extendLoadedEnv interp new_bindings =@@ -164,39 +171,39 @@ -- | Load the module containing the given Name and get its associated 'HValue'. -- -- Throws a 'ProgramError' if loading fails or the name cannot be found.-loadName :: Interp -> HscEnv -> Name -> IO ForeignHValue+loadName :: Interp -> HscEnv -> Name -> IO (ForeignHValue, [Linkable], PkgsLoaded) loadName interp hsc_env name = do   initLoaderState interp hsc_env   modifyLoaderState interp $ \pls0 -> do-    pls <- if not (isExternalName name)-       then return pls0+    (pls, links, pkgs) <- if not (isExternalName name)+       then return (pls0, [], emptyUDFM)        else do-         (pls', ok) <- loadDependencies interp hsc_env pls0 noSrcSpan-                          [nameModule name]+         (pls', ok, links, pkgs) <- loadDependencies interp hsc_env pls0 noSrcSpan+                                      [nameModule name]          if failed ok            then throwGhcExceptionIO (ProgramError "")-           else return pls'+           else return (pls', links, pkgs)      case lookupNameEnv (closure_env pls) name of-      Just (_,aa) -> return (pls,aa)-      Nothing     -> ASSERT2(isExternalName name, ppr name)+      Just (_,aa) -> return (pls,(aa, links, pkgs))+      Nothing     -> assertPpr (isExternalName name) (ppr name) $                      do let sym_to_find = nameToCLabel name "closure"                         m <- lookupClosure interp (unpackFS sym_to_find)                         r <- case m of                           Just hvref -> mkFinalizedHValue interp hvref                           Nothing -> linkFail "GHC.Linker.Loader.loadName"                                        (unpackFS sym_to_find)-                        return (pls,r)+                        return (pls,(r, links, pkgs))  loadDependencies   :: Interp   -> HscEnv   -> LoaderState-  -> SrcSpan -> [Module]-  -> IO (LoaderState, SuccessFlag)+  -> SrcSpan+  -> [Module]+  -> IO (LoaderState, SuccessFlag, [Linkable], PkgsLoaded) -- ^ returns the set of linkables required loadDependencies interp hsc_env pls span needed_mods = do --   initLoaderState (hsc_dflags hsc_env) dl-   let hpt = hsc_HPT hsc_env    let dflags = hsc_dflags hsc_env    -- The interpreter and dynamic linker can only handle object code built    -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky.@@ -205,12 +212,20 @@    maybe_normal_osuf <- checkNonStdWay dflags interp span     -- Find what packages and linkables are required-   (lnks, pkgs) <- getLinkDeps hsc_env hpt pls-                               maybe_normal_osuf span needed_mods+   (lnks, all_lnks, pkgs, this_pkgs_needed)+      <- getLinkDeps hsc_env pls+           maybe_normal_osuf span needed_mods     -- Link the packages and modules required    pls1 <- loadPackages' interp hsc_env pkgs pls-   loadModules interp hsc_env pls1 lnks+   (pls2, succ) <- loadModuleLinkables interp hsc_env pls1 lnks+   let this_pkgs_loaded = udfmRestrictKeys all_pkgs_loaded $ getUniqDSet trans_pkgs_needed+       all_pkgs_loaded = pkgs_loaded pls2+       trans_pkgs_needed = unionManyUniqDSets (this_pkgs_needed : [ loaded_pkg_trans_deps pkg+                                                                  | pkg_id <- uniqDSetToList this_pkgs_needed+                                                                  , Just pkg <- [lookupUDFM all_pkgs_loaded pkg_id]+                                                                  ])+   return (pls2, succ, all_lnks, this_pkgs_loaded)   -- | Temporarily extend the loaded env.@@ -243,9 +258,9 @@   ls <- readMVar (loader_state (interpLoader interp))   let docs = case ls of         Nothing  -> [ text "Loader not initialised"]-        Just pls -> [ text "Pkgs:" <+> ppr (pkgs_loaded pls)-                    , text "Objs:" <+> ppr (objs_loaded pls)-                    , text "BCOs:" <+> ppr (bcos_loaded pls)+        Just pls -> [ text "Pkgs:" <+> ppr (map loaded_pkg_uid $ eltsUDFM $ pkgs_loaded pls)+                    , text "Objs:" <+> ppr (moduleEnvElts $ objs_loaded pls)+                    , text "BCOs:" <+> ppr (moduleEnvElts $ bcos_loaded pls)                     ]    return $ withPprStyle defaultDumpStyle@@ -291,8 +306,9 @@   -- (a) initialise the C dynamic linker   initObjLinker interp +   -- (b) Load packages from the command-line (Note [preload packages])-  pls <- loadPackages' interp hsc_env (preloadUnits (hsc_units hsc_env)) pls0+  pls <- unitEnv_foldWithKey (\k u env -> k >>= \pls' -> loadPackages' interp (hscSetActiveUnitId u hsc_env) (preloadUnits (homeUnitEnv_units env)) pls') (return pls0) (hsc_HUG hsc_env)    -- steps (c), (d) and (e)   loadCmdLineLibs' interp hsc_env pls@@ -304,13 +320,33 @@   modifyLoaderState_ interp $ \pls ->     loadCmdLineLibs' interp hsc_env pls -loadCmdLineLibs'++loadCmdLineLibs' :: Interp -> HscEnv -> LoaderState -> IO LoaderState+loadCmdLineLibs' interp hsc_env pls = snd <$>+    foldM+      (\(done', pls') cur_uid ->  load done' cur_uid pls')+      (Set.empty, pls)+      (hsc_all_home_unit_ids hsc_env)++  where+    load :: Set.Set UnitId -> UnitId -> LoaderState -> IO (Set.Set UnitId, LoaderState)+    load done uid pls | uid `Set.member` done = return (done, pls)+    load done uid pls = do+      let hsc' = hscSetActiveUnitId uid hsc_env+      -- Load potential dependencies first+      (done', pls') <- foldM (\(done', pls') uid -> load done' uid pls') (done, pls)+                          (homeUnitDepends (hsc_units hsc'))+      pls'' <- loadCmdLineLibs'' interp hsc' pls'+      return $ (Set.insert uid done', pls'')++loadCmdLineLibs''   :: Interp   -> HscEnv   -> LoaderState   -> IO LoaderState-loadCmdLineLibs' interp hsc_env pls =+loadCmdLineLibs'' interp hsc_env pls =   do+       let dflags@(DynFlags { ldInputs = cmdline_ld_inputs                            , libraryPaths = lib_paths_base})             = hsc_dflags hsc_env@@ -334,16 +370,16 @@        lib_paths_env <- addEnvPaths "LIBRARY_PATH" lib_paths_base -      maybePutStrLn logger dflags "Search directories (user):"-      maybePutStr logger dflags (unlines $ map ("  "++) lib_paths_env)-      maybePutStrLn logger dflags "Search directories (gcc):"-      maybePutStr logger dflags (unlines $ map ("  "++) gcc_paths)+      maybePutStrLn logger "Search directories (user):"+      maybePutStr logger (unlines $ map ("  "++) lib_paths_env)+      maybePutStrLn logger "Search directories (gcc):"+      maybePutStr logger (unlines $ map ("  "++) gcc_paths)        libspecs         <- mapM (locateLib interp hsc_env False lib_paths_env gcc_paths) minus_ls        -- (d) Link .o files from the command-line-      classified_ld_inputs <- mapM (classifyLdInput logger dflags)+      classified_ld_inputs <- mapM (classifyLdInput logger platform)                                 [ f | FileOption _ f <- cmdline_ld_inputs ]        -- (e) Link any MacOS frameworks@@ -375,13 +411,13 @@            pls1 <- foldM (preloadLib interp hsc_env lib_paths framework_paths) pls                          merged_specs -           maybePutStr logger dflags "final link ... "+           maybePutStr logger "final link ... "            ok <- resolveObjs interp             -- DLLs are loaded, reset the search paths            mapM_ (removeLibrarySearchPath interp) $ reverse pathCache -           if succeeded ok then maybePutStrLn logger dflags "done"+           if succeeded ok then maybePutStrLn logger "done"            else throwGhcExceptionIO (ProgramError "linking extra libraries/objects failed")             return pls1@@ -400,7 +436,7 @@     go [] [] = []  {- Note [preload packages]-+   ~~~~~~~~~~~~~~~~~~~~~~~ Why do we need to preload packages from the command line?  This is an explanation copied from #2437: @@ -424,16 +460,15 @@ users? -} -classifyLdInput :: Logger -> DynFlags -> FilePath -> IO (Maybe LibrarySpec)-classifyLdInput logger dflags f+classifyLdInput :: Logger -> Platform -> FilePath -> IO (Maybe LibrarySpec)+classifyLdInput logger platform f   | isObjectFilename platform f = return (Just (Objects [f]))   | isDynLibFilename platform f = return (Just (DLLPath f))   | otherwise          = do-        putLogMsg logger dflags NoReason SevInfo noSrcSpan+        logMsg logger MCInfo noSrcSpan             $ withPprStyle defaultUserStyle             (text ("Warning: ignoring unrecognised input `" ++ f ++ "'"))         return Nothing-    where platform = targetPlatform dflags  preloadLib   :: Interp@@ -444,22 +479,22 @@   -> LibrarySpec   -> IO LoaderState preloadLib interp hsc_env lib_paths framework_paths pls lib_spec = do-  maybePutStr logger dflags ("Loading object " ++ showLS lib_spec ++ " ... ")+  maybePutStr logger ("Loading object " ++ showLS lib_spec ++ " ... ")   case lib_spec of     Objects static_ishs -> do       (b, pls1) <- preload_statics lib_paths static_ishs-      maybePutStrLn logger dflags (if b  then "done" else "not found")+      maybePutStrLn logger (if b  then "done" else "not found")       return pls1      Archive static_ish -> do       b <- preload_static_archive lib_paths static_ish-      maybePutStrLn logger dflags (if b  then "done" else "not found")+      maybePutStrLn logger (if b  then "done" else "not found")       return pls      DLL dll_unadorned -> do       maybe_errstr <- loadDLL interp (platformSOName platform dll_unadorned)       case maybe_errstr of-         Nothing -> maybePutStrLn logger dflags "done"+         Nothing -> maybePutStrLn logger "done"          Just mm | platformOS platform /= OSDarwin ->            preloadFailed mm lib_paths lib_spec          Just mm | otherwise -> do@@ -469,14 +504,14 @@            let libfile = ("lib" ++ dll_unadorned) <.> "so"            err2 <- loadDLL interp libfile            case err2 of-             Nothing -> maybePutStrLn logger dflags "done"+             Nothing -> maybePutStrLn logger "done"              Just _  -> preloadFailed mm lib_paths lib_spec       return pls      DLLPath dll_path -> do       do maybe_errstr <- loadDLL interp dll_path          case maybe_errstr of-            Nothing -> maybePutStrLn logger dflags "done"+            Nothing -> maybePutStrLn logger "done"             Just mm -> preloadFailed mm lib_paths lib_spec          return pls @@ -484,7 +519,7 @@       if platformUsesFrameworks (targetPlatform dflags)       then do maybe_errstr <- loadFramework interp framework_paths framework               case maybe_errstr of-                 Nothing -> maybePutStrLn logger dflags "done"+                 Nothing -> maybePutStrLn logger "done"                  Just mm -> preloadFailed mm framework_paths lib_spec               return pls       else throwGhcExceptionIO (ProgramError "preloadLib Framework")@@ -497,7 +532,7 @@      preloadFailed :: String -> [String] -> LibrarySpec -> IO ()     preloadFailed sys_errmsg paths spec-       = do maybePutStr logger dflags "failed.\n"+       = do maybePutStr logger "failed.\n"             throwGhcExceptionIO $               CmdLineError (                     "user specified .o/.so/.DLL could not be loaded ("@@ -553,7 +588,7 @@   -- Take lock for the actual work.   modifyLoaderState interp $ \pls0 -> do     -- Load the packages and modules required-    (pls, ok) <- loadDependencies interp hsc_env pls0 span needed_mods+    (pls, ok, _, _) <- loadDependencies interp hsc_env pls0 span needed_mods     if failed ok       then throwGhcExceptionIO (ProgramError "")       else do@@ -565,11 +600,11 @@         let nobreakarray = error "no break array"             bco_ix = mkNameEnv [(unlinkedBCOName root_ul_bco, 0)]         resolved <- linkBCO interp ie ce bco_ix nobreakarray root_ul_bco-        [root_hvref] <- createBCOs interp dflags [resolved]+        bco_opts <- initBCOOpts (hsc_dflags hsc_env)+        [root_hvref] <- createBCOs interp bco_opts [resolved]         fhv <- mkFinalizedHValue interp root_hvref         return (pls, fhv)   where-     dflags = hsc_dflags hsc_env      free_names = uniqDSetToList (bcoFreeNames root_ul_bco)       needed_mods :: [Module]@@ -583,21 +618,25 @@         -- by default, so we can safely ignore them here.  dieWith :: DynFlags -> SrcSpan -> SDoc -> IO a-dieWith dflags span msg = throwGhcExceptionIO (ProgramError (showSDoc dflags (mkLocMessage SevFatal span msg)))+dieWith dflags span msg = throwGhcExceptionIO (ProgramError (showSDoc dflags (mkLocMessage MCFatal span msg)))   checkNonStdWay :: DynFlags -> Interp -> SrcSpan -> IO (Maybe FilePath)-checkNonStdWay dflags interp srcspan+checkNonStdWay _dflags interp _srcspan   | ExternalInterp {} <- interpInstance interp = return Nothing     -- with -fexternal-interpreter we load the .o files, whatever way     -- they were built.  If they were built for a non-std way, then     -- we will use the appropriate variant of the iserv binary to load them. +-- #if-guard the following equations otherwise the pattern match checker will+-- complain that they are redundant.+#if defined(HAVE_INTERNAL_INTERPRETER)+checkNonStdWay dflags _interp srcspan   | hostFullWays == targetFullWays = return Nothing     -- Only if we are compiling with the same ways as GHC is built     -- with, can we dynamically load those object files. (see #3604) -  | objectSuf dflags == normalObjectSuffix && not (null targetFullWays)+  | objectSuf_ dflags == normalObjectSuffix && not (null targetFullWays)   = failNonStd dflags srcspan    | otherwise = return (Just (hostWayTag ++ "o"))@@ -607,52 +646,80 @@                   "" -> ""                   tag -> tag ++ "_" -normalObjectSuffix :: String-normalObjectSuffix = phaseInputExt StopLn+    normalObjectSuffix :: String+    normalObjectSuffix = phaseInputExt StopLn +data Way' = Normal | Prof | Dyn+ failNonStd :: DynFlags -> SrcSpan -> IO (Maybe FilePath) failNonStd dflags srcspan = dieWith dflags srcspan $-  text "Cannot load" <+> compWay <+>-     text "objects when GHC is built" <+> ghciWay $$+  text "Cannot load" <+> pprWay' compWay <+>+     text "objects when GHC is built" <+> pprWay' ghciWay $$   text "To fix this, either:" $$   text "  (1) Use -fexternal-interpreter, or" $$-  text "  (2) Build the program twice: once" <+>-                       ghciWay <> text ", and then" $$-  text "      with" <+> compWay <+>-     text "using -osuf to set a different object file suffix."+  buildTwiceMsg     where compWay-            | WayDyn `elem` ways dflags = text "-dynamic"-            | WayProf `elem` ways dflags = text "-prof"-            | otherwise = text "normal"+            | ways dflags `hasWay` WayDyn  = Dyn+            | ways dflags `hasWay` WayProf = Prof+            | otherwise = Normal           ghciWay-            | hostIsDynamic = text "with -dynamic"-            | hostIsProfiled = text "with -prof"-            | otherwise = text "the normal way"+            | hostIsDynamic = Dyn+            | hostIsProfiled = Prof+            | otherwise = Normal+          buildTwiceMsg = case (ghciWay, compWay) of+            (Normal, Dyn) -> dynamicTooMsg+            (Dyn, Normal) -> dynamicTooMsg+            _ ->+              text "  (2) Build the program twice: once" <+>+                pprWay' ghciWay <> text ", and then" $$+              text "      " <> pprWay' compWay <+>+                text "using -osuf to set a different object file suffix."+          dynamicTooMsg = text "  (2) Use -dynamic-too," <+>+            text "and use -osuf and -dynosuf to set object file suffixes as needed."+          pprWay' :: Way' -> SDoc+          pprWay' way = text $ case way of+            Normal -> "the normal way"+            Prof -> "with -prof"+            Dyn -> "with -dynamic"+#endif -getLinkDeps :: HscEnv -> HomePackageTable+getLinkDeps :: HscEnv             -> LoaderState-            -> Maybe FilePath                   -- replace object suffices?+            -> Maybe FilePath                   -- replace object suffixes?             -> SrcSpan                          -- for error messages             -> [Module]                         -- If you need these-            -> IO ([Linkable], [UnitId])     -- ... then link these first+            -> IO ([Linkable], [Linkable], [UnitId], UniqDSet UnitId)     -- ... then link these first+            -- The module and package dependencies for the needed modules are returned.+            -- See Note [Object File Dependencies] -- Fails with an IO exception if it can't find enough files -getLinkDeps hsc_env hpt pls replace_osuf span mods+getLinkDeps hsc_env pls replace_osuf span mods -- Find all the packages and linkables that a set of modules depends on  = do {         -- 1.  Find the dependent home-pkg-modules/packages from each iface         -- (omitting modules from the interactive package, which is already linked)-      ; (mods_s, pkgs_s) <- follow_deps (filterOut isInteractiveModule mods)-                                        emptyUniqDSet emptyUniqDSet;+      ; (mods_s, pkgs_s) <-+          -- Why two code paths here? There is a significant amount of repeated work+          -- performed calculating transitive dependencies+          -- if --make uses the oneShot code path (see MultiLayerModulesTH_* tests)+          if isOneShot (ghcMode dflags)+            then follow_deps (filterOut isInteractiveModule mods)+                              emptyUniqDSet emptyUniqDSet;+            else do+              (pkgs, mmods) <- unzip <$> mapM get_mod_info all_home_mods+              return (catMaybes mmods, unionManyUniqDSets (init_pkg_set : pkgs)) -      ; let {+      ; let         -- 2.  Exclude ones already linked         --      Main reason: avoid findModule calls in get_linkable-            mods_needed = mods_s `minusList` linked_mods     ;-            pkgs_needed = pkgs_s `minusList` pkgs_loaded pls ;+            (mods_needed, links_got) = partitionEithers (map split_mods mods_s)+            pkgs_needed = eltsUDFM $ getUniqDSet pkgs_s `minusUDFM` pkgs_loaded pls -            linked_mods = map (moduleName.linkableModule)-                                (objs_loaded pls ++ bcos_loaded pls)  }+            split_mods mod =+                let is_linked = findModuleLinkable_maybe (objs_loaded pls) mod <|> findModuleLinkable_maybe (bcos_loaded pls) mod+                in case is_linked of+                     Just linkable -> Right linkable+                     Nothing -> Left mod          -- 3.  For each dependent module, find its linkable         --     This will either be in the HPT or (in the case of one-shot@@ -660,21 +727,67 @@       ; let { osuf = objectSuf dflags }       ; lnks_needed <- mapM (get_linkable osuf) mods_needed -      ; return (lnks_needed, pkgs_needed) }+      ; return (lnks_needed, links_got ++ lnks_needed, pkgs_needed, pkgs_s) }   where     dflags = hsc_dflags hsc_env+    mod_graph = hsc_mod_graph hsc_env -        -- The ModIface contains the transitive closure of the module dependencies-        -- within the current package, *except* for boot modules: if we encounter-        -- a boot module, we have to find its real interface and discover the-        -- dependencies of that.  Hence we need to traverse the dependency-        -- tree recursively.  See bug #936, testcase ghci/prog007.+    -- This code is used in `--make` mode to calculate the home package and unit dependencies+    -- for a set of modules.+    --+    -- It is significantly more efficient to use the shared transitive dependency+    -- calculation than to compute the transitive dependency set in the same manner as oneShot mode.++    -- It is also a matter of correctness to use the module graph so that dependencies between home units+    -- is resolved correctly.+    make_deps_loop :: (UniqDSet UnitId, Set.Set NodeKey) -> [ModNodeKeyWithUid] -> (UniqDSet UnitId, Set.Set NodeKey)+    make_deps_loop found [] = found+    make_deps_loop found@(found_units, found_mods) (nk:nexts)+      | NodeKey_Module nk `Set.member` found_mods = make_deps_loop found nexts+      | otherwise =+        case M.lookup (NodeKey_Module nk) (mgTransDeps mod_graph) of+            Just trans_deps ->+              let deps = Set.insert (NodeKey_Module nk) trans_deps+                  -- See #936 and the ghci.prog007 test for why we have to continue traversing through+                  -- boot modules.+                  todo_boot_mods = [ModNodeKeyWithUid (GWIB mn NotBoot) uid | NodeKey_Module (ModNodeKeyWithUid (GWIB mn IsBoot) uid) <- Set.toList trans_deps]+              in make_deps_loop (found_units, deps `Set.union` found_mods) (todo_boot_mods ++ nexts)+            Nothing ->+              let (ModNodeKeyWithUid _ uid) = nk+              in make_deps_loop (addOneToUniqDSet found_units uid, found_mods) nexts++    mkNk m = ModNodeKeyWithUid (GWIB (moduleName m) NotBoot) (moduleUnitId m)+    (init_pkg_set, all_deps) = make_deps_loop (emptyUniqDSet, Set.empty) $ map mkNk (filterOut isInteractiveModule mods)++    all_home_mods = [with_uid | NodeKey_Module with_uid <- Set.toList all_deps]++    get_mod_info (ModNodeKeyWithUid gwib uid) =+      case lookupHug (hsc_HUG hsc_env) uid (gwib_mod gwib) of+        Just hmi ->+          let iface = (hm_iface hmi)+              mmod = case mi_hsc_src iface of+                      HsBootFile -> link_boot_mod_error (mi_module iface)+                      _ -> return $ Just (mi_module iface)++          in (mkUniqDSet $ Set.toList $ dep_direct_pkgs (mi_deps iface),) <$>  mmod+        Nothing ->+          let err = text "getLinkDeps: Home module not loaded" <+> ppr (gwib_mod gwib) <+> ppr uid+          in throwGhcExceptionIO (ProgramError (showSDoc dflags err))+++       -- This code is used in one-shot mode to traverse downwards through the HPT+       -- to find all link dependencies.+       -- The ModIface contains the transitive closure of the module dependencies+       -- within the current package, *except* for boot modules: if we encounter+       -- a boot module, we have to find its real interface and discover the+       -- dependencies of that.  Hence we need to traverse the dependency+       -- tree recursively.  See bug #936, testcase ghci/prog007.     follow_deps :: [Module]             -- modules to follow-                -> UniqDSet ModuleName         -- accum. module dependencies+                -> UniqDSet Module         -- accum. module dependencies                 -> UniqDSet UnitId          -- accum. package dependencies-                -> IO ([ModuleName], [UnitId]) -- result+                -> IO ([Module], UniqDSet UnitId) -- result     follow_deps []     acc_mods acc_pkgs-        = return (uniqDSetToList acc_mods, uniqDSetToList acc_pkgs)+        = return (uniqDSetToList acc_mods, acc_pkgs)     follow_deps (mod:mods) acc_mods acc_pkgs         = do           mb_iface <- initIfaceCheck (text "getLinkDeps") hsc_env $@@ -688,28 +801,32 @@           let             pkg = moduleUnit mod             deps  = mi_deps iface-            home_unit = hsc_home_unit hsc_env -            pkg_deps = dep_pkgs deps-            (boot_deps, mod_deps) = flip partitionWith (dep_mods deps) $-              \ (GWIB { gwib_mod = m, gwib_isBoot = is_boot }) ->-                m & case is_boot of-                  IsBoot -> Left-                  NotBoot -> Right+            pkg_deps = dep_direct_pkgs deps+            (boot_deps, mod_deps) = flip partitionWith (Set.toList (dep_direct_mods deps)) $+              \case+                (_, GWIB m IsBoot)  -> Left m+                (_, GWIB m NotBoot) -> Right m -            boot_deps' = filter (not . (`elementOfUniqDSet` acc_mods)) boot_deps-            acc_mods'  = addListToUniqDSet acc_mods (moduleName mod : mod_deps)-            acc_pkgs'  = addListToUniqDSet acc_pkgs $ map fst pkg_deps-          ---          if not (isHomeUnit home_unit pkg)-             then follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toUnitId pkg))-             else follow_deps (map (mkHomeModule home_unit) boot_deps' ++ mods)-                              acc_mods' acc_pkgs'+            mod_deps' = case hsc_home_unit_maybe hsc_env of+                          Nothing -> []+                          Just home_unit -> filter (not . (`elementOfUniqDSet` acc_mods)) (map (mkHomeModule home_unit) $ (boot_deps ++ mod_deps))+            acc_mods'  = case hsc_home_unit_maybe hsc_env of+                          Nothing -> acc_mods+                          Just home_unit -> addListToUniqDSet acc_mods (mod : map (mkHomeModule home_unit) mod_deps)+            acc_pkgs'  = addListToUniqDSet acc_pkgs (Set.toList pkg_deps)++          case hsc_home_unit_maybe hsc_env of+            Just home_unit | isHomeUnit home_unit pkg ->  follow_deps (mod_deps' ++ mods)+                                                                      acc_mods' acc_pkgs'+            _ ->  follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toUnitId pkg))         where-            msg = text "need to link module" <+> ppr mod <+>+           msg = text "need to link module" <+> ppr mod <+>                   text "due to use of Template Haskell"  ++    link_boot_mod_error :: Module -> IO a     link_boot_mod_error mod =         throwGhcExceptionIO (ProgramError (showSDoc dflags (             text "module" <+> ppr mod <+>@@ -725,16 +842,23 @@          -- This one is a build-system bug -    get_linkable osuf mod_name      -- A home-package module-        | Just mod_info <- lookupHpt hpt mod_name+    get_linkable osuf mod      -- A home-package module+        | Just mod_info <- lookupHugByModule mod (hsc_HUG hsc_env)         = adjust_linkable (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info))         | otherwise         = do    -- It's not in the HPT because we are in one shot mode,                 -- so use the Finder to get a ModLocation...-             mb_stuff <- findHomeModule hsc_env mod_name-             case mb_stuff of+             case hsc_home_unit_maybe hsc_env of+              Nothing -> no_obj mod+              Just home_unit -> do++                let fc = hsc_FC hsc_env+                let dflags = hsc_dflags hsc_env+                let fopts = initFinderOpts dflags+                mb_stuff <- findHomeModule fc fopts home_unit (moduleName mod)+                case mb_stuff of                   Found loc mod -> found loc mod-                  _ -> no_obj mod_name+                  _ -> no_obj (moduleName mod)         where             found loc mod = do {                 -- ...and then find the linkable for it@@ -753,7 +877,7 @@                         return lnk              adjust_ul new_osuf (DotO file) = do-                MASSERT(osuf `isSuffixOf` file)+                massert (osuf `isSuffixOf` file)                 let file_base = fromJust (stripExtension osuf file)                     new_file = file_base <.> new_osuf                 ok <- doesFileExist new_file@@ -767,14 +891,13 @@             adjust_ul _ l@(BCOs {}) = return l  - {- **********************************************************************                Loading a Decls statement    ********************************************************************* -} -loadDecls :: Interp -> HscEnv -> SrcSpan -> CompiledByteCode -> IO [(Name, ForeignHValue)]+loadDecls :: Interp -> HscEnv -> SrcSpan -> CompiledByteCode -> IO ([(Name, ForeignHValue)], [Linkable], PkgsLoaded) loadDecls interp hsc_env span cbc@CompiledByteCode{..} = do     -- Initialise the linker (if it's not been done already)     initLoaderState interp hsc_env@@ -782,7 +905,7 @@     -- Take lock for the actual work.     modifyLoaderState interp $ \pls0 -> do       -- Link the packages and modules required-      (pls, ok) <- loadDependencies interp hsc_env pls0 span needed_mods+      (pls, ok, links_needed, units_needed) <- loadDependencies interp hsc_env pls0 span needed_mods       if failed ok         then throwGhcExceptionIO (ProgramError "")         else do@@ -791,13 +914,13 @@               ce = closure_env pls            -- Link the necessary packages and linkables-          new_bindings <- linkSomeBCOs dflags interp ie ce [cbc]+          bco_opts <- initBCOOpts (hsc_dflags hsc_env)+          new_bindings <- linkSomeBCOs bco_opts interp ie ce [cbc]           nms_fhvs <- makeForeignNamedHValueRefs interp new_bindings           let pls2 = pls { closure_env = extendClosureEnv ce nms_fhvs                          , itbl_env    = ie }-          return (pls2, nms_fhvs)+          return (pls2, (nms_fhvs, links_needed, units_needed))   where-    dflags = hsc_dflags hsc_env     free_names = uniqDSetToList $       foldr (unionUniqDSets . bcoFreeNames) emptyUniqDSet bc_bcos @@ -821,7 +944,7 @@ loadModule interp hsc_env mod = do   initLoaderState interp hsc_env   modifyLoaderState_ interp $ \pls -> do-    (pls', ok) <- loadDependencies interp hsc_env pls noSrcSpan [mod]+    (pls', ok, _, _) <- loadDependencies interp hsc_env pls noSrcSpan [mod]     if failed ok       then throwGhcExceptionIO (ProgramError "could not load module")       else return pls'@@ -834,13 +957,13 @@    ********************************************************************* -} -loadModules :: Interp -> HscEnv -> LoaderState -> [Linkable] -> IO (LoaderState, SuccessFlag)-loadModules interp hsc_env pls linkables+loadModuleLinkables :: Interp -> HscEnv -> LoaderState -> [Linkable] -> IO (LoaderState, SuccessFlag)+loadModuleLinkables interp hsc_env pls linkables   = mask_ $ do  -- don't want to be interrupted by ^C in here          let (objs, bcos) = partition isObjectLinkable                               (concatMap partitionLinkable linkables)-        let dflags = hsc_dflags hsc_env+        bco_opts <- initBCOOpts (hsc_dflags hsc_env)                  -- Load objects first; they can't depend on BCOs         (pls1, ok_flag) <- loadObjects interp hsc_env pls objs@@ -848,7 +971,7 @@         if failed ok_flag then                 return (pls1, Failed)           else do-                pls2 <- dynLinkBCOs dflags interp pls1 bcos+                pls2 <- dynLinkBCOs bco_opts interp pls1 bcos                 return (pls2, Succeeded)  @@ -864,14 +987,10 @@                            li {linkableUnlinked=li_uls_bco}]             _ -> [li] -findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable-findModuleLinkable_maybe lis mod-   = case [LM time nm us | LM time nm us <- lis, nm == mod] of-        []   -> Nothing-        [li] -> Just li-        _    -> pprPanic "findModuleLinkable" (ppr mod)+findModuleLinkable_maybe :: LinkableSet -> Module -> Maybe Linkable+findModuleLinkable_maybe = lookupModuleEnv -linkableInSet :: Linkable -> [Linkable] -> Bool+linkableInSet :: Linkable -> LinkableSet -> Bool linkableInSet l objs_loaded =   case findModuleLinkable_maybe objs_loaded (linkableModule l) of         Nothing -> False@@ -929,7 +1048,7 @@     let minus_ls = [ lib | Option ('-':'l':lib) <- ldInputs dflags ]     let minus_big_ls = [ lib | Option ('-':'L':lib) <- ldInputs dflags ]     (soFile, libPath , libName) <--      newTempLibName logger tmpfs dflags TFL_CurrentModule (platformSOExt platform)+      newTempLibName logger tmpfs (tmpDir dflags) TFL_CurrentModule (platformSOExt platform)     let         dflags2 = dflags {                       -- We don't want the original ldInputs in@@ -975,7 +1094,7 @@     -- link all "loaded packages" so symbols in those can be resolved     -- Note: We are loading packages with local scope, so to see the     -- symbols in this link we must link all loaded packages again.-    linkDynLib logger tmpfs dflags2 unit_env objs pkgs_loaded+    linkDynLib logger tmpfs dflags2 unit_env objs (loaded_pkg_uid <$> eltsUDFM pkgs_loaded)      -- if we got this far, extend the lifetime of the library file     changeTempFilesLifetime tmpfs TFL_GhcSession [soFile]@@ -986,9 +1105,9 @@   where     msg = "GHC.Linker.Loader.dynLoadObjs: Loading temp shared object failed" -rmDupLinkables :: [Linkable]    -- Already loaded+rmDupLinkables :: LinkableSet    -- Already loaded                -> [Linkable]    -- New linkables-               -> ([Linkable],  -- New loaded set (including new ones)+               -> (LinkableSet,  -- New loaded set (including new ones)                    [Linkable])  -- New linkables (excluding dups) rmDupLinkables already ls   = go already [] ls@@ -996,7 +1115,7 @@     go already extras [] = (already, extras)     go already extras (l:ls)         | linkableInSet l already = go already     extras     ls-        | otherwise               = go (l:already) (l:extras) ls+        | otherwise               = go (extendModuleEnv already (linkableModule l) l) (l:extras) ls  {- ********************************************************************** @@ -1005,8 +1124,8 @@   ********************************************************************* -}  -dynLinkBCOs :: DynFlags -> Interp -> LoaderState -> [Linkable] -> IO LoaderState-dynLinkBCOs dflags interp pls bcos = do+dynLinkBCOs :: BCOOpts -> Interp -> LoaderState -> [Linkable] -> IO LoaderState+dynLinkBCOs bco_opts interp pls bcos = do          let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos             pls1                     = pls { bcos_loaded = bcos_loaded' }@@ -1021,7 +1140,7 @@             gce       = closure_env pls             final_ie  = foldr plusNameEnv (itbl_env pls) ies -        names_and_refs <- linkSomeBCOs dflags interp final_ie gce cbcs+        names_and_refs <- linkSomeBCOs bco_opts interp final_ie gce cbcs          -- We only want to add the external ones to the ClosureEnv         let (to_add, to_drop) = partition (isExternalName.fst) names_and_refs@@ -1035,7 +1154,7 @@                       itbl_env    = final_ie }  -- Link a bunch of BCOs and return references to their values-linkSomeBCOs :: DynFlags+linkSomeBCOs :: BCOOpts              -> Interp              -> ItblEnv              -> ClosureEnv@@ -1045,7 +1164,7 @@                         -- the incoming unlinked BCOs.  Each gives the                         -- value of the corresponding unlinked BCO -linkSomeBCOs dflags interp ie ce mods = foldr fun do_link mods []+linkSomeBCOs bco_opts interp ie ce mods = foldr fun do_link mods []  where   fun CompiledByteCode{..} inner accum =     case bc_breaks of@@ -1060,7 +1179,7 @@         bco_ix = mkNameEnv (zip names [0..])     resolved <- sequence [ linkBCO interp ie ce bco_ix breakarray bco                          | (breakarray, bco) <- flat ]-    hvrefs <- createBCOs interp dflags resolved+    hvrefs <- createBCOs interp bco_opts resolved     return (zip names hvrefs)  -- | Useful to apply to the result of 'linkSomeBCOs'@@ -1105,12 +1224,11 @@                  pls1 <- unload_wkr interp linkables pls                  return (pls1, pls1) -        let dflags = hsc_dflags hsc_env         let logger = hsc_logger hsc_env-        debugTraceMsg logger dflags 3 $-          text "unload: retaining objs" <+> ppr (objs_loaded new_pls)-        debugTraceMsg logger dflags 3 $-          text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls)+        debugTraceMsg logger 3 $+          text "unload: retaining objs" <+> ppr (moduleEnvElts $ objs_loaded new_pls)+        debugTraceMsg logger 3 $+          text "unload: retaining bcos" <+> ppr (moduleEnvElts $ bcos_loaded new_pls)         return ()  unload_wkr@@ -1126,32 +1244,32 @@   -- we're unloading some code.  -fghci-leak-check with the tests in   -- testsuite/ghci can detect space leaks here. -  let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable keep_linkables+  let (objs_to_keep', bcos_to_keep') = partition isObjectLinkable keep_linkables+      objs_to_keep = mkLinkableSet objs_to_keep'+      bcos_to_keep = mkLinkableSet bcos_to_keep'        discard keep l = not (linkableInSet l keep)        (objs_to_unload, remaining_objs_loaded) =-         partition (discard objs_to_keep) objs_loaded+         partitionModuleEnv (discard objs_to_keep) objs_loaded       (bcos_to_unload, remaining_bcos_loaded) =-         partition (discard bcos_to_keep) bcos_loaded+         partitionModuleEnv (discard bcos_to_keep) bcos_loaded -  mapM_ unloadObjs objs_to_unload-  mapM_ unloadObjs bcos_to_unload+      linkables_to_unload = moduleEnvElts objs_to_unload ++ moduleEnvElts bcos_to_unload +  mapM_ unloadObjs linkables_to_unload+   -- If we unloaded any object files at all, we need to purge the cache   -- of lookupSymbol results.-  when (not (null (objs_to_unload ++-                   filter (not . null . linkableObjs) bcos_to_unload))) $+  when (not (null (filter (not . null . linkableObjs) linkables_to_unload))) $     purgeLookupSymbolCache interp -  let !bcos_retained = mkModuleSet $ map linkableModule remaining_bcos_loaded--      -- Note that we want to remove all *local*+  let -- Note that we want to remove all *local*       -- (i.e. non-isExternal) names too (these are the       -- temporary bindings from the command line).       keep_name :: (Name, a) -> Bool       keep_name (n,_) = isExternalName n &&-                        nameModule n `elemModuleSet` bcos_retained+                        nameModule n `elemModuleEnv` remaining_bcos_loaded        itbl_env'     = filterNameEnv keep_name itbl_env       closure_env'  = filterNameEnv keep_name closure_env@@ -1165,10 +1283,7 @@   where     unloadObjs :: Linkable -> IO ()     unloadObjs lnk-        -- The RTS's PEi386 linker currently doesn't support unloading.-      | isWindowsHost = return ()--      | hostIsDynamic = return ()+      | interpreterDynamic interp = return ()         -- We don't do any cleanup when linking objects with the         -- dynamic linker.  Doing so introduces extra complexity for         -- not much benefit.@@ -1182,55 +1297,6 @@                 -- letting go of them (plus of course depopulating                 -- the symbol table which is done in the main body) -{- **********************************************************************--                Loading packages--  ********************************************************************* -}--data LibrarySpec-   = Objects [FilePath] -- Full path names of set of .o files, including trailing .o-                        -- We allow batched loading to ensure that cyclic symbol-                        -- references can be resolved (see #13786).-                        -- For dynamic objects only, try to find the object-                        -- file in all the directories specified in-                        -- v_Library_paths before giving up.--   | Archive FilePath   -- Full path name of a .a file, including trailing .a--   | DLL String         -- "Unadorned" name of a .DLL/.so-                        --  e.g.    On unix     "qt"  denotes "libqt.so"-                        --          On Windows  "burble"  denotes "burble.DLL" or "libburble.dll"-                        --  loadDLL is platform-specific and adds the lib/.so/.DLL-                        --  suffixes platform-dependently--   | DLLPath FilePath   -- Absolute or relative pathname to a dynamic library-                        -- (ends with .dll or .so).--   | Framework String   -- Only used for darwin, but does no harm--instance Outputable LibrarySpec where-  ppr (Objects objs) = text "Objects" <+> ppr objs-  ppr (Archive a) = text "Archive" <+> text a-  ppr (DLL s) = text "DLL" <+> text s-  ppr (DLLPath f) = text "DLLPath" <+> text f-  ppr (Framework s) = text "Framework" <+> text s---- If this package is already part of the GHCi binary, we'll already--- have the right DLLs for this package loaded, so don't try to--- load them again.------ But on Win32 we must load them 'again'; doing so is a harmless no-op--- as far as the loader is concerned, but it does initialise the list--- of DLL handles that rts/Linker.c maintains, and that in turn is--- used by lookupSymbol.  So we must call addDLL for each library--- just to get the DLL handle into the list.-partOfGHCi :: [PackageName]-partOfGHCi- | isWindowsHost || isDarwinHost = []- | otherwise = map (PackageName . mkFastString)-                   ["base", "template-haskell", "editline"]- showLS :: LibrarySpec -> String showLS (Objects nms)  = "(static) [" ++ intercalate ", " nms ++ "]" showLS (Archive nm)   = "(static archive) " ++ nm@@ -1262,28 +1328,34 @@ loadPackages' :: Interp -> HscEnv -> [UnitId] -> LoaderState -> IO LoaderState loadPackages' interp hsc_env new_pks pls = do     pkgs' <- link (pkgs_loaded pls) new_pks-    return $! pls { pkgs_loaded = pkgs' }+    return $! pls { pkgs_loaded = pkgs'+                  }   where-     link :: [UnitId] -> [UnitId] -> IO [UnitId]+     link :: PkgsLoaded -> [UnitId] -> IO PkgsLoaded      link pkgs new_pkgs =          foldM link_one pkgs new_pkgs       link_one pkgs new_pkg-        | new_pkg `elem` pkgs   -- Already linked+        | new_pkg `elemUDFM` pkgs   -- Already linked         = return pkgs          | Just pkg_cfg <- lookupUnitId (hsc_units hsc_env) new_pkg-        = do {  -- Link dependents first-               pkgs' <- link pkgs (unitDepends pkg_cfg)+        = do { let deps = unitDepends pkg_cfg+               -- Link dependents first+             ; pkgs' <- link pkgs deps                 -- Now link the package itself-             ; loadPackage interp hsc_env pkg_cfg-             ; return (new_pkg : pkgs') }+             ; (hs_cls, extra_cls) <- loadPackage interp hsc_env pkg_cfg+             ; let trans_deps = unionManyUniqDSets [ addOneToUniqDSet (loaded_pkg_trans_deps loaded_pkg_info) dep_pkg+                                                   | dep_pkg <- deps+                                                   , Just loaded_pkg_info <- pure (lookupUDFM pkgs' dep_pkg)+                                                   ]+             ; return (addToUDFM pkgs' new_pkg (LoadedPkgInfo new_pkg hs_cls extra_cls trans_deps)) }          | otherwise         = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (unitIdFS new_pkg)))  -loadPackage :: Interp -> HscEnv -> UnitInfo -> IO ()+loadPackage :: Interp -> HscEnv -> UnitInfo -> IO ([LibrarySpec], [LibrarySpec]) loadPackage interp hsc_env pkg    = do         let dflags    = hsc_dflags hsc_env@@ -1326,7 +1398,9 @@          -- Complication: all the .so's must be loaded before any of the .o's.         let known_dlls = [ dll  | DLLPath dll    <- classifieds ]+#if defined(CAN_LOAD_DLL)             dlls       = [ dll  | DLL dll        <- classifieds ]+#endif             objs       = [ obj  | Objects objs    <- classifieds                                 , obj <- objs ]             archs      = [ arch | Archive arch   <- classifieds ]@@ -1337,19 +1411,17 @@         all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths         pathCache <- mapM (addLibrarySearchPath interp) all_paths_env -        maybePutSDoc logger dflags+        maybePutSDoc logger             (text "Loading unit " <> pprUnitInfoForUser pkg <> text " ... ") -        -- See comments with partOfGHCi #if defined(CAN_LOAD_DLL)-        when (unitPackageName pkg `notElem` partOfGHCi) $ do-            loadFrameworks interp platform pkg-            -- See Note [Crash early load_dyn and locateLib]-            -- Crash early if can't load any of `known_dlls`-            mapM_ (load_dyn interp hsc_env True) known_dlls-            -- For remaining `dlls` crash early only when there is surely-            -- no package's DLL around ... (not is_dyn)-            mapM_ (load_dyn interp hsc_env (not is_dyn) . platformSOName platform) dlls+        loadFrameworks interp platform pkg+        -- See Note [Crash early load_dyn and locateLib]+        -- Crash early if can't load any of `known_dlls`+        mapM_ (load_dyn interp hsc_env True) known_dlls+        -- For remaining `dlls` crash early only when there is surely+        -- no package's DLL around ... (not is_dyn)+        mapM_ (load_dyn interp hsc_env (not is_dyn) . platformSOName platform) dlls #endif         -- After loading all the DLLs, we can load the static objects.         -- Ordering isn't important here, because we do one final link@@ -1357,7 +1429,7 @@         mapM_ (loadObj interp) objs         mapM_ (loadArchive interp) archs -        maybePutStr logger dflags "linking ... "+        maybePutStr logger "linking ... "         ok <- resolveObjs interp          -- DLLs are loaded, reset the search paths@@ -1367,7 +1439,9 @@         mapM_ (removeLibrarySearchPath interp) $ reverse pathCache          if succeeded ok-           then maybePutStrLn logger dflags "done."+           then do+             maybePutStrLn logger "done."+             return (hs_classifieds, extra_classifieds)            else let errmsg = text "unable to load unit `"                              <> pprUnitInfoForUser pkg <> text "'"                  in throwGhcExceptionIO (InstallationError (showSDoc dflags errmsg))@@ -1415,6 +1489,7 @@ restriction very easily. -} +#if defined(CAN_LOAD_DLL) -- we have already searched the filesystem; the strings passed to load_dyn -- can be passed directly to loadDLL.  They are either fully-qualified -- ("/usr/lib/libfoo.so"), or unqualified ("libfoo.so").  In the latter case,@@ -1428,12 +1503,12 @@       if crash_early         then cmdLineErrorIO err         else-          when (wopt Opt_WarnMissedExtraSharedLib dflags)-            $ putLogMsg logger dflags-                (Reason Opt_WarnMissedExtraSharedLib) SevWarning+          when (diag_wopt Opt_WarnMissedExtraSharedLib diag_opts)+            $ logMsg logger+                (mkMCDiagnostic diag_opts $ WarningWithFlag Opt_WarnMissedExtraSharedLib)                   noSrcSpan $ withPprStyle defaultUserStyle (note err)   where-    dflags = hsc_dflags hsc_env+    diag_opts = initDiagOpts (hsc_dflags hsc_env)     logger = hsc_logger hsc_env     note err = vcat $ map text       [ err@@ -1453,6 +1528,7 @@                     Nothing  -> return ()                     Just err -> cmdLineErrorIO ("can't load framework: "                                                 ++ fw ++ " (" ++ err ++ ")" )+#endif  -- Try to find an object file for a given library in the given paths. -- If it isn't present, we assume that addDLL in the RTS can find it,@@ -1468,7 +1544,7 @@   -> [FilePath]   -> String   -> IO LibrarySpec-locateLib interp hsc_env is_hs lib_dirs gcc_dirs lib+locateLib interp hsc_env is_hs lib_dirs gcc_dirs lib0   | not is_hs     -- For non-Haskell libraries (e.g. gmp, iconv):     --   first look in library-dirs for a dynamic library (on User paths only)@@ -1521,52 +1597,79 @@    where      dflags = hsc_dflags hsc_env      logger = hsc_logger hsc_env+     diag_opts = initDiagOpts dflags      dirs   = lib_dirs ++ gcc_dirs      gcc    = False      user   = True +     -- Emulate ld's behavior of treating $LIB in `-l:$LIB` as a literal file+     -- name+     (lib, verbatim) = case lib0 of+       ':' : rest -> (rest, True)+       other      -> (other, False)+      obj_file        | is_hs && loading_profiled_hs_libs = lib <.> "p_o"        | otherwise = lib <.> "o"      dyn_obj_file = lib <.> "dyn_o"-     arch_files = [ "lib" ++ lib ++ lib_tag <.> "a"-                  , lib <.> "a" -- native code has no lib_tag-                  , "lib" ++ lib, lib-                  ]+     arch_files+       | verbatim = [lib]+       | otherwise = [ "lib" ++ lib ++ lib_tag <.> "a"+                     , lib <.> "a" -- native code has no lib_tag+                     , "lib" ++ lib+                     , lib+                     ]      lib_tag = if is_hs && loading_profiled_hs_libs then "_p" else ""       loading_profiled_hs_libs = interpreterProfiled interp      loading_dynamic_hs_libs  = interpreterDynamic  interp -     import_libs  = [ lib <.> "lib"           , "lib" ++ lib <.> "lib"-                    , "lib" ++ lib <.> "dll.a", lib <.> "dll.a"-                    ]+     import_libs+       | verbatim = [lib]+       | otherwise = [ lib <.> "lib"+                     , "lib" ++ lib <.> "lib"+                     , "lib" ++ lib <.> "dll.a"+                     , lib <.> "dll.a"+                     ]       hs_dyn_lib_name = lib ++ dynLibSuffix (ghcNameVersion dflags)      hs_dyn_lib_file = platformHsSOName platform hs_dyn_lib_name +#if defined(CAN_LOAD_DLL)      so_name     = platformSOName platform lib      lib_so_name = "lib" ++ so_name-     dyn_lib_file = case (arch, os) of-                             (ArchX86_64, OSSolaris2) -> "64" </> so_name-                             _ -> so_name+     dyn_lib_file+       | verbatim && any (`isExtensionOf` lib) [".so", ".dylib", ".dll"]+       = lib +       | ArchX86_64 <- arch+       , OSSolaris2 <- os+       = "64" </> so_name++       | otherwise+        = so_name+#endif+      findObject    = liftM (fmap $ Objects . (:[]))  $ findFile dirs obj_file      findDynObject = liftM (fmap $ Objects . (:[]))  $ findFile dirs dyn_obj_file      findArchive   = let local name = liftM (fmap Archive) $ findFile dirs name                      in  apply (map local arch_files)      findHSDll     = liftM (fmap DLLPath) $ findFile dirs hs_dyn_lib_file+#if defined(CAN_LOAD_DLL)      findDll    re = let dirs' = if re == user then lib_dirs else gcc_dirs                      in liftM (fmap DLLPath) $ findFile dirs' dyn_lib_file      findSysDll    = fmap (fmap $ DLL . dropExtension . takeFileName) $                         findSystemLibrary interp so_name+#endif      tryGcc        = let search   = searchForLibUsingGcc logger dflags+#if defined(CAN_LOAD_DLL)                          dllpath  = liftM (fmap DLLPath)                          short    = dllpath $ search so_name lib_dirs                          full     = dllpath $ search lib_so_name lib_dirs+                         dlls     = [short, full]+#endif                          gcc name = liftM (fmap Archive) $ search name lib_dirs                          files    = import_libs ++ arch_files-                         dlls     = [short, full]                          archives = map gcc files                      in apply $ #if defined(CAN_LOAD_DLL)@@ -1590,10 +1693,11 @@       , not loading_dynamic_hs_libs       , interpreterProfiled interp       = do-          warningMsg logger dflags-            (text "Interpreter failed to load profiled static library" <+> text lib <> char '.' $$+          let diag = mkMCDiagnostic diag_opts WarningWithoutFlag+          logMsg logger diag noSrcSpan $ withPprStyle defaultErrStyle $+            text "Interpreter failed to load profiled static library" <+> text lib <> char '.' $$               text " \tTrying dynamic library instead. If this fails try to rebuild" <+>-              text "libraries with profiling support.")+              text "libraries with profiling support."           return (DLL lib)       | otherwise = return (DLL lib)      infixr `orElse`@@ -1607,7 +1711,9 @@                           else apply xs       platform = targetPlatform dflags+#if defined(CAN_LOAD_DLL)      arch = platformArch platform+#endif      os = platformOS platform  searchForLibUsingGcc :: Logger -> DynFlags -> String -> [FilePath] -> IO (Maybe FilePath)@@ -1724,17 +1830,16 @@    ********************************************************************* -} -maybePutSDoc :: Logger -> DynFlags -> SDoc -> IO ()-maybePutSDoc logger dflags s-    = when (verbosity dflags > 1) $-          putLogMsg logger dflags-              NoReason-              SevInteractive+maybePutSDoc :: Logger -> SDoc -> IO ()+maybePutSDoc logger s+    = when (logVerbAtLeast logger 2) $+          logMsg logger+              MCInteractive               noSrcSpan               $ withPprStyle defaultUserStyle s -maybePutStr :: Logger -> DynFlags -> String -> IO ()-maybePutStr logger dflags s = maybePutSDoc logger dflags (text s)+maybePutStr :: Logger -> String -> IO ()+maybePutStr logger s = maybePutSDoc logger (text s) -maybePutStrLn :: Logger -> DynFlags -> String -> IO ()-maybePutStrLn logger dflags s = maybePutSDoc logger dflags (text s <> text "\n")+maybePutStrLn :: Logger -> String -> IO ()+maybePutStrLn logger s = maybePutSDoc logger (text s <> text "\n")
compiler/GHC/Linker/Static.hs view
@@ -2,7 +2,6 @@    ( linkBinary    , linkBinary'    , linkStaticLib-   , exeFileName    ) where @@ -29,6 +28,7 @@ import GHC.Linker.Dynamic import GHC.Linker.ExtraObj import GHC.Linker.Windows+import GHC.Linker.Static.Utils  import GHC.Driver.Session @@ -73,7 +73,7 @@         unit_state = ue_units unit_env         toolSettings' = toolSettings dflags         verbFlags = getVerbFlags dflags-        output_fn = exeFileName platform staticLink (outputFile dflags)+        output_fn = exeFileName platform staticLink (outputFile_ dflags)      -- get the full list of packages to link with, by combining the     -- explicit packages with the auto packages and all of their@@ -89,7 +89,7 @@         get_pkg_lib_path_opts l          | osElfTarget (platformOS platform) &&            dynLibLoader dflags == SystemDependent &&-           WayDyn `elem` ways dflags+           ways dflags `hasWay` WayDyn             = let libpath = if gopt Opt_RelativeDynlibPaths dflags                             then "$ORIGIN" </>                                  (l `makeRelativeTo` full_output_fn)@@ -110,7 +110,7 @@               in ["-L" ++ l] ++ rpathlink ++ rpath          | osMachOTarget (platformOS platform) &&            dynLibLoader dflags == SystemDependent &&-           WayDyn `elem` ways dflags &&+           ways dflags `hasWay` WayDyn &&            useXLinkerRPath dflags (platformOS platform)             = let libpath = if gopt Opt_RelativeDynlibPaths dflags                             then "@loader_path" </>@@ -123,7 +123,7 @@       if gopt Opt_SingleLibFolder dflags       then do         libs <- getLibs dflags unit_env dep_units-        tmpDir <- newTempDir logger tmpfs dflags+        tmpDir <- newTempDir logger tmpfs (tmpDir dflags)         sequence_ [ copyFile lib (tmpDir </> basename)                   | (lib, basename) <- libs]         return [ "-L" ++ tmpDir ]@@ -197,12 +197,12 @@                       ++ [ GHC.SysTools.Option "-o"                          , GHC.SysTools.FileOption "" output_fn                          ]-                      ++ libmLinkOpts+                      ++ libmLinkOpts platform                       ++ map GHC.SysTools.Option (                          []                        -- See Note [No PIE when linking]-                      ++ picCCOpts dflags+                      ++ pieCCLDOpts dflags                        -- Permit the linker to auto link _symbol to _imp_symbol.                       -- This lets us link against DLLs without needing an "import library".@@ -278,7 +278,7 @@   let platform  = ue_platform unit_env       extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ]       modules = o_files ++ extra_ld_inputs-      output_fn = exeFileName platform True (outputFile dflags)+      output_fn = exeFileName platform True (outputFile_ dflags)    full_output_fn <- if isAbsolute output_fn                     then return output_fn@@ -307,30 +307,3 @@    -- run ranlib over the archive. write*Ar does *not* create the symbol index.   runRanlib logger dflags [GHC.SysTools.FileOption "" output_fn]------ | Compute the output file name of a program.------ StaticLink boolean is used to indicate if the program is actually a static library--- (e.g., on iOS).------ Use the provided filename (if any), otherwise use "main.exe" (Windows),--- "a.out (otherwise without StaticLink set), "liba.a". In every case, add the--- extension if it is missing.-exeFileName :: Platform -> Bool -> Maybe FilePath -> FilePath-exeFileName platform staticLink output_fn-  | Just s <- output_fn =-      case platformOS platform of-          OSMinGW32 -> s <?.> "exe"-          _         -> if staticLink-                         then s <?.> "a"-                         else s-  | otherwise =-      if platformOS platform == OSMinGW32-      then "main.exe"-      else if staticLink-           then "liba.a"-           else "a.out"- where s <?.> ext | null (takeExtension s) = s <.> ext-                  | otherwise              = s
compiler/GHC/Linker/Unit.hs view
@@ -50,7 +50,7 @@ -- | Either the 'unitLibraryDirs' or 'unitLibraryDynDirs' as appropriate for the way. libraryDirsForWay :: Ways -> UnitInfo -> [String] libraryDirsForWay ws-  | WayDyn `elem` ws = map ST.unpack . unitLibraryDynDirs+  | hasWay ws WayDyn = map ST.unpack . unitLibraryDynDirs   | otherwise        = map ST.unpack . unitLibraryDirs  getLibs :: DynFlags -> UnitEnv -> [UnitId] -> IO [(String,String)]
compiler/GHC/Linker/Windows.hs view
@@ -45,9 +45,9 @@    if not (gopt Opt_EmbedManifest dflags)       then return []       else do-         rc_filename <- newTempName logger tmpfs dflags TFL_CurrentModule "rc"+         rc_filename <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "rc"          rc_obj_filename <--           newTempName logger tmpfs dflags TFL_GhcSession (objectSuf dflags)+           newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession (objectSuf dflags)           writeFile rc_filename $              "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n"
compiler/GHC/Llvm.hs view
@@ -10,9 +10,6 @@ --  module GHC.Llvm (-        LlvmOpts (..),-        initLlvmOpts,-         -- * Modules, Functions and Blocks         LlvmModule(..),
compiler/GHC/Llvm/Ppr.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE LambdaCase #-}  --------------------------------------------------------------------------------@@ -30,8 +30,6 @@      ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Llvm.Syntax@@ -41,16 +39,17 @@ import Data.Int import Data.List ( intersperse ) import GHC.Utils.Outputable++import GHC.CmmToLlvm.Config import GHC.Utils.Panic import GHC.Types.Unique-import GHC.Data.FastString  -------------------------------------------------------------------------------- -- * Top Level Print functions --------------------------------------------------------------------------------  -- | Print out a whole LLVM module.-ppLlvmModule :: LlvmOpts -> LlvmModule -> SDoc+ppLlvmModule :: LlvmCgConfig -> LlvmModule -> SDoc ppLlvmModule opts (LlvmModule comments aliases meta globals decls funcs)   = ppLlvmComments comments $+$ newLine     $+$ ppLlvmAliases aliases $+$ newLine@@ -69,11 +68,11 @@   -- | Print out a list of global mutable variable definitions-ppLlvmGlobals :: LlvmOpts -> [LMGlobal] -> SDoc+ppLlvmGlobals :: LlvmCgConfig -> [LMGlobal] -> SDoc ppLlvmGlobals opts ls = vcat $ map (ppLlvmGlobal opts) ls  -- | Print out a global mutable variable definition-ppLlvmGlobal :: LlvmOpts -> LMGlobal -> SDoc+ppLlvmGlobal :: LlvmCgConfig -> LMGlobal -> SDoc ppLlvmGlobal opts (LMGlobal var@(LMGlobalVar _ _ link x a c) dat) =     let sect = case x of             Just x' -> text ", section" <+> doubleQuotes (ftext x')@@ -111,11 +110,11 @@   -- | Print out a list of LLVM metadata.-ppLlvmMetas :: LlvmOpts -> [MetaDecl] -> SDoc+ppLlvmMetas :: LlvmCgConfig -> [MetaDecl] -> SDoc ppLlvmMetas opts metas = vcat $ map (ppLlvmMeta opts) metas  -- | Print out an LLVM metadata definition.-ppLlvmMeta :: LlvmOpts -> MetaDecl -> SDoc+ppLlvmMeta :: LlvmCgConfig -> MetaDecl -> SDoc ppLlvmMeta opts (MetaUnnamed n m)   = ppr n <+> equals <+> ppMetaExpr opts m @@ -126,11 +125,11 @@   -- | Print out a list of function definitions.-ppLlvmFunctions :: LlvmOpts -> LlvmFunctions -> SDoc+ppLlvmFunctions :: LlvmCgConfig -> LlvmFunctions -> SDoc ppLlvmFunctions opts funcs = vcat $ map (ppLlvmFunction opts) funcs  -- | Print out a function definition.-ppLlvmFunction :: LlvmOpts -> LlvmFunction -> SDoc+ppLlvmFunction :: LlvmCgConfig -> LlvmFunction -> SDoc ppLlvmFunction opts fun =     let attrDoc = ppSpaceJoin (funcAttrs fun)         secDoc = case funcSect fun of@@ -151,9 +150,9 @@ ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> SDoc ppLlvmFunctionHeader (LlvmFunctionDecl n l c r varg p a) args   = let varg' = case varg of-                      VarArgs | null p    -> sLit "..."-                              | otherwise -> sLit ", ..."-                      _otherwise          -> sLit ""+                      VarArgs | null p    -> text "..."+                              | otherwise -> text ", ..."+                      _otherwise          -> text ""         align = case a of                      Just a' -> text " align " <> ppr a'                      Nothing -> empty@@ -161,7 +160,7 @@                                     <> ftext n)                     (zip p args)     in ppr l <+> ppr c <+> ppr r <+> char '@' <> ftext n <> lparen <>-        (hsep $ punctuate comma args') <> ptext varg' <> rparen <> align+        (hsep $ punctuate comma args') <> varg' <> rparen <> align  -- | Print out a list of function declaration. ppLlvmFunctionDecls :: LlvmFunctionDecls -> SDoc@@ -173,25 +172,25 @@ ppLlvmFunctionDecl :: LlvmFunctionDecl -> SDoc ppLlvmFunctionDecl (LlvmFunctionDecl n l c r varg p a)   = let varg' = case varg of-                      VarArgs | null p    -> sLit "..."-                              | otherwise -> sLit ", ..."-                      _otherwise          -> sLit ""+                      VarArgs | null p    -> text "..."+                              | otherwise -> text ", ..."+                      _otherwise          -> text ""         align = case a of                      Just a' -> text " align" <+> ppr a'                      Nothing -> empty         args = hcat $ intersperse (comma <> space) $                   map (\(t,a) -> ppr t <+> ppSpaceJoin a) p     in text "declare" <+> ppr l <+> ppr c <+> ppr r <+> char '@' <>-        ftext n <> lparen <> args <> ptext varg' <> rparen <> align $+$ newLine+        ftext n <> lparen <> args <> varg' <> rparen <> align $+$ newLine   -- | Print out a list of LLVM blocks.-ppLlvmBlocks :: LlvmOpts -> LlvmBlocks -> SDoc+ppLlvmBlocks :: LlvmCgConfig -> LlvmBlocks -> SDoc ppLlvmBlocks opts blocks = vcat $ map (ppLlvmBlock opts) blocks  -- | Print out an LLVM block. -- It must be part of a function definition.-ppLlvmBlock :: LlvmOpts -> LlvmBlock -> SDoc+ppLlvmBlock :: LlvmCgConfig -> LlvmBlock -> SDoc ppLlvmBlock opts (LlvmBlock blockId stmts) =   let isLabel (MkLabel _) = True       isLabel _           = False@@ -210,7 +209,7 @@   -- | Print out an LLVM statement.-ppLlvmStatement :: LlvmOpts -> LlvmStatement -> SDoc+ppLlvmStatement :: LlvmCgConfig -> LlvmStatement -> SDoc ppLlvmStatement opts stmt =   let ind = (text "  " <>)   in case stmt of@@ -231,7 +230,7 @@   -- | Print out an LLVM expression.-ppLlvmExpression :: LlvmOpts -> LlvmExpression -> SDoc+ppLlvmExpression :: LlvmCgConfig -> LlvmExpression -> SDoc ppLlvmExpression opts expr   = case expr of         Alloca     tp amount        -> ppAlloca opts tp amount@@ -253,7 +252,7 @@         Asm        asm c ty v se sk -> ppAsm opts asm c ty v se sk         MExpr      meta expr        -> ppMetaAnnotExpr opts meta expr -ppMetaExpr :: LlvmOpts -> MetaExpr -> SDoc+ppMetaExpr :: LlvmCgConfig -> MetaExpr -> SDoc ppMetaExpr opts = \case   MetaVar (LMLitVar (LMNullLit _)) -> text "null"   MetaStr    s                     -> char '!' <> doubleQuotes (ftext s)@@ -268,7 +267,7 @@  -- | Should always be a function pointer. So a global var of function type -- (since globals are always pointers) or a local var of pointer function type.-ppCall :: LlvmOpts -> LlvmCallType -> LlvmVar -> [MetaExpr] -> [LlvmFuncAttr] -> SDoc+ppCall :: LlvmCgConfig -> LlvmCallType -> LlvmVar -> [MetaExpr] -> [LlvmFuncAttr] -> SDoc ppCall opts ct fptr args attrs = case fptr of                            --     -- if local var function pointer, unwrap@@ -296,7 +295,7 @@                     <> fnty <+> ppName opts fptr <> lparen <+> ppValues                     <+> rparen <+> attrDoc -        ppCallParams :: LlvmOpts -> [[LlvmParamAttr]] -> [MetaExpr] -> SDoc+        ppCallParams :: LlvmCgConfig -> [[LlvmParamAttr]] -> [MetaExpr] -> SDoc         ppCallParams opts attrs args = hsep $ punctuate comma $ zipWith ppCallMetaExpr attrs args          where           -- Metadata needs to be marked as having the `metadata` type when used@@ -305,13 +304,13 @@           ppCallMetaExpr _ v             = text "metadata" <+> ppMetaExpr opts v  -ppMachOp :: LlvmOpts -> LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc+ppMachOp :: LlvmCgConfig -> LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc ppMachOp opts op left right =   (ppr op) <+> (ppr (getVarType left)) <+> ppName opts left         <> comma <+> ppName opts right  -ppCmpOp :: LlvmOpts -> LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc+ppCmpOp :: LlvmCgConfig -> LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc ppCmpOp opts op left right =   let cmpOp         | isInt (getVarType left) && isInt (getVarType right) = text "icmp"@@ -326,7 +325,7 @@         <+> ppName opts left <> comma <+> ppName opts right  -ppAssignment :: LlvmOpts -> LlvmVar -> SDoc -> SDoc+ppAssignment :: LlvmCgConfig -> LlvmVar -> SDoc -> SDoc ppAssignment opts var expr = ppName opts var <+> equals <+> expr  ppFence :: Bool -> LlvmSyncOrdering -> SDoc@@ -356,19 +355,19 @@ ppAtomicOp LAO_Umax = text "umax" ppAtomicOp LAO_Umin = text "umin" -ppAtomicRMW :: LlvmOpts -> LlvmAtomicOp -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> SDoc+ppAtomicRMW :: LlvmCgConfig -> LlvmAtomicOp -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> SDoc ppAtomicRMW opts aop tgt src ordering =   text "atomicrmw" <+> ppAtomicOp aop <+> ppVar opts tgt <> comma   <+> ppVar opts src <+> ppSyncOrdering ordering -ppCmpXChg :: LlvmOpts -> LlvmVar -> LlvmVar -> LlvmVar+ppCmpXChg :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar           -> LlvmSyncOrdering -> LlvmSyncOrdering -> SDoc ppCmpXChg opts addr old new s_ord f_ord =   text "cmpxchg" <+> ppVar opts addr <> comma <+> ppVar opts old <> comma <+> ppVar opts new   <+> ppSyncOrdering s_ord <+> ppSyncOrdering f_ord  -ppLoad :: LlvmOpts -> LlvmVar -> Maybe Int -> SDoc+ppLoad :: LlvmCgConfig -> LlvmVar -> LMAlign -> SDoc ppLoad opts var alignment =   text "load" <+> ppr derefType <> comma <+> ppVar opts var <> align   where@@ -378,9 +377,9 @@         Just n  -> text ", align" <+> ppr n         Nothing -> empty -ppALoad :: LlvmOpts -> LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> SDoc+ppALoad :: LlvmCgConfig -> LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> SDoc ppALoad opts ord st var =-  let alignment = (llvmWidthInBits (llvmOptsPlatform opts) $ getVarType var) `quot` 8+  let alignment = llvmWidthInBits (llvmCgPlatform opts) (getVarType var) `quot` 8       align     = text ", align" <+> ppr alignment       sThreaded | st        = text " singlethread"                 | otherwise = empty@@ -388,7 +387,7 @@   in text "load atomic" <+> ppr derefType <> comma <+> ppVar opts var <> sThreaded             <+> ppSyncOrdering ord <> align -ppStore :: LlvmOpts -> LlvmVar -> LlvmVar -> LMAlign -> SDoc+ppStore :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LMAlign -> SDoc ppStore opts val dst alignment =     text "store" <+> ppVar opts val <> comma <+> ppVar opts dst <> align   where@@ -398,7 +397,7 @@         Nothing -> empty  -ppCast :: LlvmOpts -> LlvmCastOp -> LlvmVar -> LlvmType -> SDoc+ppCast :: LlvmCgConfig -> LlvmCastOp -> LlvmVar -> LlvmType -> SDoc ppCast opts op from to     =   ppr op     <+> ppr (getVarType from) <+> ppName opts from@@ -406,19 +405,19 @@     <+> ppr to  -ppMalloc :: LlvmOpts -> LlvmType -> Int -> SDoc+ppMalloc :: LlvmCgConfig -> LlvmType -> Int -> SDoc ppMalloc opts tp amount =   let amount' = LMLitVar $ LMIntLit (toInteger amount) i32   in text "malloc" <+> ppr tp <> comma <+> ppVar opts amount'  -ppAlloca :: LlvmOpts -> LlvmType -> Int -> SDoc+ppAlloca :: LlvmCgConfig -> LlvmType -> Int -> SDoc ppAlloca opts tp amount =   let amount' = LMLitVar $ LMIntLit (toInteger amount) i32   in text "alloca" <+> ppr tp <> comma <+> ppVar opts amount'  -ppGetElementPtr :: LlvmOpts -> Bool -> LlvmVar -> [LlvmVar] -> SDoc+ppGetElementPtr :: LlvmCgConfig -> Bool -> LlvmVar -> [LlvmVar] -> SDoc ppGetElementPtr opts inb ptr idx =   let indexes = comma <+> ppCommaJoin (map (ppVar opts) idx)       inbound = if inb then text "inbounds" else empty@@ -427,27 +426,27 @@                             <> indexes  -ppReturn :: LlvmOpts -> Maybe LlvmVar -> SDoc+ppReturn :: LlvmCgConfig -> Maybe LlvmVar -> SDoc ppReturn opts (Just var) = text "ret" <+> ppVar opts var ppReturn _    Nothing    = text "ret" <+> ppr LMVoid  -ppBranch :: LlvmOpts -> LlvmVar -> SDoc+ppBranch :: LlvmCgConfig -> LlvmVar -> SDoc ppBranch opts var = text "br" <+> ppVar opts var  -ppBranchIf :: LlvmOpts -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc+ppBranchIf :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc ppBranchIf opts cond trueT falseT   = text "br" <+> ppVar opts cond <> comma <+> ppVar opts trueT <> comma <+> ppVar opts falseT  -ppPhi :: LlvmOpts -> LlvmType -> [(LlvmVar,LlvmVar)] -> SDoc+ppPhi :: LlvmCgConfig -> LlvmType -> [(LlvmVar,LlvmVar)] -> SDoc ppPhi opts tp preds =   let ppPreds (val, label) = brackets $ ppName opts val <> comma <+> ppName opts label   in text "phi" <+> ppr tp <+> hsep (punctuate comma $ map ppPreds preds)  -ppSwitch :: LlvmOpts -> LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> SDoc+ppSwitch :: LlvmCgConfig -> LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> SDoc ppSwitch opts scrut dflt targets =   let ppTarget  (val, lab) = ppVar opts val <> comma <+> ppVar opts lab       ppTargets  xs        = brackets $ vcat (map ppTarget xs)@@ -455,7 +454,7 @@         <+> ppTargets targets  -ppAsm :: LlvmOpts -> LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> SDoc+ppAsm :: LlvmCgConfig -> LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> SDoc ppAsm opts asm constraints rty vars sideeffect alignstack =   let asm'  = doubleQuotes $ ftext asm       cons  = doubleQuotes $ ftext constraints@@ -466,19 +465,19 @@   in text "call" <+> rty' <+> text "asm" <+> side <+> align <+> asm' <> comma         <+> cons <> vars' -ppExtract :: LlvmOpts -> LlvmVar -> LlvmVar -> SDoc+ppExtract :: LlvmCgConfig -> LlvmVar -> LlvmVar -> SDoc ppExtract opts vec idx =     text "extractelement"     <+> ppr (getVarType vec) <+> ppName opts vec <> comma     <+> ppVar opts idx -ppExtractV :: LlvmOpts -> LlvmVar -> Int -> SDoc+ppExtractV :: LlvmCgConfig -> LlvmVar -> Int -> SDoc ppExtractV opts struct idx =     text "extractvalue"     <+> ppr (getVarType struct) <+> ppName opts struct <> comma     <+> ppr idx -ppInsert :: LlvmOpts -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc+ppInsert :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc ppInsert opts vec elt idx =     text "insertelement"     <+> ppr (getVarType vec) <+> ppName opts vec <> comma@@ -486,15 +485,15 @@     <+> ppVar opts idx  -ppMetaStatement :: LlvmOpts -> [MetaAnnot] -> LlvmStatement -> SDoc+ppMetaStatement :: LlvmCgConfig -> [MetaAnnot] -> LlvmStatement -> SDoc ppMetaStatement opts meta stmt =    ppLlvmStatement opts stmt <> ppMetaAnnots opts meta -ppMetaAnnotExpr :: LlvmOpts -> [MetaAnnot] -> LlvmExpression -> SDoc+ppMetaAnnotExpr :: LlvmCgConfig -> [MetaAnnot] -> LlvmExpression -> SDoc ppMetaAnnotExpr opts meta expr =    ppLlvmExpression opts expr <> ppMetaAnnots opts meta -ppMetaAnnots :: LlvmOpts -> [MetaAnnot] -> SDoc+ppMetaAnnots :: LlvmCgConfig -> [MetaAnnot] -> SDoc ppMetaAnnots opts meta = hcat $ map ppMeta meta   where     ppMeta (MetaAnnot name e)@@ -506,7 +505,7 @@  -- | Return the variable name or value of the 'LlvmVar' -- in Llvm IR textual representation (e.g. @\@x@, @%y@ or @42@).-ppName :: LlvmOpts -> LlvmVar -> SDoc+ppName :: LlvmCgConfig -> LlvmVar -> SDoc ppName opts v = case v of    LMGlobalVar {} -> char '@' <> ppPlainName opts v    LMLocalVar  {} -> char '%' <> ppPlainName opts v@@ -515,7 +514,7 @@  -- | Return the variable name or value of the 'LlvmVar' -- in a plain textual representation (e.g. @x@, @y@ or @42@).-ppPlainName :: LlvmOpts -> LlvmVar -> SDoc+ppPlainName :: LlvmCgConfig -> LlvmVar -> SDoc ppPlainName opts v = case v of    (LMGlobalVar x _ _ _ _ _) -> ftext x    (LMLocalVar  x LMLabel  ) -> text (show x)@@ -524,13 +523,13 @@    (LMLitVar    x          ) -> ppLit opts x  -- | Print a literal value. No type.-ppLit :: LlvmOpts -> LlvmLit -> SDoc+ppLit :: LlvmCgConfig -> LlvmLit -> SDoc ppLit opts l = case l of    (LMIntLit i (LMInt 32))  -> ppr (fromInteger i :: Int32)    (LMIntLit i (LMInt 64))  -> ppr (fromInteger i :: Int64)    (LMIntLit   i _       )  -> ppr ((fromInteger i)::Int)-   (LMFloatLit r LMFloat )  -> ppFloat (llvmOptsPlatform opts) $ narrowFp r-   (LMFloatLit r LMDouble)  -> ppDouble (llvmOptsPlatform opts) r+   (LMFloatLit r LMFloat )  -> ppFloat (llvmCgPlatform opts) $ narrowFp r+   (LMFloatLit r LMDouble)  -> ppDouble (llvmCgPlatform opts) r    f@(LMFloatLit _ _)       -> pprPanic "ppLit" (text "Can't print this float literal: " <> ppTypeLit opts f)    (LMVectorLit ls  )       -> char '<' <+> ppCommaJoin (map (ppTypeLit opts) ls) <+> char '>'    (LMNullLit _     )       -> text "null"@@ -542,27 +541,27 @@    -- common types) with values that are likely to cause a crash or test    -- failure.    (LMUndefLit t    )-      | llvmOptsFillUndefWithGarbage opts+      | llvmCgFillUndefWithGarbage opts       , Just lit <- garbageLit t   -> ppLit opts lit       | otherwise                  -> text "undef" -ppVar :: LlvmOpts -> LlvmVar -> SDoc+ppVar :: LlvmCgConfig -> LlvmVar -> SDoc ppVar = ppVar' [] -ppVar' :: [LlvmParamAttr] -> LlvmOpts -> LlvmVar -> SDoc+ppVar' :: [LlvmParamAttr] -> LlvmCgConfig -> LlvmVar -> SDoc ppVar' attrs opts v = case v of   LMLitVar x -> ppTypeLit' attrs opts x   x          -> ppr (getVarType x) <+> ppSpaceJoin attrs <+> ppName opts x -ppTypeLit :: LlvmOpts -> LlvmLit -> SDoc+ppTypeLit :: LlvmCgConfig -> LlvmLit -> SDoc ppTypeLit = ppTypeLit' [] -ppTypeLit' :: [LlvmParamAttr] -> LlvmOpts -> LlvmLit -> SDoc+ppTypeLit' :: [LlvmParamAttr] -> LlvmCgConfig -> LlvmLit -> SDoc ppTypeLit' attrs opts l = case l of   LMVectorLit {} -> ppLit opts l   _              -> ppr (getLitType l) <+> ppSpaceJoin attrs <+> ppLit opts l -ppStatic :: LlvmOpts -> LlvmStatic -> SDoc+ppStatic :: LlvmCgConfig -> LlvmStatic -> SDoc ppStatic opts st = case st of   LMComment       s -> text "; " <> ftext s   LMStaticLit   l   -> ppTypeLit opts l@@ -570,15 +569,16 @@   LMStaticStr   s t -> ppr t <> text " c\"" <> ftext s <> text "\\00\""   LMStaticArray d t -> ppr t <> text " [" <> ppCommaJoin (map (ppStatic opts) d) <> char ']'   LMStaticStruc d t -> ppr t <> text "<{" <> ppCommaJoin (map (ppStatic opts) d) <> text "}>"+  LMStaticStrucU d t -> ppr t <> text "{" <> ppCommaJoin (map (ppStatic opts) d) <> text "}"   LMStaticPointer v -> ppVar opts v   LMTrunc v t       -> ppr t <> text " trunc (" <> ppStatic opts v <> text " to " <> ppr t <> char ')'   LMBitc v t        -> ppr t <> text " bitcast (" <> ppStatic opts v <> text " to " <> ppr t <> char ')'   LMPtoI v t        -> ppr t <> text " ptrtoint (" <> ppStatic opts v <> text " to " <> ppr t <> char ')'-  LMAdd s1 s2       -> pprStaticArith opts s1 s2 (sLit "add") (sLit "fadd") "LMAdd"-  LMSub s1 s2       -> pprStaticArith opts s1 s2 (sLit "sub") (sLit "fsub") "LMSub"+  LMAdd s1 s2       -> pprStaticArith opts s1 s2 (text "add") (text "fadd") (text "LMAdd")+  LMSub s1 s2       -> pprStaticArith opts s1 s2 (text "sub") (text "fsub") (text "LMSub")  -pprSpecialStatic :: LlvmOpts -> LlvmStatic -> SDoc+pprSpecialStatic :: LlvmCgConfig -> LlvmStatic -> SDoc pprSpecialStatic opts stat = case stat of    LMBitc v t        -> ppr (pLower t)                         <> text ", bitcast ("@@ -589,15 +589,15 @@    _                 -> ppStatic opts stat  -pprStaticArith :: LlvmOpts -> LlvmStatic -> LlvmStatic -> PtrString -> PtrString-                  -> String -> SDoc+pprStaticArith :: LlvmCgConfig -> LlvmStatic -> LlvmStatic -> SDoc -> SDoc+                  -> SDoc -> SDoc pprStaticArith opts s1 s2 int_op float_op op_name =   let ty1 = getStatType s1       op  = if isFloat ty1 then float_op else int_op   in if ty1 == getStatType s2-     then ppr ty1 <+> ptext op <+> lparen <> ppStatic opts s1 <> comma <> ppStatic opts s2 <> rparen+     then ppr ty1 <+> op <+> lparen <> ppStatic opts s1 <> comma <> ppStatic opts s2 <> rparen      else pprPanic "pprStaticArith" $-            text op_name <> text " with different types! s1: " <> ppStatic opts s1+                 op_name <> text " with different types! s1: " <> ppStatic opts s1                          <> text", s2: " <> ppStatic opts s2
compiler/GHC/Llvm/Types.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP        #-}+ {-# LANGUAGE LambdaCase #-}  --------------------------------------------------------------------------------@@ -7,15 +7,12 @@  module GHC.Llvm.Types where -#include "GhclibHsVersions.h"- import GHC.Prelude  import Data.Char import Numeric  import GHC.Platform-import GHC.Driver.Session import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic@@ -88,12 +85,12 @@ ppParams :: LlvmParameterListType -> [LlvmParameter] -> SDoc ppParams varg p   = let varg' = case varg of-          VarArgs | null args -> sLit "..."-                  | otherwise -> sLit ", ..."-          _otherwise          -> sLit ""+          VarArgs | null args -> text "..."+                  | otherwise -> text ", ..."+          _otherwise          -> text ""         -- by default we don't print param attributes         args = map fst p-    in ppCommaJoin args <> ptext varg'+    in ppCommaJoin args <> varg'  -- | An LLVM section definition. If Nothing then let LLVM decide the section type LMSection = Maybe LMString@@ -143,6 +140,7 @@   | LMStaticStr LMString LlvmType       -- ^ Defines a static 'LMString'   | LMStaticArray [LlvmStatic] LlvmType -- ^ A static array   | LMStaticStruc [LlvmStatic] LlvmType -- ^ A static structure type+  | LMStaticStrucU [LlvmStatic] LlvmType -- ^ A static structure type   | LMStaticPointer LlvmVar             -- ^ A pointer to other data    -- static expressions, could split out but leave@@ -158,21 +156,6 @@ -- ** Operations on LLVM Basic Types and Variables -- --- | LLVM code generator options-data LlvmOpts = LlvmOpts-   { llvmOptsPlatform             :: !Platform -- ^ Target platform-   , llvmOptsFillUndefWithGarbage :: !Bool     -- ^ Fill undefined literals with garbage values-   , llvmOptsSplitSections        :: !Bool     -- ^ Split sections-   }---- | Get LlvmOptions from DynFlags-initLlvmOpts :: DynFlags -> LlvmOpts-initLlvmOpts dflags = LlvmOpts-   { llvmOptsPlatform             = targetPlatform dflags-   , llvmOptsFillUndefWithGarbage = gopt Opt_LlvmFillUndefWithGarbage dflags-   , llvmOptsSplitSections        = gopt Opt_SplitSections dflags-   }- garbageLit :: LlvmType -> Maybe LlvmLit garbageLit t@(LMInt w)     = Just (LMIntLit (0xbbbbbbbbbbbbbbb0 `mod` (2^w)) t)   -- Use a value that looks like an untagged pointer, so we are more@@ -209,6 +192,7 @@ getStatType (LMStaticStr   _ t) = t getStatType (LMStaticArray _ t) = t getStatType (LMStaticStruc _ t) = t+getStatType (LMStaticStrucU _ t) = t getStatType (LMStaticPointer v) = getVarType v getStatType (LMTrunc       _ t) = t getStatType (LMBitc        _ t) = t
+ compiler/GHC/Plugins.hs view
@@ -0,0 +1,210 @@+{-# OPTIONS_GHC -fno-warn-duplicate-exports -fno-warn-orphans #-}++-- | This module is not used by GHC itself.  Rather, it exports all of+-- the functions and types you are likely to need when writing a+-- plugin for GHC. So authors of plugins can probably get away simply+-- with saying "import GHC.Plugins".+--+-- Particularly interesting modules for plugin writers include+-- "GHC.Core" and "GHC.Core.Opt.Monad".+module GHC.Plugins+   ( module GHC.Driver.Plugins+   , module GHC.Types.Name.Reader+   , module GHC.Types.Name.Occurrence+   , module GHC.Types.Name+   , module GHC.Types.Var+   , module GHC.Types.Id+   , module GHC.Types.Id.Info+   , module GHC.Types.PkgQual+   , module GHC.Core.Opt.Monad+   , module GHC.Core+   , module GHC.Types.Literal+   , module GHC.Core.DataCon+   , module GHC.Core.Utils+   , module GHC.Core.Make+   , module GHC.Core.FVs+   , module GHC.Core.Subst+   , module GHC.Core.Rules+   , module GHC.Types.Annotations+   , module GHC.Driver.Session+   , module GHC.Driver.Ppr+   , module GHC.Unit.State+   , module GHC.Unit.Module+   , module GHC.Unit.Home+   , module GHC.Core.Type+   , module GHC.Core.TyCon+   , module GHC.Core.Coercion+   , module GHC.Builtin.Types+   , module GHC.Driver.Env+   , module GHC.Types.Basic+   , module GHC.Types.Var.Set+   , module GHC.Types.Var.Env+   , module GHC.Types.Name.Set+   , module GHC.Types.Name.Env+   , module GHC.Types.Unique+   , module GHC.Types.Unique.Set+   , module GHC.Types.Unique.FM+   , module GHC.Data.FiniteMap+   , module GHC.Utils.Misc+   , module GHC.Serialized+   , module GHC.Types.SrcLoc+   , module GHC.Utils.Outputable+   , module GHC.Utils.Panic+   , module GHC.Types.Unique.Supply+   , module GHC.Data.FastString+   , module GHC.Tc.Errors.Hole.FitTypes   -- for hole-fit plugins+   , module GHC.Unit.Module.ModGuts+   , module GHC.Unit.Module.ModSummary+   , module GHC.Unit.Module.ModIface+   , module GHC.Types.Meta+   , module GHC.Types.SourceError+   , module GHC.Parser.Errors.Types+   , module GHC.Types.Error+   , module GHC.Hs+   , -- * Getting 'Name's+     thNameToGhcName+   , thNameToGhcNameIO+   )+where++-- Plugin stuff itself+import GHC.Driver.Plugins++-- Variable naming+import GHC.Types.TyThing+import GHC.Types.PkgQual+import GHC.Types.SourceError+import GHC.Types.Name.Reader+import GHC.Types.Name.Occurrence  hiding  ( varName {- conflicts with Var.varName -} )+import GHC.Types.Name     hiding  ( varName {- reexport from OccName, conflicts with Var.varName -} )+import GHC.Types.Var+import GHC.Types.Id       hiding  ( lazySetIdInfo, setIdExported, setIdNotExported {- all three conflict with Var -} )+import GHC.Types.Id.Info++-- Core+import GHC.Core.Opt.Monad+import GHC.Core+import GHC.Types.Literal+import GHC.Core.DataCon+import GHC.Core.Utils+import GHC.Core.Make+import GHC.Core.FVs+import GHC.Core.Subst hiding( substTyVarBndr, substCoVarBndr, extendCvSubst )+       -- These names are also exported by Type++import GHC.Core.Rules+import GHC.Types.Annotations+import GHC.Types.Meta++import GHC.Driver.Session+import GHC.Unit.State++import GHC.Unit.Home+import GHC.Unit.Module+import GHC.Unit.Module.ModGuts+import GHC.Unit.Module.ModSummary+import GHC.Unit.Module.ModIface+import GHC.Core.Type hiding {- conflict with GHC.Core.Subst -}+                ( substTy, extendTvSubst, extendTvSubstList, isInScope )+import GHC.Core.Coercion hiding {- conflict with GHC.Core.Subst -}+                ( substCo )+import GHC.Core.TyCon+import GHC.Builtin.Types+import GHC.Driver.Env+import GHC.Types.Basic++-- Collections and maps+import GHC.Types.Var.Set+import GHC.Types.Var.Env+import GHC.Types.Name.Set+import GHC.Types.Name.Env+import GHC.Types.Unique.Set+import GHC.Types.Unique.FM+-- Conflicts with UniqFM:+--import LazyUniqFM+import GHC.Data.FiniteMap++-- Common utilities+import GHC.Utils.Misc+import GHC.Serialized+import GHC.Types.SrcLoc+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Driver.Ppr+import GHC.Types.Unique.Supply+import GHC.Types.Unique ( Unique, Uniquable(..) )+import GHC.Data.FastString+import Data.Maybe++import GHC.Iface.Env    ( lookupNameCache )+import GHC.Prelude+import GHC.Utils.Monad  ( mapMaybeM )+import GHC.ThToHs       ( thRdrNameGuesses )+import GHC.Tc.Utils.Env ( lookupGlobal )+import GHC.Types.Name.Cache ( NameCache )++import GHC.Tc.Errors.Hole.FitTypes++-- For parse result plugins+import GHC.Parser.Errors.Types ( PsWarning, PsError )+import GHC.Types.Error         ( Messages )+import GHC.Hs                  ( HsParsedModule )++import qualified Language.Haskell.TH as TH++{- This instance is defined outside GHC.Core.Opt.Monad so that+   GHC.Core.Opt.Monad does not depend on GHC.Tc.Utils.Env -}+instance MonadThings CoreM where+    lookupThing name = do { hsc_env <- getHscEnv+                          ; liftIO $ lookupGlobal hsc_env name }++{-+************************************************************************+*                                                                      *+               Template Haskell interoperability+*                                                                      *+************************************************************************+-}++-- | Attempt to convert a Template Haskell name to one that GHC can+-- understand. Original TH names such as those you get when you use+-- the @'foo@ syntax will be translated to their equivalent GHC name+-- exactly. Qualified or unqualified TH names will be dynamically bound+-- to names in the module being compiled, if possible. Exact TH names+-- will be bound to the name they represent, exactly.+thNameToGhcName :: TH.Name -> CoreM (Maybe Name)+thNameToGhcName th_name = do+  hsc_env <- getHscEnv+  liftIO $ thNameToGhcNameIO (hsc_NC hsc_env) th_name++-- | Attempt to convert a Template Haskell name to one that GHC can+-- understand. Original TH names such as those you get when you use+-- the @'foo@ syntax will be translated to their equivalent GHC name+-- exactly. Qualified or unqualified TH names will be dynamically bound+-- to names in the module being compiled, if possible. Exact TH names+-- will be bound to the name they represent, exactly.+--+-- One must be careful to consistently use the same 'NameCache' to+-- create identifier that might be compared. (C.f. how the+-- 'Control.Monad.ST.ST' Monad enforces that variables from separate+-- 'Control.Monad.ST.runST' invocations are never intermingled; it would+-- be valid to use the same tricks for 'Name's and 'NameCache's.)+--+-- For now, the easiest and recommended way to ensure a consistent+-- 'NameCache' is used it to retrieve the preexisting one from an active+-- 'HscEnv'. A single 'HscEnv' is created per GHC "session", and this+-- ensures everything in that sesssion will getthe same name cache.+thNameToGhcNameIO :: NameCache -> TH.Name -> IO (Maybe Name)+thNameToGhcNameIO cache th_name+  =  do { names <- mapMaybeM lookup (thRdrNameGuesses th_name)+          -- Pick the first that works+          -- E.g. reify (mkName "A") will pick the class A in preference+          -- to the data constructor A+        ; return (listToMaybe names) }+  where+    lookup rdr_name+      | Just n <- isExact_maybe rdr_name   -- This happens in derived code+      = return $ if isExternalName n then Just n else Nothing+      | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name+      = Just <$> lookupNameCache cache rdr_mod rdr_occ+      | otherwise = return Nothing
compiler/GHC/Rename/Bind.hs view
@@ -18,7 +18,7 @@  module GHC.Rename.Bind (    -- Renaming top-level bindings-   rnTopBindsLHS, rnTopBindsBoot, rnValBindsRHS,+   rnTopBindsLHS, rnTopBindsLHSBoot, rnTopBindsBoot, rnValBindsRHS,     -- Renaming local bindings    rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,@@ -35,19 +35,23 @@ import {-# SOURCE #-} GHC.Rename.Expr( rnExpr, rnLExpr, rnStmts )  import GHC.Hs+import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Rename.HsType import GHC.Rename.Pat import GHC.Rename.Names import GHC.Rename.Env import GHC.Rename.Fixity-import GHC.Rename.Utils ( HsDocContext(..), mapFvRn-                        , checkDupRdrNames, checkDupRdrNamesN, warnUnusedLocalBinds+import GHC.Rename.Utils ( mapFvRn+                        , checkDupRdrNames, checkDupRdrNamesN+                        , warnUnusedLocalBinds+                        , warnForallIdentifier                         , checkUnusedRecordWildcard                         , checkDupAndShadowedNames, bindLocalNamesFV                         , addNoNestedForallsContextsErr, checkInferredVars ) import GHC.Driver.Session import GHC.Unit.Module+import GHC.Types.Error import GHC.Types.FieldLabel import GHC.Types.Name import GHC.Types.Name.Env@@ -187,13 +191,24 @@ rnTopBindsLHS fix_env binds   = rnValBindsLHS (topRecNameMaker fix_env) binds +-- Ensure that a hs-boot file has no top-level bindings.+rnTopBindsLHSBoot :: MiniFixityEnv+                  -> HsValBinds GhcPs+                  -> RnM (HsValBindsLR GhcRn GhcPs)+rnTopBindsLHSBoot fix_env binds+  = do  { topBinds <- rnTopBindsLHS fix_env binds+        ; case topBinds of+            ValBinds x mbinds sigs ->+              do  { mapM_ bindInHsBootFileErr mbinds+                  ; pure (ValBinds x emptyBag sigs) }+            _ -> pprPanic "rnTopBindsLHSBoot" (ppr topBinds) }+ rnTopBindsBoot :: NameSet -> HsValBindsLR GhcRn GhcPs                -> RnM (HsValBinds GhcRn, DefUses) -- A hs-boot file has no bindings. -- Return a single HsBindGroup with empty binds and renamed signatures-rnTopBindsBoot bound_names (ValBinds _ mbinds sigs)-  = do  { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds)-        ; (sigs', fvs) <- renameSigs (HsBootCtxt bound_names) sigs+rnTopBindsBoot bound_names (ValBinds _ _ sigs)+  = do  { (sigs', fvs) <- renameSigs (HsBootCtxt bound_names) sigs         ; return (XValBindsLR (NValBinds [] sigs'), usesOnly fvs) } rnTopBindsBoot _ b = pprPanic "rnTopBindsBoot" (ppr b) @@ -229,9 +244,9 @@     return (IPBinds noExtField ip_binds', plusFVs fvs_s)  rnIPBind :: IPBind GhcPs -> RnM (IPBind GhcRn, FreeVars)-rnIPBind (IPBind _ ~(Left n) expr) = do+rnIPBind (IPBind _ n expr) = do     (expr',fvExpr) <- rnLExpr expr-    return (IPBind noAnn (Left n) expr', fvExpr)+    return (IPBind noExtField n expr', fvExpr)  {- ************************************************************************@@ -431,7 +446,8 @@ rnBindLHS name_maker _ (PatSynBind x psb@PSB{ psb_id = rdrname })   | isTopRecNameMaker name_maker   = do { addLocMA checkConName rdrname-       ; name <- lookupLocatedTopBndrRnN rdrname -- Should be in scope already+       ; name <-+           lookupLocatedTopConstructorRnN rdrname -- Should be in scope already        ; return (PatSynBind x psb{ psb_ext = noAnn, psb_id = name }) }    | otherwise  -- Pattern synonym, not at top level@@ -440,10 +456,8 @@        ; name <- applyNameMaker name_maker rdrname        ; return (PatSynBind x psb{ psb_ext = noAnn, psb_id = name }) }   where-    localPatternSynonymErr :: SDoc-    localPatternSynonymErr-      = hang (text "Illegal pattern synonym declaration for" <+> quotes (ppr rdrname))-           2 (text "Pattern synonym declarations are only valid at top level")+    localPatternSynonymErr :: TcRnMessage+    localPatternSynonymErr = TcRnIllegalPatSynDecl rdrname  rnBindLHS _ _ b = pprPanic "rnBindHS" (ppr b) @@ -489,8 +503,7 @@         -- See Note [Pattern bindings that bind no variables]         ; whenWOptM Opt_WarnUnusedPatternBinds $           when (null bndrs && not ok_nobind_pat) $-          addWarn (Reason Opt_WarnUnusedPatternBinds) $-          unusedPatBindWarn bind'+          addTcRnDiagnostic (TcRnUnusedPatternBinds bind')          ; fvs' `seq` -- See Note [Free-variable space leak]           return (bind', bndrs, all_fvs) }@@ -651,9 +664,10 @@            ; return env}      } -dupFixityDecl :: SrcSpan -> RdrName -> SDoc+dupFixityDecl :: SrcSpan -> RdrName -> TcRnMessage dupFixityDecl loc rdr_name-  = vcat [text "Multiple fixity declarations for" <+> quotes (ppr rdr_name),+  = TcRnUnknownMessage $ mkPlainError noHints $+    vcat [text "Multiple fixity declarations for" <+> quotes (ppr rdr_name),           text "also at " <+> ppr loc]  @@ -694,7 +708,7 @@                       ; return ( (pat', InfixCon name1 name2)                                , mkFVs (map unLoc [name1, name2])) }                RecCon vars ->-                   do { checkDupRdrNames (map (rdrNameFieldOcc . recordPatSynField) vars)+                   do { checkDupRdrNames (map (foLabel . recordPatSynField) vars)                       ; fls <- lookupConstructorFields name                       ; let fld_env = mkFsEnv [ (flLabel fl, fl) | fl <- fls ]                       ; let rnRecordPatSynField@@ -730,7 +744,7 @@                           , psb_ext = fvs' }               selector_names = case details' of                                  RecCon names ->-                                  map (extFieldOcc . recordPatSynField) names+                                  map (foExt . recordPatSynField) names                                  _ -> []          ; fvs' `seq` -- See Note [Free-variable space leak]@@ -741,9 +755,10 @@     -- See Note [Renaming pattern synonym variables]     lookupPatSynBndr = wrapLocMA lookupLocalOccRn -    patternSynonymErr :: SDoc+    patternSynonymErr :: TcRnMessage     patternSynonymErr-      = hang (text "Illegal pattern synonym declaration")+      = TcRnUnknownMessage $ mkPlainError noHints $+        hang (text "Illegal pattern synonym declaration")            2 (text "Use -XPatternSynonyms to enable this extension")  {-@@ -860,15 +875,17 @@         -- Rename the pragmas and signatures        -- Annoyingly the type variables /are/ in scope for signatures, but-       -- /are not/ in scope in SPECIALISE and SPECIALISE instance pragmas.-       -- See Note [Type variable scoping in SPECIALISE pragmas].-       ; let (spec_prags, other_sigs) = partition (isSpecLSig <||> isSpecInstLSig) sigs+       -- /are not/ in scope in the SPECIALISE instance pramas; e.g.+       --    instance Eq a => Eq (T a) where+       --       (==) :: a -> a -> a+       --       {-# SPECIALISE instance Eq a => Eq (T [a]) #-}+       ; let (spec_inst_prags, other_sigs) = partition isSpecInstLSig sigs              bound_nms = mkNameSet (collectHsBindsBinders CollNoDictBinders binds')              sig_ctxt | is_cls_decl = ClsDeclCtxt cls                       | otherwise   = InstDeclCtxt bound_nms-       ; (spec_prags', spg_fvs) <- renameSigs sig_ctxt spec_prags-       ; (other_sigs', sig_fvs) <- bindLocalNamesFV ktv_names $-                                      renameSigs sig_ctxt other_sigs+       ; (spec_inst_prags', sip_fvs) <- renameSigs sig_ctxt spec_inst_prags+       ; (other_sigs',      sig_fvs) <- bindLocalNamesFV ktv_names $+                                        renameSigs sig_ctxt other_sigs         -- Rename the bindings RHSs.  Again there's an issue about whether the        -- type variables from the class/instance head are in scope.@@ -879,47 +896,8 @@                                            emptyFVs binds_w_dus                  ; return (mapBag fstOf3 binds_w_dus, bind_fvs) } -       ; return ( binds'', spec_prags' ++ other_sigs'-                , sig_fvs `plusFV` spg_fvs `plusFV` bind_fvs) }--{- Note [Type variable scoping in SPECIALISE pragmas]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When renaming the methods of a class or instance declaration, we must be careful-with the scoping of the type variables that occur in SPECIALISE and SPECIALISE instance-pragmas: the type variables from the class/instance header DO NOT scope over these,-unlike class/instance method type signatures.--Examples:--  1. SPECIALISE--    class C a where-      meth :: a-    instance C (Maybe a) where-      meth = Nothing-      {-# SPECIALISE INLINE meth :: Maybe [a] #-}--  2. SPECIALISE instance--    instance Eq a => Eq (T a) where-       (==) :: a -> a -> a-       {-# SPECIALISE instance Eq a => Eq (T [a]) #-}--  In both cases, the type variable `a` mentioned in the PRAGMA is NOT the same-  as the type variable `a` from the instance header.-  For example, the SPECIALISE instance pragma above is a shorthand for--      {-# SPECIALISE instance forall a. Eq a => Eq (T [a]) #-}--  which is alpha-equivalent to--      {-# SPECIALISE instance forall b. Eq b => Eq (T [b]) #-}--  This shows that the type variables are not bound in the header.--  Getting this scoping wrong can lead to out-of-scope type variable errors from-  Core Lint, see e.g. #22913.--}+       ; return ( binds'', spec_inst_prags' ++ other_sigs'+                , sig_fvs `plusFV` sip_fvs `plusFV` bind_fvs) }  rnMethodBindLHS :: Bool -> Name                 -> LHsBindLR GhcPs GhcPs@@ -935,7 +913,7 @@ -- Report error for all other forms of bindings -- This is why we use a fold rather than map rnMethodBindLHS is_cls_decl _ (L loc bind) rest-  = do { addErrAt (locA loc) $+  = do { addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $          vcat [ what <+> text "not allowed in" <+> decl_sort               , nest 2 (ppr bind) ]        ; return rest }@@ -1005,6 +983,7 @@   = do  { defaultSigs_on <- xoptM LangExt.DefaultSignatures         ; when (is_deflt && not defaultSigs_on) $           addErr (defaultSigErr sig)+        ; mapM_ warnForallIdentifier vs         ; new_v <- mapM (lookupSigOccRnN ctxt sig) vs         ; (new_ty, fvs) <- rnHsSigType ty_ctxt TypeLevel ty         ; return (ClassOpSig noAnn is_deflt new_v new_ty, fvs) }@@ -1081,8 +1060,8 @@         return (CompleteMatchSig noAnn s (L l new_bf) new_mty, emptyFVs)   where-    orphanError :: SDoc-    orphanError =+    orphanError :: TcRnMessage+    orphanError = TcRnUnknownMessage $ mkPlainError noHints $       text "Orphan COMPLETE pragmas not supported" $$       text "A COMPLETE pragma must mention at least one data constructor" $$       text "or pattern synonym defined in the same module."@@ -1205,20 +1184,48 @@     , Anno [LocatedA (Match GhcPs (LocatedA (body GhcPs)))] ~ SrcSpanAnnL     , Anno (Match GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA     , Anno (Match GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA-    , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ SrcSpan-    , Anno (GRHS GhcPs (LocatedA (body GhcPs))) ~ SrcSpan+    , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ SrcAnn NoEpAnns+    , Anno (GRHS GhcPs (LocatedA (body GhcPs))) ~ SrcAnn NoEpAnns     , Outputable (body GhcPs)     ) +-- Note [Empty MatchGroups]+-- ~~~~~~~~~~~~~~~~~~~~~~~~+-- In some cases, MatchGroups are allowed to be empty. Firstly, the+-- prerequisite is that -XEmptyCase is enabled. Then you have an empty+-- MatchGroup resulting either from a case-expression:+--+--     case e of {}+--+-- or from a \case-expression:+--+--     \case {}+--+-- NB: \cases {} is not allowed, since it's not clear how many patterns this+-- should match on.+--+-- The same applies in arrow notation commands: With -XEmptyCases, it is+-- allowed in case- and \case-commands, but not \cases.+--+-- Since the lambda expressions and empty function definitions are already+-- disallowed elsewhere, here, we only need to make sure we don't accept empty+-- \cases expressions or commands. In that case, or if we encounter an empty+-- MatchGroup but -XEmptyCases is disabled, we add an error.+ rnMatchGroup :: (Outputable (body GhcPs), AnnoBody body) => HsMatchContext GhcRn              -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))              -> MatchGroup GhcPs (LocatedA (body GhcPs))              -> RnM (MatchGroup GhcRn (LocatedA (body GhcRn)), FreeVars) rnMatchGroup ctxt rnBody (MG { mg_alts = L lm ms, mg_origin = origin })-  = do { empty_case_ok <- xoptM LangExt.EmptyCase-       ; when (null ms && not empty_case_ok) (addErr (emptyCaseErr ctxt))+         -- see Note [Empty MatchGroups]+  = do { whenM ((null ms &&) <$> mustn't_be_empty) (addErr (emptyCaseErr ctxt))        ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms        ; return (mkMatchGroup origin (L lm new_ms), ms_fvs) }+  where+    mustn't_be_empty = case ctxt of+      LamCaseAlt LamCases -> return True+      ArrowMatchCtxt (ArrowLamCaseAlt LamCases) -> return True+      _ -> not <$> xoptM LangExt.EmptyCase  rnMatch :: AnnoBody body         => HsMatchContext GhcRn@@ -1242,18 +1249,30 @@         ; return (Match { m_ext = noAnn, m_ctxt = mf', m_pats = pats'                         , m_grhss = grhss'}, grhss_fvs ) } -emptyCaseErr :: HsMatchContext GhcRn -> SDoc-emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt ctxt)-                       2 (text "Use EmptyCase to allow this")+emptyCaseErr :: HsMatchContext GhcRn -> TcRnMessage+emptyCaseErr ctxt = TcRnUnknownMessage $ mkPlainError noHints $ message ctxt   where     pp_ctxt :: HsMatchContext GhcRn -> SDoc     pp_ctxt c = case c of-      CaseAlt       -> text "case expression"-      LambdaExpr    -> text "\\case expression"-      ArrowMatchCtxt ArrowCaseAlt -> text "case expression"-      ArrowMatchCtxt KappaExpr    -> text "kappa abstraction"-      _             -> text "(unexpected)" <+> pprMatchContextNoun c+      CaseAlt                                  -> text "case expression"+      LamCaseAlt LamCase                       -> text "\\case expression"+      ArrowMatchCtxt (ArrowLamCaseAlt LamCase) -> text "\\case command"+      ArrowMatchCtxt ArrowCaseAlt              -> text "case command"+      ArrowMatchCtxt KappaExpr                 -> text "kappa abstraction"+      _                                        -> text "(unexpected)"+                                                  <+> pprMatchContextNoun c +    message :: HsMatchContext GhcRn -> SDoc+    message (LamCaseAlt LamCases) = lcases_msg <+> text "expression"+    message (ArrowMatchCtxt (ArrowLamCaseAlt LamCases)) =+      lcases_msg <+> text "command"+    message ctxt =+      hang (text "Empty list of alternatives in" <+> pp_ctxt ctxt)+           2 (text "Use EmptyCase to allow this")++    lcases_msg =+      text "Empty list of alternatives is not allowed in \\cases"+ {- ************************************************************************ *                                                                      *@@ -1277,7 +1296,7 @@        -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))        -> LGRHS GhcPs (LocatedA (body GhcPs))        -> RnM (LGRHS GhcRn (LocatedA (body GhcRn)), FreeVars)-rnGRHS ctxt rnBody = wrapLocFstM (rnGRHS' ctxt rnBody)+rnGRHS ctxt rnBody = wrapLocFstMA (rnGRHS' ctxt rnBody)  rnGRHS' :: HsMatchContext GhcRn         -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))@@ -1288,8 +1307,10 @@         ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) rnExpr guards $ \ _ ->                                     rnBody rhs -        ; unless (pattern_guards_allowed || is_standard_guard guards')-                 (addWarn NoReason (nonStdGuardErr guards'))+        ; unless (pattern_guards_allowed || is_standard_guard guards') $+            let diag = TcRnUnknownMessage $+                  mkPlainDiagnostic WarningWithoutFlag noHints (nonStdGuardErr guards')+            in addDiagnostic diag          ; return (GRHS noAnn guards' rhs', fvs) }   where@@ -1342,7 +1363,7 @@  dupSigDeclErr :: NonEmpty (LocatedN RdrName, Sig GhcPs) -> RnM () dupSigDeclErr pairs@((L loc name, sig) :| _)-  = addErrAt (locA loc) $+  = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $     vcat [ text "Duplicate" <+> what_it_is            <> text "s for" <+> quotes (ppr name)          , text "at" <+> vcat (map ppr $ sortBy SrcLoc.leftmost_smallest@@ -1354,18 +1375,19 @@  misplacedSigErr :: LSig GhcRn -> RnM () misplacedSigErr (L loc sig)-  = addErrAt (locA loc) $+  = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $     sep [text "Misplaced" <+> hsSigDoc sig <> colon, ppr sig] -defaultSigErr :: Sig GhcPs -> SDoc-defaultSigErr sig = vcat [ hang (text "Unexpected default signature:")-                              2 (ppr sig)-                         , text "Use DefaultSignatures to enable default signatures" ]+defaultSigErr :: Sig GhcPs -> TcRnMessage+defaultSigErr sig = TcRnUnknownMessage $ mkPlainError noHints $+  vcat [ hang (text "Unexpected default signature:")+         2 (ppr sig)+       , text "Use DefaultSignatures to enable default signatures" ] -bindsInHsBootFile :: LHsBindsLR GhcRn GhcPs -> SDoc-bindsInHsBootFile mbinds-  = hang (text "Bindings in hs-boot files are not allowed")-       2 (ppr mbinds)+bindInHsBootFileErr :: LHsBindLR GhcRn GhcPs -> RnM ()+bindInHsBootFileErr (L loc _)+  = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $+      vcat [ text "Bindings in hs-boot files are not allowed" ]  nonStdGuardErr :: (Outputable body,                    Anno (Stmt GhcRn body) ~ SrcSpanAnnA)@@ -1374,14 +1396,9 @@   = hang (text "accepting non-standard pattern guards (use PatternGuards to suppress this message)")        4 (interpp'SP guards) -unusedPatBindWarn :: HsBind GhcRn -> SDoc-unusedPatBindWarn bind-  = hang (text "This pattern-binding binds no variables:")-       2 (ppr bind)- dupMinimalSigErr :: [LSig GhcPs] -> RnM () dupMinimalSigErr sigs@(L loc _ : _)-  = addErrAt (locA loc) $+  = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $     vcat [ text "Multiple minimal complete definitions"          , text "at" <+> vcat (map ppr $ sortBy SrcLoc.leftmost_smallest $ map getLocA sigs)          , text "Combine alternative minimal complete definitions with `|'" ]
+ compiler/GHC/Rename/Doc.hs view
@@ -0,0 +1,46 @@+module GHC.Rename.Doc ( rnHsDoc, rnLHsDoc, rnLDocDecl, rnDocDecl ) where++import GHC.Prelude++import GHC.Tc.Types+import GHC.Hs+import GHC.Types.Name.Reader+import GHC.Types.Name+import GHC.Types.SrcLoc+import GHC.Tc.Utils.Monad (getGblEnv)+import GHC.Types.Avail+import GHC.Rename.Env++rnLHsDoc :: LHsDoc GhcPs -> RnM (LHsDoc GhcRn)+rnLHsDoc = traverse rnHsDoc++rnLDocDecl :: LDocDecl GhcPs -> RnM (LDocDecl GhcRn)+rnLDocDecl = traverse rnDocDecl++rnDocDecl :: DocDecl GhcPs -> RnM (DocDecl GhcRn)+rnDocDecl (DocCommentNext doc) = do+  doc' <- rnLHsDoc doc+  pure $ (DocCommentNext doc')+rnDocDecl (DocCommentPrev doc) = do+  doc' <- rnLHsDoc doc+  pure $ (DocCommentPrev doc')+rnDocDecl (DocCommentNamed n doc) = do+  doc' <- rnLHsDoc doc+  pure $ (DocCommentNamed n doc')+rnDocDecl (DocGroup i doc) = do+  doc' <- rnLHsDoc doc+  pure $ (DocGroup i doc')++rnHsDoc :: WithHsDocIdentifiers a GhcPs -> RnM (WithHsDocIdentifiers a GhcRn)+rnHsDoc (WithHsDocIdentifiers s ids) = do+  gre <- tcg_rdr_env <$> getGblEnv+  pure (WithHsDocIdentifiers s (rnHsDocIdentifiers gre ids))++rnHsDocIdentifiers :: GlobalRdrEnv+                  -> [Located RdrName]+                  -> [Located Name]+rnHsDocIdentifiers gre ns = concat+  [ map (L l . greNamePrintableName . gre_name) (lookupGRE_RdrName c gre)+  | L l rdr_name <- ns+  , c <- dataTcOccs rdr_name+  ]
compiler/GHC/Rename/Env.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeApplications #-} @@ -13,8 +13,11 @@         newTopSrcBinder,          lookupLocatedTopBndrRn, lookupLocatedTopBndrRnN, lookupTopBndrRn,+        lookupLocatedTopConstructorRn, lookupLocatedTopConstructorRnN, -        lookupLocatedOccRn, lookupOccRn, lookupOccRn_maybe,+        lookupLocatedOccRn, lookupLocatedOccRnConstr, lookupLocatedOccRnRecField,+        lookupLocatedOccRnNone,+        lookupOccRn, lookupOccRn_maybe,         lookupLocalOccRn_maybe, lookupInfoOccRn,         lookupLocalOccThLvl_maybe, lookupLocalOccRn,         lookupTypeOccRn,@@ -55,14 +58,13 @@      ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Iface.Load   ( loadInterfaceForName, loadSrcInterface_maybe ) import GHC.Iface.Env import GHC.Hs import GHC.Types.Name.Reader+import GHC.Tc.Errors.Types import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad import GHC.Parser.PostProcess ( setRdrNameSpace )@@ -71,6 +73,8 @@ import GHC.Types.Name.Set import GHC.Types.Name.Env import GHC.Types.Avail+import GHC.Types.Hint+import GHC.Types.Error import GHC.Unit.Module import GHC.Unit.Module.ModIface import GHC.Unit.Module.Warnings  ( WarningTxt, pprWarningTxtForMsg )@@ -94,11 +98,12 @@ import GHC.Rename.Utils import qualified Data.Semigroup as Semi import Data.Either      ( partitionEithers )-import Data.List        ( find, sortBy )+import Data.List        ( find ) import qualified Data.List.NonEmpty as NE import Control.Arrow    ( first )-import Data.Function import GHC.Types.FieldLabel+import GHC.Data.Bag+import GHC.Types.PkgQual  {- *********************************************************@@ -252,7 +257,7 @@  -- Can be made to not be exposed -- Only used unwrapped in rnAnnProvenance-lookupTopBndrRn :: RdrName -> RnM Name+lookupTopBndrRn :: WhatLooking -> RdrName -> RnM Name -- Look up a top-level source-code binder.   We may be looking up an unqualified 'f', -- and there may be several imported 'f's too, which must not confuse us. -- For example, this is OK:@@ -263,7 +268,7 @@ -- -- A separate function (importsFromLocalDecls) reports duplicate top level -- decls, so here it's safe just to choose an arbitrary one.-lookupTopBndrRn rdr_name =+lookupTopBndrRn which_suggest rdr_name =   lookupExactOrOrig rdr_name id $     do  {  -- Check for operators in type or class declarations            -- See Note [Type and class operator definitions]@@ -277,19 +282,25 @@             [gre] -> return (greMangledName gre)             _     -> do -- Ambiguous (can't happen) or unbound                         traceRn "lookupTopBndrRN fail" (ppr rdr_name)-                        unboundName WL_LocalTop rdr_name+                        unboundName (LF which_suggest WL_LocalTop) rdr_name     } +lookupLocatedTopConstructorRn :: Located RdrName -> RnM (Located Name)+lookupLocatedTopConstructorRn = wrapLocM (lookupTopBndrRn WL_Constructor)++lookupLocatedTopConstructorRnN :: LocatedN RdrName -> RnM (LocatedN Name)+lookupLocatedTopConstructorRnN = wrapLocMA (lookupTopBndrRn WL_Constructor)+ lookupLocatedTopBndrRn :: Located RdrName -> RnM (Located Name)-lookupLocatedTopBndrRn = wrapLocM lookupTopBndrRn+lookupLocatedTopBndrRn = wrapLocM (lookupTopBndrRn WL_Anything)  lookupLocatedTopBndrRnN :: LocatedN RdrName -> RnM (LocatedN Name)-lookupLocatedTopBndrRnN = wrapLocMA lookupTopBndrRn+lookupLocatedTopBndrRnN = wrapLocMA (lookupTopBndrRn WL_Anything)  -- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames]. -- This never adds an error, but it may return one, see -- Note [Errors in lookup functions]-lookupExactOcc_either :: Name -> RnM (Either SDoc Name)+lookupExactOcc_either :: Name -> RnM (Either NotInScopeError Name) lookupExactOcc_either name   | Just thing <- wiredInNameTyThing_maybe name   , Just tycon <- case thing of@@ -330,28 +341,12 @@                             ; th_topnames <- readTcRef th_topnames_var                             ; if name `elemNameSet` th_topnames                               then return (Right name)-                              else return (Left (exactNameErr name))+                              else return (Left (NoExactName name))                             }                        }-           gres -> return (Left (sameNameErr gres))   -- Ugh!  See Note [Template Haskell ambiguity]-       } -sameNameErr :: [GlobalRdrElt] -> SDoc-sameNameErr [] = panic "addSameNameErr: empty list"-sameNameErr gres@(_ : _)-  = hang (text "Same exact name in multiple name-spaces:")-       2 (vcat (map pp_one sorted_names) $$ th_hint)-  where-    sorted_names = sortBy (SrcLoc.leftmost_smallest `on` nameSrcSpan) (map greMangledName gres)-    pp_one name-      = hang (pprNameSpace (occNameSpace (getOccName name))-              <+> quotes (ppr name) <> comma)-           2 (text "declared at:" <+> ppr (nameSrcLoc name))--    th_hint = vcat [ text "Probable cause: you bound a unique Template Haskell name (NameU),"-                   , text "perhaps via newName, in different name-spaces."-                   , text "If that's it, then -ddump-splices might be useful" ]-+           gres -> return (Left (SameName gres)) -- Ugh!  See Note [Template Haskell ambiguity]+       }  ----------------------------------------------- lookupInstDeclBndr :: Name -> SDoc -> RdrName -> RnM Name@@ -382,7 +377,8 @@                                 -- when it's used                           cls doc rdr        ; case mb_name of-           Left err -> do { addErr err; return (mkUnboundNameRdr rdr) }+           Left err -> do { addErr (mkTcRnNotInScope rdr err)+                          ; return (mkUnboundNameRdr rdr) }            Right nm -> return nm }   where     doc = what <+> text "of class" <+> quotes (ppr cls)@@ -395,7 +391,7 @@ lookupFamInstName (Just cls) tc_rdr  -- Associated type; c.f GHC.Rename.Bind.rnMethodBind   = wrapLocMA (lookupInstDeclBndr cls (text "associated type")) tc_rdr lookupFamInstName Nothing tc_rdr     -- Family instance; tc_rdr is an *occurrence*-  = lookupLocatedOccRn tc_rdr+  = lookupLocatedOccRnConstr tc_rdr  ----------------------------------------------- lookupConstructorFields :: Name -> RnM [FieldLabel]@@ -429,7 +425,7 @@        ; case men of           FoundExactOrOrig n -> return (res n)           ExactOrOrigError e ->-            do { addErr e+            do { addErr (mkTcRnNotInScope rdr_name e)                ; return (res (mkUnboundNameRdr rdr_name)) }           NotExactOrOrig     -> k } @@ -445,9 +441,9 @@            NotExactOrOrig     -> k }  data ExactOrOrigResult = FoundExactOrOrig Name -- ^ Found an Exact Or Orig Name-                       | ExactOrOrigError SDoc -- ^ The RdrName was an Exact-                                                 -- or Orig, but there was an-                                                 -- error looking up the Name+                       | ExactOrOrigError NotInScopeError -- ^ The RdrName was an Exact+                                                          -- or Orig, but there was an+                                                          -- error looking up the Name                        | NotExactOrOrig -- ^ The RdrName is neither an Exact nor                                         -- Orig @@ -499,7 +495,8 @@   , isUnboundName con  -- Avoid error cascade   = return (mkUnboundNameRdr rdr_name)   | Just con <- mb_con-  = do { flds <- lookupConstructorFields con+  = lookupExactOrOrig rdr_name id $  -- See Note [Record field names and Template Haskell]+    do { flds <- lookupConstructorFields con        ; env <- getGlobalRdrEnv        ; let lbl      = occNameFS (rdrNameOcc rdr_name)              mb_field = do fl <- find ((== lbl) . flLabel) flds@@ -515,12 +512,13 @@        ; case mb_field of            Just (fl, gre) -> do { addUsedGRE True gre                                 ; return (flSelector fl) }-           Nothing        -> lookupGlobalOccRn' WantBoth rdr_name }-             -- See Note [Fall back on lookupGlobalOccRn in lookupRecFieldOcc]-  | otherwise-  -- This use of Global is right as we are looking up a selector which-  -- can only be defined at the top level.+           Nothing        -> do { addErr (badFieldConErr con lbl)+                                ; return (mkUnboundNameRdr rdr_name) } }++  | otherwise  -- Can't use the data constructor to disambiguate   = lookupGlobalOccRn' WantBoth rdr_name+    -- This use of Global is right as we are looking up a selector,+    -- which can only be defined at the top level.  -- | Look up an occurrence of a field in a record update, returning the selector -- name.@@ -552,7 +550,8 @@                                   Nothing -> unbound           | otherwise   -> unbound   where-    unbound = UnambiguousGre . NormalGreName <$> unboundName WL_Global rdr_name+    unbound = UnambiguousGre . NormalGreName+          <$> unboundName (LF WL_RecField WL_Global) rdr_name   {- Note [DisambiguateRecordFields]@@ -635,25 +634,8 @@ qualifier to be omitted, because we do not have a data constructor from which to determine it. --Note [Fall back on lookupGlobalOccRn in lookupRecFieldOcc]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Whenever we fail to find the field or it is not in scope, mb_field-will be False, and we fall back on looking it up normally using-lookupGlobalOccRn.  We don't report an error immediately because the-actual problem might be located elsewhere.  For example (#9975):--   data Test = Test { x :: Int }-   pattern Test wat = Test { x = wat }--Here there are multiple declarations of Test (as a data constructor-and as a pattern synonym), which will be reported as an error.  We-shouldn't also report an error about the occurrence of `x` in the-pattern synonym RHS.  However, if the pattern synonym gets added to-the environment first, we will try and fail to find `x` amongst the-(nonexistent) fields of the pattern synonym.--Alternatively, the scope check can fail due to Template Haskell.+Note [Record field names and Template Haskell]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider (#12130):     module Foo where@@ -672,7 +654,6 @@ -}  - -- | Used in export lists to lookup the children. lookupSubBndrOcc_helper :: Bool -> Bool -> Name -> RdrName                         -> RnM ChildLookupResult@@ -835,21 +816,21 @@                  -> Name     -- Parent                  -> SDoc                  -> RdrName-                 -> RnM (Either SDoc Name)+                 -> RnM (Either NotInScopeError Name) -- Find all the things the rdr-name maps to--- and pick the one with the right parent namep+-- and pick the one with the right parent name lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name = do   res <-     lookupExactOrOrig rdr_name (FoundChild NoParent . NormalGreName) $       -- This happens for built-in classes, see mod052 for example       lookupSubBndrOcc_helper True warn_if_deprec the_parent rdr_name   case res of-    NameNotFound -> return (Left (unknownSubordinateErr doc rdr_name))+    NameNotFound -> return (Left (UnknownSubordinate doc))     FoundChild _p child -> return (Right (greNameMangledName child))     IncorrectParent {}          -- See [Mismatched class methods and associated type families]          -- in TcInstDecls.-      -> return $ Left (unknownSubordinateErr doc rdr_name)+      -> return $ Left (UnknownSubordinate doc)  {- Note [Family instance binders]@@ -993,6 +974,18 @@                    -> TcRn (GenLocated (SrcSpanAnn' ann) Name) lookupLocatedOccRn = wrapLocMA lookupOccRn +lookupLocatedOccRnConstr :: GenLocated (SrcSpanAnn' ann) RdrName+                         -> TcRn (GenLocated (SrcSpanAnn' ann) Name)+lookupLocatedOccRnConstr = wrapLocMA lookupOccRnConstr++lookupLocatedOccRnRecField :: GenLocated (SrcSpanAnn' ann) RdrName+                           -> TcRn (GenLocated (SrcSpanAnn' ann) Name)+lookupLocatedOccRnRecField = wrapLocMA lookupOccRnRecField++lookupLocatedOccRnNone :: GenLocated (SrcSpanAnn' ann) RdrName+                       -> TcRn (GenLocated (SrcSpanAnn' ann) Name)+lookupLocatedOccRnNone = wrapLocMA lookupOccRnNone+ lookupLocalOccRn_maybe :: RdrName -> RnM (Maybe Name) -- Just look in the local environment lookupLocalOccRn_maybe rdr_name@@ -1005,14 +998,35 @@   = do { lcl_env <- getLclEnv        ; return (lookupNameEnv (tcl_th_bndrs lcl_env) name) } --- lookupOccRn looks up an occurrence of a RdrName-lookupOccRn :: RdrName -> RnM Name-lookupOccRn rdr_name+-- lookupOccRn' looks up an occurrence of a RdrName, and uses its argument to+-- determine what kind of suggestions should be displayed if it is not in scope+lookupOccRn' :: WhatLooking -> RdrName -> RnM Name+lookupOccRn' which_suggest rdr_name   = do { mb_name <- lookupOccRn_maybe rdr_name        ; case mb_name of            Just name -> return name-           Nothing   -> reportUnboundName rdr_name }+           Nothing   -> reportUnboundName' which_suggest rdr_name } +-- lookupOccRn looks up an occurrence of a RdrName and displays suggestions if+-- it is not in scope+lookupOccRn :: RdrName -> RnM Name+lookupOccRn = lookupOccRn' WL_Anything++-- lookupOccRnConstr looks up an occurrence of a RdrName and displays+-- constructors and pattern synonyms as suggestions if it is not in scope+lookupOccRnConstr :: RdrName -> RnM Name+lookupOccRnConstr = lookupOccRn' WL_Constructor++-- lookupOccRnRecField looks up an occurrence of a RdrName and displays+-- record fields as suggestions if it is not in scope+lookupOccRnRecField :: RdrName -> RnM Name+lookupOccRnRecField = lookupOccRn' WL_RecField++-- lookupOccRnRecField looks up an occurrence of a RdrName and displays+-- no suggestions if it is not in scope+lookupOccRnNone :: RdrName -> RnM Name+lookupOccRnNone = lookupOccRn' WL_None+ -- Only used in one place, to rename pattern synonym binders. -- See Note [Renaming pattern synonym variables] in GHC.Rename.Bind lookupLocalOccRn :: RdrName -> RnM Name@@ -1020,7 +1034,7 @@   = do { mb_name <- lookupLocalOccRn_maybe rdr_name        ; case mb_name of            Just name -> return name-           Nothing   -> unboundName WL_LocalOnly rdr_name }+           Nothing   -> unboundName (LF WL_Anything WL_LocalOnly) rdr_name }  -- lookupTypeOccRn looks up an optionally promoted RdrName. -- Used for looking up type variables.@@ -1033,47 +1047,56 @@   = do { mb_name <- lookupOccRn_maybe rdr_name        ; case mb_name of              Just name -> return name-             Nothing   -> lookup_demoted rdr_name }+             Nothing   ->+               if occName rdr_name == occName eqTyCon_RDR -- See Note [eqTyCon (~) compatibility fallback]+               then eqTyConName <$ addDiagnostic TcRnTypeEqualityOutOfScope+               else lookup_demoted rdr_name } +{- Note [eqTyCon (~) compatibility fallback]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Before GHC Proposal #371, the (~) type operator used in type equality+constraints (a~b) was considered built-in syntax.++This had two implications:++1. Users could use it without importing it from Data.Type.Equality or Prelude.+2. TypeOperators were not required to use it (it was guarded behind TypeFamilies/GADTs instead)++To ease migration and minimize breakage, we continue to support those usages+but emit appropriate warnings.+-}+ lookup_demoted :: RdrName -> RnM Name lookup_demoted rdr_name   | Just demoted_rdr <- demoteRdrName rdr_name     -- Maybe it's the name of a *data* constructor   = do { data_kinds <- xoptM LangExt.DataKinds        ; star_is_type <- xoptM LangExt.StarIsType-       ; let star_info = starInfo star_is_type rdr_name+       ; let is_star_type = if star_is_type then StarIsType else StarIsNotType+             star_is_type_hints = noStarIsTypeHints is_star_type rdr_name        ; if data_kinds             then do { mb_demoted_name <- lookupOccRn_maybe demoted_rdr                     ; case mb_demoted_name of-                        Nothing -> unboundNameX WL_Any rdr_name star_info-                        Just demoted_name ->-                          do { whenWOptM Opt_WarnUntickedPromotedConstructors $-                               addWarn-                                 (Reason Opt_WarnUntickedPromotedConstructors)-                                 (untickedPromConstrWarn demoted_name)-                             ; return demoted_name } }+                        Nothing -> unboundNameX looking_for rdr_name star_is_type_hints+                        Just demoted_name -> return demoted_name }             else do { -- We need to check if a data constructor of this name is                       -- in scope to give good error messages. However, we do                       -- not want to give an additional error if the data                       -- constructor happens to be out of scope! See #13947.                       mb_demoted_name <- discardErrs $                                          lookupOccRn_maybe demoted_rdr-                    ; let suggestion | isJust mb_demoted_name = suggest_dk-                                     | otherwise = star_info-                    ; unboundNameX WL_Any rdr_name suggestion } }+                    ; let suggestion | isJust mb_demoted_name+                                     , let additional = text "to refer to the data constructor of that name?"+                                     = [SuggestExtension $ SuggestSingleExtension additional LangExt.DataKinds]+                                     | otherwise+                                     = star_is_type_hints+                    ; unboundNameX looking_for rdr_name suggestion } }    | otherwise-  = reportUnboundName rdr_name+  = reportUnboundName' (lf_which looking_for) rdr_name    where-    suggest_dk = text "A data constructor of that name is in scope; did you mean DataKinds?"-    untickedPromConstrWarn name =-      text "Unticked promoted constructor" <> colon <+> quotes (ppr name) <> dot-      $$-      hsep [ text "Use"-           , quotes (char '\'' <> ppr name)-           , text "instead of"-           , quotes (ppr name) <> dot ]+    looking_for = LF WL_Constructor WL_Anywhere  -- If the given RdrName can be promoted to the type level and its promoted variant is in scope, -- lookup_promoted returns the corresponding type-level Name.@@ -1088,8 +1111,9 @@  badVarInType :: RdrName -> RnM Name badVarInType rdr_name-  = do { addErr (text "Illegal promoted term variable in a type:"-                 <+> ppr rdr_name)+  = do { addErr (TcRnUnknownMessage $ mkPlainError noHints+           (text "Illegal promoted term variable in a type:"+                 <+> ppr rdr_name))        ; return (mkUnboundNameRdr rdr_name) }  {- Note [Promoted variables in types]@@ -1158,21 +1182,17 @@ -- -- This may be a local variable, global variable, or one or more record selector -- functions.  It will not return record fields created with the--- @NoFieldSelectors@ extension (see Note [NoFieldSelectors]).  The--- 'DuplicateRecordFields' argument controls whether ambiguous fields will be--- allowed (resulting in an 'AmbiguousFields' result being returned).+-- @NoFieldSelectors@ extension (see Note [NoFieldSelectors]). -- -- If the name is not in scope at the term level, but its promoted equivalent is -- in scope at the type level, the lookup will succeed (so that the type-checker -- can report a more informative error later).  See Note [Promotion]. ---lookupExprOccRn-  :: DuplicateRecordFields -> RdrName-  -> RnM (Maybe AmbiguousResult)-lookupExprOccRn dup_fields_ok rdr_name-  = do { mb_name <- lookupOccRnX_maybe global_lookup (UnambiguousGre . NormalGreName) rdr_name+lookupExprOccRn :: RdrName -> RnM (Maybe GreName)+lookupExprOccRn rdr_name+  = do { mb_name <- lookupOccRnX_maybe global_lookup NormalGreName rdr_name        ; case mb_name of-           Nothing   -> fmap @Maybe (UnambiguousGre . NormalGreName) <$> lookup_promoted rdr_name+           Nothing   -> fmap @Maybe NormalGreName <$> lookup_promoted rdr_name                         -- See Note [Promotion].                         -- We try looking up the name as a                         -- type constructor or type variable, if@@ -1180,8 +1200,14 @@            p         -> return p }    where-    global_lookup :: RdrName -> RnM (Maybe AmbiguousResult)-    global_lookup = lookupGlobalOccRn_overloaded dup_fields_ok WantNormal+    global_lookup :: RdrName -> RnM (Maybe GreName)+    global_lookup  rdr_name =+      do { mb_name <- lookupGlobalOccRn_overloaded NoDuplicateRecordFields WantNormal rdr_name+         ; case mb_name of+             Just (UnambiguousGre name) -> return (Just name)+             Just _ -> panic "GHC.Rename.Env.global_lookup: The impossible happened!"+             Nothing -> return Nothing+         }  lookupGlobalOccRn_maybe :: RdrName -> RnM (Maybe Name) -- Looks up a RdrName occurrence in the top-level@@ -1211,7 +1237,11 @@     case mn of       Just n -> return n       Nothing -> do { traceRn "lookupGlobalOccRn" (ppr rdr_name)-                    ; unboundName WL_Global rdr_name }+                    ; unboundName (LF which_suggest WL_Global) rdr_name }+        where which_suggest = case fos of+                WantNormal -> WL_Anything+                WantBoth   -> WL_RecField+                WantField  -> WL_RecField  -- Looks up a RdrName occurrence in the GlobalRdrEnv and with -- lookupQualifiedNameGHCi. Does not try to find an Exact or Orig name first.@@ -1399,7 +1429,7 @@ {-  Note [ Unbound vs Ambiguous Names ]-+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ lookupGreRn_maybe deals with failures in two different ways. If a name is unbound then we return a `Nothing` but if the name is ambiguous then we raise an error and return a dummy name.@@ -1447,7 +1477,7 @@         GreNotFound ->           do             traceRn "lookupGreAvailRn" (ppr rdr_name)-            name <- unboundName WL_Global rdr_name+            name <- unboundName (LF WL_Anything WL_Global) rdr_name             return (name, avail name)         MultipleNames gres ->           do@@ -1515,7 +1545,7 @@  warnIfDeprecated :: GlobalRdrElt -> RnM () warnIfDeprecated gre@(GRE { gre_imp = iss })-  | (imp_spec : _) <- iss+  | Just imp_spec <- headMaybe iss   = do { dflags <- getDynFlags        ; this_mod <- getModule        ; when (wopt Opt_WarnWarningsDeprecations dflags &&@@ -1523,16 +1553,21 @@                    -- See Note [Handling of deprecations]          do { iface <- loadInterfaceForName doc name             ; case lookupImpDeprec iface gre of-                Just txt -> addWarn (Reason Opt_WarnWarningsDeprecations)-                                   (mk_msg imp_spec txt)+                Just txt -> do+                  let msg = TcRnUnknownMessage $+                              mkPlainDiagnostic (WarningWithFlag Opt_WarnWarningsDeprecations)+                                                noHints+                                                (mk_msg imp_spec txt)++                  addDiagnostic msg                 Nothing  -> return () } }   | otherwise   = return ()   where     occ = greOccName gre     name = greMangledName gre-    name_mod = ASSERT2( isExternalName name, ppr name ) nameModule name-    doc = text "The name" <+> quotes (ppr occ) <+> ptext (sLit "is mentioned explicitly")+    name_mod = assertPpr (isExternalName name) (ppr name) (nameModule name)+    doc = text "The name" <+> quotes (ppr occ) <+> text "is mentioned explicitly"      mk_msg imp_spec txt       = sep [ sep [ text "In the use of"@@ -1546,7 +1581,7 @@         extra | imp_mod == moduleName name_mod = Outputable.empty               | otherwise = text ", but defined in" <+> ppr name_mod -lookupImpDeprec :: ModIface -> GlobalRdrElt -> Maybe WarningTxt+lookupImpDeprec :: ModIface -> GlobalRdrElt -> Maybe (WarningTxt GhcRn) lookupImpDeprec iface gre   = mi_warn_fn (mi_final_exts iface) (greOccName gre) `mplus`  -- Bleat if the thing,     case gre_par gre of                      -- or its parent, is warn'd@@ -1631,7 +1666,7 @@     -- -fimplicit-import-qualified is used with a module that exports the same     -- field name multiple times (see     -- Note [DuplicateRecordFields and -fimplicit-import-qualified]).-    toGRE gname = GRE { gre_name = gname, gre_par = NoParent, gre_lcl = False, gre_imp = [is] }+    toGRE gname = GRE { gre_name = gname, gre_par = NoParent, gre_lcl = False, gre_imp = unitBag is }     is = ImpSpec { is_decl = ImpDeclSpec { is_mod = mod, is_as = mod, is_qual = True, is_dloc = noSrcSpan }                  , is_item = ImpAll }     -- If -fimplicit-import-qualified succeeded, the name must be qualified.@@ -1655,7 +1690,7 @@       , is_ghci       , gopt Opt_ImplicitImportQualified dflags   -- Enables this GHCi behaviour       , not (safeDirectImpsReq dflags)            -- See Note [Safe Haskell and GHCi]-      = do { res <- loadSrcInterface_maybe doc mod NotBoot Nothing+      = do { res <- loadSrcInterface_maybe doc mod NotBoot NoPkgQual            ; case res of                 Succeeded iface                   -> return [ gname@@ -1762,7 +1797,8 @@   = wrapLocMA $ \ rdr_name ->     do { mb_name <- lookupBindGroupOcc ctxt what rdr_name        ; case mb_name of-           Left err   -> do { addErr err; return (mkUnboundNameRdr rdr_name) }+           Left err   -> do { addErr (mkTcRnNotInScope rdr_name err)+                            ; return (mkUnboundNameRdr rdr_name) }            Right name -> return name }  -- | Lookup a name in relation to the names in a 'HsSigCtxt'@@ -1774,12 +1810,13 @@   = wrapLocMA $ \ rdr_name ->     do { mb_name <- lookupBindGroupOcc ctxt what rdr_name        ; case mb_name of-           Left err   -> do { addErr err; return (mkUnboundNameRdr rdr_name) }+           Left err   -> do { addErr (mkTcRnNotInScope rdr_name err)+                            ; return (mkUnboundNameRdr rdr_name) }            Right name -> return name }  lookupBindGroupOcc :: HsSigCtxt                    -> SDoc-                   -> RdrName -> RnM (Either SDoc Name)+                   -> RdrName -> RnM (Either NotInScopeError Name) -- Looks up the RdrName, expecting it to resolve to one of the -- bound names passed in.  If not, return an appropriate error message --@@ -1814,11 +1851,12 @@      lookup_top keep_me       = do { env <- getGlobalRdrEnv+           ; dflags <- getDynFlags            ; let all_gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name)                  names_in_scope = -- If rdr_name lacks a binding, only                                   -- recommend alternatives from related                                   -- namespaces. See #17593.-                                  filter (\n -> nameSpacesRelated+                                  filter (\n -> nameSpacesRelated dflags WL_Anything                                                   (rdrNameSpace rdr_name)                                                   (nameNameSpace n))                                 $ map greMangledName@@ -1840,32 +1878,24 @@                  | otherwise                   -> bale_out_with local_msg                Nothing                         -> bale_out_with candidates_msg } -    bale_out_with msg-        = return (Left (sep [ text "The" <+> what-                                <+> text "for" <+> quotes (ppr rdr_name)-                           , nest 2 $ text "lacks an accompanying binding"]-                       $$ nest 2 msg))+    bale_out_with hints = return (Left $ MissingBinding what hints) -    local_msg = parens $ text "The"  <+> what <+> ptext (sLit "must be given where")-                           <+> quotes (ppr rdr_name) <+> text "is declared"+    local_msg = [SuggestMoveToDeclarationSite what rdr_name]      -- Identify all similar names and produce a message listing them-    candidates :: [Name] -> SDoc+    candidates :: [Name] -> [GhcHint]     candidates names_in_scope-      = case similar_names of-          []  -> Outputable.empty-          [n] -> text "Perhaps you meant" <+> pp_item n-          _   -> sep [ text "Perhaps you meant one of these:"-                     , nest 2 (pprWithCommas pp_item similar_names) ]+      | (nm : nms) <- map SimilarName similar_names+      = [SuggestSimilarNames rdr_name (nm NE.:| nms)]+      | otherwise+      = []       where         similar_names           = fuzzyLookup (unpackFS $ occNameFS $ rdrNameOcc rdr_name)                         $ map (\x -> ((unpackFS $ occNameFS $ nameOccName x), x))                               names_in_scope -        pp_item x = quotes (ppr x) <+> parens (pprDefinedAt x) - --------------- lookupLocalTcNames :: HsSigCtxt -> SDoc -> RdrName -> RnM [(RdrName, Name)] -- GHC extension: look up both the tycon and data con or variable.@@ -1875,7 +1905,8 @@ lookupLocalTcNames ctxt what rdr_name   = do { mb_gres <- mapM lookup (dataTcOccs rdr_name)        ; let (errs, names) = partitionEithers mb_gres-       ; when (null names) $ addErr (head errs) -- Bleat about one only+       ; when (null names) $+          addErr (head errs) -- Bleat about one only        ; return names }   where     lookup rdr = do { this_mod <- getModule@@ -1886,10 +1917,11 @@     guard_builtin_syntax this_mod rdr (Right name)       | Just _ <- isBuiltInOcc_maybe (occName rdr)       , this_mod /= nameModule name-      = Left (hsep [text "Illegal", what, text "of built-in syntax:", ppr rdr])+      = Left $ TcRnIllegalBuiltinSyntax what rdr       | otherwise       = Right (rdr, name)-    guard_builtin_syntax _ _ (Left err) = Left err+    guard_builtin_syntax _ _ (Left err)+      = Left $ mkTcRnNotInScope rdr_name err  dataTcOccs :: RdrName -> [RdrName] -- Return both the given name and the same name promoted to the TcClsName@@ -1902,13 +1934,7 @@   = [rdr_name]   where     occ = rdrNameOcc rdr_name-    rdr_name_tc =-      case rdr_name of-        -- The (~) type operator is always in scope, so we need a special case-        -- for it here, or else  :info (~)  fails in GHCi.-        -- See Note [eqTyCon (~) is built-in syntax]-        Unqual occ | occNameFS occ == fsLit "~" -> eqTyCon_RDR-        _ -> setRdrNameSpace rdr_name tcName+    rdr_name_tc = setRdrNameSpace rdr_name tcName  {- Note [dataTcOccs and Exact Names]@@ -1977,7 +2003,7 @@   = do { rebindable_on <- xoptM LangExt.RebindableSyntax        ; if not rebindable_on          then return Nothing-         else do { ite <- lookupOccRn (mkVarUnqual (fsLit "ifThenElse"))+         else do { ite <- lookupOccRnNone (mkVarUnqual (fsLit "ifThenElse"))                  ; return (Just ite) } }  lookupSyntaxName :: Name                 -- ^ The standard name@@ -1992,7 +2018,7 @@   = do { rebind <- xoptM LangExt.RebindableSyntax        ; if not rebind          then return (std_name, emptyFVs)-         else do { nm <- lookupOccRn (mkRdrUnqual (nameOccName std_name))+         else do { nm <- lookupOccRnNone (mkRdrUnqual (nameOccName std_name))                  ; return (nm, unitFV nm) } }  lookupSyntaxExpr :: Name                          -- ^ The standard name@@ -2016,7 +2042,8 @@        ; if not rebindable_on then              return (map (HsVar noExtField . noLocA) std_names, emptyFVs)         else-          do { usr_names <- mapM (lookupOccRn . mkRdrUnqual . nameOccName) std_names+          do { usr_names <-+                 mapM (lookupOccRnNone . mkRdrUnqual . nameOccName) std_names              ; return (map (HsVar noExtField . noLocA) usr_names, mkFVs usr_names) } }  @@ -2050,7 +2077,7 @@  lookupNameWithQualifier :: Name -> ModuleName -> RnM (Name, FreeVars) lookupNameWithQualifier std_name modName-  = do { qname <- lookupOccRn (mkRdrQual modName (nameOccName std_name))+  = do { qname <- lookupOccRnNone (mkRdrQual modName (nameOccName std_name))        ; return (qname, unitFV qname) }  -- See Note [QualifiedDo].@@ -2066,19 +2093,20 @@  -- Error messages -opDeclErr :: RdrName -> SDoc+opDeclErr :: RdrName -> TcRnMessage opDeclErr n-  = hang (text "Illegal declaration of a type or class operator" <+> quotes (ppr n))+  = TcRnUnknownMessage $ mkPlainError noHints $+    hang (text "Illegal declaration of a type or class operator" <+> quotes (ppr n))        2 (text "Use TypeOperators to declare operators in type and declarations") -badOrigBinding :: RdrName -> SDoc+badOrigBinding :: RdrName -> TcRnMessage badOrigBinding name   | Just _ <- isBuiltInOcc_maybe occ-  = text "Illegal binding of built-in syntax:" <+> ppr occ+  = TcRnUnknownMessage $ mkPlainError noHints $ text "Illegal binding of built-in syntax:" <+> ppr occ     -- Use an OccName here because we don't want to print Prelude.(,)   | otherwise-  = text "Cannot redefine a Name retrieved by a Template Haskell quote:"-    <+> ppr name+  = TcRnUnknownMessage $ mkPlainError noHints $+    text "Cannot redefine a Name retrieved by a Template Haskell quote:" <+> ppr name     -- This can happen when one tries to use a Template Haskell splice to     -- define a top-level identifier with an already existing name, e.g.,     --
compiler/GHC/Rename/Expr.hs view
@@ -1,8 +1,10 @@-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE CPP                 #-} {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE MultiWayIf          #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-} {-# LANGUAGE TypeFamilies        #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}@@ -25,25 +27,27 @@         AnnoBody    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Rename.Bind ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS                         , rnMatchGroup, rnGRHS, makeMiniFixityEnv) import GHC.Hs+import GHC.Tc.Errors.Types import GHC.Tc.Utils.Env ( isBrackStage ) import GHC.Tc.Utils.Monad-import GHC.Unit.Module ( getModule )+import GHC.Unit.Module ( getModule, isInteractiveModule ) import GHC.Rename.Env import GHC.Rename.Fixity-import GHC.Rename.Utils ( HsDocContext(..), bindLocalNamesFV, checkDupNames+import GHC.Rename.Utils ( bindLocalNamesFV, checkDupNames                         , bindLocalNames                         , mapMaybeFvRn, mapFvRn                         , warnUnusedLocalBinds, typeAppErr-                        , checkUnusedRecordWildcard )+                        , checkUnusedRecordWildcard+                        , wrapGenSpan, genHsIntegralLit, genHsTyLit+                        , genHsVar, genLHsVar, genHsApp, genHsApps+                        , genAppType ) import GHC.Rename.Unbound ( reportUnboundName )-import GHC.Rename.Splice  ( rnBracket, rnSpliceExpr, checkThLocalName )+import GHC.Rename.Splice  ( rnTypedBracket, rnUntypedBracket, rnSpliceExpr, checkThLocalName ) import GHC.Rename.HsType import GHC.Rename.Pat import GHC.Driver.Session@@ -51,6 +55,7 @@  import GHC.Types.FieldLabel import GHC.Types.Fixity+import GHC.Types.Hint (suggestExtension) import GHC.Types.Id.Make import GHC.Types.Name import GHC.Types.Name.Set@@ -61,9 +66,9 @@ import GHC.Data.List.SetOps ( removeDups ) import GHC.Utils.Error import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Outputable as Outputable import GHC.Types.SrcLoc-import GHC.Data.FastString import Control.Monad import GHC.Builtin.Types ( nilDataConName ) import qualified GHC.LanguageExtensions as LangExt@@ -108,7 +113,10 @@ This is accomplished by lookupSyntaxName, and it applies to all the constructs below. -Here are the constructs that we transform in this way. Some are uniform,+See also Note [Handling overloaded and rebindable patterns] in GHC.Rename.Pat+for the story with patterns.++Here are the expressions that we transform in this way. Some are uniform, but several have a little bit of special treatment:  * HsIf (if-the-else)@@ -132,7 +140,7 @@ * SectionL and SectionR (left and right sections)      (`op` e) ==> rightSection op e      (e `op`) ==> leftSection  (op e)-  where `leftSection` and `rightSection` are levity-polymorphic+  where `leftSection` and `rightSection` are representation-polymorphic   wired-in Ids. See Note [Left and right sections]  * It's a bit painful to transform `OpApp e1 op e2` to a `HsExpansion`@@ -200,25 +208,18 @@       ; return (HsVar noExtField (L (la2na l) name), unitFV name) }  rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars)-rnUnboundVar v =-  if isUnqual v-  then -- Treat this as a "hole"-       -- Do not fail right now; instead, return HsUnboundVar-       -- and let the type checker report the error-       return (HsUnboundVar noExtField (rdrNameOcc v), emptyFVs)--        else -- Fail immediately (qualified name)-             do { n <- reportUnboundName v-                ; return (HsVar noExtField (noLocA n), emptyFVs) }+rnUnboundVar v = do+  deferOutofScopeVariables <- goptM Opt_DeferOutOfScopeVariables+  unless (isUnqual v || deferOutofScopeVariables) (reportUnboundName v >> return ())+  return (HsUnboundVar noExtField (rdrNameOcc v), emptyFVs)  rnExpr (HsVar _ (L l v))   = do { dflags <- getDynFlags-       ; let dup_fields_ok = xopt_DuplicateRecordFields dflags-       ; mb_name <- lookupExprOccRn dup_fields_ok v+       ; mb_name <- lookupExprOccRn v         ; case mb_name of {            Nothing -> rnUnboundVar v ;-           Just (UnambiguousGre (NormalGreName name))+           Just (NormalGreName name)               | name == nilDataConName -- Treat [] as an ExplicitList, so that                                        -- OverloadedLists works correctly                                        -- Note [Empty lists] in GHC.Hs.Expr@@ -227,12 +228,15 @@                | otherwise               -> finishHsVar (L (na2la l) name) ;-            Just (UnambiguousGre (FieldGreName fl)) ->-              let sel_name = flSelector fl in-              return ( HsRecFld noExtField (Unambiguous sel_name (L l v) ), unitFV sel_name) ;-            Just AmbiguousFields ->-              return ( HsRecFld noExtField (Ambiguous noExtField (L l v) ), emptyFVs) } }-+            Just (FieldGreName fl)+              -> do { let sel_name = flSelector fl+                    ; this_mod <- getModule+                    ; when (nameIsLocalOrFrom this_mod sel_name) $+                        checkThLocalName sel_name+                    ; return ( HsRecSel noExtField (FieldOcc sel_name (L l v) ), unitFV sel_name)+                    }+         }+       }  rnExpr (HsIPVar x v)   = return (HsIPVar x v, emptyFVs)@@ -294,7 +298,7 @@         -- should prevent bad things happening.         ; fixity <- case op' of               L _ (HsVar _ (L _ n)) -> lookupFixityRn n-              L _ (HsRecFld _ f)    -> lookupFieldFixityRn f+              L _ (HsRecSel _ f)    -> lookupFieldFixityRn f               _ -> return (Fixity NoSourceText minPrecedence InfixL)                    -- c.f. lookupFixity for unbound @@ -316,41 +320,42 @@ rnExpr (HsGetField _ e f)  = do { (getField, fv_getField) <- lookupSyntaxName getFieldName       ; (e, fv_e) <- rnLExpr e-      ; let f' = rnHsFieldLabel f+      ; let f' = rnDotFieldOcc f       ; return ( mkExpandedExpr                    (HsGetField noExtField e f')-                   (mkGetField getField e (fmap (unLoc . hflLabel) f'))+                   (mkGetField getField e (fmap (unLoc . dfoLabel) f'))                , fv_e `plusFV` fv_getField ) }  rnExpr (HsProjection _ fs)   = do { (getField, fv_getField) <- lookupSyntaxName getFieldName        ; circ <- lookupOccRn compose_RDR-       ; let fs' = fmap rnHsFieldLabel fs+       ; let fs' = fmap rnDotFieldOcc fs        ; return ( mkExpandedExpr                     (HsProjection noExtField fs')-                    (mkProjection getField circ (fmap (fmap (unLoc . hflLabel)) fs'))+                    (mkProjection getField circ (fmap (fmap (unLoc . dfoLabel)) fs'))                 , unitFV circ `plusFV` fv_getField) }  ------------------------------------------ -- Template Haskell extensions-rnExpr e@(HsBracket _ br_body) = rnBracket e br_body+rnExpr e@(HsTypedBracket _ br_body)   = rnTypedBracket e br_body+rnExpr e@(HsUntypedBracket _ br_body) = rnUntypedBracket e br_body  rnExpr (HsSpliceE _ splice) = rnSpliceExpr splice  --------------------------------------------- --      Sections -- See Note [Parsing sections] in GHC.Parser-rnExpr (HsPar x (L loc (section@(SectionL {}))))+rnExpr (HsPar x lpar (L loc (section@(SectionL {}))) rpar)   = do  { (section', fvs) <- rnSection section-        ; return (HsPar x (L loc section'), fvs) }+        ; return (HsPar x lpar (L loc section') rpar, fvs) } -rnExpr (HsPar x (L loc (section@(SectionR {}))))+rnExpr (HsPar x lpar (L loc (section@(SectionR {}))) rpar)   = do  { (section', fvs) <- rnSection section-        ; return (HsPar x (L loc section'), fvs) }+        ; return (HsPar x lpar (L loc section') rpar, fvs) } -rnExpr (HsPar x e)+rnExpr (HsPar x lpar e rpar)   = do  { (e', fvs_e) <- rnLExpr e-        ; return (HsPar x e', fvs_e) }+        ; return (HsPar x lpar e' rpar, fvs_e) }  rnExpr expr@(SectionL {})   = do  { addErr (sectionErr expr); rnSection expr }@@ -369,26 +374,26 @@   = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches        ; return (HsLam x matches', fvMatch) } -rnExpr (HsLamCase x matches)-  = do { (matches', fvs_ms) <- rnMatchGroup CaseAlt rnLExpr matches-       ; return (HsLamCase x matches', fvs_ms) }+rnExpr (HsLamCase x lc_variant matches)+  = do { (matches', fvs_ms) <- rnMatchGroup (LamCaseAlt lc_variant) rnLExpr matches+       ; return (HsLamCase x lc_variant matches', fvs_ms) }  rnExpr (HsCase _ expr matches)   = do { (new_expr, e_fvs) <- rnLExpr expr        ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches        ; return (HsCase noExtField new_expr new_matches, e_fvs `plusFV` ms_fvs) } -rnExpr (HsLet _ binds expr)+rnExpr (HsLet _ tkLet binds tkIn expr)   = rnLocalBindsAndThen binds $ \binds' _ -> do       { (expr',fvExpr) <- rnLExpr expr-      ; return (HsLet noExtField binds' expr', fvExpr) }+      ; return (HsLet noExtField tkLet binds' tkIn expr', fvExpr) }  rnExpr (HsDo _ do_or_lc (L l stmts))-  = do  { ((stmts', _), fvs) <--           rnStmtsWithPostProcessing do_or_lc rnExpr-             postProcessStmtsForApplicativeDo stmts-             (\ _ -> return ((), emptyFVs))-        ; return ( HsDo noExtField do_or_lc (L l stmts'), fvs ) }+ = do { ((stmts1, _), fvs1) <-+          rnStmtsWithFreeVars (HsDoStmt do_or_lc) rnExpr stmts+            (\ _ -> return ((), emptyFVs))+      ; (pp_stmts, fvs2) <- postProcessStmtsForApplicativeDo do_or_lc stmts1+      ; return ( HsDo noExtField do_or_lc (L l pp_stmts), fvs1 `plusFV` fvs2 ) }  -- ExplicitList: see Note [Handling overloaded and rebindable constructs] rnExpr (ExplicitList _ exps)@@ -400,7 +405,7 @@     do { (from_list_n_name, fvs') <- lookupSyntaxName fromListNName        ; let rn_list  = ExplicitList noExtField exps'              lit_n    = mkIntegralLit (length exps)-             hs_lit   = wrapGenSpan (HsLit noAnn (HsInt noExtField lit_n))+             hs_lit   = genHsIntegralLit lit_n              exp_list = genHsApps from_list_n_name [hs_lit, wrapGenSpan rn_list]        ; return ( mkExpandedExpr rn_list exp_list                 , fvs `plusFV` fvs') } }@@ -420,7 +425,7 @@  rnExpr (RecordCon { rcon_con = con_id                   , rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) })-  = do { con_lname@(L _ con_name) <- lookupLocatedOccRn con_id+  = do { con_lname@(L _ con_name) <- lookupLocatedOccRnConstr con_id        ; (flds, fvs)   <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds        ; (flds', fvss) <- mapAndUnzipM rn_field flds        ; let rec_binds' = HsRecFields { rec_flds = flds', rec_dotdot = dd }@@ -429,8 +434,8 @@                 , fvs `plusFV` plusFVs fvss `addOneFV` con_name) }   where     mk_hs_var l n = HsVar noExtField (L (noAnnSrcSpan l) n)-    rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)-                            ; return (L l (fld { hsRecFieldArg = arg' }), fvs) }+    rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hfbRHS fld)+                            ; return (L l (fld { hfbRHS = arg' }), fvs) }  rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds })   = case rbinds of@@ -441,11 +446,13 @@             }       Right flds ->  -- 'OverloadedRecordUpdate' is in effect. Record dot update desugaring.         do { ; unlessXOptM LangExt.RebindableSyntax $-                 addErr $ text "RebindableSyntax is required if OverloadedRecordUpdate is enabled."-             ; let punnedFields = [fld | (L _ fld) <- flds, hsRecPun fld]-             ; punsEnabled <-xoptM LangExt.RecordPuns+                 addErr $ TcRnUnknownMessage $ mkPlainError noHints $+                   text "RebindableSyntax is required if OverloadedRecordUpdate is enabled."+             ; let punnedFields = [fld | (L _ fld) <- flds, hfbPun fld]+             ; punsEnabled <-xoptM LangExt.NamedFieldPuns              ; unless (null punnedFields || punsEnabled) $-                 addErr $ text "For this to work enable NamedFieldPuns."+                 addErr $ TcRnUnknownMessage $ mkPlainError noHints $+                   text "For this to work enable NamedFieldPuns."              ; (getField, fv_getField) <- lookupSyntaxName getFieldName              ; (setField, fv_setField) <- lookupSyntaxName setFieldName              ; (e, fv_e) <- rnLExpr expr@@ -520,12 +527,13 @@     -- absolutely prepared to cope with static forms, we check for     -- -XStaticPointers here as well.     unlessXOptM LangExt.StaticPointers $-      addErr $ hang (text "Illegal static expression:" <+> ppr e)+      addErr $ TcRnUnknownMessage $ mkPlainError noHints $+        hang (text "Illegal static expression:" <+> ppr e)                   2 (text "Use StaticPointers to enable this extension")     (expr',fvExpr) <- rnLExpr expr     stage <- getStage     case stage of-      Splice _ -> addErr $ sep+      Splice _ -> addErr $ TcRnUnknownMessage $ mkPlainError noHints $ sep              [ text "static forms cannot be used in splices:"              , nest 2 $ ppr e              ]@@ -534,7 +542,8 @@     let fvExpr' = filterNameSet (nameIsLocalOrFrom mod) fvExpr     return (HsStatic fvExpr' expr', fvExpr) -{- *********************************************************************+{-+************************************************************************ *                                                                      *         Arrow notation *                                                                      *@@ -549,7 +558,8 @@ rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)         -- HsWrap -{- *********************************************************************+{-+************************************************************************ *                                                                      *         Operator sections *                                                                      *@@ -600,11 +610,11 @@ Note [Desugaring operator sections]  Here are their definitions:-   leftSection :: forall r1 r2 n (a:TYPE r1) (b:TYPE r2).+   leftSection :: forall r1 r2 n (a::TYPE r1) (b::TYPE r2).                   (a %n-> b) -> a %n-> b    leftSection f x = f x -   rightSection :: forall r1 r2 r3 (a:TYPE r1) (b:TYPE r2) (c:TYPE r3).+   rightSection :: forall r1 r2 r3 n1 n2 (a::TYPE r1) (b::TYPE r2) (c::TYPE r3).                    (a %n1 -> b %n2-> c) -> b %n2-> a %n1-> c    rightSection f y x = f x y @@ -616,23 +626,23 @@   Plus, infix operator applications would be trickier to make   rebindable, so it'd be inconsistent to do so for sections. -  TL;DR: we still us the renamer-expansion mechanism for operator-  sections , but only to eliminate special-purpose code paths in the+  TL;DR: we still use the renamer-expansion mechanism for operator+  sections, but only to eliminate special-purpose code paths in the   renamer and desugarer. -* leftSection and rightSection must be levity-polymorphic, to allow-  (+# 4#) and (4# +#) to work. See GHC.Types.Id.Make.-  Note [Wired-in Ids for rebindable syntax] in+* leftSection and rightSection must be representation-polymorphic, to allow+  (+# 4#) and (4# +#) to work. See+  Note [Wired-in Ids for rebindable syntax] in GHC.Types.Id.Make.  * leftSection and rightSection must be multiplicity-polymorphic.   (Test linear/should_compile/OldList showed this up.) -* Because they are levity-polymorphic, we have to define them+* Because they are representation-polymorphic, we have to define them   as wired-in Ids, with compulsory inlining.  See   GHC.Types.Id.Make.leftSectionId, rightSectionId.  * leftSection is just ($) really; but unlike ($) it is-  levity polymorphic in the result type, so we can write+  representation-polymorphic in the result type, so we can write   `(x +#)`, say.  * The type of leftSection must have an arrow in its first argument,@@ -649,16 +659,6 @@       (e `op`)  ==>   op e   with no auxiliary function at all.  Simple! -* leftSection and rightSection switch on ImpredicativeTypes locally,-  during Quick Look; see GHC.Tc.Gen.App.wantQuickLook. Consider-  test DeepSubsumption08:-     type Setter st t a b = forall f. Identical f => blah-     (.~) :: Setter s t a b -> b -> s -> t-     clear :: Setter a a' b (Maybe b') -> a -> a'-     clear = (.~ Nothing)-   The expansion look like (rightSection (.~) Nothing).  So we must-   instantiate `rightSection` first type argument to a polytype!-   Hence the special magic in App.wantQuickLook.  Historical Note [Desugaring operator sections] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -719,11 +719,11 @@ ************************************************************************ -} -rnHsFieldLabel :: Located (HsFieldLabel GhcPs) -> Located (HsFieldLabel GhcRn)-rnHsFieldLabel (L l (HsFieldLabel x label)) = L l (HsFieldLabel x label)+rnDotFieldOcc :: LocatedAn NoEpAnns (DotFieldOcc GhcPs) -> LocatedAn NoEpAnns (DotFieldOcc GhcRn)+rnDotFieldOcc (L l (DotFieldOcc x label)) = L l (DotFieldOcc x label)  rnFieldLabelStrings :: FieldLabelStrings GhcPs -> FieldLabelStrings GhcRn-rnFieldLabelStrings (FieldLabelStrings fls) = FieldLabelStrings (map rnHsFieldLabel fls)+rnFieldLabelStrings (FieldLabelStrings fls) = FieldLabelStrings (map rnDotFieldOcc fls)  {- ************************************************************************@@ -741,7 +741,7 @@        ; return (arg':args', fvArg `plusFV` fvArgs) }  rnCmdTop :: LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars)-rnCmdTop = wrapLocFstM rnCmdTop'+rnCmdTop = wrapLocFstMA rnCmdTop'  where   rnCmdTop' :: HsCmdTop GhcPs -> RnM (HsCmdTop GhcRn, FreeVars)   rnCmdTop' (HsCmdTop _ cmd)@@ -800,9 +800,9 @@   = do { (matches', fvMatch) <- rnMatchGroup (ArrowMatchCtxt KappaExpr) rnLCmd matches        ; return (HsCmdLam noExtField matches', fvMatch) } -rnCmd (HsCmdPar x e)+rnCmd (HsCmdPar x lpar e rpar)   = do  { (e', fvs_e) <- rnLCmd e-        ; return (HsCmdPar x e', fvs_e) }+        ; return (HsCmdPar x lpar e' rpar, fvs_e) }  rnCmd (HsCmdCase _ expr matches)   = do { (new_expr, e_fvs) <- rnLExpr expr@@ -810,9 +810,10 @@        ; return (HsCmdCase noExtField new_expr new_matches                 , e_fvs `plusFV` ms_fvs) } -rnCmd (HsCmdLamCase x matches)-  = do { (new_matches, ms_fvs) <- rnMatchGroup (ArrowMatchCtxt ArrowCaseAlt) rnLCmd matches-       ; return (HsCmdLamCase x new_matches, ms_fvs) }+rnCmd (HsCmdLamCase x lc_variant matches)+  = do { (new_matches, ms_fvs) <-+           rnMatchGroup (ArrowMatchCtxt $ ArrowLamCaseAlt lc_variant) rnLCmd matches+       ; return (HsCmdLamCase x lc_variant new_matches, ms_fvs) }  rnCmd (HsCmdIf _ _ p b1 b2)   = do { (p', fvP) <- rnLExpr p@@ -826,10 +827,10 @@         ; return (HsCmdIf noExtField ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2])} -rnCmd (HsCmdLet _ binds cmd)+rnCmd (HsCmdLet _ tkLet binds tkIn cmd)   = rnLocalBindsAndThen binds $ \ binds' _ -> do       { (cmd',fvExpr) <- rnLCmd cmd-      ; return (HsCmdLet noExtField binds' cmd', fvExpr) }+      ; return (HsCmdLet noExtField tkLet binds' tkIn cmd', fvExpr) }  rnCmd (HsCmdDo _ (L l stmts))   = do  { ((stmts', _), fvs) <-@@ -852,19 +853,19 @@   = unitFV appAName methodNamesCmd (HsCmdArrForm {}) = emptyFVs -methodNamesCmd (HsCmdPar _ c) = methodNamesLCmd c+methodNamesCmd (HsCmdPar _ _ c _) = methodNamesLCmd c  methodNamesCmd (HsCmdIf _ _ _ c1 c2)   = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName -methodNamesCmd (HsCmdLet _ _ c)          = methodNamesLCmd c+methodNamesCmd (HsCmdLet _ _ _ _ c)      = methodNamesLCmd c methodNamesCmd (HsCmdDo _ (L _ stmts))   = methodNamesStmts stmts methodNamesCmd (HsCmdApp _ c _)          = methodNamesLCmd c methodNamesCmd (HsCmdLam _ match)        = methodNamesMatch match  methodNamesCmd (HsCmdCase _ _ matches)   = methodNamesMatch matches `addOneFV` choiceAName-methodNamesCmd (HsCmdLamCase _ matches)+methodNamesCmd (HsCmdLamCase _ _ matches)   = methodNamesMatch matches `addOneFV` choiceAName  --methodNamesCmd _ = emptyFVs@@ -886,7 +887,7 @@  ------------------------------------------------- -methodNamesGRHS :: Located (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds+methodNamesGRHS :: LocatedAn NoEpAnns (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds methodNamesGRHS (L _ (GRHS _ _ rhs)) = methodNamesLCmd rhs  ---------------------------------------------------@@ -987,34 +988,13 @@            -- ^ if these statements scope over something, this renames it            -- and returns the result.         -> RnM (([LStmt GhcRn (LocatedA (body GhcRn))], thing), FreeVars)-rnStmts ctxt rnBody = rnStmtsWithPostProcessing ctxt rnBody noPostProcessStmts---- | like 'rnStmts' but applies a post-processing step to the renamed Stmts-rnStmtsWithPostProcessing-        :: AnnoBody body-        => HsStmtContext GhcRn-        -> (body GhcPs -> RnM (body GhcRn, FreeVars))-           -- ^ How to rename the body of each statement (e.g. rnLExpr)-        -> (HsStmtContext GhcRn-              -> [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)]-              -> RnM ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars))-           -- ^ postprocess the statements-        -> [LStmt GhcPs (LocatedA (body GhcPs))]-           -- ^ Statements-        -> ([Name] -> RnM (thing, FreeVars))-           -- ^ if these statements scope over something, this renames it-           -- and returns the result.-        -> RnM (([LStmt GhcRn (LocatedA (body GhcRn))], thing), FreeVars)-rnStmtsWithPostProcessing ctxt rnBody ppStmts stmts thing_inside- = do { ((stmts', thing), fvs) <--          rnStmtsWithFreeVars ctxt rnBody stmts thing_inside-      ; (pp_stmts, fvs') <- ppStmts ctxt stmts'-      ; return ((pp_stmts, thing), fvs `plusFV` fvs')-      }+rnStmts ctxt rnBody stmts thing_inside+ = do { ((stmts', thing), fvs) <- rnStmtsWithFreeVars ctxt rnBody stmts thing_inside+      ; return ((map fst stmts', thing), fvs) }  -- | maybe rearrange statements according to the ApplicativeDo transformation postProcessStmtsForApplicativeDo-  :: HsStmtContext GhcRn+  :: HsDoFlavour   -> [(ExprLStmt GhcRn, FreeVars)]   -> RnM ([ExprLStmt GhcRn], FreeVars) postProcessStmtsForApplicativeDo ctxt stmts@@ -1031,7 +1011,7 @@        ; if ado_is_on && is_do_expr && not in_th_bracket             then do { traceRn "ppsfa" (ppr stmts)                     ; rearrangeForApplicativeDo ctxt stmts }-            else noPostProcessStmts ctxt stmts }+            else noPostProcessStmts (HsDoStmt ctxt) stmts }  -- | strip the FreeVars annotations from statements noPostProcessStmts@@ -1059,7 +1039,7 @@        ; (thing, fvs) <- thing_inside []        ; return (([], thing), fvs) } -rnStmtsWithFreeVars mDoExpr@MDoExpr{} rnBody stmts thing_inside    -- Deal with mdo+rnStmtsWithFreeVars mDoExpr@(HsDoStmt MDoExpr{}) rnBody stmts thing_inside    -- Deal with mdo   = -- Behave like do { rec { ...all but last... }; last }     do { ((stmts1, (stmts2, thing)), fvs)            <- rnStmt mDoExpr rnBody (noLocA $ mkRecStmt noAnn (noLocA all_but_last)) $ \ _ ->@@ -1194,7 +1174,11 @@                               segs           -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]         ; (thing, fvs_later) <- thing_inside bndrs-        ; let (rec_stmts', fvs) = segmentRecStmts (locA loc) ctxt empty_rec_stmt segs fvs_later+        -- In interactive mode, all variables could be used later. So we pass whether+        -- we are in GHCi along to segmentRecStmts. See Note [What is "used later" in a rec stmt]+        ; is_interactive <- isInteractiveModule . tcg_mod <$> getGblEnv+        ; let+             (rec_stmts', fvs) = segmentRecStmts (locA loc) ctxt empty_rec_stmt segs (fvs_later, is_interactive)         -- We aren't going to try to group RecStmts with         -- ApplicativeDo, so attaching empty FVs is fine.         ; return ( ((zip rec_stmts' (repeat emptyNameSet)), thing)@@ -1278,7 +1262,8 @@            ; return ((seg':segs', thing), fvs) }      cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2-    dupErr vs = addErr (text "Duplicate binding in parallel list comprehension for:"+    dupErr vs = addErr $ TcRnUnknownMessage $ mkPlainError noHints $+                  (text "Duplicate binding in parallel list comprehension for:"                     <+> quotes (ppr (NE.head vs)))  lookupQualifiedDoStmtName :: HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)@@ -1315,18 +1300,22 @@ -- Neither is ArrowExpr, which has its own desugarer in GHC.HsToCore.Arrows rebindableContext :: HsStmtContext GhcRn -> Bool rebindableContext ctxt = case ctxt of-  ListComp        -> False-  ArrowExpr       -> False-  PatGuard {}     -> False+  HsDoStmt flavour -> rebindableDoStmtContext flavour+  ArrowExpr -> False+  PatGuard {} -> False -  DoExpr m        -> isNothing m-  MDoExpr m       -> isNothing m-  MonadComp       -> True-  GhciStmtCtxt    -> True   -- I suppose?    ParStmtCtxt   c -> rebindableContext c     -- Look inside to   TransStmtCtxt c -> rebindableContext c     -- the parent context +rebindableDoStmtContext :: HsDoFlavour -> Bool+rebindableDoStmtContext flavour = case flavour of+  ListComp -> False+  DoExpr m -> isNothing m+  MDoExpr m -> isNothing m+  MonadComp -> True+  GhciStmtCtxt -> True   -- I suppose?+ {- Note [Renaming parallel Stmts] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1541,14 +1530,19 @@ segmentRecStmts :: AnnoBody body                 => SrcSpan -> HsStmtContext GhcRn                 -> Stmt GhcRn (LocatedA (body GhcRn))-                -> [Segment (LStmt GhcRn (LocatedA (body GhcRn)))] -> FreeVars+                -> [Segment (LStmt GhcRn (LocatedA (body GhcRn)))]+                -> (FreeVars, Bool)+                    -- ^ The free variables used in later statements.+                    -- If the boolean is 'True', this might be an underestimate+                    -- because we are in GHCi, and might thus be missing some "used later"+                    -- FVs. See Note [What is "used later" in a rec stmt]                 -> ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars) -segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later+segmentRecStmts loc ctxt empty_rec_stmt segs (fvs_later, might_be_more_fvs_later)   | null segs-  = ([], fvs_later)+  = ([], final_fv_uses) -  | MDoExpr _ <- ctxt+  | HsDoStmt (MDoExpr _) <- ctxt   = segsToStmts empty_rec_stmt grouped_segs fvs_later                -- Step 4: Turn the segments into Stmts                 --         Use RecStmt when and only when there are fwd refs@@ -1559,14 +1553,23 @@   | otherwise   = ([ L (noAnnSrcSpan loc) $        empty_rec_stmt { recS_stmts = noLocA ss-                      , recS_later_ids = nameSetElemsStable-                                           (defs `intersectNameSet` fvs_later)+                      , recS_later_ids = nameSetElemsStable final_fvs_later                       , recS_rec_ids   = nameSetElemsStable                                            (defs `intersectNameSet` uses) }]           -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]-    , uses `plusFV` fvs_later)+    , uses `plusFV` final_fv_uses)    where+    (final_fv_uses, final_fvs_later)+      | might_be_more_fvs_later+      = (defs, defs)+        -- If there might be more uses later (e.g. we are in GHCi and have not+        -- yet seen the whole rec statement), conservatively assume that everything+        -- will be used later (as is possible).+      | otherwise+      = ( uses `plusFV` fvs_later+        , defs `intersectNameSet` fvs_later )+     (defs_s, uses_s, _, ss) = unzip4 segs     defs = plusFVs defs_s     uses = plusFVs uses_s@@ -1641,6 +1644,28 @@      { rec { x <- ...y...; p <- z ; y <- ...x... ;              q <- x ; z <- y } ;        r <- x }++Note [What is "used later" in a rec stmt]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We desugar a recursive Stmt to something like++  (a,_,c) <- mfix (\(a,b,_) -> do { ... ; return (a,b,c) })+  ...stuff after the rec...++The knot-tied tuple must contain+* All the variables that are used before they are bound in the `rec` block+* All the variables that are used after the entire `rec` block++In the case of GHCi, however, we don't know what variables will be used+after the `rec` (#20206).  For example, we might have+    ghci>  rec { x <- e1; y <- e2 }+    ghci>  print x+    ghci>  print y++So we have to assume that *all* the variables bound in the `rec` are used+afterwards.  We pass a Boolean to segmentRecStmts to signal such a situation,+in which case that function conservatively assumes that everything might well+be used later. -}  glomSegments :: HsStmtContext GhcRn@@ -1684,7 +1709,7 @@  segsToStmts _ [] fvs_later = ([], fvs_later) segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later-  = ASSERT( not (null ss) )+  = assert (not (null ss))     (new_stmt : later_stmts, later_uses `plusFV` uses)   where     (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later@@ -1706,7 +1731,7 @@ ************************************************************************  Note [ApplicativeDo]-+~~~~~~~~~~~~~~~~~~~~ = Example =  For a sequence of statements@@ -1812,6 +1837,12 @@      <*> ...      <*> argexpr(arg_n) +== Special cases ==++If a do-expression contains only "return E" or "return $ E" plus+zero or more let-statements, we replace the "return" with "pure".+See Section 3.6 of the paper.+ = Relevant modules in the rest of the compiler =  ApplicativeDo touches a few phases in the compiler:@@ -1854,19 +1885,29 @@ -- | rearrange a list of statements using ApplicativeDoStmt.  See -- Note [ApplicativeDo]. rearrangeForApplicativeDo-  :: HsStmtContext GhcRn+  :: HsDoFlavour   -> [(ExprLStmt GhcRn, FreeVars)]   -> RnM ([ExprLStmt GhcRn], FreeVars)  rearrangeForApplicativeDo _ [] = return ([], emptyNameSet)-rearrangeForApplicativeDo _ [(one,_)] = return ([one], emptyNameSet)+-- If the do-block contains a single @return@ statement, change it to+-- @pure@ if ApplicativeDo is turned on. See Note [ApplicativeDo].+rearrangeForApplicativeDo ctxt [(one,_)] = do+  (return_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) returnMName+  (pure_name, _)   <- lookupQualifiedDoName (HsDoStmt ctxt) pureAName+  let pure_expr = nl_HsVar pure_name+  let monad_names = MonadNames { return_name = return_name+                               , pure_name   = pure_name }+  return $ case needJoin monad_names [one] (Just pure_expr) of+    (False, one') -> (one', emptyNameSet)+    (True, _) -> ([one], emptyNameSet) rearrangeForApplicativeDo ctxt stmts0 = do   optimal_ado <- goptM Opt_OptimalApplicativeDo   let stmt_tree | optimal_ado = mkStmtTreeOptimal stmts                 | otherwise = mkStmtTreeHeuristic stmts   traceRn "rearrangeForADo" (ppr stmt_tree)-  (return_name, _) <- lookupQualifiedDoName ctxt returnMName-  (pure_name, _)   <- lookupQualifiedDoName ctxt pureAName+  (return_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) returnMName+  (pure_name, _)   <- lookupQualifiedDoName (HsDoStmt ctxt) pureAName   let monad_names = MonadNames { return_name = return_name                                , pure_name   = pure_name }   stmtTreeToStmts monad_names ctxt stmt_tree [last] last_fvs@@ -1917,8 +1958,8 @@ -- using dynamic programming.  /O(n^3)/ mkStmtTreeOptimal :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree mkStmtTreeOptimal stmts =-  ASSERT(not (null stmts)) -- the empty case is handled by the caller;-                           -- we don't support empty StmtTrees.+  assert (not (null stmts)) $ -- the empty case is handled by the caller;+                              -- we don't support empty StmtTrees.   fst (arr ! (0,n))   where     n = length stmts - 1@@ -1980,7 +2021,7 @@ -- ApplicativeStmt where necessary. stmtTreeToStmts   :: MonadNames-  -> HsStmtContext GhcRn+  -> HsDoFlavour   -> ExprStmtTree   -> [ExprLStmt GhcRn]             -- ^ the "tail"   -> FreeVars                     -- ^ free variables of the tail@@ -1993,9 +2034,12 @@ -- In the spec, but we do it here rather than in the desugarer, -- because we need the typechecker to typecheck the <$> form rather than -- the bind form, which would give rise to a Monad constraint.+--+-- If we have a single let, and the last statement is @return E@ or @return $ E@,+-- change the @return@ to @pure@. stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt xbs pat rhs), _))                 tail _tail_fvs-  | not (isStrictPattern pat), (False,tail') <- needJoin monad_names tail+  | not (isStrictPattern pat), (False,tail') <- needJoin monad_names tail Nothing   -- See Note [ApplicativeDo and strict patterns]   = mkApplicativeStmt ctxt [ApplicativeArgOne                             { xarg_app_arg_one = xbsrn_failOp xbs@@ -2006,7 +2050,7 @@                       False tail' stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ _),_))                 tail _tail_fvs-  | (False,tail') <- needJoin monad_names tail+  | (False,tail') <- needJoin monad_names tail Nothing   = mkApplicativeStmt ctxt       [ApplicativeArgOne        { xarg_app_arg_one = Nothing@@ -2014,6 +2058,12 @@        , arg_expr         = rhs        , is_body_stmt     = True        }] False tail'+stmtTreeToStmts monad_names ctxt (StmtTreeOne (let_stmt@(L _ LetStmt{}),_))+                tail _tail_fvs = do+  (pure_expr, _) <- lookupQualifiedDoExpr (HsDoStmt ctxt) pureAName+  return $ case needJoin monad_names tail (Just pure_expr) of+    (False, tail') -> (let_stmt : tail', emptyNameSet)+    (True, _) -> (let_stmt : tail, emptyNameSet)  stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs =   return (s : tail, emptyNameSet)@@ -2032,7 +2082,7 @@      -- See Note [ApplicativeDo and refutable patterns]          if any (hasRefutablePattern dflags) stmts'          then (True, tail)-         else needJoin monad_names tail+         else needJoin monad_names tail Nothing     (stmts, fvs) <- mkApplicativeStmt ctxt stmts' need_join tail'    return (stmts, unionNameSets (fvs:fvss))@@ -2064,7 +2114,7 @@         if | L _ ApplicativeStmt{} <- last stmts' ->              return (unLoc tup, emptyNameSet)            | otherwise -> do-             (ret, _) <- lookupQualifiedDoExpr ctxt returnMName+             (ret, _) <- lookupQualifiedDoExpr (HsDoStmt ctxt) returnMName              let expr = HsApp noComments (noLocA ret) tup              return (expr, emptyFVs)      return ( ApplicativeArgMany@@ -2145,7 +2195,7 @@    (\(x,y) -> \z -> C) <$> A <*> B -then it could be lazier than the standard desuraging using >>=.  See #13875+then it could be lazier than the standard desugaring using >>=.  See #13875 for more examples.  Thus, whenever we have a strict pattern match, we treat it as a@@ -2155,14 +2205,14 @@ can do with the rest of the statements in the same "do" expression. -} -isStrictPattern :: LPat (GhcPass p) -> Bool-isStrictPattern lpat =-  case unLoc lpat of+isStrictPattern :: forall p. IsPass p => LPat (GhcPass p) -> Bool+isStrictPattern (L loc pat) =+  case pat of     WildPat{}       -> False     VarPat{}        -> False     LazyPat{}       -> False     AsPat _ _ p     -> isStrictPattern p-    ParPat _ p      -> isStrictPattern p+    ParPat _ _ p _  -> isStrictPattern p     ViewPat _ _ p   -> isStrictPattern p     SigPat _ p _    -> isStrictPattern p     BangPat{}       -> True@@ -2174,7 +2224,16 @@     NPat{}          -> True     NPlusKPat{}     -> True     SplicePat{}     -> True-    XPat{}          -> panic "isStrictPattern: XPat"+    XPat ext        -> case ghcPass @p of+#if __GLASGOW_HASKELL__ < 811+      GhcPs -> dataConCantHappen ext+#endif+      GhcRn+        | HsPatExpanded _ p <- ext+        -> isStrictPattern (L loc p)+      GhcTc -> case ext of+        ExpansionPat _ p -> isStrictPattern (L loc p)+        CoPat {} -> panic "isStrictPattern: CoPat"  {- Note [ApplicativeDo and refutable patterns]@@ -2259,17 +2318,17 @@ -- it this way rather than try to ignore the return later in both the -- typechecker and the desugarer (I tried it that way first!). mkApplicativeStmt-  :: HsStmtContext GhcRn+  :: HsDoFlavour   -> [ApplicativeArg GhcRn]             -- ^ The args   -> Bool                               -- ^ True <=> need a join   -> [ExprLStmt GhcRn]        -- ^ The body statements   -> RnM ([ExprLStmt GhcRn], FreeVars) mkApplicativeStmt ctxt args need_join body_stmts-  = do { (fmap_op, fvs1) <- lookupQualifiedDoStmtName ctxt fmapName-       ; (ap_op, fvs2) <- lookupQualifiedDoStmtName ctxt apAName+  = do { (fmap_op, fvs1) <- lookupQualifiedDoStmtName (HsDoStmt ctxt) fmapName+       ; (ap_op, fvs2) <- lookupQualifiedDoStmtName (HsDoStmt ctxt) apAName        ; (mb_join, fvs3) <-            if need_join then-             do { (join_op, fvs) <- lookupQualifiedDoStmtName ctxt joinMName+             do { (join_op, fvs) <- lookupQualifiedDoStmtName (HsDoStmt ctxt) joinMName                 ; return (Just join_op, fvs) }            else              return (Nothing, emptyNameSet)@@ -2281,28 +2340,50 @@  -- | Given the statements following an ApplicativeStmt, determine whether -- we need a @join@ or not, and remove the @return@ if necessary.+--+-- We don't need @join@ if there's a single @LastStmt@ in the form of+-- @return E@, @return $ E@, @pure E@ or @pure $ E@. needJoin :: MonadNames          -> [ExprLStmt GhcRn]+            -- If this is @Just pure@, replace return by pure+            -- If this is @Nothing@, strip the return/pure+         -> Maybe (HsExpr GhcRn)          -> (Bool, [ExprLStmt GhcRn])-needJoin _monad_names [] = (False, [])  -- we're in an ApplicativeArg-needJoin monad_names  [L loc (LastStmt _ e _ t)]- | Just (arg, wasDollar) <- isReturnApp monad_names e =-       (False, [L loc (LastStmt noExtField arg (Just wasDollar) t)])-needJoin _monad_names stmts = (True, stmts)+needJoin _monad_names [] _mb_pure = (False, [])  -- we're in an ApplicativeArg+needJoin monad_names  [L loc (LastStmt _ e _ t)] mb_pure+ | Just (arg, noret) <- isReturnApp monad_names e mb_pure =+       (False, [L loc (LastStmt noExtField arg noret t)])+needJoin _monad_names stmts _mb_pure = (True, stmts) --- | @(Just e, False)@, if the expression is @return e@---   @(Just e, True)@ if the expression is @return $ e@,+-- | @(Just e, Just False)@, if the expression is @return/pure e@,+--     and the third argument is Nothing,+--   @(Just e, Just True)@ if the expression is @return/pure $ e@,+--     and the third argument is Nothing,+--   @(Just (pure e), Nothing)@ if the expression is @return/pure e@,+--     and the third argument is @Just pure_expr@,+--   @(Just (pure $ e), Nothing)@ if the expression is @return/pure $ e@,+--     and the third argument is @Just pure_expr@, --   otherwise @Nothing@. isReturnApp :: MonadNames             -> LHsExpr GhcRn-            -> Maybe (LHsExpr GhcRn, Bool)-isReturnApp monad_names (L _ (HsPar _ expr)) = isReturnApp monad_names expr-isReturnApp monad_names (L _ e) = case e of-  OpApp _ l op r | is_return l, is_dollar op -> Just (r, True)-  HsApp _ f arg  | is_return f               -> Just (arg, False)+            -- If this is @Just pure@, replace return by pure+            -- If this is @Nothing@, strip the return/pure+            -> Maybe (HsExpr GhcRn)+            -> Maybe (LHsExpr GhcRn, Maybe Bool)+isReturnApp monad_names (L _ (HsPar _ _ expr _)) mb_pure =+  isReturnApp monad_names expr mb_pure+isReturnApp monad_names (L loc e) mb_pure = case e of+  OpApp x l op r+    | Just pure_expr <- mb_pure, is_return l, is_dollar op ->+        Just (L loc (OpApp x (to_pure l pure_expr) op r), Nothing)+    | is_return l, is_dollar op -> Just (r, Just True)+  HsApp x f arg+    | Just pure_expr <- mb_pure, is_return f ->+        Just (L loc (HsApp x (to_pure f pure_expr) arg), Nothing)+    | is_return f -> Just (arg, Just False)   _otherwise -> Nothing  where-  is_var f (L _ (HsPar _ e)) = is_var f e+  is_var f (L _ (HsPar _ _ e _)) = is_var f e   is_var f (L _ (HsAppType _ e _)) = is_var f e   is_var f (L _ (HsVar _ (L _ r))) = f r        -- TODO: I don't know how to get this right for rebindable syntax@@ -2310,6 +2391,7 @@    is_return = is_var (\n -> n == return_name monad_names                          || n == pure_name monad_names)+  to_pure (L loc _) pure_expr = L loc pure_expr   is_dollar = is_var (`hasKey` dollarIdKey)  {-@@ -2329,10 +2411,15 @@ okEmpty (PatGuard {}) = True okEmpty _             = False -emptyErr :: HsStmtContext GhcRn -> SDoc-emptyErr (ParStmtCtxt {})   = text "Empty statement group in parallel comprehension"-emptyErr (TransStmtCtxt {}) = text "Empty statement group preceding 'group' or 'then'"-emptyErr ctxt               = text "Empty" <+> pprStmtContext ctxt+emptyErr :: HsStmtContext GhcRn -> TcRnMessage+emptyErr (ParStmtCtxt {})   = TcRnUnknownMessage $ mkPlainError noHints $+  text "Empty statement group in parallel comprehension"+emptyErr (TransStmtCtxt {}) = TcRnUnknownMessage $ mkPlainError noHints $+  text "Empty statement group preceding 'group' or 'then'"+emptyErr ctxt@(HsDoStmt _)  = TcRnUnknownMessage $ mkPlainError [suggestExtension LangExt.NondecreasingIndentation] $+  text "Empty" <+> pprStmtContext ctxt+emptyErr ctxt               = TcRnUnknownMessage $ mkPlainError noHints $+  text "Empty" <+> pprStmtContext ctxt  ---------------------- checkLastStmt :: AnnoBody body => HsStmtContext GhcRn@@ -2340,11 +2427,11 @@               -> RnM (LStmt GhcPs (LocatedA (body GhcPs))) checkLastStmt ctxt lstmt@(L loc stmt)   = case ctxt of-      ListComp  -> check_comp-      MonadComp -> check_comp+      HsDoStmt ListComp  -> check_comp+      HsDoStmt MonadComp -> check_comp+      HsDoStmt DoExpr{}  -> check_do+      HsDoStmt MDoExpr{} -> check_do       ArrowExpr -> check_do-      DoExpr{}  -> check_do-      MDoExpr{} -> check_do       _         -> check_other   where     check_do    -- Expect BodyStmt, and change it to LastStmt@@ -2352,7 +2439,9 @@           BodyStmt _ e _ _ -> return (L loc (mkLastStmt e))           LastStmt {}      -> return lstmt   -- "Deriving" clauses may generate a                                              -- LastStmt directly (unlike the parser)-          _                -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt }+          _                -> do { addErr $ TcRnUnknownMessage $ mkPlainError noHints $+                                     (hang last_error 2 (ppr stmt))+                                 ; return lstmt }     last_error = (text "The last statement in" <+> pprAStmtContext ctxt                   <+> text "must be an expression") @@ -2372,9 +2461,9 @@   = do { dflags <- getDynFlags        ; case okStmt dflags ctxt stmt of            IsValid        -> return ()-           NotValid extra -> addErr (msg $$ extra) }+           NotValid extra -> addErr $ TcRnUnknownMessage $ mkPlainError noHints (msg $$ extra) }   where-   msg = sep [ text "Unexpected" <+> pprStmtCat stmt <+> ptext (sLit "statement")+   msg = sep [ text "Unexpected" <+> pprStmtCat stmt <+> text "statement"              , text "in" <+> pprAStmtContext ctxt ]  pprStmtCat :: Stmt (GhcPass a) body -> SDoc@@ -2401,14 +2490,20 @@   = case ctxt of       PatGuard {}        -> okPatGuardStmt stmt       ParStmtCtxt ctxt   -> okParStmt  dflags ctxt stmt-      DoExpr{}           -> okDoStmt   dflags ctxt stmt-      MDoExpr{}          -> okDoStmt   dflags ctxt stmt+      HsDoStmt flavour   -> okDoFlavourStmt dflags flavour ctxt stmt       ArrowExpr          -> okDoStmt   dflags ctxt stmt-      GhciStmtCtxt       -> okDoStmt   dflags ctxt stmt-      ListComp           -> okCompStmt dflags ctxt stmt-      MonadComp          -> okCompStmt dflags ctxt stmt       TransStmtCtxt ctxt -> okStmt dflags ctxt stmt +okDoFlavourStmt+  :: DynFlags -> HsDoFlavour -> HsStmtContext GhcRn+  -> Stmt GhcPs (LocatedA (body GhcPs)) -> Validity+okDoFlavourStmt dflags flavour ctxt stmt = case flavour of+      DoExpr{}     -> okDoStmt   dflags ctxt stmt+      MDoExpr{}    -> okDoStmt   dflags ctxt stmt+      GhciStmtCtxt -> okDoStmt   dflags ctxt stmt+      ListComp     -> okCompStmt dflags ctxt stmt+      MonadComp    -> okCompStmt dflags ctxt stmt+ ------------- okPatGuardStmt :: Stmt GhcPs (LocatedA (body GhcPs)) -> Validity okPatGuardStmt stmt@@ -2458,17 +2553,21 @@   = do  { tuple_section <- xoptM LangExt.TupleSections         ; checkErr (all tupArgPresent args || tuple_section) msg }   where-    msg = text "Illegal tuple section: use TupleSections"+    msg :: TcRnMessage+    msg = TcRnUnknownMessage $ mkPlainError noHints $+      text "Illegal tuple section: use TupleSections"  ----------sectionErr :: HsExpr GhcPs -> SDoc+sectionErr :: HsExpr GhcPs -> TcRnMessage sectionErr expr-  = hang (text "A section must be enclosed in parentheses")+  = TcRnUnknownMessage $ mkPlainError noHints $+    hang (text "A section must be enclosed in parentheses")        2 (text "thus:" <+> (parens (ppr expr))) -badIpBinds :: Outputable a => SDoc -> a -> SDoc+badIpBinds :: Outputable a => SDoc -> a -> TcRnMessage badIpBinds what binds-  = hang (text "Implicit-parameter bindings illegal in" <+> what)+  = TcRnUnknownMessage $ mkPlainError noHints $+    hang (text "Implicit-parameter bindings illegal in" <+> what)          2 (ppr binds)  ---------@@ -2560,29 +2659,6 @@ *                                                                      * ********************************************************************* -} -genHsApps :: Name -> [LHsExpr GhcRn] -> HsExpr GhcRn-genHsApps fun args = foldl genHsApp (genHsVar fun) args--genHsApp :: HsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn-genHsApp fun arg = HsApp noAnn (wrapGenSpan fun) arg--genLHsVar :: Name -> LHsExpr GhcRn-genLHsVar nm = wrapGenSpan $ genHsVar nm--genHsVar :: Name -> HsExpr GhcRn-genHsVar nm = HsVar noExtField $ wrapGenSpan nm--genAppType :: HsExpr GhcRn -> HsType (NoGhcTc GhcRn) -> HsExpr GhcRn-genAppType expr = HsAppType noExtField (wrapGenSpan expr) . mkEmptyWildCardBndrs . wrapGenSpan--genHsTyLit :: FastString -> HsType GhcRn-genHsTyLit = HsTyLit noExtField . HsStrTy NoSourceText--wrapGenSpan :: a -> LocatedAn an a--- Wrap something in a "generatedSrcSpan"--- See Note [Rebindable syntax and HsExpansion]-wrapGenSpan x = L (noAnnSrcSpan generatedSrcSpan) x- -- | Build a 'HsExpansion' out of an extension constructor, --   and the two components of the expansion: original and --   desugared expressions.@@ -2599,42 +2675,42 @@  -- mkGetField arg field calcuates a get_field @field arg expression. -- e.g. z.x = mkGetField z x = get_field @x z-mkGetField :: Name -> LHsExpr GhcRn -> Located FieldLabelString -> HsExpr GhcRn+mkGetField :: Name -> LHsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> HsExpr GhcRn mkGetField get_field arg field = unLoc (head $ mkGet get_field [arg] field)  -- mkSetField a field b calculates a set_field @field expression. -- e.g mkSetSetField a field b = set_field @"field" a b (read as "set field 'field' on a to b").-mkSetField :: Name -> LHsExpr GhcRn -> Located FieldLabelString -> LHsExpr GhcRn -> HsExpr GhcRn+mkSetField :: Name -> LHsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> LHsExpr GhcRn -> HsExpr GhcRn mkSetField set_field a (L _ field) b =   genHsApp (genHsApp (genHsVar set_field `genAppType` genHsTyLit field)  a) b -mkGet :: Name -> [LHsExpr GhcRn] -> Located FieldLabelString -> [LHsExpr GhcRn]+mkGet :: Name -> [LHsExpr GhcRn] -> LocatedAn NoEpAnns FieldLabelString -> [LHsExpr GhcRn] mkGet get_field l@(r : _) (L _ field) =   wrapGenSpan (genHsApp (genHsVar get_field `genAppType` genHsTyLit field) r) : l mkGet _ [] _ = panic "mkGet : The impossible has happened!" -mkSet :: Name -> LHsExpr GhcRn -> (Located FieldLabelString, LHsExpr GhcRn) -> LHsExpr GhcRn+mkSet :: Name -> LHsExpr GhcRn -> (LocatedAn NoEpAnns FieldLabelString, LHsExpr GhcRn) -> LHsExpr GhcRn mkSet set_field acc (field, g) = wrapGenSpan (mkSetField set_field g field acc)  -- mkProjection fields calculates a projection. -- e.g. .x = mkProjection [x] = getField @"x" --      .x.y = mkProjection [.x, .y] = (.y) . (.x) = getField @"y" . getField @"x"-mkProjection :: Name -> Name -> NonEmpty (Located FieldLabelString) -> HsExpr GhcRn+mkProjection :: Name -> Name -> NonEmpty (LocatedAn NoEpAnns FieldLabelString) -> HsExpr GhcRn mkProjection getFieldName circName (field :| fields) = foldl' f (proj field) fields   where-    f :: HsExpr GhcRn -> Located FieldLabelString -> HsExpr GhcRn+    f :: HsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> HsExpr GhcRn     f acc field = genHsApps circName $ map wrapGenSpan [proj field, acc] -    proj :: Located FieldLabelString -> HsExpr GhcRn+    proj :: LocatedAn NoEpAnns FieldLabelString -> HsExpr GhcRn     proj (L _ f) = genHsVar getFieldName `genAppType` genHsTyLit f  -- mkProjUpdateSetField calculates functions representing dot notation record updates. -- e.g. Suppose an update like foo.bar = 1. --      We calculate the function \a -> setField @"foo" a (setField @"bar" (getField @"foo" a) 1). mkProjUpdateSetField :: Name -> Name -> LHsRecProj GhcRn (LHsExpr GhcRn) -> (LHsExpr GhcRn -> LHsExpr GhcRn)-mkProjUpdateSetField get_field set_field (L _ (HsRecField { hsRecFieldLbl = (L _ (FieldLabelStrings flds')), hsRecFieldArg = arg } ))+mkProjUpdateSetField get_field set_field (L _ (HsFieldBind { hfbLHS = (L _ (FieldLabelStrings flds')), hfbRHS = arg } ))   = let {-      ; flds = map (fmap (unLoc . hflLabel)) flds'+      ; flds = map (fmap (unLoc . dfoLabel)) flds'       ; final = last flds  -- quux       ; fields = init flds   -- [foo, bar, baz]       ; getters = \a -> foldl' (mkGet get_field) [a] fields  -- Ordered from deep to shallow.@@ -2657,9 +2733,11 @@   pure (u, plusFVs fvs)   where     rnRecUpdProj :: LHsRecUpdProj GhcPs -> RnM (LHsRecUpdProj GhcRn, FreeVars)-    rnRecUpdProj (L l (HsRecField _ fs arg pun))+    rnRecUpdProj (L l (HsFieldBind _ fs arg pun))       = do { (arg, fv) <- rnLExpr arg-           ; return $ (L l (HsRecField { hsRecFieldAnn = noAnn-                                       , hsRecFieldLbl = fmap rnFieldLabelStrings fs-                                       , hsRecFieldArg = arg-                                       , hsRecPun = pun}), fv) }+           ; return $+               (L l (HsFieldBind {+                         hfbAnn = noAnn+                       , hfbLHS = fmap rnFieldLabelStrings fs+                       , hfbRHS = arg+                       , hfbPun = pun}), fv ) }
compiler/GHC/Rename/Expr.hs-boot view
@@ -1,6 +1,12 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ConstraintKinds #-} module GHC.Rename.Expr where++#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)+import Data.Type.Equality (type (~))+#endif+ import GHC.Types.Name import GHC.Hs import GHC.Types.Name.Set ( FreeVars )
compiler/GHC/Rename/Fixity.hs view
@@ -30,15 +30,11 @@ import GHC.Types.SrcLoc  import GHC.Utils.Outputable-import GHC.Utils.Panic  import GHC.Data.Maybe  import GHC.Rename.Unbound -import Data.List (groupBy)-import Data.Function    ( on )- {- ********************************************************* *                                                      *@@ -184,39 +180,10 @@ lookupTyFixityRn :: LocatedN Name -> RnM Fixity lookupTyFixityRn = lookupFixityRn . unLoc --- | Look up the fixity of a (possibly ambiguous) occurrence of a record field--- selector.  We use 'lookupFixityRn'' so that we can specify the 'OccName' as--- the field label, which might be different to the 'OccName' of the selector--- 'Name' if @DuplicateRecordFields@ is in use (#1173). If there are--- multiple possible selectors with different fixities, generate an error.-lookupFieldFixityRn :: AmbiguousFieldOcc GhcRn -> RnM Fixity-lookupFieldFixityRn (Unambiguous n lrdr)+-- | Look up the fixity of an occurrence of a record field selector.+-- We use 'lookupFixityRn'' so that we can specify the 'OccName' as+-- the field label, which might be different to the 'OccName' of the+-- selector 'Name' if @DuplicateRecordFields@ is in use (#1173).+lookupFieldFixityRn :: FieldOcc GhcRn -> RnM Fixity+lookupFieldFixityRn (FieldOcc n lrdr)   = lookupFixityRn' n (rdrNameOcc (unLoc lrdr))-lookupFieldFixityRn (Ambiguous _ lrdr) = get_ambiguous_fixity (unLoc lrdr)-  where-    get_ambiguous_fixity :: RdrName -> RnM Fixity-    get_ambiguous_fixity rdr_name = do-      traceRn "get_ambiguous_fixity" (ppr rdr_name)-      rdr_env <- getGlobalRdrEnv-      let elts =  lookupGRE_RdrName rdr_name rdr_env--      fixities <- groupBy ((==) `on` snd) . zip elts-                  <$> mapM lookup_gre_fixity elts--      case fixities of-        -- There should always be at least one fixity.-        -- Something's very wrong if there are no fixity candidates, so panic-        [] -> panic "get_ambiguous_fixity: no candidates for a given RdrName"-        [ (_, fix):_ ] -> return fix-        ambigs -> addErr (ambiguous_fixity_err rdr_name ambigs)-                  >> return (Fixity NoSourceText minPrecedence InfixL)--    lookup_gre_fixity gre = lookupFixityRn' (greMangledName gre) (greOccName gre)--    ambiguous_fixity_err rn ambigs-      = vcat [ text "Ambiguous fixity for record field" <+> quotes (ppr rn)-             , hang (text "Conflicts: ") 2 . vcat .-               map format_ambig $ concat ambigs ]--    format_ambig (elt, fix) = hang (ppr fix)-                                 2 (pprNameProvenance elt)
compiler/GHC/Rename/HsType.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE DataKinds           #-} {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE LambdaCase          #-}@@ -12,7 +12,7 @@  module GHC.Rename.HsType (         -- Type related stuff-        rnHsType, rnLHsType, rnLHsTypes, rnContext,+        rnHsType, rnLHsType, rnLHsTypes, rnContext, rnMaybeContext,         rnHsKind, rnLHsKind, rnLHsTypeArgs,         rnHsSigType, rnHsWcType, rnHsPatSigTypeBindingVars,         HsPatSigTypeScoping(..), rnHsSigWcType, rnHsPatSigType,@@ -32,7 +32,7 @@         bindHsOuterTyVarBndrs, bindHsForAllTelescope,         bindLHsTyVarBndr, bindLHsTyVarBndrs, WarnUnusedForalls(..),         rnImplicitTvOccs, bindSigTyVarsFV, bindHsQTyVars,-        FreeKiTyVars,+        FreeKiTyVars, filterInScopeM,         extractHsTyRdrTyVars, extractHsTyRdrTyVarsKindVars,         extractHsTysRdrTyVars, extractRdrKindSigVars,         extractConDeclGADTDetailsTyVars, extractDataDefnKindVars,@@ -48,28 +48,33 @@ import GHC.Driver.Session import GHC.Hs import GHC.Rename.Env-import GHC.Rename.Utils  ( HsDocContext(..), inHsDocContext, withHsDocContext-                         , mapFvRn, pprHsDocContext, bindLocalNamesFV+import GHC.Rename.Doc+import GHC.Rename.Utils  ( mapFvRn, bindLocalNamesFV                          , typeAppErr, newLocalBndrRn, checkDupRdrNamesN-                         , checkShadowedRdrNames )+                         , checkShadowedRdrNames, warnForallIdentifier ) import GHC.Rename.Fixity ( lookupFieldFixityRn, lookupFixityRn                          , lookupTyFixityRn )-import GHC.Rename.Unbound ( notInScopeErr )+import GHC.Rename.Unbound ( notInScopeErr, WhereLooking(WL_LocalOnly) )+import GHC.Tc.Errors.Types+import GHC.Tc.Errors.Ppr ( pprScopeError+                         , inHsDocContext, withHsDocContext, pprHsDocContext ) import GHC.Tc.Utils.Monad import GHC.Types.Name.Reader import GHC.Builtin.Names+import GHC.Types.Hint ( UntickedPromotedThing(..) ) import GHC.Types.Name import GHC.Types.SrcLoc import GHC.Types.Name.Set import GHC.Types.FieldLabel+import GHC.Types.Error  import GHC.Utils.Misc import GHC.Types.Fixity ( compareFixity, negateFixity                         , Fixity(..), FixityDirection(..), LexicalFixity(..) )-import GHC.Types.Basic  ( TypeOrKind(..) )+import GHC.Types.Basic  ( PromotionFlag(..), isPromoted, TypeOrKind(..) ) import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Data.FastString+import GHC.Utils.Panic.Plain import GHC.Data.Maybe import qualified GHC.LanguageExtensions as LangExt @@ -78,8 +83,6 @@ import Data.List.NonEmpty (NonEmpty(..)) import Control.Monad -#include "GhclibHsVersions.h"- {- These type renamers are in a separate module, rather than in (say) GHC.Rename.Module, to break several loops.@@ -210,7 +213,7 @@     -- Should the inner `a` refer to the outer one? shadow it? We are, as yet, undecided,     -- so we currently reject.     when (not (null varsInScope)) $-      addErr $+      addErr $ TcRnUnknownMessage $ mkPlainError noHints $         vcat           [ text "Type variable" <> plural varsInScope             <+> hcat (punctuate (text ",") (map (quotes . ppr) varsInScope))@@ -257,34 +260,27 @@                                 , hst_tele = tele', hst_body = hs_body' }                     , fvs) } -    rn_ty env (HsQualTy { hst_ctxt = m_ctxt+    rn_ty env (HsQualTy { hst_ctxt = L cx hs_ctxt                         , hst_body = hs_ty })-      | Just (L cx hs_ctxt) <- m_ctxt-      , Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt+      | Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt       , L lx (HsWildCardTy _)  <- ignoreParens hs_ctxt_last       = do { (hs_ctxt1', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt1            ; setSrcSpanA lx $ checkExtraConstraintWildCard env hs_ctxt1            ; let hs_ctxt' = hs_ctxt1' ++ [L lx (HsWildCardTy noExtField)]            ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty            ; return (HsQualTy { hst_xqual = noExtField-                              , hst_ctxt = Just (L cx hs_ctxt')+                              , hst_ctxt = L cx hs_ctxt'                               , hst_body = hs_ty' }                     , fvs1 `plusFV` fvs2) } -      | Just (L cx hs_ctxt) <- m_ctxt+      | otherwise       = do { (hs_ctxt', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt            ; (hs_ty', fvs2)   <- rnLHsTyKi env hs_ty            ; return (HsQualTy { hst_xqual = noExtField-                              , hst_ctxt = Just (L cx hs_ctxt')+                              , hst_ctxt = L cx hs_ctxt'                               , hst_body = hs_ty' }                     , fvs1 `plusFV` fvs2) } -      | Nothing <- m_ctxt-      = do { (hs_ty', fvs2)   <- rnLHsTyKi env hs_ty-           ; return (HsQualTy { hst_xqual = noExtField-                              , hst_ctxt = Nothing-                              , hst_body = hs_ty' }-                    , fvs2) }      rn_ty env hs_ty = rnHsTyKi env hs_ty @@ -297,10 +293,11 @@ -- Check that extra-constraints are allowed at all, and -- if so that it's an anonymous wildcard checkExtraConstraintWildCard env hs_ctxt-  = checkWildCard env mb_bad+  = checkWildCard env Nothing mb_bad   where     mb_bad | not (extraConstraintWildCardsAllowed env)-           = Just base_msg+           = Just $ ExtraConstraintWildcardNotAllowed+                      SoleExtraConstraintWildcardNotAllowed              -- Currently, we do not allow wildcards in their full glory in              -- standalone deriving declarations. We only allow a single              -- extra-constraints wildcard à la:@@ -312,18 +309,11 @@              --   deriving instance (Eq a, _) => Eq (Foo a)            | DerivDeclCtx {} <- rtke_ctxt env            , not (null hs_ctxt)-           = Just deriv_decl_msg+           = Just $ ExtraConstraintWildcardNotAllowed+                      SoleExtraConstraintWildcardAllowed            | otherwise            = Nothing -    base_msg = text "Extra-constraint wildcard" <+> quotes pprAnonWildCard-                   <+> text "not allowed"--    deriv_decl_msg-      = hang base_msg-           2 (vcat [ text "except as the sole constraint"-                   , nest 2 (text "e.g., deriving instance _ => Eq (Foo a)") ])- extraConstraintWildCardsAllowed :: RnTyKiEnv -> Bool extraConstraintWildCardsAllowed env   = case rtke_ctxt env of@@ -453,8 +443,11 @@ rnImplicitTvBndrs ctx mb_assoc implicit_vs_with_dups thing_inside   = do { implicit_vs <- forM (NE.groupBy eqLocated $ sortBy cmpLocated $ implicit_vs_with_dups) $ \case            (x :| []) -> return x-           (x :| _) -> do addErr $ text "Variable" <+> text "`" <> ppr x <> text "'" <+> text "would be bound multiple times by" <+> pprHsDocContext ctx <> text "."-                          return x+           (x :| _) -> do+             let msg = TcRnUnknownMessage $ mkPlainError noHints $+                   text "Variable" <+> text "`" <> ppr x <> text "'" <+> text "would be bound multiple times by" <+> pprHsDocContext ctx <> text "."+             addErr msg+             return x         ; traceRn "rnImplicitTvBndrs" $          vcat [ ppr implicit_vs_with_dups, ppr implicit_vs ]@@ -577,19 +570,27 @@ rnLHsTypeArgs doc args = mapFvRn (rnLHsTypeArg doc) args  ---------------rnTyKiContext :: RnTyKiEnv -> Maybe (LHsContext GhcPs)-              -> RnM (Maybe (LHsContext GhcRn), FreeVars)-rnTyKiContext _ Nothing = return (Nothing, emptyFVs)-rnTyKiContext env (Just (L loc cxt))+rnTyKiContext :: RnTyKiEnv -> LHsContext GhcPs+              -> RnM (LHsContext GhcRn, FreeVars)+rnTyKiContext env (L loc cxt)   = do { traceRn "rncontext" (ppr cxt)        ; let env' = env { rtke_what = RnConstraint }        ; (cxt', fvs) <- mapFvRn (rnLHsTyKi env') cxt-       ; return (Just $ L loc cxt', fvs) }+       ; return (L loc cxt', fvs) } -rnContext :: HsDocContext -> Maybe (LHsContext GhcPs)-          -> RnM (Maybe (LHsContext GhcRn), FreeVars)+rnContext :: HsDocContext -> LHsContext GhcPs+          -> RnM (LHsContext GhcRn, FreeVars) rnContext doc theta = rnTyKiContext (mkTyKiEnv doc TypeLevel RnConstraint) theta +rnMaybeContext :: HsDocContext -> Maybe (LHsContext GhcPs)+          -> RnM (Maybe (LHsContext GhcRn), FreeVars)+rnMaybeContext _ Nothing = return (Nothing, emptyFVs)+rnMaybeContext doc (Just theta)+  = do { (theta', fvs) <- rnContext doc theta+       ; return (Just theta', fvs)+       }++ -------------- rnLHsTyKi  :: RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars) rnLHsTyKi env (L loc ty)@@ -619,22 +620,28 @@  rnHsTyKi env (HsTyVar _ ip (L loc rdr_name))   = do { when (isRnKindLevel env && isRdrTyVar rdr_name) $-         unlessXOptM LangExt.PolyKinds $ addErr $+         unlessXOptM LangExt.PolyKinds $ addErr $ TcRnUnknownMessage $ mkPlainError noHints $          withHsDocContext (rtke_ctxt env) $          vcat [ text "Unexpected kind variable" <+> quotes (ppr rdr_name)               , text "Perhaps you intended to use PolyKinds" ]            -- Any type variable at the kind level is illegal without the use            -- of PolyKinds (see #14710)        ; name <- rnTyVar env rdr_name+       ; when (isDataConName name && not (isPromoted ip)) $+         -- NB: a prefix symbolic operator such as (:) is represented as HsTyVar.+            addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor Prefix name)        ; return (HsTyVar noAnn ip (L loc name), unitFV name) } -rnHsTyKi env ty@(HsOpTy _ ty1 l_op ty2)+rnHsTyKi env ty@(HsOpTy _ prom ty1 l_op ty2)   = setSrcSpan (getLocA l_op) $-    do  { (l_op', fvs1) <- rnHsTyOp env ty l_op+    do  { (l_op', fvs1) <- rnHsTyOp env (ppr ty) l_op+        ; let op_name = unLoc l_op'         ; fix   <- lookupTyFixityRn l_op'         ; (ty1', fvs2) <- rnLHsTyKi env ty1         ; (ty2', fvs3) <- rnLHsTyKi env ty2-        ; res_ty <- mkHsOpTyRn l_op' fix ty1' ty2'+        ; res_ty <- mkHsOpTyRn prom l_op' fix ty1' ty2'+        ; when (isDataConName op_name && not (isPromoted prom)) $+            addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor Infix op_name)         ; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) }  rnHsTyKi env (HsParTy _ ty)@@ -654,8 +661,8 @@     get_fields (ConDeclCtx names)       = concatMapM (lookupConstructorFields . unLoc) names     get_fields _-      = do { addErr (hang (text "Record syntax is illegal here:")-                                   2 (ppr ty))+      = do { addErr $ TcRnUnknownMessage $ mkPlainError noHints $+               (hang (text "Record syntax is illegal here:") 2 (ppr ty))            ; return [] }  rnHsTyKi env (HsFunTy u mult ty1 ty2)@@ -705,7 +712,9 @@     negLit (HsStrTy _ _) = False     negLit (HsNumTy _ i) = i < 0     negLit (HsCharTy _ _) = False-    negLitErr = text "Illegal literal in type (type literals must not be negative):" <+> ppr tyLit+    negLitErr :: TcRnMessage+    negLitErr = TcRnUnknownMessage $ mkPlainError noHints $+      text "Illegal literal in type (type literals must not be negative):" <+> ppr tyLit  rnHsTyKi env (HsAppTy _ ty1 ty2)   = do { (ty1', fvs1) <- rnLHsTyKi env ty1@@ -732,7 +741,8 @@  rnHsTyKi env (HsDocTy x ty haddock_doc)   = do { (ty', fvs) <- rnLHsTyKi env ty-       ; return (HsDocTy x ty' haddock_doc, fvs) }+       ; haddock_doc' <- rnLHsDoc haddock_doc+       ; return (HsDocTy x ty' haddock_doc', fvs) }  -- See Note [Renaming HsCoreTys] rnHsTyKi env (XHsType ty)@@ -745,14 +755,18 @@     check_in_scope :: RdrName -> RnM ()     check_in_scope rdr_name = do       mb_name <- lookupLocalOccRn_maybe rdr_name+      -- TODO: refactor this to avoid TcRnUnknownMessage       when (isNothing mb_name) $-        addErr $ withHsDocContext (rtke_ctxt env) $-        notInScopeErr rdr_name+        addErr $ TcRnUnknownMessage $ mkPlainError noHints $+          withHsDocContext (rtke_ctxt env) $+          pprScopeError rdr_name (notInScopeErr WL_LocalOnly rdr_name)  rnHsTyKi env ty@(HsExplicitListTy _ ip tys)   = do { data_kinds <- xoptM LangExt.DataKinds        ; unless data_kinds (addErr (dataKindsErr env ty))        ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys+       ; unless (isPromoted ip) $+           addDiagnostic (TcRnUntickedPromotedThing $ UntickedExplicitList)        ; return (HsExplicitListTy noExtField ip tys', fvs) }  rnHsTyKi env ty@(HsExplicitTupleTy _ tys)@@ -766,10 +780,11 @@        ; return (HsWildCardTy noExtField, emptyFVs) }  rnHsArrow :: RnTyKiEnv -> HsArrow GhcPs -> RnM (HsArrow GhcRn, FreeVars)-rnHsArrow _env (HsUnrestrictedArrow u) = return (HsUnrestrictedArrow u, emptyFVs)-rnHsArrow _env (HsLinearArrow u a) = return (HsLinearArrow u a, emptyFVs)-rnHsArrow env (HsExplicitMult u a p)-  = (\(mult, fvs) -> (HsExplicitMult u a mult, fvs)) <$> rnLHsTyKi env p+rnHsArrow _env (HsUnrestrictedArrow arr) = return (HsUnrestrictedArrow arr, emptyFVs)+rnHsArrow _env (HsLinearArrow (HsPct1 pct1 arr)) = return (HsLinearArrow (HsPct1 pct1 arr), emptyFVs)+rnHsArrow _env (HsLinearArrow (HsLolly arr)) = return (HsLinearArrow (HsLolly arr), emptyFVs)+rnHsArrow env (HsExplicitMult pct p arr)+  = (\(mult, fvs) -> (HsExplicitMult pct mult arr, fvs)) <$> rnLHsTyKi env p  {- Note [Renaming HsCoreTys]@@ -818,57 +833,50 @@        ; return (L loc tyvar) }  ---------------rnHsTyOp :: Outputable a-         => RnTyKiEnv -> a -> LocatedN RdrName+rnHsTyOp :: RnTyKiEnv -> SDoc -> LocatedN RdrName          -> RnM (LocatedN Name, FreeVars) rnHsTyOp env overall_ty (L loc op)-  = do { ops_ok <- xoptM LangExt.TypeOperators-       ; op' <- rnTyVar env op-       ; unless (ops_ok || op' `hasKey` eqTyConKey) $-           addErr (opTyErr op overall_ty)-       ; let l_op' = L loc op'-       ; return (l_op', unitFV op') }+  = do { op' <- rnTyVar env op+       ; unlessXOptM LangExt.TypeOperators $+           if (op' `hasKey` eqTyConKey) -- See [eqTyCon (~) compatibility fallback] in GHC.Rename.Env+           then addDiagnostic TcRnTypeEqualityRequiresOperators+           else addErr $ TcRnIllegalTypeOperator overall_ty op+       ; return (L loc op', unitFV op') }  ---------------notAllowed :: SDoc -> SDoc-notAllowed doc-  = text "Wildcard" <+> quotes doc <+> ptext (sLit "not allowed")--checkWildCard :: RnTyKiEnv -> Maybe SDoc -> RnM ()-checkWildCard env (Just doc)-  = addErr $ vcat [doc, nest 2 (text "in" <+> pprHsDocContext (rtke_ctxt env))]-checkWildCard _ Nothing+checkWildCard :: RnTyKiEnv+              -> Maybe Name -- ^ name of the wildcard,+                            -- or 'Nothing' for an anonymous wildcard+              -> Maybe BadAnonWildcardContext+              -> RnM ()+checkWildCard env mb_name (Just bad)+  = addErr $ TcRnIllegalWildcardInType mb_name bad (Just $ rtke_ctxt env)+checkWildCard _ _ Nothing   = return ()  checkAnonWildCard :: RnTyKiEnv -> RnM () -- Report an error if an anonymous wildcard is illegal here checkAnonWildCard env-  = checkWildCard env mb_bad+  = checkWildCard env Nothing mb_bad   where-    mb_bad :: Maybe SDoc+    mb_bad :: Maybe BadAnonWildcardContext     mb_bad | not (wildCardsAllowed env)-           = Just (notAllowed pprAnonWildCard)+           = Just WildcardsNotAllowedAtAll            | otherwise            = case rtke_what env of                RnTypeBody      -> Nothing-               RnTopConstraint -> Just constraint_msg-               RnConstraint    -> Just constraint_msg--    constraint_msg = hang-                         (notAllowed pprAnonWildCard <+> text "in a constraint")-                        2 hint_msg-    hint_msg = vcat [ text "except as the last top-level constraint of a type signature"-                    , nest 2 (text "e.g  f :: (Eq a, _) => blah") ]+               RnTopConstraint -> Just WildcardNotLastInConstraint+               RnConstraint    -> Just WildcardNotLastInConstraint  checkNamedWildCard :: RnTyKiEnv -> Name -> RnM () -- Report an error if a named wildcard is illegal here checkNamedWildCard env name-  = checkWildCard env mb_bad+  = checkWildCard env (Just name) mb_bad   where     mb_bad | not (name `elemNameSet` rtke_nwcs env)            = Nothing  -- Not a wildcard            | not (wildCardsAllowed env)-           = Just (notAllowed (ppr name))+           = Just WildcardsNotAllowedAtAll            | otherwise            = case rtke_what env of                RnTypeBody      -> Nothing   -- Allowed@@ -876,8 +884,7 @@                   -- f :: (Eq _a) => _a -> Int                   -- g :: (_a, _b) => T _a _b -> Int                   -- The named tyvars get filled in from elsewhere-               RnConstraint    -> Just constraint_msg-    constraint_msg = notAllowed (ppr name) <+> text "in a constraint"+               RnConstraint    -> Just WildcardNotLastInConstraint  wildCardsAllowed :: RnTyKiEnv -> Bool -- ^ In what contexts are wildcards permitted@@ -907,8 +914,9 @@   | isRnKindLevel env   = do { polykinds <- xoptM LangExt.PolyKinds        ; unless polykinds $-         addErr (text "Illegal kind:" <+> ppr ty $$-                 text "Did you mean to enable PolyKinds?") }+         addErr $ TcRnUnknownMessage $ mkPlainError noHints $+           (text "Illegal kind:" <+> ppr ty $$+            text "Did you mean to enable PolyKinds?") } checkPolyKinds _ _ = return ()  notInKinds :: Outputable ty@@ -917,7 +925,8 @@            -> RnM () notInKinds env ty   | isRnKindLevel env-  = addErr (text "Illegal kind:" <+> ppr ty)+  = addErr $ TcRnUnknownMessage $ mkPlainError noHints $+     text "Illegal kind:" <+> ppr ty notInKinds _ _ = return ()  {- *****************************************************@@ -948,8 +957,8 @@               -> (LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars))                   -- The Bool is True <=> all kind variables used in the                   -- kind signature are bound on the left.  Reason:-                  -- the last clause of Note [CUSKs: Complete user-supplied-                  -- kind signatures] in GHC.Hs.Decls+                  -- the last clause of Note [CUSKs: complete user-supplied kind signatures]+                  -- in GHC.Hs.Decls               -> RnM (b, FreeVars)  -- See Note [bindHsQTyVars examples]@@ -1270,9 +1279,11 @@ rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField GhcPs         -> RnM (LConDeclField GhcRn, FreeVars) rnField fl_env env (L l (ConDeclField _ names ty haddock_doc))-  = do { let new_names = map (fmap (lookupField fl_env)) names+  = do { mapM_ (\(L _ (FieldOcc _ rdr_name)) -> warnForallIdentifier rdr_name) names+       ; let new_names = map (fmap (lookupField fl_env)) names        ; (new_ty, fvs) <- rnLHsTyKi env ty-       ; return (L l (ConDeclField noAnn new_names new_ty haddock_doc)+       ; haddock_doc' <- traverse rnLHsDoc haddock_doc+       ; return (L l (ConDeclField noAnn new_names new_ty haddock_doc')                 , fvs) }  lookupField :: FastStringEnv FieldLabel -> FieldOcc GhcPs -> FieldOcc GhcRn@@ -1312,33 +1323,34 @@ -}  ------------------ Building (ty1 `op1` (ty21 `op2` ty22))-mkHsOpTyRn :: LocatedN Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn+-- Building (ty1 `op1` (ty2a `op2` ty2b))+mkHsOpTyRn :: PromotionFlag+           -> LocatedN Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn            -> RnM (HsType GhcRn) -mkHsOpTyRn op1 fix1 ty1 (L loc2 (HsOpTy _ ty21 op2 ty22))+mkHsOpTyRn prom1 op1 fix1 ty1 (L loc2 (HsOpTy _ prom2 ty2a op2 ty2b))   = do  { fix2 <- lookupTyFixityRn op2-        ; mk_hs_op_ty op1 fix1 ty1 op2 fix2 ty21 ty22 loc2 }+        ; mk_hs_op_ty prom1 op1 fix1 ty1 prom2 op2 fix2 ty2a ty2b loc2 } -mkHsOpTyRn op1 _ ty1 ty2              -- Default case, no rearrangment-  = return (HsOpTy noExtField ty1 op1 ty2)+mkHsOpTyRn prom1 op1 _ ty1 ty2              -- Default case, no rearrangment+  = return (HsOpTy noAnn prom1 ty1 op1 ty2)  ----------------mk_hs_op_ty :: LocatedN Name -> Fixity -> LHsType GhcRn-            -> LocatedN Name -> Fixity -> LHsType GhcRn+mk_hs_op_ty :: PromotionFlag -> LocatedN Name -> Fixity -> LHsType GhcRn+            -> PromotionFlag -> LocatedN Name -> Fixity -> LHsType GhcRn             -> LHsType GhcRn -> SrcSpanAnnA             -> RnM (HsType GhcRn)-mk_hs_op_ty op1 fix1 ty1 op2 fix2 ty21 ty22 loc2+mk_hs_op_ty prom1 op1 fix1 ty1 prom2 op2 fix2 ty2a ty2b loc2   | nofix_error     = do { precParseErr (NormalOp (unLoc op1),fix1)                                         (NormalOp (unLoc op2),fix2)-                         ; return (ty1 `op1ty` (L loc2 (ty21 `op2ty` ty22))) }-  | associate_right = return (ty1 `op1ty` (L loc2 (ty21 `op2ty` ty22)))-  | otherwise       = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)-                           new_ty <- mkHsOpTyRn op1 fix1 ty1 ty21-                         ; return (noLocA new_ty `op2ty` ty22) }+                         ; return (ty1 `op1ty` (L loc2 (ty2a `op2ty` ty2b))) }+  | associate_right = return (ty1 `op1ty` (L loc2 (ty2a `op2ty` ty2b)))+  | otherwise       = do { -- Rearrange to ((ty1 `op1` ty2a) `op2` ty2b)+                           new_ty <- mkHsOpTyRn prom1 op1 fix1 ty1 ty2a+                         ; return (noLocA new_ty `op2ty` ty2b) }   where-    lhs `op1ty` rhs = HsOpTy noExtField lhs op1 rhs-    lhs `op2ty` rhs = HsOpTy noExtField lhs op2 rhs+    lhs `op1ty` rhs = HsOpTy noAnn prom1 lhs op1 rhs+    lhs `op2ty` rhs = HsOpTy noAnn prom2 lhs op2 rhs     (nofix_error, associate_right) = compareFixity fix1 fix2  @@ -1350,17 +1362,17 @@                                        -- be a NegApp)           -> RnM (HsExpr GhcRn) --- (e11 `op1` e12) `op2` e2-mkOpAppRn negation_handling e1@(L _ (OpApp fix1 e11 op1 e12)) op2 fix2 e2+-- (e1a `op1` e1b) `op2` e2+mkOpAppRn negation_handling e1@(L _ (OpApp fix1 e1a op1 e1b)) op2 fix2 e2   | nofix_error   = do precParseErr (get_op op1,fix1) (get_op op2,fix2)        return (OpApp fix2 e1 op2 e2)    | associate_right = do-    new_e <- mkOpAppRn negation_handling e12 op2 fix2 e2-    return (OpApp fix1 e11 op1 (L loc' new_e))+    new_e <- mkOpAppRn negation_handling e1b op2 fix2 e2+    return (OpApp fix1 e1a op1 (L loc' new_e))   where-    loc'= combineLocsA e12 e2+    loc'= combineLocsA e1b e2     (nofix_error, associate_right) = compareFixity fix1 fix2  ---------------------------@@ -1389,7 +1401,8 @@ --------------------------- --      Default case mkOpAppRn _ e1 op fix e2                  -- Default case, no rearrangment-  = ASSERT2(right_op_ok fix (unLoc e2), ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2)+  = assertPpr (right_op_ok fix (unLoc e2))+              (ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2) $     return (OpApp fix e1 op e2)  data NegationHandling = ReassociateNegation | KeepNegationIntact@@ -1397,11 +1410,10 @@ ----------------------------  -- | Name of an operator in an operator application or section-data OpName = NormalOp Name         -- ^ A normal identifier-            | NegateOp              -- ^ Prefix negation-            | UnboundOp OccName     -- ^ An unbound indentifier-            | RecFldOp (AmbiguousFieldOcc GhcRn)-              -- ^ A (possibly ambiguous) record field occurrence+data OpName = NormalOp Name             -- ^ A normal identifier+            | NegateOp                  -- ^ Prefix negation+            | UnboundOp OccName         -- ^ An unbound indentifier+            | RecFldOp (FieldOcc GhcRn) -- ^ A record field occurrence  instance Outputable OpName where   ppr (NormalOp n)   = ppr n@@ -1414,7 +1426,7 @@ -- See GHC.Rename.Expr.rnUnboundVar get_op (L _ (HsVar _ n))         = NormalOp (unLoc n) get_op (L _ (HsUnboundVar _ uv)) = UnboundOp uv-get_op (L _ (HsRecFld _ fld))    = RecFldOp fld+get_op (L _ (HsRecSel _ fld))    = RecFldOp fld get_op other                     = pprPanic "get_op" (ppr other)  -- Parser left-associates everything, but@@ -1432,7 +1444,7 @@ -- And "deriving" code should respect this (use HsPar if not) mkNegAppRn :: LHsExpr GhcRn -> SyntaxExpr GhcRn -> RnM (HsExpr GhcRn) mkNegAppRn neg_arg neg_name-  = ASSERT( not_op_app (unLoc neg_arg) )+  = assert (not_op_app (unLoc neg_arg)) $     return (NegApp noExtField neg_arg neg_name)  not_op_app :: HsExpr id -> Bool@@ -1445,20 +1457,20 @@           -> LHsCmdTop GhcRn             -- Right operand (not an infix)           -> RnM (HsCmd GhcRn) --- (e11 `op1` e12) `op2` e2-mkOpFormRn a1@(L loc+-- (e1a `op1` e1b) `op2` e2+mkOpFormRn e1@(L loc                     (HsCmdTop _                      (L _ (HsCmdArrForm x op1 f (Just fix1)-                        [a11,a12]))))-        op2 fix2 a2+                        [e1a,e1b]))))+        op2 fix2 e2   | nofix_error   = do precParseErr (get_op op1,fix1) (get_op op2,fix2)-       return (HsCmdArrForm x op2 f (Just fix2) [a1, a2])+       return (HsCmdArrForm x op2 f (Just fix2) [e1, e2])    | associate_right-  = do new_c <- mkOpFormRn a12 op2 fix2 a2+  = do new_c <- mkOpFormRn e1a op2 fix2 e2        return (HsCmdArrForm noExtField op1 f (Just fix1)-               [a11, L loc (HsCmdTop [] (L (noAnnSrcSpan loc) new_c))])+               [e1b, L loc (HsCmdTop [] (L (l2l loc) new_c))])         -- TODO: locs are wrong   where     (nofix_error, associate_right) = compareFixity fix1 fix2@@ -1472,7 +1484,7 @@ mkConOpPatRn :: LocatedN Name -> Fixity -> LPat GhcRn -> LPat GhcRn              -> RnM (Pat GhcRn) -mkConOpPatRn op2 fix2 p1@(L loc (ConPat NoExtField op1 (InfixCon p11 p12))) p2+mkConOpPatRn op2 fix2 p1@(L loc (ConPat NoExtField op1 (InfixCon p1a p1b))) p2   = do  { fix1 <- lookupFixityRn (unLoc op1)         ; let (nofix_error, associate_right) = compareFixity fix1 fix2 @@ -1487,11 +1499,11 @@                 }            else if associate_right then do-                { new_p <- mkConOpPatRn op2 fix2 p12 p2+                { new_p <- mkConOpPatRn op2 fix2 p1b p2                 ; return $ ConPat                     { pat_con_ext = noExtField                     , pat_con = op1-                    , pat_args = InfixCon p11 (L loc new_p)+                    , pat_args = InfixCon p1a (L loc new_p)                     }                 }                 -- XXX loc right?@@ -1503,7 +1515,7 @@         }  mkConOpPatRn op _ p1 p2                         -- Default case, no rearrangment-  = ASSERT( not_op_pat (unLoc p2) )+  = assert (not_op_pat (unLoc p2)) $     return $ ConPat       { pat_con_ext = noExtField       , pat_con = op@@ -1578,8 +1590,7 @@                                  (arg_op, arg_fix) section)  -- | Look up the fixity for an operator name.  Be careful to use--- 'lookupFieldFixityRn' for (possibly ambiguous) record fields--- (see #13132).+-- 'lookupFieldFixityRn' for record fields (see #13132). lookupFixityOp :: OpName -> RnM Fixity lookupFixityOp (NormalOp n)  = lookupFixityRn n lookupFixityOp NegateOp      = lookupFixityRn negateName@@ -1594,8 +1605,9 @@   | is_unbound n1 || is_unbound n2   = return ()     -- Avoid error cascade   | otherwise-  = addErr $ hang (text "Precedence parsing error")-      4 (hsep [text "cannot mix", ppr_opfix op1, ptext (sLit "and"),+  = addErr $ TcRnUnknownMessage $ mkPlainError noHints $+      hang (text "Precedence parsing error")+      4 (hsep [text "cannot mix", ppr_opfix op1, text "and",                ppr_opfix op2,                text "in the same infix expression"]) @@ -1604,7 +1616,8 @@   | is_unbound n1 || is_unbound n2   = return ()     -- Avoid error cascade   | otherwise-  = addErr $ vcat [text "The operator" <+> ppr_opfix op <+> ptext (sLit "of a section"),+  = addErr $ TcRnUnknownMessage $ mkPlainError noHints $+      vcat [text "The operator" <+> ppr_opfix op <+> text "of a section",          nest 4 (sep [text "must have lower precedence than that of the operand,",                       nest 2 (text "namely" <+> ppr_opfix arg_op)]),          nest 4 (text "in the section:" <+> quotes (ppr section))]@@ -1627,21 +1640,23 @@ *                                                      * ***************************************************** -} -unexpectedPatSigTypeErr :: HsPatSigType GhcPs -> SDoc+unexpectedPatSigTypeErr :: HsPatSigType GhcPs -> TcRnMessage unexpectedPatSigTypeErr ty-  = hang (text "Illegal type signature:" <+> quotes (ppr ty))+  = TcRnUnknownMessage $ mkPlainError noHints $+    hang (text "Illegal type signature:" <+> quotes (ppr ty))        2 (text "Type signatures are only allowed in patterns with ScopedTypeVariables")  badKindSigErr :: HsDocContext -> LHsType GhcPs -> TcM () badKindSigErr doc (L loc ty)-  = setSrcSpanA loc $ addErr $+  = setSrcSpanA loc $ addErr $ TcRnUnknownMessage $ mkPlainError noHints $     withHsDocContext doc $     hang (text "Illegal kind signature:" <+> quotes (ppr ty))        2 (text "Perhaps you intended to use KindSignatures") -dataKindsErr :: RnTyKiEnv -> HsType GhcPs -> SDoc+dataKindsErr :: RnTyKiEnv -> HsType GhcPs -> TcRnMessage dataKindsErr env thing-  = hang (text "Illegal" <+> pp_what <> colon <+> quotes (ppr thing))+  = TcRnUnknownMessage $ mkPlainError noHints $+    hang (text "Illegal" <+> pp_what <> colon <+> quotes (ppr thing))        2 (text "Perhaps you intended to use DataKinds")   where     pp_what | isRnKindLevel env = text "kind"@@ -1650,16 +1665,12 @@ warnUnusedForAll :: OutputableBndrFlag flag 'Renamed                  => HsDocContext -> LHsTyVarBndr flag GhcRn -> FreeVars -> TcM () warnUnusedForAll doc (L loc tv) used_names-  = whenWOptM Opt_WarnUnusedForalls $-    unless (hsTyVarName tv `elemNameSet` used_names) $-    addWarnAt (Reason Opt_WarnUnusedForalls) (locA loc) $-    vcat [ text "Unused quantified type variable" <+> quotes (ppr tv)-         , inHsDocContext doc ]--opTyErr :: Outputable a => RdrName -> a -> SDoc-opTyErr op overall_ty-  = hang (text "Illegal operator" <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr overall_ty))-         2 (text "Use TypeOperators to allow operators in types")+  = unless (hsTyVarName tv `elemNameSet` used_names) $ do+      let msg = TcRnUnknownMessage $+            mkPlainDiagnostic (WarningWithFlag Opt_WarnUnusedForalls) noHints $+              vcat [ text "Unused quantified type variable" <+> quotes (ppr tv)+                   , inHsDocContext doc ]+      addDiagnosticAt (locA loc) msg  {- ************************************************************************@@ -1898,8 +1909,8 @@ extractConDeclGADTDetailsTyVars ::   HsConDeclGADTDetails GhcPs -> FreeKiTyVars -> FreeKiTyVars extractConDeclGADTDetailsTyVars con_args = case con_args of-  PrefixConGADT args    -> extract_scaled_ltys args-  RecConGADT (L _ flds) -> extract_ltys $ map (cd_fld_type . unLoc) $ flds+  PrefixConGADT args      -> extract_scaled_ltys args+  RecConGADT (L _ flds) _ -> extract_ltys $ map (cd_fld_type . unLoc) $ flds  -- | Get type/kind variables mentioned in the kind signature, preserving -- left-to-right order:@@ -1912,9 +1923,8 @@ extractDataDefnKindVars (HsDataDefn { dd_kindSig = ksig })   = maybe [] extractHsTyRdrTyVars ksig -extract_lctxt :: Maybe (LHsContext GhcPs) -> FreeKiTyVars -> FreeKiTyVars-extract_lctxt Nothing     = id-extract_lctxt (Just ctxt) = extract_ltys (unLoc ctxt)+extract_lctxt :: LHsContext GhcPs -> FreeKiTyVars -> FreeKiTyVars+extract_lctxt ctxt = extract_ltys (unLoc ctxt)  extract_scaled_ltys :: [HsScaled GhcPs (LHsType GhcPs)]                     -> FreeKiTyVars -> FreeKiTyVars@@ -1946,7 +1956,7 @@                                      extract_lty ty2 $                                      extract_hs_arrow w acc       HsIParamTy _ _ ty           -> extract_lty ty acc-      HsOpTy _ ty1 tv ty2         -> extract_tv tv $+      HsOpTy _ _ ty1 tv ty2       -> extract_tv tv $                                      extract_lty ty1 $                                      extract_lty ty2 acc       HsParTy _ ty                -> extract_lty ty acc@@ -1974,7 +1984,7 @@  extract_hs_arrow :: HsArrow GhcPs -> FreeKiTyVars ->                    FreeKiTyVars-extract_hs_arrow (HsExplicitMult _ _ p) acc = extract_lty p acc+extract_hs_arrow (HsExplicitMult _ p _) acc = extract_lty p acc extract_hs_arrow _ acc = acc  extract_hs_for_all_telescope :: HsForAllTelescope GhcPs
compiler/GHC/Rename/Module.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies        #-}@@ -13,30 +13,32 @@ -}  module GHC.Rename.Module (-        rnSrcDecls, addTcgDUs, findSplice+        rnSrcDecls, addTcgDUs, findSplice, rnWarningTxt     ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import {-# SOURCE #-} GHC.Rename.Expr( rnLExpr ) import {-# SOURCE #-} GHC.Rename.Splice ( rnSpliceDecl, rnTopSpliceDecls )  import GHC.Hs+import GHC.Types.Error import GHC.Types.FieldLabel import GHC.Types.Name.Reader import GHC.Rename.HsType import GHC.Rename.Bind+import GHC.Rename.Doc import GHC.Rename.Env-import GHC.Rename.Utils ( HsDocContext(..), mapFvRn, bindLocalNames+import GHC.Rename.Utils ( mapFvRn, bindLocalNames                         , checkDupRdrNamesN, bindLocalNamesFV                         , checkShadowedRdrNames, warnUnusedTypePatterns                         , newLocalBndrsRn-                        , withHsDocContext, noNestedForallsContextsErr-                        , addNoNestedForallsContextsErr, checkInferredVars )-import GHC.Rename.Unbound ( mkUnboundName, notInScopeErr )+                        , noNestedForallsContextsErr+                        , addNoNestedForallsContextsErr, checkInferredVars, warnForallIdentifier )+import GHC.Rename.Unbound ( mkUnboundName, notInScopeErr, WhereLooking(WL_Global) ) import GHC.Rename.Names+import GHC.Tc.Errors.Types+import GHC.Tc.Errors.Ppr (withHsDocContext, pprScopeError ) import GHC.Tc.Gen.Annotation ( annCtxt ) import GHC.Tc.Utils.Monad @@ -58,7 +60,7 @@ import GHC.Data.FastString import GHC.Types.SrcLoc as SrcLoc import GHC.Driver.Session-import GHC.Utils.Misc   ( debugIsOn, lengthExceeds, partitionWith )+import GHC.Utils.Misc   ( lengthExceeds, partitionWith ) import GHC.Utils.Panic import GHC.Driver.Env ( HscEnv(..), hsc_home_unit) import GHC.Data.List.SetOps ( findDupsEq, removeDups, equivClasses )@@ -125,7 +127,7 @@    (tc_envs, tc_bndrs) <- getLocalNonValBinders local_fix_env group ;  -   setEnvs tc_envs $ do {+   restoreEnvs tc_envs $ do {     failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations @@ -140,15 +142,20 @@    -- (D2) Rename the left-hand sides of the value bindings.    --     This depends on everything from (B) being in scope.    --     It uses the fixity env from (A) to bind fixities for view patterns.-   new_lhs <- rnTopBindsLHS local_fix_env val_decls ; +   -- We need to throw an error on such value bindings when in a boot file.+   is_boot <- tcIsHsBootOrSig ;+   new_lhs <- if is_boot+    then rnTopBindsLHSBoot local_fix_env val_decls+    else rnTopBindsLHS     local_fix_env val_decls ;+    -- Bind the LHSes (and their fixities) in the global rdr environment    let { id_bndrs = collectHsIdBinders CollNoDictBinders new_lhs } ;                     -- Excludes pattern-synonym binders                     -- They are already in scope    traceRn "rnSrcDecls" (ppr id_bndrs) ;    tc_envs <- extendGlobalRdrEnvRn (map avail id_bndrs) local_fix_env ;-   setEnvs tc_envs $ do {+   restoreEnvs tc_envs $ do {     --  Now everything is in scope, as the remaining renaming assumes. @@ -168,7 +175,6 @@    -- (F) Rename Value declarations right-hand sides    traceRn "Start rnmono" empty ;    let { val_bndr_set = mkNameSet id_bndrs `unionNameSet` mkNameSet pat_syn_bndrs } ;-   is_boot <- tcIsHsBootOrSig ;    (rn_val_decls, bind_dus) <- if is_boot     -- For an hs-boot, use tc_bndrs (which collects how we're renamed     -- signatures), since val_bndr_set is empty (there are no x = ...@@ -200,6 +206,7 @@    (rn_default_decls, src_fvs5) <- rnList rnDefaultDecl   default_decls ;    (rn_deriv_decls,   src_fvs6) <- rnList rnSrcDerivDecl  deriv_decls ;    (rn_splice_decls,  src_fvs7) <- rnList rnSpliceDecl    splice_decls ;+   rn_docs <- traverse rnLDocDecl docs ;     last_tcg_env <- getGblEnv ;    -- (I) Compute the results and return@@ -215,7 +222,7 @@                              hs_annds  = rn_ann_decls,                              hs_defds  = rn_default_decls,                              hs_ruleds = rn_rule_decls,-                             hs_docs   = docs } ;+                             hs_docs   = rn_docs } ;          tcf_bndrs = hsTyClForeignBinders rn_tycl_decls rn_foreign_decls ;         other_def  = (Just (mkNameSet tcf_bndrs), emptyNameSet) ;@@ -259,14 +266,14 @@ -}  -- checks that the deprecations are defined locally, and that there are no duplicates-rnSrcWarnDecls :: NameSet -> [LWarnDecls GhcPs] -> RnM Warnings+rnSrcWarnDecls :: NameSet -> [LWarnDecls GhcPs] -> RnM (Warnings GhcRn) rnSrcWarnDecls _ []   = return NoWarnings  rnSrcWarnDecls bndr_set decls'   = do { -- check for duplicates        ; mapM_ (\ dups -> let ((L loc rdr) :| (lrdr':_)) = dups-                          in addErrAt (locA loc) (dupWarnDecl lrdr' rdr))+                          in addErrAt (locA loc) (TcRnDuplicateWarningDecls lrdr' rdr))                warn_rdr_dups        ; pairs_s <- mapM (addLocMA rn_deprec) decls        ; return (WarnSome ((concat pairs_s))) }@@ -279,13 +286,23 @@        -- ensures that the names are defined locally      = do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc)                                 rdr_names-          ; return [(rdrNameOcc rdr, txt) | (rdr, _) <- names] }+          ; txt' <- rnWarningTxt txt+          ; return [(rdrNameOcc rdr, txt') | (rdr, _) <- names] }     what = text "deprecation"     warn_rdr_dups = findDupRdrNames                    $ concatMap (\(L _ (Warning _ ns _)) -> ns) decls +rnWarningTxt :: WarningTxt GhcPs -> RnM (WarningTxt GhcRn)+rnWarningTxt (WarningTxt st wst) = do+  wst' <- traverse (traverse rnHsDoc) wst+  pure (WarningTxt st wst')+rnWarningTxt (DeprecatedTxt st wst) = do+  wst' <- traverse (traverse rnHsDoc) wst+  pure (DeprecatedTxt st wst')++ findDupRdrNames :: [LocatedN RdrName] -> [NonEmpty (LocatedN RdrName)] findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y)) @@ -293,12 +310,6 @@ -- we check that the names are defined above -- invt: the lists returned by findDupsEq always have at least two elements -dupWarnDecl :: LocatedN RdrName -> RdrName -> SDoc--- Located RdrName -> DeprecDecl RdrName -> SDoc-dupWarnDecl d rdr_name-  = vcat [text "Multiple warning declarations for" <+> quotes (ppr rdr_name),-          text "also at " <+> ppr (getLocA d)]- {- ********************************************************* *                                                      *@@ -320,8 +331,10 @@                 -> RnM (AnnProvenance GhcRn, FreeVars) rnAnnProvenance provenance = do     provenance' <- case provenance of-      ValueAnnProvenance n -> ValueAnnProvenance <$> lookupLocatedTopBndrRnN n-      TypeAnnProvenance n  -> TypeAnnProvenance  <$> lookupLocatedTopBndrRnN n+      ValueAnnProvenance n -> ValueAnnProvenance+                          <$> lookupLocatedTopBndrRnN n+      TypeAnnProvenance n  -> TypeAnnProvenance+                          <$> lookupLocatedTopConstructorRnN n       ModuleAnnProvenance  -> return ModuleAnnProvenance     return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance')) @@ -351,6 +364,7 @@ rnHsForeignDecl :: ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, FreeVars) rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec })   = do { topEnv :: HscEnv <- getTopEnv+       ; warnForallIdentifier name        ; name' <- lookupLocatedTopBndrRnN name        ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty @@ -441,7 +455,7 @@         "https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid"    where-    -- | Warn about unsound/non-canonical 'Applicative'/'Monad' instance+    -- Warn about unsound/non-canonical 'Applicative'/'Monad' instance     -- declarations. Specifically, the following conditions are verified:     --     -- In 'Monad' instances declarations:@@ -487,7 +501,7 @@        | otherwise = return () -    -- | Check whether Monoid(mappend) is defined in terms of+    -- Check whether Monoid(mappend) is defined in terms of     -- Semigroup((<>)) (and not the other way round). Specifically,     -- the following conditions are verified:     --@@ -526,7 +540,7 @@        | otherwise = return () -    -- | test whether MatchGroup represents a trivial \"lhsName = rhsName\"+    -- test whether MatchGroup represents a trivial \"lhsName = rhsName\"     -- binding, and return @Just rhsName@ if this is the case     isAliasMG :: MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name     isAliasMG MG {mg_alts = (L _ [L _ (Match { m_pats = []@@ -537,36 +551,40 @@     isAliasMG _ = Nothing      -- got "lhs = rhs" but expected something different-    addWarnNonCanonicalMethod1 refURL flag lhs rhs =-        addWarn (Reason flag) $ vcat-                       [ text "Noncanonical" <+>-                         quotes (text (lhs ++ " = " ++ rhs)) <+>-                         text "definition detected"-                       , instDeclCtxt1 poly_ty-                       , text "Move definition from" <+>-                         quotes (text rhs) <+>-                         text "to" <+> quotes (text lhs)-                       , text "See also:" <+>-                         text refURL-                       ]+    addWarnNonCanonicalMethod1 refURL flag lhs rhs = do+        let dia = TcRnUnknownMessage $+              mkPlainDiagnostic (WarningWithFlag flag) noHints $+                vcat [ text "Noncanonical" <+>+                       quotes (text (lhs ++ " = " ++ rhs)) <+>+                       text "definition detected"+                     , instDeclCtxt1 poly_ty+                     , text "Move definition from" <+>+                       quotes (text rhs) <+>+                       text "to" <+> quotes (text lhs)+                     , text "See also:" <+>+                       text refURL+                     ]+        addDiagnostic dia      -- expected "lhs = rhs" but got something else-    addWarnNonCanonicalMethod2 refURL flag lhs rhs =-        addWarn (Reason flag) $ vcat-                       [ text "Noncanonical" <+>-                         quotes (text lhs) <+>-                         text "definition detected"-                       , instDeclCtxt1 poly_ty-                       , quotes (text lhs) <+>-                         text "will eventually be removed in favour of" <+>-                         quotes (text rhs)-                       , text "Either remove definition for" <+>-                         quotes (text lhs) <+> text "(recommended)" <+>-                         text "or define as" <+>-                         quotes (text (lhs ++ " = " ++ rhs))-                       , text "See also:" <+>-                         text refURL-                       ]+    addWarnNonCanonicalMethod2 refURL flag lhs rhs = do+        let dia = TcRnUnknownMessage $+              mkPlainDiagnostic (WarningWithFlag flag) noHints $+                vcat [ text "Noncanonical" <+>+                       quotes (text lhs) <+>+                       text "definition detected"+                     , instDeclCtxt1 poly_ty+                     , quotes (text lhs) <+>+                       text "will eventually be removed in favour of" <+>+                       quotes (text rhs)+                     , text "Either remove definition for" <+>+                       quotes (text lhs) <+> text "(recommended)" <+>+                       text "or define as" <+>+                       quotes (text (lhs ++ " = " ++ rhs))+                     , text "See also:" <+>+                       text refURL+                     ]+        addDiagnostic dia      -- stolen from GHC.Tc.TyCl.Instance     instDeclCtxt1 :: LHsSigType GhcRn -> SDoc@@ -661,7 +679,7 @@     -- reach the typechecker, lest we encounter different errors that are     -- hopelessly confusing (such as the one in #16114).     bail_out (l, err_msg) = do-      addErrAt l $ withHsDocContext ctxt err_msg+      addErrAt l $ TcRnUnknownMessage $ mkPlainError noHints (withHsDocContext ctxt err_msg)       pure $ mkUnboundName (mkTcOccFS (fsLit "<class>"))  rnFamEqn :: HsDocContext@@ -719,7 +737,10 @@          -- data instance H :: k -> Type where ...          --   -- all_imp_vars = [k]          -- @-       ; let all_imp_vars = pat_kity_vars ++ extra_kvars+         --+         -- For associated type family instances, exclude the type variables+         -- bound by the instance head with filterInScopeM (#19649).+       ; all_imp_vars <- filterInScopeM $ pat_kity_vars ++ extra_kvars         ; bindHsOuterTyVarBndrs doc mb_cls all_imp_vars outer_bndrs $ \rn_outer_bndrs ->     do { (pats', pat_fvs) <- rnLHsTypeArgs (FamPatCtx tycon) pats@@ -755,8 +776,18 @@          -- parent instance declaration is mentioned on the RHS of the          -- associated family instance but not bound on the LHS, then reject          -- that type variable as being out of scope.-         -- See Note [Renaming associated types]-       ; let lhs_bound_vars = extendNameSetList pat_fvs all_nms+         -- See Note [Renaming associated types].+         -- Per that Note, the LHS type variables consist of:+         --+         -- - The variables mentioned in the instance's type patterns+         --   (pat_fvs), and+         --+         -- - The variables mentioned in an outermost kind signature on the+         --   RHS. This is a subset of `rhs_fvs`. To compute it, we look up+         --   each RdrName in `extra_kvars` to find its corresponding Name in+         --   the LocalRdrEnv.+       ; extra_kvar_nms <- mapMaybeM (lookupLocalOccRn_maybe . unLoc) extra_kvars+       ; let lhs_bound_vars = pat_fvs `extendNameSetList` extra_kvar_nms              improperly_scoped cls_tkv =                   cls_tkv `elemNameSet` rhs_fvs                     -- Mentioned on the RHS...@@ -812,7 +843,8 @@      badAssocRhs :: [Name] -> RnM ()     badAssocRhs ns-      = addErr (hang (text "The RHS of an associated type declaration mentions"+      = addErr $ TcRnUnknownMessage $ mkPlainError noHints $+           (hang (text "The RHS of an associated type declaration mentions"                       <+> text "out-of-scope variable" <> plural ns                       <+> pprWithCommas (quotes . ppr) ns)                    2 (text "All such variables must be bound on the LHS"))@@ -1120,7 +1152,7 @@ Here, we /do/ want to warn that `CF` is unused in the module `C`, as it is defined but not used (#18470). -GHC accomplishes this in rnFamInstEqn when determining the set of free+GHC accomplishes this in rnFamEqn when determining the set of free variables to return at the end. If renaming a data family or open type family equation, we add the name of the type family constructor to the set of returned free variables to ensure that the name is marked as an occurrence. If renaming@@ -1172,9 +1204,10 @@     loc = getLocA nowc_ty     nowc_ty = dropWildCards ty -standaloneDerivErr :: SDoc+standaloneDerivErr :: TcRnMessage standaloneDerivErr-  = hang (text "Illegal standalone deriving declaration")+  = TcRnUnknownMessage $ mkPlainError noHints $+    hang (text "Illegal standalone deriving declaration")        2 (text "Use StandaloneDeriving to enable this extension")  {-@@ -1201,6 +1234,7 @@                      , rd_lhs  = lhs                      , rd_rhs  = rhs })   = do { let rdr_names_w_loc = map (get_var . unLoc) tmvs+       ; mapM_ warnForallIdentifier rdr_names_w_loc        ; checkDupRdrNamesN rdr_names_w_loc        ; checkShadowedRdrNames rdr_names_w_loc        ; names <- newLocalBndrsRn rdr_names_w_loc@@ -1315,23 +1349,28 @@     checkl_es es = foldr (mplus . checkl_e) Nothing es -} -badRuleVar :: FastString -> Name -> SDoc+badRuleVar :: FastString -> Name -> TcRnMessage badRuleVar name var-  = sep [text "Rule" <+> doubleQuotes (ftext name) <> colon,+  = TcRnUnknownMessage $ mkPlainError noHints $+    sep [text "Rule" <+> doubleQuotes (ftext name) <> colon,          text "Forall'd variable" <+> quotes (ppr var) <+>                 text "does not appear on left hand side"] -badRuleLhsErr :: FastString -> LHsExpr GhcRn -> HsExpr GhcRn -> SDoc+badRuleLhsErr :: FastString -> LHsExpr GhcRn -> HsExpr GhcRn -> TcRnMessage badRuleLhsErr name lhs bad_e-  = sep [text "Rule" <+> pprRuleName name <> colon,+  = TcRnUnknownMessage $ mkPlainError noHints $+    sep [text "Rule" <+> pprRuleName name <> colon,          nest 2 (vcat [err,                        text "in left-hand side:" <+> ppr lhs])]     $$     text "LHS must be of form (f e1 .. en) where f is not forall'd"   where-    err = case bad_e of-            HsUnboundVar _ uv -> notInScopeErr (mkRdrUnqual uv)-            _                 -> text "Illegal expression:" <+> ppr bad_e+    err =+      case bad_e of+        HsUnboundVar _ uv ->+          let rdr = mkRdrUnqual uv+          in  pprScopeError rdr $ notInScopeErr WL_Global (mkRdrUnqual uv)+        _ -> text "Illegal expression:" <+> ppr bad_e  {- **************************************************************          *                                                      *@@ -1510,8 +1549,11 @@               all_groups = first_group ++ groups -       ; MASSERT2( null final_inst_ds,  ppr instds_w_fvs $$ ppr inst_ds_map-                                       $$ ppr (flattenSCCs tycl_sccs) $$ ppr final_inst_ds  )+       ; massertPpr (null final_inst_ds)+                    (ppr instds_w_fvs+                     $$ ppr inst_ds_map+                     $$ ppr (flattenSCCs tycl_sccs)+                     $$ ppr final_inst_ds)         ; traceRn "rnTycl dependency analysis made groups" (ppr all_groups)        ; return (all_groups, all_fvs) }@@ -1580,8 +1622,8 @@         ; return (StandaloneKindSig noExtField new_v new_ki, fvs)         }   where-    standaloneKiSigErr :: SDoc-    standaloneKiSigErr =+    standaloneKiSigErr :: TcRnMessage+    standaloneKiSigErr = TcRnUnknownMessage $ mkPlainError noHints $       hang (text "Illegal standalone kind signature")          2 (text "Did you mean to enable StandaloneKindSignatures?") @@ -1654,7 +1696,7 @@  dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> RnM () dupRoleAnnotErr list-  = addErrAt (locA loc) $+  = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $     hang (text "Duplicate role annotations for" <+>           quotes (ppr $ roleAnnotDeclName first_decl) <> colon)        2 (vcat $ map pp_role_annot $ NE.toList sorted_list)@@ -1669,7 +1711,7 @@  dupKindSig_Err :: NonEmpty (LStandaloneKindSig GhcPs) -> RnM () dupKindSig_Err list-  = addErrAt (locA loc) $+  = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $     hang (text "Duplicate standalone kind signatures for" <+>           quotes (ppr $ standaloneKindSigName first_decl) <> colon)        2 (vcat $ map pp_kisig $ NE.toList sorted_list)@@ -1763,7 +1805,7 @@  rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars,                       tcdFixity = fixity, tcdRhs = rhs })-  = do { tycon' <- lookupLocatedTopBndrRnN tycon+  = do { tycon' <- lookupLocatedTopConstructorRnN tycon        ; let kvs = extractHsTyRdrTyVarsKindVars rhs              doc = TySynCtx tycon        ; traceRn "rntycl-ty" (ppr tycon <+> ppr kvs)@@ -1779,7 +1821,7 @@       tcdFixity = fixity,       tcdDataDefn = defn@HsDataDefn{ dd_ND = new_or_data                                    , dd_kindSig = kind_sig} })-  = do { tycon' <- lookupLocatedTopBndrRnN tycon+  = do { tycon' <- lookupLocatedTopConstructorRnN tycon        ; let kvs = extractDataDefnKindVars defn              doc = TyDataCtx tycon        ; traceRn "rntycl-data" (ppr tycon <+> ppr kvs)@@ -1800,7 +1842,7 @@                         tcdFDs = fds, tcdSigs = sigs,                         tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,                         tcdDocs = docs})-  = do  { lcls' <- lookupLocatedTopBndrRnN lcls+  = do  { lcls' <- lookupLocatedTopConstructorRnN lcls         ; let cls' = unLoc lcls'               kvs = []  -- No scoped kind vars except those in                         -- kind signatures on the tyvars@@ -1809,7 +1851,7 @@         ; ((tyvars', context', fds', ats'), stuff_fvs)             <- bindHsQTyVars cls_doc Nothing kvs tyvars $ \ tyvars' _ -> do                   -- Checks for distinct tyvars-             { (context', cxt_fvs) <- rnContext cls_doc context+             { (context', cxt_fvs) <- rnMaybeContext cls_doc context              ; fds'  <- rnFds fds                          -- The fundeps have no free variables              ; (ats', fv_ats) <- rnATDecls cls' ats@@ -1848,11 +1890,12 @@                 -- and the methods are already in scope          ; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs+        ; docs' <- traverse rnLDocDecl docs         ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls',                               tcdTyVars = tyvars', tcdFixity = fixity,                               tcdFDs = fds', tcdSigs = sigs',                               tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs',-                              tcdDocs = docs, tcdCExt = all_fvs },+                              tcdDocs = docs', tcdCExt = all_fvs },                   all_fvs ) }   where     cls_doc  = ClassDeclCtx lcls@@ -1900,13 +1943,15 @@ rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType                            , dd_ctxt = context, dd_cons = condecls                            , dd_kindSig = m_sig, dd_derivs = derivs })-  = do  { checkTc (h98_style || null (fromMaybeContext context))+  = do  { -- DatatypeContexts (i.e., stupid contexts) can't be combined with+          -- GADT syntax. See Note [The stupid context] in GHC.Core.DataCon.+          checkTc (h98_style || null (fromMaybeContext context))                   (badGadtStupidTheta doc)          ; (m_sig', sig_fvs) <- case m_sig of              Just sig -> first Just <$> rnLHsKind doc sig              Nothing  -> return (Nothing, emptyFVs)-        ; (context', fvs1) <- rnContext doc context+        ; (context', fvs1) <- rnMaybeContext doc context         ; (derivs',  fvs3) <- rn_derivs derivs          -- For the constructor declarations, drop the LocalRdrEnv@@ -1945,16 +1990,16 @@                  -> RnM () warnNoDerivStrat mds loc   = do { dyn_flags <- getDynFlags-       ; when (wopt Opt_WarnMissingDerivingStrategies dyn_flags) $-           case mds of-             Nothing -> addWarnAt-               (Reason Opt_WarnMissingDerivingStrategies)-               loc-               (if xopt LangExt.DerivingStrategies dyn_flags-                 then no_strat_warning-                 else no_strat_warning $+$ deriv_strat_nenabled-               )-             _ -> pure ()+       ; case mds of+           Nothing ->+             let dia = TcRnUnknownMessage $+                   mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingDerivingStrategies) noHints $+                     (if xopt LangExt.DerivingStrategies dyn_flags+                       then no_strat_warning+                       else no_strat_warning $+$ deriv_strat_nenabled+                     )+             in addDiagnosticAt loc dia+           _ -> pure ()        }   where     no_strat_warning :: SDoc@@ -1972,7 +2017,7 @@                               , deriv_clause_tys = dct }))   = do { (dcs', dct', fvs)            <- rnLDerivStrategy doc dcs $ rn_deriv_clause_tys dct-       ; warnNoDerivStrat dcs' loc+       ; warnNoDerivStrat dcs' (locA loc)        ; pure ( L loc (HsDerivingClause { deriv_clause_ext = noExtField                                         , deriv_clause_strategy = dcs'                                         , deriv_clause_tys = dct' })@@ -2010,7 +2055,7 @@   = case mds of       Nothing -> boring_case Nothing       Just (L loc ds) ->-        setSrcSpan loc $ do+        setSrcSpanA loc $ do           (ds', thing, fvs) <- rn_deriv_strat ds           pure (Just (L loc ds'), thing, fvs)   where@@ -2053,14 +2098,16 @@       (thing, fvs) <- thing_inside       pure (ds, thing, fvs) -badGadtStupidTheta :: HsDocContext -> SDoc+badGadtStupidTheta :: HsDocContext -> TcRnMessage badGadtStupidTheta _-  = vcat [text "No context is allowed on a GADT-style data declaration",+  = TcRnUnknownMessage $ mkPlainError noHints $+    vcat [text "No context is allowed on a GADT-style data declaration",           text "(You can put a context on each constructor, though.)"] -illegalDerivStrategyErr :: DerivStrategy GhcPs -> SDoc+illegalDerivStrategyErr :: DerivStrategy GhcPs -> TcRnMessage illegalDerivStrategyErr ds-  = vcat [ text "Illegal deriving strategy" <> colon <+> derivStrategyName ds+  = TcRnUnknownMessage $ mkPlainError noHints $+    vcat [ text "Illegal deriving strategy" <> colon <+> derivStrategyName ds          , text enableStrategy ]    where@@ -2071,9 +2118,10 @@       | otherwise       = "Use DerivingStrategies to enable this extension" -multipleDerivClausesErr :: SDoc+multipleDerivClausesErr :: TcRnMessage multipleDerivClausesErr-  = vcat [ text "Illegal use of multiple, consecutive deriving clauses"+  = TcRnUnknownMessage $ mkPlainError noHints $+    vcat [ text "Illegal use of multiple, consecutive deriving clauses"          , text "Use DerivingStrategies to allow this" ]  rnFamDecl :: Maybe Name -- Just cls => this FamilyDecl is nested@@ -2086,11 +2134,11 @@                              , fdFixity = fixity                              , fdInfo = info, fdResultSig = res_sig                              , fdInjectivityAnn = injectivity })-  = do { tycon' <- lookupLocatedTopBndrRnN tycon+  = do { tycon' <- lookupLocatedTopConstructorRnN tycon        ; ((tyvars', res_sig', injectivity'), fv1) <-             bindHsQTyVars doc mb_cls kvs tyvars $ \ tyvars' _ ->             do { let rn_sig = rnFamResultSig doc-               ; (res_sig', fv_kind) <- wrapLocFstM rn_sig res_sig+               ; (res_sig', fv_kind) <- wrapLocFstMA rn_sig res_sig                ; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig')                                           injectivity                ; return ( (tyvars', res_sig', injectivity') , fv_kind ) }@@ -2138,7 +2186,7 @@           rdr_env <- getLocalRdrEnv        ;  let resName = hsLTyVarName tvbndr        ;  when (resName `elemLocalRdrEnv` rdr_env) $-          addErrAt (getLocA tvbndr) $+          addErrAt (getLocA tvbndr) $ TcRnUnknownMessage $ mkPlainError noHints $                      (hsep [ text "Type variable", quotes (ppr resName) <> comma                            , text "naming a type family result,"                            ] $$@@ -2198,7 +2246,9 @@              -- e.g.   type family F a = (r::*) | r -> a              do { injFrom' <- rnLTyVar injFrom                 ; injTo'   <- mapM rnLTyVar injTo-                ; return $ L srcSpan (InjectivityAnn x injFrom' injTo') }+                -- Note: srcSpan is unchanged, but typechecker gets+                -- confused, l2l call makes it happy+                ; return $ L (l2l srcSpan) (InjectivityAnn x injFrom' injTo') }     ; let tvNames  = Set.fromList $ hsAllLTyVarNames tvBndrs          resName  = hsLTyVarName resTv@@ -2210,7 +2260,7 @@    -- not-in-scope variables) don't check the validity of injectivity    -- annotation. This gives better error messages.    ; when (noRnErrors && not lhsValid) $-        addErrAt (getLocA injFrom)+        addErrAt (getLocA injFrom) $ TcRnUnknownMessage $ mkPlainError noHints $               ( vcat [ text $ "Incorrect type variable on the LHS of "                            ++ "injectivity condition"               , nest 5@@ -2219,7 +2269,8 @@     ; when (noRnErrors && not (Set.null rhsValid)) $       do { let errorVars = Set.toList rhsValid-         ; addErrAt srcSpan $ ( hsep+         ; addErrAt (locA srcSpan) $ TcRnUnknownMessage $ mkPlainError noHints $+                        ( hsep                         [ text "Unknown type variable" <> plural errorVars                         , text "on the RHS of injectivity condition:"                         , interpp'SP errorVars ] ) }@@ -2235,7 +2286,7 @@ -- So we rename injectivity annotation like we normally would except that -- this time we expect "result" to be reported not in scope by rnLTyVar. rnInjectivityAnn _ _ (L srcSpan (InjectivityAnn x injFrom injTo)) =-   setSrcSpan srcSpan $ do+   setSrcSpanA srcSpan $ do    (injDecl', _) <- askNoErrs $ do      injFrom' <- rnLTyVar injFrom      injTo'   <- mapM rnLTyVar injTo@@ -2267,9 +2318,9 @@ rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars) rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs                            , con_mb_cxt = mcxt, con_args = args-                           , con_doc = mb_doc, con_forall = forall })+                           , con_doc = mb_doc, con_forall = forall_ })   = do  { _        <- addLocMA checkConName name-        ; new_name <- lookupLocatedTopBndrRnN name+        ; new_name <- lookupLocatedTopConstructorRnN name          -- We bind no implicit binders here; this is just like         -- a nested HsForAllTy.  E.g. consider@@ -2290,11 +2341,12 @@              [ text "ex_tvs:" <+> ppr ex_tvs              , text "new_ex_dqtvs':" <+> ppr new_ex_tvs ]) +        ; mb_doc' <- traverse rnLHsDoc mb_doc         ; return (decl { con_ext = noAnn                        , con_name = new_name, con_ex_tvs = new_ex_tvs                        , con_mb_cxt = new_context, con_args = new_args-                       , con_doc = mb_doc-                       , con_forall = forall }, -- Remove when #18311 is fixed+                       , con_doc = mb_doc'+                       , con_forall = forall_ }, -- Remove when #18311 is fixed                   all_fvs) }}  rnConDecl (ConDeclGADT { con_names   = names@@ -2304,7 +2356,7 @@                        , con_res_ty  = res_ty                        , con_doc     = mb_doc })   = do  { mapM_ (addLocMA checkConName) names-        ; new_names <- mapM lookupLocatedTopBndrRnN names+        ; new_names <- mapM (lookupLocatedTopConstructorRnN) names          ; let -- We must ensure that we extract the free tkvs in left-to-right               -- order of their appearance in the constructor type.@@ -2334,16 +2386,17 @@          ; traceRn "rnConDecl (ConDeclGADT)"             (ppr names $$ ppr outer_bndrs')+        ; new_mb_doc <- traverse rnLHsDoc mb_doc         ; return (ConDeclGADT { con_g_ext = noAnn, con_names = new_names                               , con_bndrs = L l outer_bndrs', con_mb_cxt = new_cxt                               , con_g_args = new_args, con_res_ty = new_res_ty-                              , con_doc = mb_doc },+                              , con_doc = new_mb_doc },                   all_fvs) } }  rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs)             -> RnM (Maybe (LHsContext GhcRn), FreeVars) rnMbContext _    Nothing    = return (Nothing, emptyFVs)-rnMbContext doc cxt = do { (ctx',fvs) <- rnContext doc cxt+rnMbContext doc cxt = do { (ctx',fvs) <- rnMaybeContext doc cxt                          ; return (ctx',fvs) }  rnConDeclH98Details ::@@ -2370,9 +2423,9 @@ rnConDeclGADTDetails _ doc (PrefixConGADT tys)   = do { (new_tys, fvs) <- mapFvRn (rnScaledLHsType doc) tys        ; return (PrefixConGADT new_tys, fvs) }-rnConDeclGADTDetails con doc (RecConGADT flds)+rnConDeclGADTDetails con doc (RecConGADT flds arr)   = do { (new_flds, fvs) <- rnRecConDeclFields con doc flds-       ; return (RecConGADT new_flds, fvs) }+       ; return (RecConGADT new_flds arr, fvs) }  rnRecConDeclFields ::      Name@@ -2402,7 +2455,7 @@     ; let field_env' = extendNameEnvList (tcg_field_env gbl_env) names_with_fls          final_gbl_env = gbl_env { tcg_field_env = field_env' }-   ; setEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) }+   ; restoreEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) }   where     new_ps :: HsValBinds GhcPs -> TcM [(Name, [FieldLabel])]     new_ps (ValBinds _ binds _) = foldrM new_ps' [] binds@@ -2416,7 +2469,7 @@                                        , psb_args = RecCon as }))) <- bind       = do           bnd_name <- newTopSrcBinder (L (l2l bind_loc) n)-          let field_occs = map ((\ f -> L (getLocA (rdrNameFieldOcc f)) f) . recordPatSynField) as+          let field_occs = map ((\ f -> L (noAnnSrcSpan $ getLocA (foLabel f)) f) . recordPatSynField) as           flds <- mapM (newRecordSelector dup_fields_ok has_sel [bnd_name]) field_occs           return ((bnd_name, flds): names)       | L bind_loc (PatSynBind _ (PSB { psb_id = L _ n})) <- bind@@ -2497,7 +2550,9 @@         ; return (gp, Just (splice, ds)) }   where-    badImplicitSplice = text "Parse error: module header, import declaration"+    badImplicitSplice :: TcRnMessage+    badImplicitSplice = TcRnUnknownMessage $ mkPlainError noHints $+                        text "Parse error: module header, import declaration"                      $$ text "or top-level declaration expected."                      -- The compiler should suggest the above, and not using                      -- TemplateHaskell since the former suggestion is more
compiler/GHC/Rename/Names.hs view
@@ -4,11 +4,12 @@ Extracting imported and top-level names in scope -} -{-# LANGUAGE CPP, NondecreasingIndentation #-}+{-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE LambdaCase #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}@@ -22,16 +23,13 @@         checkConName,         mkChildEnv,         findChildren,-        dodgyMsg,-        dodgyMsgInsert,         findImportUsage,         getMinimalImports,         printMinimalImports,+        renamePkgQual, renameRawPkgQual,         ImportDeclUsage     ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Driver.Env@@ -42,6 +40,7 @@ import GHC.Rename.Fixity import GHC.Rename.Utils ( warnUnusedTopBinds, mkFieldEnv ) +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad @@ -51,13 +50,13 @@ import GHC.Parser.PostProcess ( setRdrNameSpace ) import GHC.Core.Type import GHC.Core.PatSyn-import GHC.Core.TyCo.Ppr-import GHC.Core.TyCon ( TyCon, tyConName, tyConKind )+import GHC.Core.TyCon ( TyCon, tyConName ) import qualified GHC.LanguageExtensions as LangExt  import GHC.Utils.Outputable as Outputable import GHC.Utils.Misc as Utils import GHC.Utils.Panic+import GHC.Utils.Trace  import GHC.Types.Fixity.Env import GHC.Types.SafeHaskell@@ -73,12 +72,15 @@ import GHC.Types.SourceText import GHC.Types.Id import GHC.Types.HpcInfo+import GHC.Types.Error+import GHC.Types.PkgQual  import GHC.Unit import GHC.Unit.Module.Warnings import GHC.Unit.Module.ModIface import GHC.Unit.Module.Imported import GHC.Unit.Module.Deps+import GHC.Unit.Env  import GHC.Data.Maybe import GHC.Data.FastString@@ -95,6 +97,7 @@ import System.FilePath  ((</>))  import System.IO+import GHC.Data.Bag  {- ************************************************************************@@ -111,7 +114,7 @@ and packages. Doing this without caching any trust information would be very slow as we would need to touch all packages and interface files a module depends on. To avoid this we make use of the property that if a modules Safe Haskell-mode changes, this triggers a recompilation from that module in the dependcy+mode changes, this triggers a recompilation from that module in the dependecy graph. So we can just worry mostly about direct imports.  There is one trust property that can change for a package though without@@ -187,22 +190,37 @@ -- the return types represent. -- Note: Do the non SOURCE ones first, so that we get a helpful warning -- for SOURCE ones that are unnecessary-rnImports :: [LImportDecl GhcPs]+rnImports :: [(LImportDecl GhcPs, SDoc)]           -> RnM ([LImportDecl GhcRn], GlobalRdrEnv, ImportAvails, AnyHpcUsage) rnImports imports = do     tcg_env <- getGblEnv     -- NB: want an identity module here, because it's OK for a signature     -- module to import from its implementor     let this_mod = tcg_mod tcg_env-    let (source, ordinary) = partition is_source_import imports+    let (source, ordinary) = partition (is_source_import . fst) imports         is_source_import d = ideclSource (unLoc d) == IsBoot     stuff1 <- mapAndReportM (rnImportDecl this_mod) ordinary     stuff2 <- mapAndReportM (rnImportDecl this_mod) source     -- Safe Haskell: See Note [Tracking Trust Transitively]     let (decls, rdr_env, imp_avails, hpc_usage) = combine (stuff1 ++ stuff2)-    return (decls, rdr_env, imp_avails, hpc_usage)+    -- Update imp_boot_mods if imp_direct_mods mentions any of them+    let merged_import_avail = clobberSourceImports imp_avails+    dflags <- getDynFlags+    let final_import_avail  =+          merged_import_avail { imp_dep_direct_pkgs = S.fromList (implicitPackageDeps dflags)+                                                        `S.union` imp_dep_direct_pkgs merged_import_avail}+    return (decls, rdr_env, final_import_avail, hpc_usage)    where+    clobberSourceImports imp_avails =+      imp_avails { imp_boot_mods = imp_boot_mods' }+      where+        imp_boot_mods' = mergeInstalledModuleEnv combJ id (const emptyInstalledModuleEnv)+                            (imp_boot_mods imp_avails)+                            (imp_direct_dep_mods imp_avails)++        combJ (GWIB _ IsBoot) x = Just x+        combJ r _               = Just r     -- See Note [Combining ImportAvails]     combine :: [(LImportDecl GhcRn,  GlobalRdrEnv, ImportAvails, AnyHpcUsage)]             -> ([LImportDecl GhcRn], GlobalRdrEnv, ImportAvails, AnyHpcUsage)@@ -284,17 +302,19 @@ -- --  4. A boolean 'AnyHpcUsage' which is true if the imported module --     used HPC.-rnImportDecl  :: Module -> LImportDecl GhcPs+rnImportDecl  :: Module -> (LImportDecl GhcPs, SDoc)              -> RnM (LImportDecl GhcRn, GlobalRdrEnv, ImportAvails, AnyHpcUsage) rnImportDecl this_mod              (L loc decl@(ImportDecl { ideclName = loc_imp_mod_name-                                     , ideclPkgQual = mb_pkg+                                     , ideclPkgQual = raw_pkg_qual                                      , ideclSource = want_boot, ideclSafe = mod_safe                                      , ideclQualified = qual_style, ideclImplicit = implicit-                                     , ideclAs = as_mod, ideclHiding = imp_details }))+                                     , ideclAs = as_mod, ideclHiding = imp_details }), import_reason)   = setSrcSpanA loc $ do -    when (isJust mb_pkg) $ do+    case raw_pkg_qual of+      NoRawPkgQual -> pure ()+      RawPkgQual _ -> do         pkg_imports <- xoptM LangExt.PackageImports         when (not pkg_imports) $ addErr packageImportErr @@ -303,8 +323,12 @@     -- If there's an error in loadInterface, (e.g. interface     -- file not found) we get lots of spurious errors from 'filterImports'     let imp_mod_name = unLoc loc_imp_mod_name-        doc = ppr imp_mod_name <+> text "is directly imported"+        doc = ppr imp_mod_name <+> import_reason +    hsc_env <- getTopEnv+    unit_env <- hsc_unit_env <$> getTopEnv+    let pkg_qual = renameRawPkgQual unit_env imp_mod_name raw_pkg_qual+     -- Check for self-import, which confuses the typechecker (#9032)     -- ghc --make rejects self-import cycles already, but batch-mode may not     -- at least not until GHC.IfaceToCore.tcHiBootIface, which is too late to avoid@@ -318,14 +342,15 @@     -- extend Provenance to support a local definition in a qualified location.     -- For now, we don't support it, but see #10336     when (imp_mod_name == moduleName this_mod &&-          (case mb_pkg of  -- If we have import "<pkg>" M, then we should-                           -- check that "<pkg>" is "this" (which is magic)-                           -- or the name of this_mod's package.  Yurgh!-                           -- c.f. GHC.findModule, and #9997-             Nothing         -> True-             Just (StringLiteral _ pkg_fs _) -> pkg_fs == fsLit "this" ||-                            fsToUnit pkg_fs == moduleUnit this_mod))-         (addErr (text "A module cannot import itself:" <+> ppr imp_mod_name))+          (case pkg_qual of -- If we have import "<pkg>" M, then we should+                            -- check that "<pkg>" is "this" (which is magic)+                            -- or the name of this_mod's package.  Yurgh!+                            -- c.f. GHC.findModule, and #9997+             NoPkgQual         -> True+             ThisPkg uid       -> uid == homeUnitId_ (hsc_dflags hsc_env)+             OtherPkg _        -> False))+         (addErr $ TcRnUnknownMessage $ mkPlainError noHints $+           (text "A module cannot import itself:" <+> ppr imp_mod_name))      -- Check for a missing import list (Opt_WarnMissingImportList also     -- checks for T(..) items but that is done in checkDodgyImport below)@@ -333,15 +358,19 @@         Just (False, _) -> return () -- Explicit import list         _  | implicit   -> return () -- Do not bleat for implicit imports            | qual_only  -> return ()-           | otherwise  -> whenWOptM Opt_WarnMissingImportList $-                           addWarn (Reason Opt_WarnMissingImportList)-                                   (missingImportListWarn imp_mod_name)+           | otherwise  -> whenWOptM Opt_WarnMissingImportList $ do+                             let msg = TcRnUnknownMessage $+                                   mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingImportList)+                                                     noHints+                                                     (missingImportListWarn imp_mod_name)+                             addDiagnostic msg -    iface <- loadSrcInterface doc imp_mod_name want_boot (fmap sl_fs mb_pkg) +    iface <- loadSrcInterface doc imp_mod_name want_boot pkg_qual+     -- Compiler sanity check: if the import didn't say     -- {-# SOURCE #-} we should not get a hi-boot file-    WARN( (want_boot == NotBoot) && (mi_boot iface == IsBoot), ppr imp_mod_name ) do+    warnPprTrace ((want_boot == NotBoot) && (mi_boot iface == IsBoot)) "rnImportDecl" (ppr imp_mod_name) $ do      -- Issue a user warning for a redundant {- SOURCE -} import     -- NB that we arrange to read all the ordinary imports before@@ -355,9 +384,9 @@     warnIf ((want_boot == IsBoot) && (mi_boot iface == NotBoot) && isOneShot (ghcMode dflags))            (warnRedundantSourceImport imp_mod_name)     when (mod_safe && not (safeImportsOn dflags)) $-        addErr (text "safe import can't be used as Safe Haskell isn't on!"-                $+$ ptext (sLit $ "please enable Safe Haskell through either "-                                   ++ "Safe, Trustworthy or Unsafe"))+        addErr $ TcRnUnknownMessage $ mkPlainError noHints $+          (text "safe import can't be used as Safe Haskell isn't on!"+                $+$ text ("please enable Safe Haskell through either Safe, Trustworthy or Unsafe"))      let         qual_mod_name = fmap unLoc as_mod `orElse` imp_mod_name@@ -383,6 +412,7 @@      hsc_env <- getTopEnv     let home_unit = hsc_home_unit hsc_env+        other_home_units = hsc_all_home_unit_ids hsc_env         imv = ImportedModsVal             { imv_name        = qual_mod_name             , imv_span        = locA loc@@ -391,35 +421,81 @@             , imv_all_exports = potential_gres             , imv_qualified   = qual_only             }-        imports = calculateAvails home_unit iface mod_safe' want_boot (ImportedByUser imv)+        imports = calculateAvails home_unit other_home_units iface mod_safe' want_boot (ImportedByUser imv)      -- Complain if we import a deprecated module-    whenWOptM Opt_WarnWarningsDeprecations (-       case (mi_warns iface) of-          WarnAll txt -> addWarn (Reason Opt_WarnWarningsDeprecations)-                                (moduleWarn imp_mod_name txt)-          _           -> return ()-     )+    case mi_warns iface of+       WarnAll txt -> do+         let msg = TcRnUnknownMessage $+               mkPlainDiagnostic (WarningWithFlag Opt_WarnWarningsDeprecations)+                                 noHints+                                 (moduleWarn imp_mod_name txt)+         addDiagnostic msg+       _           -> return ()      -- Complain about -Wcompat-unqualified-imports violations.     warnUnqualifiedImport decl iface -    let new_imp_decl = L loc (decl { ideclExt = noExtField, ideclSafe = mod_safe'-                                   , ideclHiding = new_imp_details-                                   , ideclName = ideclName decl-                                   , ideclAs = ideclAs decl })+    let new_imp_decl = ImportDecl+          { ideclExt       = noExtField+          , ideclSourceSrc = ideclSourceSrc decl+          , ideclName      = ideclName decl+          , ideclPkgQual   = pkg_qual+          , ideclSource    = ideclSource decl+          , ideclSafe      = mod_safe'+          , ideclQualified = ideclQualified decl+          , ideclImplicit  = ideclImplicit decl+          , ideclAs        = ideclAs decl+          , ideclHiding    = new_imp_details+          } -    return (new_imp_decl, gbl_env, imports, mi_hpc iface)+    return (L loc new_imp_decl, gbl_env, imports, mi_hpc iface) ++-- | Rename raw package imports+renameRawPkgQual :: UnitEnv -> ModuleName -> RawPkgQual -> PkgQual+renameRawPkgQual unit_env mn = \case+  NoRawPkgQual -> NoPkgQual+  RawPkgQual p -> renamePkgQual unit_env mn (Just (sl_fs p))++-- | Rename raw package imports+renamePkgQual :: UnitEnv -> ModuleName -> Maybe FastString -> PkgQual+renamePkgQual unit_env mn mb_pkg = case mb_pkg of+  Nothing -> NoPkgQual+  Just pkg_fs+    | Just uid <- homeUnitId <$> ue_homeUnit unit_env+    , pkg_fs == fsLit "this"+    -> ThisPkg uid++    | Just (uid, _) <- find (fromMaybe False . fmap (== pkg_fs) . snd) home_names+    -> ThisPkg uid++    | Just uid <- resolvePackageImport (ue_units unit_env) mn (PackageName pkg_fs)+    -> OtherPkg uid++    | otherwise+    -> OtherPkg (UnitId pkg_fs)+       -- not really correct as pkg_fs is unlikely to be a valid unit-id but+       -- we will report the failure later...+  where+    home_names  = map (\uid -> (uid, mkFastString <$> thisPackageName (homeUnitEnv_dflags (ue_findHomeUnitEnv uid unit_env)))) hpt_deps++    units = ue_units unit_env++    hpt_deps :: [UnitId]+    hpt_deps  = homeUnitDepends units++ -- | Calculate the 'ImportAvails' induced by an import of a particular -- interface, but without 'imp_mods'. calculateAvails :: HomeUnit+                -> S.Set UnitId                 -> ModIface                 -> IsSafeImport                 -> IsBootInterface                 -> ImportedBy                 -> ImportAvails-calculateAvails home_unit iface mod_safe' want_boot imported_by =+calculateAvails home_unit other_home_units iface mod_safe' want_boot imported_by =   let imp_mod    = mi_module iface       imp_sem_mod= mi_semantic_module iface       orph_iface = mi_orphan (mi_final_exts iface)@@ -427,6 +503,7 @@       deps       = mi_deps iface       trust      = getSafeMode $ mi_trust iface       trust_pkg  = mi_trust_pkg iface+      is_sig     = mi_hsc_src iface == HsigFile        -- If the module exports anything defined in this module, just       -- ignore it.  Reason: otherwise it looks as if there are two@@ -454,61 +531,72 @@       -- 'imp_finsts' if it defines an orphan or instance family; thus the       -- orph_iface/has_iface tests. -      orphans | orph_iface = ASSERT2( not (imp_sem_mod `elem` dep_orphs deps), ppr imp_sem_mod <+> ppr (dep_orphs deps) )-                             imp_sem_mod : dep_orphs deps-              | otherwise  = dep_orphs deps+      deporphs  = dep_orphs deps+      depfinsts = dep_finsts deps -      finsts | has_finsts = ASSERT2( not (imp_sem_mod `elem` dep_finsts deps), ppr imp_sem_mod <+> ppr (dep_orphs deps) )-                            imp_sem_mod : dep_finsts deps-             | otherwise  = dep_finsts deps+      orphans | orph_iface = assertPpr (not (imp_sem_mod `elem` deporphs)) (ppr imp_sem_mod <+> ppr deporphs) $+                             imp_sem_mod : deporphs+              | otherwise  = deporphs +      finsts | has_finsts = assertPpr (not (imp_sem_mod `elem` depfinsts)) (ppr imp_sem_mod <+> ppr depfinsts) $+                            imp_sem_mod : depfinsts+             | otherwise  = depfinsts++      -- Trusted packages are a lot like orphans.+      trusted_pkgs | mod_safe' = dep_trusted_pkgs deps+                   | otherwise = S.empty++       pkg = moduleUnit (mi_module iface)       ipkg = toUnitId pkg        -- Does this import mean we now require our own pkg       -- to be trusted? See Note [Trust Own Package]       ptrust = trust == Sf_Trustworthy || trust_pkg+      pkg_trust_req+        | isHomeUnit home_unit pkg = ptrust+        | otherwise = False -      (dependent_mods, dependent_pkgs, pkg_trust_req)-         | isHomeUnit home_unit pkg =-            -- Imported module is from the home package-            -- Take its dependent modules and add imp_mod itself-            -- Take its dependent packages unchanged-            ---            -- NB: (dep_mods deps) might include a hi-boot file-            -- for the module being compiled, CM. Do *not* filter-            -- this out (as we used to), because when we've-            -- finished dealing with the direct imports we want to-            -- know if any of them depended on CM.hi-boot, in-            -- which case we should do the hi-boot consistency-            -- check.  See GHC.Iface.Load.loadHiBootInterface-            ( GWIB { gwib_mod = moduleName imp_mod, gwib_isBoot = want_boot } : dep_mods deps-            , dep_pkgs deps-            , ptrust-            )+      dependent_pkgs = if toUnitId pkg `S.member` other_home_units+                        then S.empty+                        else S.singleton ipkg -         | otherwise =-            -- Imported module is from another package-            -- Dump the dependent modules-            -- Add the package imp_mod comes from to the dependent packages-            ASSERT2( not (ipkg `elem` (map fst $ dep_pkgs deps))-                   , ppr ipkg <+> ppr (dep_pkgs deps) )-            ([], (ipkg, False) : dep_pkgs deps, False)+      direct_mods = mkModDeps $ if toUnitId pkg `S.member` other_home_units+                      then S.singleton (moduleUnitId imp_mod, (GWIB (moduleName imp_mod) want_boot))+                      else S.empty +      dep_boot_mods_map = mkModDeps (dep_boot_mods deps)++      boot_mods+        -- If we are looking for a boot module, it must be HPT+        | IsBoot <- want_boot = extendInstalledModuleEnv dep_boot_mods_map (toUnitId <$> imp_mod) (GWIB (moduleName imp_mod) IsBoot)+        -- Now we are importing A properly, so don't go looking for+        -- A.hs-boot+        | isHomeUnit home_unit pkg = dep_boot_mods_map+        -- There's no boot files to find in external imports+        | otherwise = emptyInstalledModuleEnv++      sig_mods =+        if is_sig+          then moduleName imp_mod : dep_sig_mods deps+          else dep_sig_mods deps++   in ImportAvails {           imp_mods       = unitModuleEnv (mi_module iface) [imported_by],           imp_orphs      = orphans,           imp_finsts     = finsts,-          imp_dep_mods   = mkModDeps dependent_mods,-          imp_dep_pkgs   = S.fromList . map fst $ dependent_pkgs,+          imp_sig_mods   = sig_mods,+          imp_direct_dep_mods = direct_mods,+          imp_dep_direct_pkgs = dependent_pkgs,+          imp_boot_mods = boot_mods,+           -- Add in the imported modules trusted package           -- requirements. ONLY do this though if we import the           -- module as a safe import.           -- See Note [Tracking Trust Transitively]           -- and Note [Trust Transitive Property]-          imp_trust_pkgs = if mod_safe'-                               then S.fromList . map fst $ filter snd dependent_pkgs-                               else S.empty,+          imp_trust_pkgs = trusted_pkgs,           -- Do we require our own pkg to be trusted?           -- See Note [Trust Own Package]           imp_trust_own_pkg = pkg_trust_req@@ -520,9 +608,12 @@ -- `Data.List.singleton` proposal. See #17244. warnUnqualifiedImport :: ImportDecl GhcPs -> ModIface -> RnM () warnUnqualifiedImport decl iface =-    whenWOptM Opt_WarnCompatUnqualifiedImports-    $ when bad_import-    $ addWarnAt (Reason Opt_WarnCompatUnqualifiedImports) loc warning+    when bad_import $ do+      let msg = TcRnUnknownMessage $+            mkPlainDiagnostic (WarningWithFlag Opt_WarnCompatUnqualifiedImports)+                              noHints+                              warning+      addDiagnosticAt loc msg   where     mod = mi_module iface     loc = getLocA $ ideclName decl@@ -535,9 +626,9 @@         Just (False, _) -> True         _               -> False     bad_import =-      mod `elemModuleSet` qualifiedMods-      && not is_qual+         not is_qual       && not has_import_list+      && mod `elemModuleSet` qualifiedMods      warning = vcat       [ text "To ensure compatibility with future core libraries changes"@@ -549,10 +640,10 @@     qualifiedMods = mkModuleSet [ dATA_LIST ]  -warnRedundantSourceImport :: ModuleName -> SDoc+warnRedundantSourceImport :: ModuleName -> TcRnMessage warnRedundantSourceImport mod_name-  = text "Unnecessary {-# SOURCE #-} in the import of module"-          <+> quotes (ppr mod_name)+  = TcRnUnknownMessage $ mkPlainDiagnostic WarningWithoutFlag noHints $+      text "Unnecessary {-# SOURCE #-} in the import of module" <+> quotes (ppr mod_name)  {- ************************************************************************@@ -598,7 +689,8 @@ -- see Note [Top-level Names in Template Haskell decl quotes]  extendGlobalRdrEnvRn avails new_fixities-  = do  { (gbl_env, lcl_env) <- getEnvs+  = checkNoErrs $  -- See Note [Fail fast on duplicate definitions]+    do  { (gbl_env, lcl_env) <- getEnvs         ; stage <- getStage         ; isGHCi <- getIsGHCi         ; let rdr_env  = tcg_rdr_env gbl_env@@ -612,7 +704,7 @@               -- See Note [GlobalRdrEnv shadowing]               inBracket = isBrackStage stage -              lcl_env_TH = lcl_env { tcl_rdr = delLocalRdrEnvList (tcl_rdr lcl_env) new_occs }+              lcl_env_TH = lcl_env { tcl_rdr = minusLocalRdrEnv (tcl_rdr lcl_env) new_occs }                            -- See Note [GlobalRdrEnv shadowing]                lcl_env2 | inBracket = lcl_env_TH@@ -620,7 +712,7 @@                -- Deal with shadowing: see Note [GlobalRdrEnv shadowing]               want_shadowing = isGHCi || inBracket-              rdr_env1 | want_shadowing = shadowNames rdr_env new_names+              rdr_env1 | want_shadowing = shadowNames rdr_env new_occs                        | otherwise      = rdr_env                lcl_env3 = lcl_env2 { tcl_th_bndrs = extendNameEnvList th_bndrs@@ -637,7 +729,7 @@         ; return (gbl_env', lcl_env3) }   where     new_names = concatMap availGreNames avails-    new_occs  = map occName new_names+    new_occs  = occSetToEnv (mkOccSet (map occName new_names))      -- If there is a fixity decl for the gre, add it to the fixity env     extend_fix_env fix_env gre@@ -675,7 +767,19 @@               (False, True)  -> isNoFieldSelectorGRE gre'               (False, False) -> False -{-+{- Note [Fail fast on duplicate definitions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If there are duplicate bindings for the same thing, we want to fail+fast. Having two bindings for the same thing can cause follow-on errors.+Example (test T9975a):+   data Test = Test { x :: Int }+   pattern Test wat = Test { x = wat }+This defines 'Test' twice.  The second defn has no field-names; and then+we get an error from Test { x=wat }, saying "Test has no field 'x'".++Easiest thing is to bale out fast on duplicate definitions, which+we do via `checkNoErrs` on `extendGlobalRdrEnvRn`.+ Note [Reporting duplicate local declarations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In general, a single module may not define the same OccName multiple times. This@@ -799,7 +903,7 @@                                  (tyClGroupTyClDecls tycl_decls)         ; traceRn "getLocalNonValBinders 1" (ppr tc_avails)         ; envs <- extendGlobalRdrEnvRn tc_avails fixity_env-        ; setEnvs envs $ do {+        ; restoreEnvs envs $ do {             -- Bring these things into scope first             -- See Note [Looking up family names in family instances] @@ -823,9 +927,12 @@         ; traceRn "getLocalNonValBinders 2" (ppr avails)         ; (tcg_env, tcl_env) <- extendGlobalRdrEnvRn avails fixity_env +        -- Force the field access so that tcg_env is not retained. The+        -- selector thunk optimisation doesn't kick-in, see #20139+        ; let !old_field_env = tcg_field_env tcg_env         -- Extend tcg_field_env with new fields (this used to be the         -- work of extendRecordFieldEnv)-        ; let field_env = extendNameEnvList (tcg_field_env tcg_env) flds+              field_env = extendNameEnvList old_field_env flds               envs      = (tcg_env { tcg_field_env = field_env }, tcl_env)          ; traceRn "getLocalNonValBinders 3" (vcat [ppr flds, ppr field_env])@@ -871,7 +978,7 @@             = [( find_con_name rdr                , concatMap find_con_decl_flds (unLoc cdflds) )]         find_con_flds (L _ (ConDeclGADT { con_names = rdrs-                                        , con_g_args = RecConGADT flds }))+                                        , con_g_args = RecConGADT flds _ }))             = [ ( find_con_name rdr                  , concatMap find_con_decl_flds (unLoc flds))               | L _ rdr <- rdrs ]@@ -943,7 +1050,7 @@ newRecordSelector :: DuplicateRecordFields -> FieldSelectors -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel newRecordSelector _ _ [] _ = error "newRecordSelector: datatype has no constructors!" newRecordSelector dup_fields_ok has_sel (dc:_) (L loc (FieldOcc _ (L _ fld)))-  = do { selName <- newTopSrcBinder $ L (noAnnSrcSpan loc) $ field+  = do { selName <- newTopSrcBinder $ L (l2l loc) $ field        ; return $ FieldLabel { flLabel = fieldLabelString                              , flHasDuplicateRecordFields = dup_fields_ok                              , flHasFieldSelector = has_sel@@ -1128,16 +1235,16 @@             -> (GreName, AvailInfo, Maybe Name)     combine (NormalGreName name1, a1@(AvailTC p1 _), mb1)             (NormalGreName name2, a2@(AvailTC p2 _), mb2)-      = ASSERT2( name1 == name2 && isNothing mb1 && isNothing mb2-               , ppr name1 <+> ppr name2 <+> ppr mb1 <+> ppr mb2 )+      = assertPpr (name1 == name2 && isNothing mb1 && isNothing mb2)+                  (ppr name1 <+> ppr name2 <+> ppr mb1 <+> ppr mb2) $         if p1 == name1 then (NormalGreName name1, a1, Just p2)                        else (NormalGreName name1, a2, Just p1)     -- 'combine' may also be called for pattern synonyms which appear both     -- unassociated and associated (see Note [Importing PatternSynonyms]).     combine (c1, a1, mb1) (c2, a2, mb2)-      = ASSERT2( c1 == c2 && isNothing mb1 && isNothing mb2-                          && (isAvailTC a1 || isAvailTC a2)-               , ppr c1 <+> ppr c2 <+> ppr a1 <+> ppr a2 <+> ppr mb1 <+> ppr mb2 )+      = assertPpr (c1 == c2 && isNothing mb1 && isNothing mb2+                          && (isAvailTC a1 || isAvailTC a2))+                  (ppr c1 <+> ppr c2 <+> ppr a1 <+> ppr a2 <+> ppr mb1 <+> ppr mb2) $         if isAvailTC a1 then (c1, a1, Nothing)                         else (c1, a2, Nothing) @@ -1147,7 +1254,7 @@     lookup_name :: IE GhcPs -> RdrName -> IELookupM (Name, AvailInfo, Maybe Name)     lookup_name ie rdr        | isQual rdr              = failLookupWith (QualImportError rdr)-       | Just succ <- mb_success = case nameEnvElts succ of+       | Just succ <- mb_success = case nonDetNameEnvElts succ of                                      -- See Note [Importing DuplicateRecordFields]                                      [(c,a,x)] -> return (greNameMangledName c, a, x)                                      xs -> failLookupWith (AmbiguousImport rdr (map sndOf3 xs))@@ -1165,15 +1272,21 @@         where             -- Warn when importing T(..) if T was exported abstractly             emit_warning (DodgyImport n) = whenWOptM Opt_WarnDodgyImports $-              addWarn (Reason Opt_WarnDodgyImports) (dodgyImportWarn n)+              addTcRnDiagnostic (TcRnDodgyImports n)             emit_warning MissingImportList = whenWOptM Opt_WarnMissingImportList $-              addWarn (Reason Opt_WarnMissingImportList) (missingImportListItem ieRdr)-            emit_warning (BadImportW ie) = whenWOptM Opt_WarnDodgyImports $-              addWarn (Reason Opt_WarnDodgyImports) (lookup_err_msg (BadImport ie))+              addTcRnDiagnostic (TcRnMissingImportList ieRdr)+            emit_warning (BadImportW ie) = whenWOptM Opt_WarnDodgyImports $ do+              let msg = TcRnUnknownMessage $+                    mkPlainDiagnostic (WarningWithFlag Opt_WarnDodgyImports)+                                      noHints+                                      (lookup_err_msg (BadImport ie))+              addDiagnostic msg              run_lookup :: IELookupM a -> TcRn (Maybe a)             run_lookup m = case m of-              Failed err -> addErr (lookup_err_msg err) >> return Nothing+              Failed err -> do+                addErr $ TcRnUnknownMessage $ mkPlainError noHints (lookup_err_msg err)+                return Nothing               Succeeded a -> return (Just a)              lookup_err_msg err = case err of@@ -1465,86 +1578,103 @@ *                                                                      * ********************************************************************* -} +{-+Note [Missing signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~+There are four warning flags in play:++  * -Wmissing-exported-signatures+    Warn about any exported top-level function/value without a type signature.+    Does not include pattern synonyms.++  * -Wmissing-signatures+    Warn about any top-level function/value without a type signature. Does not+    include pattern synonyms. Takes priority over -Wmissing-exported-signatures.++  * -Wmissing-exported-pattern-synonym-signatures+    Warn about any exported pattern synonym without a type signature.++  * -Wmissing-pattern-synonym-signatures+    Warn about any pattern synonym without a type signature. Takes priority over+    -Wmissing-exported-pattern-synonym-signatures.++-}+ -- | Warn the user about top level binders that lack type signatures. -- Called /after/ type inference, so that we can report the -- inferred type of the function warnMissingSignatures :: TcGblEnv -> RnM () warnMissingSignatures gbl_env-  = do { let exports = availsToNameSet (tcg_exports gbl_env)+  = do { warn_binds    <- woptM Opt_WarnMissingSignatures+       ; warn_pat_syns <- woptM Opt_WarnMissingPatternSynonymSignatures+       ; let exports = availsToNameSet (tcg_exports gbl_env)              sig_ns  = tcg_sigs gbl_env                -- We use sig_ns to exclude top-level bindings that are generated by GHC              binds    = collectHsBindsBinders CollNoDictBinders $ tcg_binds gbl_env              pat_syns = tcg_patsyns gbl_env -         -- Warn about missing signatures-         -- Do this only when we have a type to offer-       ; warn_missing_sigs  <- woptM Opt_WarnMissingSignatures-       ; warn_only_exported <- woptM Opt_WarnMissingExportedSignatures-       ; warn_pat_syns      <- woptM Opt_WarnMissingPatternSynonymSignatures--       ; let add_sig_warns-               | warn_missing_sigs  = add_warns Opt_WarnMissingSignatures-               | warn_only_exported = add_warns Opt_WarnMissingExportedSignatures-               | warn_pat_syns      = add_warns Opt_WarnMissingPatternSynonymSignatures-               | otherwise          = return ()--             add_warns flag-                = when (warn_missing_sigs || warn_only_exported)-                       (mapM_ add_bind_warn binds) >>-                  when (warn_missing_sigs || warn_pat_syns)-                       (mapM_ add_pat_syn_warn pat_syns)-                where-                  add_pat_syn_warn p-                    = add_warn name $-                      hang (text "Pattern synonym with no type signature:")-                         2 (text "pattern" <+> pprPrefixName name <+> dcolon <+> pp_ty)-                    where-                      name  = patSynName p-                      pp_ty = pprPatSynType p--                  add_bind_warn :: Id -> IOEnv (Env TcGblEnv TcLclEnv) ()-                  add_bind_warn id-                    = do { env <- tcInitTidyEnv     -- Why not use emptyTidyEnv?-                         ; let name    = idName id-                               (_, ty) = tidyOpenType env (idType id)-                               ty_msg  = pprSigmaType ty-                         ; add_warn name $-                           hang (text "Top-level binding with no type signature:")-                              2 (pprPrefixName name <+> dcolon <+> ty_msg) }+             not_ghc_generated :: Name -> Bool+             not_ghc_generated name = name `elemNameSet` sig_ns -                  add_warn name msg-                    = when (name `elemNameSet` sig_ns && export_check name)-                           (addWarnAt (Reason flag) (getSrcSpan name) msg)+             add_binding_warn :: Id -> RnM ()+             add_binding_warn id =+               when (not_ghc_generated name) $+               do { env <- tcInitTidyEnv -- Why not use emptyTidyEnv?+                  ; let (_, ty) = tidyOpenType env (idType id)+                        missing = MissingTopLevelBindingSig name ty+                        diag = TcRnMissingSignature missing exported warn_binds+                  ; addDiagnosticAt (getSrcSpan name) diag }+               where+                 name = idName id+                 exported = if name `elemNameSet` exports+                            then IsExported+                            else IsNotExported -                  export_check name-                    = warn_missing_sigs || not warn_only_exported || name `elemNameSet` exports+             add_patsyn_warn :: PatSyn -> RnM ()+             add_patsyn_warn ps =+               when (not_ghc_generated name) $+                 addDiagnosticAt (getSrcSpan name)+                  (TcRnMissingSignature missing exported warn_pat_syns)+               where+                 name = patSynName ps+                 missing = MissingPatSynSig ps+                 exported = if name `elemNameSet` exports+                            then IsExported+                            else IsNotExported -       ; add_sig_warns }+         -- Warn about missing signatures+         -- Do this only when we have a type to offer+         -- See Note [Missing signatures]+       ; mapM_ add_binding_warn binds+       ; mapM_ add_patsyn_warn  pat_syns+       }  -- | Warn the user about tycons that lack kind signatures. -- Called /after/ type (and kind) inference, so that we can report the -- inferred kinds. warnMissingKindSignatures :: TcGblEnv -> RnM () warnMissingKindSignatures gbl_env-  = do { warn_missing_kind_sigs  <- woptM Opt_WarnMissingKindSignatures-       ; cusks_enabled <- xoptM LangExt.CUSKs-       ; when (warn_missing_kind_sigs) (mapM_ (add_ty_warn cusks_enabled) tcs)+  = do { cusks_enabled <- xoptM LangExt.CUSKs+       ; mapM_ (add_ty_warn cusks_enabled) tcs        }   where     tcs = tcg_tcs gbl_env     ksig_ns = tcg_ksigs gbl_env+    exports = availsToNameSet (tcg_exports gbl_env)+    not_ghc_generated :: Name -> Bool+    not_ghc_generated name = name `elemNameSet` ksig_ns -    add_ty_warn :: Bool -> TyCon -> IOEnv (Env TcGblEnv TcLclEnv) ()-    add_ty_warn cusks_enabled tyCon = when (name `elemNameSet` ksig_ns) $-        addWarnAt (Reason Opt_WarnMissingKindSignatures) (getSrcSpan name) $-            hang msg 2 (text "type" <+> pprPrefixName name <+> dcolon <+> ki_msg)+    add_ty_warn :: Bool -> TyCon -> RnM ()+    add_ty_warn cusks_enabled tyCon =+      when (not_ghc_generated name) $+        addDiagnosticAt (getSrcSpan name) diag       where-        msg | cusks_enabled = text "Top-level type constructor with no standalone kind signature or CUSK:"-            | otherwise     = text "Top-level type constructor with no standalone kind signature:"         name = tyConName tyCon-        ki = tyConKind tyCon-        ki_msg :: SDoc-        ki_msg = pprKind ki+        diag = TcRnMissingSignature missing exported False+        missing = MissingTyConKindSig tyCon cusks_enabled+        exported = if name `elemNameSet` exports+                   then IsExported+                   else IsNotExported  {- *********************************************************@@ -1684,7 +1814,7 @@        RealSrcLoc decl_loc _ -> Map.insertWith add decl_loc [gre] imp_map        UnhelpfulLoc _ -> imp_map        where-          best_imp_spec = bestImport imp_specs+          best_imp_spec = bestImport (bagToList imp_specs)           add _ gres = gre : gres  warnUnusedImport :: WarningFlag -> NameEnv (FieldLabelString, Parent)@@ -1703,7 +1833,9 @@    -- Nothing used; drop entire declaration   | null used-  = addWarnAt (Reason flag) (locA loc) msg1+  = let dia = TcRnUnknownMessage $+          mkPlainDiagnostic (WarningWithFlag flag) noHints msg1+    in addDiagnosticAt (locA loc) dia    -- Everything imported is used; nop   | null unused@@ -1714,11 +1846,13 @@   | Just (_, L _ imports) <- ideclHiding decl   , length unused == 1   , Just (L loc _) <- find (\(L _ ie) -> ((ieName ie) :: Name) `elem` unused) imports-  = addWarnAt (Reason flag) (locA loc) msg2+  = let dia = TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag flag) noHints msg2+    in addDiagnosticAt (locA loc) dia    -- Some imports are unused   | otherwise-  = addWarnAt (Reason flag) (locA loc)  msg2+  = let dia = TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag flag) noHints msg2+    in addDiagnosticAt (locA loc) dia    where     msg1 = vcat [ pp_herald <+> quotes pp_mod <+> is_redundant@@ -1781,8 +1915,8 @@       | otherwise       = do { let ImportDecl { ideclName    = L _ mod_name                             , ideclSource  = is_boot-                            , ideclPkgQual = mb_pkg } = decl-           ; iface <- loadSrcInterface doc mod_name is_boot (fmap sl_fs mb_pkg)+                            , ideclPkgQual = pkg_qual } = decl+           ; iface <- loadSrcInterface doc mod_name is_boot pkg_qual            ; let used_avails = gresToAvailInfo used_gres                  lies = map (L l) (concatMap (to_ie iface) used_avails)            ; return (L l (decl { ideclHiding = Just (False, L (l2l l) lies) })) }@@ -2006,30 +2140,10 @@ illegalImportItemErr :: SDoc illegalImportItemErr = text "Illegal import item" -dodgyImportWarn :: RdrName -> SDoc-dodgyImportWarn item-  = dodgyMsg (text "import") item (dodgyMsgInsert item :: IE GhcPs)--dodgyMsg :: (Outputable a, Outputable b) => SDoc -> a -> b -> SDoc-dodgyMsg kind tc ie-  = sep [ text "The" <+> kind <+> ptext (sLit "item")-                    -- <+> quotes (ppr (IEThingAll (noLoc (IEName $ noLoc tc))))-                     <+> quotes (ppr ie)-                <+> text "suggests that",-          quotes (ppr tc) <+> text "has (in-scope) constructors or class methods,",-          text "but it has none" ]--dodgyMsgInsert :: forall p . IdP (GhcPass p) -> IE (GhcPass p)-dodgyMsgInsert tc = IEThingAll noAnn ii-  where-    ii :: LIEWrappedName (IdP (GhcPass p))-    ii = noLocA (IEName $ noLocA tc)-- addDupDeclErr :: [GlobalRdrElt] -> TcRn () addDupDeclErr [] = panic "addDupDeclErr: empty list" addDupDeclErr gres@(gre : _)-  = addErrAt (getSrcSpan (last sorted_names)) $+  = addErrAt (getSrcSpan (last sorted_names)) $ TcRnUnknownMessage $ mkPlainError noHints $     -- Report the error at the later location     vcat [text "Multiple declarations of" <+>              quotes (ppr (greOccName gre)),@@ -2047,24 +2161,21 @@  missingImportListWarn :: ModuleName -> SDoc missingImportListWarn mod-  = text "The module" <+> quotes (ppr mod) <+> ptext (sLit "does not have an explicit import list")--missingImportListItem :: IE GhcPs -> SDoc-missingImportListItem ie-  = text "The import item" <+> quotes (ppr ie) <+> ptext (sLit "does not have an explicit import list")+  = text "The module" <+> quotes (ppr mod) <+> text "does not have an explicit import list" -moduleWarn :: ModuleName -> WarningTxt -> SDoc+moduleWarn :: ModuleName -> WarningTxt GhcRn -> SDoc moduleWarn mod (WarningTxt _ txt)-  = sep [ text "Module" <+> quotes (ppr mod) <> ptext (sLit ":"),-          nest 2 (vcat (map (ppr . sl_fs . unLoc) txt)) ]+  = sep [ text "Module" <+> quotes (ppr mod) <> colon,+          nest 2 (vcat (map (ppr . hsDocString . unLoc) txt)) ] moduleWarn mod (DeprecatedTxt _ txt)   = sep [ text "Module" <+> quotes (ppr mod)                                 <+> text "is deprecated:",-          nest 2 (vcat (map (ppr . sl_fs . unLoc) txt)) ]+          nest 2 (vcat (map (ppr . hsDocString . unLoc) txt)) ] -packageImportErr :: SDoc+packageImportErr :: TcRnMessage packageImportErr-  = text "Package-qualified imports are not enabled; use PackageImports"+  = TcRnUnknownMessage $ mkPlainError noHints $+  text "Package-qualified imports are not enabled; use PackageImports"  -- This data decl will parse OK --      data T = a Int@@ -2079,6 +2190,7 @@ checkConName :: RdrName -> TcRn () checkConName name = checkErr (isRdrDataCon name) (badDataCon name) -badDataCon :: RdrName -> SDoc+badDataCon :: RdrName -> TcRnMessage badDataCon name-   = hsep [text "Illegal data constructor name", quotes (ppr name)]+   = TcRnUnknownMessage $ mkPlainError noHints $+   hsep [text "Illegal data constructor name", quotes (ppr name)]
compiler/GHC/Rename/Pat.hs view
@@ -1,11 +1,11 @@ {-# LANGUAGE TypeApplications #-}-{-# LANGUAGE CPP                 #-} {-# LANGUAGE DeriveFunctor       #-} {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE RankNTypes          #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies        #-} {-# LANGUAGE ViewPatterns        #-}+{-# LANGUAGE DisambiguateRecordFields #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}@@ -37,9 +37,6 @@                -- Literals               rnLit, rnOverLit,--             -- Pattern Error message that is also used elsewhere-             patSigErr              ) where  -- ENH: thin imports to only what is necessary for patterns@@ -49,20 +46,21 @@ import {-# SOURCE #-} GHC.Rename.Expr ( rnLExpr ) import {-# SOURCE #-} GHC.Rename.Splice ( rnSplicePat ) -#include "GhclibHsVersions.h"- import GHC.Hs+import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Zonk   ( hsOverLitName ) import GHC.Rename.Env import GHC.Rename.Fixity-import GHC.Rename.Utils    ( HsDocContext(..), newLocalBndrRn, bindLocalNames+import GHC.Rename.Utils    ( newLocalBndrRn, bindLocalNames                            , warnUnusedMatches, newLocalBndrRn                            , checkUnusedRecordWildcard-                           , checkDupNames, checkDupAndShadowedNames )+                           , checkDupNames, checkDupAndShadowedNames+                           , wrapGenSpan, genHsApps, genLHsVar, genHsIntegralLit, warnForallIdentifier ) import GHC.Rename.HsType import GHC.Builtin.Names import GHC.Types.Avail ( greNameMangledName )+import GHC.Types.Error import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Reader@@ -71,7 +69,7 @@ import GHC.Utils.Misc import GHC.Data.List.SetOps( removeDups ) import GHC.Utils.Outputable-import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Types.SrcLoc import GHC.Types.Literal   ( inCharRange ) import GHC.Builtin.Types   ( nilDataCon )@@ -149,7 +147,7 @@  lookupConCps :: LocatedN RdrName -> CpsRn (LocatedN Name) lookupConCps con_rdr-  = CpsRn (\k -> do { con_name <- lookupLocatedOccRn con_rdr+  = CpsRn (\k -> do { con_name <- lookupLocatedOccRnConstr con_rdr                     ; (r, fvs) <- k con_name                     ; return (r, addOneFV fvs (unLoc con_name)) })     -- We add the constructor name to the free vars@@ -220,7 +218,7 @@     -- Do not report unused names in interactive contexts     -- i.e. when you type 'x <- e' at the GHCi prompt     report_unused = case ctxt of-                      StmtCtxt GhciStmtCtxt -> False+                      StmtCtxt (HsDoStmt GhciStmtCtxt) -> False                       -- also, don't warn in pattern quotes, as there                       -- is no RHS where the variables can be used!                       ThPatQuote            -> False@@ -234,14 +232,16 @@ newPatName :: NameMaker -> LocatedN RdrName -> CpsRn Name newPatName (LamMk report_unused) rdr_name   = CpsRn (\ thing_inside ->-        do { name <- newLocalBndrRn rdr_name+        do { warnForallIdentifier rdr_name+           ; name <- newLocalBndrRn rdr_name            ; (res, fvs) <- bindLocalNames [name] (thing_inside name)            ; when report_unused $ warnUnusedMatches [name] fvs            ; return (res, name `delFV` fvs) })  newPatName (LetMk is_top fix_env) rdr_name   = CpsRn (\ thing_inside ->-        do { name <- case is_top of+        do { warnForallIdentifier rdr_name+           ; name <- case is_top of                        NotTopLevel -> newLocalBndrRn rdr_name                        TopLevel    -> newTopSrcBinder rdr_name            ; bindLocalNames [name] $@@ -297,6 +297,85 @@  See #12615 for some more examples. +Note [Handling overloaded and rebindable patterns]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Overloaded paterns and rebindable patterns are desugared in the renamer+using the HsPatExpansion mechanism detailed in:+Note [Rebindable syntax and HsExpansion]+The approach is similar to that of expressions, which is further detailed+in Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr.++Here are the patterns that are currently desugared in this way:++* ListPat (list patterns [p1,p2,p3])+  When (and only when) OverloadedLists is on, desugar to a view pattern:+    [p1, p2, p3]+  ==>+    toList -> [p1, p2, p3]+              ^^^^^^^^^^^^ built-in (non-overloaded) list pattern+  NB: the type checker and desugarer still see ListPat,+      but to them it always means the built-in list pattern.+  See Note [Desugaring overloaded list patterns] below for more details.++We expect to add to this list as we deal with more patterns via the expansion+mechanism.++Note [Desugaring overloaded list patterns]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If OverloadedLists is enabled, we desugar a list pattern to a view pattern:++  [p1, p2, p3]+==>+  toList -> [p1, p2, p3]++This happens directly in the renamer, using the HsPatExpansion mechanism+detailed in Note [Rebindable syntax and HsExpansion].++Note that we emit a special view pattern: we additionally keep track of an+inverse to the pattern.+See Note [Invertible view patterns] in GHC.Tc.TyCl.PatSyn for details.++== Wrinkle ==++This is all fine, except in one very specific case:+  - when RebindableSyntax is off,+  - and the type being matched on is already a list type.++In this case, it is undesirable to desugar an overloaded list pattern into+a view pattern. To illustrate, consider the following program:++> {-# LANGUAGE OverloadedLists #-}+>+> f []    = True+> f (_:_) = False++Without any special logic, the pattern `[]` is desugared to `(toList -> [])`,+whereas `(_:_)` remains a constructor pattern. This implies that the argument+of `f` is necessarily a list (even though `OverloadedLists` is enabled).+After desugaring the overloaded list pattern `[]`, and type-checking, we obtain:++> f :: [a] -> Bool+> f (toList -> []) = True+> f (_:_)          = False++The pattern match checker then warns that the pattern `[]` is not covered,+as it isn't able to look through view patterns.+We can see that this is silly: as we are matching on a list, `toList` doesn't+actually do anything. So we ignore it, and desugar the pattern to an explicit+list pattern, instead of a view pattern.++Note however that this is not necessarily sound, because it is possible to have+a list `l` such that `toList l` is not the same as `l`.+This can happen with an overlapping instance, such as the following:++instance {-# OVERLAPPING #-} IsList [Int] where+  type Item [Int] = Int+  toList = reverse+  fromList = reverse++We make the assumption that no such instance exists, in order to avoid worsening+pattern-match warnings (see #14547).+ ********************************************************* *                                                      *         External entry points@@ -343,7 +422,7 @@           -- Nor can we check incrementally for shadowing, else we'll           --    complain *twice* about duplicates e.g. f (x,x) = ...           ---          -- See note [Don't report shadowing for pattern synonyms]+          -- See Note [Don't report shadowing for pattern synonyms]         ; let bndrs = collectPatsBinders CollNoDictBinders pats'         ; addErrCtxt doc_pat $           if isPatSynCtxt ctxt@@ -403,8 +482,9 @@  rnPatAndThen :: NameMaker -> Pat GhcPs -> CpsRn (Pat GhcRn) rnPatAndThen _  (WildPat _)   = return (WildPat noExtField)-rnPatAndThen mk (ParPat x pat)  = do { pat' <- rnLPatAndThen mk pat-                                     ; return (ParPat x pat') }+rnPatAndThen mk (ParPat x lpar pat rpar) =+  do { pat' <- rnLPatAndThen mk pat+     ; return (ParPat x lpar pat' rpar) } rnPatAndThen mk (LazyPat _ pat) = do { pat' <- rnLPatAndThen mk pat                                      ; return (LazyPat noExtField pat') } rnPatAndThen mk (BangPat _ pat) = do { pat' <- rnLPatAndThen mk pat@@ -438,7 +518,7 @@   = do { ovlStr <- liftCps (xoptM LangExt.OverloadedStrings)        ; if ovlStr          then rnPatAndThen mk-                           (mkNPat (noLoc (mkHsIsString src s))+                           (mkNPat (noLocA (mkHsIsString src s))                                       Nothing noAnn)          else normal_lit }   | otherwise = normal_lit@@ -478,15 +558,18 @@  rnPatAndThen mk p@(ViewPat _ expr pat)   = do { liftCps $ do { vp_flag <- xoptM LangExt.ViewPatterns-                      ; checkErr vp_flag (badViewPat p) }+                      ; checkErr vp_flag (TcRnIllegalViewPattern p) }          -- Because of the way we're arranging the recursive calls,          -- this will be in the right context        ; expr' <- liftCpsFV $ rnLExpr expr        ; pat' <- rnLPatAndThen mk pat        -- Note: at this point the PreTcType in ty can only be a placeHolder        -- ; return (ViewPat expr' pat' ty) }-       ; return (ViewPat noExtField expr' pat') } +       -- Note: we can't cook up an inverse for an arbitrary view pattern,+       -- so we pass 'Nothing'.+       ; return (ViewPat Nothing expr' pat') }+ rnPatAndThen mk (ConPat _ con args)    -- rnConPatAndThen takes care of reconstructing the pattern    -- The pattern for the empty list needs to be replaced by an empty explicit list pattern when overloaded lists is turned on.@@ -497,12 +580,25 @@       False   -> rnConPatAndThen mk con args  rnPatAndThen mk (ListPat _ pats)-  = do { opt_OverloadedLists <- liftCps $ xoptM LangExt.OverloadedLists+  = do { opt_OverloadedLists  <- liftCps $ xoptM LangExt.OverloadedLists        ; pats' <- rnLPatsAndThen mk pats-       ; case opt_OverloadedLists of-          True -> do { (to_list_name,_) <- liftCps $ lookupSyntax toListName-                     ; return (ListPat (Just to_list_name) pats')}-          False -> return (ListPat Nothing pats') }+       ; if not opt_OverloadedLists+         then return (ListPat noExtField pats')+         else+    -- If OverloadedLists is enabled, desugar to a view pattern.+    -- See Note [Desugaring overloaded list patterns]+    do { (to_list_name,_)     <- liftCps $ lookupSyntaxName toListName+       -- Use 'fromList' as proof of invertibility of the view pattern.+       -- See Note [Invertible view patterns] in GHC.Tc.TyCl.PatSyn+       ; (from_list_n_name,_) <- liftCps $ lookupSyntaxName fromListNName+       ; let+           lit_n   = mkIntegralLit (length pats)+           hs_lit  = genHsIntegralLit lit_n+           inverse = genHsApps from_list_n_name [hs_lit]+           rn_list_pat  = ListPat noExtField pats'+           exp_expr     = genLHsVar to_list_name+           exp_list_pat = ViewPat (Just inverse) exp_expr (wrapGenSpan rn_list_pat)+       ; return $ mkExpandedPat rn_list_pat exp_list_pat }}  rnPatAndThen mk (TuplePat _ pats boxed)   = do { pats' <- rnLPatsAndThen mk pats@@ -549,7 +645,7 @@       unless (scoped_tyvars && type_app) $         case listToMaybe tyargs of           Nothing    -> pure ()-          Just tyarg -> addErr $+          Just tyarg -> addErr $ TcRnUnknownMessage $ mkPlainError noHints $             hang (text "Illegal visible type application in a pattern:"                     <+> quotes (char '@' <> ppr tyarg))                2 (text "Both ScopedTypeVariables and TypeApplications are"@@ -593,15 +689,15 @@   where     mkVarPat l n = VarPat noExtField (L (noAnnSrcSpan l) n)     rn_field (L l fld, n') =-      do { arg' <- rnLPatAndThen (nested_mk dd mk n') (hsRecFieldArg fld)-         ; return (L l (fld { hsRecFieldArg = arg' })) }+      do { arg' <- rnLPatAndThen (nested_mk dd mk n') (hfbRHS fld)+         ; return (L l (fld { hfbRHS = arg' })) }      loc = maybe noSrcSpan getLoc dd      -- Get the arguments of the implicit binders     implicit_binders fs (unLoc -> n) = collectPatsBinders CollNoDictBinders implicit_pats       where-        implicit_pats = map (hsRecFieldArg . unLoc) (drop n fs)+        implicit_pats = map (hfbRHS . unLoc) (drop n fs)      -- Don't warn for let P{..} = ... in ...     check_unused_wildcard = case mk of@@ -614,6 +710,23 @@     nested_mk (Just (unLoc -> n)) (LamMk report_unused) n'       = LamMk (report_unused && (n' <= n)) ++{- *********************************************************************+*                                                                      *+              Generating code for HsPatExpanded+      See Note [Handling overloaded and rebindable constructs]+*                                                                      *+********************************************************************* -}++-- | Build a 'HsPatExpansion' out of an extension constructor,+--   and the two components of the expansion: original and+--   desugared patterns+mkExpandedPat+  :: Pat GhcRn -- ^ source pattern+  -> Pat GhcRn -- ^ expanded pattern+  -> Pat GhcRn -- ^ suitably wrapped 'HsPatExpansion'+mkExpandedPat a b = XPat (HsPatExpanded a b)+ {- ************************************************************************ *                                                                      *@@ -644,7 +757,7 @@ -- This is used for record construction and pattern-matching, but not updates.  rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })-  = do { pun_ok      <- xoptM LangExt.RecordPuns+  = do { pun_ok      <- xoptM LangExt.NamedFieldPuns        ; disambig_ok <- xoptM LangExt.DisambiguateRecordFields        ; let parent = guard disambig_ok >> mb_con        ; flds1  <- mapM (rn_fld pun_ok parent) flds@@ -662,23 +775,23 @@     rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs (LocatedA arg)            -> RnM (LHsRecField GhcRn (LocatedA arg))     rn_fld pun_ok parent (L l-                           (HsRecField-                              { hsRecFieldLbl =+                           (HsFieldBind+                              { hfbLHS =                                   (L loc (FieldOcc _ (L ll lbl)))-                              , hsRecFieldArg = arg-                              , hsRecPun      = pun }))-      = do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent lbl+                              , hfbRHS = arg+                              , hfbPun      = pun }))+      = do { sel <- setSrcSpanA loc $ lookupRecFieldOcc parent lbl            ; arg' <- if pun-                     then do { checkErr pun_ok (badPun (L loc lbl))+                     then do { checkErr pun_ok (TcRnIllegalFieldPunning (L (locA loc) lbl))                                -- Discard any module qualifier (#11662)                              ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)-                             ; return (L (noAnnSrcSpan loc) (mk_arg loc arg_rdr)) }+                             ; return (L (l2l loc) (mk_arg (locA loc) arg_rdr)) }                      else return arg-           ; return (L l (HsRecField-                             { hsRecFieldAnn = noAnn-                             , hsRecFieldLbl = (L loc (FieldOcc sel (L ll lbl)))-                             , hsRecFieldArg = arg'-                             , hsRecPun      = pun })) }+           ; return (L l (HsFieldBind+                             { hfbAnn = noAnn+                             , hfbLHS = (L loc (FieldOcc sel (L ll lbl)))+                             , hfbRHS = arg'+                             , hfbPun      = pun })) }       rn_dotdot :: Maybe (Located Int)      -- See Note [DotDot fields] in GHC.Hs.Pat@@ -691,12 +804,12 @@                                 -- isn't in scope the constructor lookup will add                                 -- an error but still return an unbound name. We                                 -- don't want that to screw up the dot-dot fill-in stuff.-      = ASSERT( flds `lengthIs` n )+      = assert (flds `lengthIs` n) $         do { dd_flag <- xoptM LangExt.RecordWildCards            ; checkErr dd_flag (needFlagDotDot ctxt)            ; (rdr_env, lcl_env) <- getRdrEnvs            ; con_fields <- lookupConstructorFields con-           ; when (null con_fields) (addErr (badDotDotCon con))+           ; when (null con_fields) (addErr (TcRnIllegalWildcardsInConstructor con))            ; let present_flds = mkOccSet $ map rdrNameOcc (getFieldLbls flds)                     -- For constructor uses (but not patterns)@@ -719,12 +832,12 @@             ; addUsedGREs dot_dot_gres            ; let locn = noAnnSrcSpan loc-           ; return [ L (noAnnSrcSpan loc) (HsRecField-                        { hsRecFieldAnn = noAnn-                        , hsRecFieldLbl-                           = L loc (FieldOcc sel (L (noAnnSrcSpan loc) arg_rdr))-                        , hsRecFieldArg = L locn (mk_arg loc arg_rdr)-                        , hsRecPun      = False })+           ; return [ L (noAnnSrcSpan loc) (HsFieldBind+                        { hfbAnn = noAnn+                        , hfbLHS+                           = L (noAnnSrcSpan loc) (FieldOcc sel (L (noAnnSrcSpan loc) arg_rdr))+                        , hfbRHS = L locn (mk_arg loc arg_rdr)+                        , hfbPun      = False })                     | fl <- dot_dot_fields                     , let sel     = flSelector fl                     , let arg_rdr = mkVarUnqual (flLabel fl) ] }@@ -753,45 +866,45 @@     :: [LHsRecUpdField GhcPs]     -> RnM ([LHsRecUpdField GhcRn], FreeVars) rnHsRecUpdFields flds-  = do { pun_ok        <- xoptM LangExt.RecordPuns+  = do { pun_ok        <- xoptM LangExt.NamedFieldPuns        ; dup_fields_ok <- xopt_DuplicateRecordFields <$> getDynFlags        ; (flds1, fvss) <- mapAndUnzipM (rn_fld pun_ok dup_fields_ok) flds        ; mapM_ (addErr . dupFieldErr HsRecFieldUpd) dup_flds         -- Check for an empty record update  e {}        -- NB: don't complain about e { .. }, because rn_dotdot has done that already-       ; when (null flds) $ addErr emptyUpdateErr+       ; when (null flds) $ addErr TcRnEmptyRecordUpdate         ; return (flds1, plusFVs fvss) }   where     rn_fld :: Bool -> DuplicateRecordFields -> LHsRecUpdField GhcPs            -> RnM (LHsRecUpdField GhcRn, FreeVars)-    rn_fld pun_ok dup_fields_ok (L l (HsRecField { hsRecFieldLbl = L loc f-                                               , hsRecFieldArg = arg-                                               , hsRecPun      = pun }))+    rn_fld pun_ok dup_fields_ok (L l (HsFieldBind { hfbLHS = L loc f+                                                  , hfbRHS = arg+                                                  , hfbPun      = pun }))       = do { let lbl = rdrNameAmbiguousFieldOcc f-           ; mb_sel <- setSrcSpan loc $+           ; mb_sel <- setSrcSpanA loc $                       -- Defer renaming of overloaded fields to the typechecker                       -- See Note [Disambiguating record fields] in GHC.Tc.Gen.Head                       lookupRecFieldOcc_update dup_fields_ok lbl            ; arg' <- if pun-                     then do { checkErr pun_ok (badPun (L loc lbl))+                     then do { checkErr pun_ok (TcRnIllegalFieldPunning (L (locA loc) lbl))                                -- Discard any module qualifier (#11662)                              ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)-                             ; return (L (noAnnSrcSpan loc) (HsVar noExtField-                                              (L (noAnnSrcSpan loc) arg_rdr))) }+                             ; return (L (l2l loc) (HsVar noExtField+                                              (L (l2l loc) arg_rdr))) }                      else return arg            ; (arg'', fvs) <- rnLExpr arg'             ; let (lbl', fvs') = case mb_sel of                    UnambiguousGre gname -> let sel_name = greNameMangledName gname-                                           in (Unambiguous sel_name (L (noAnnSrcSpan loc) lbl), fvs `addOneFV` sel_name)-                   AmbiguousFields       -> (Ambiguous   noExtField (L (noAnnSrcSpan loc) lbl), fvs)+                                           in (Unambiguous sel_name (L (l2l loc) lbl), fvs `addOneFV` sel_name)+                   AmbiguousFields       -> (Ambiguous   noExtField (L (l2l loc) lbl), fvs) -           ; return (L l (HsRecField { hsRecFieldAnn = noAnn-                                     , hsRecFieldLbl = L loc lbl'-                                     , hsRecFieldArg = arg''-                                     , hsRecPun      = pun }), fvs') }+           ; return (L l (HsFieldBind { hfbAnn = noAnn+                                      , hfbLHS = L loc lbl'+                                      , hfbRHS = arg''+                                      , hfbPun = pun }), fvs') }      dup_flds :: [NE.NonEmpty RdrName]         -- Each list represents a RdrName that occurred more than once@@ -802,41 +915,25 @@   getFieldIds :: [LHsRecField GhcRn arg] -> [Name]-getFieldIds flds = map (unLoc . hsRecFieldSel . unLoc) flds+getFieldIds flds = map (hsRecFieldSel . unLoc) flds  getFieldLbls :: forall p arg . UnXRec p => [LHsRecField p arg] -> [RdrName] getFieldLbls flds-  = map (unLoc . rdrNameFieldOcc . unLoc . hsRecFieldLbl . unXRec @p) flds+  = map (unXRec @p . foLabel . unXRec @p . hfbLHS . unXRec @p) flds  getFieldUpdLbls :: [LHsRecUpdField GhcPs] -> [RdrName]-getFieldUpdLbls flds = map (rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds--needFlagDotDot :: HsRecFieldContext -> SDoc-needFlagDotDot ctxt = vcat [text "Illegal `..' in record" <+> pprRFC ctxt,-                            text "Use RecordWildCards to permit this"]--badDotDotCon :: Name -> SDoc-badDotDotCon con-  = vcat [ text "Illegal `..' notation for constructor" <+> quotes (ppr con)-         , nest 2 (text "The constructor has no labelled fields") ]--emptyUpdateErr :: SDoc-emptyUpdateErr = text "Empty record update"+getFieldUpdLbls flds = map (rdrNameAmbiguousFieldOcc . unLoc . hfbLHS . unLoc) flds -badPun :: Located RdrName -> SDoc-badPun fld = vcat [text "Illegal use of punning for field" <+> quotes (ppr fld),-                   text "Use NamedFieldPuns to permit this"]+needFlagDotDot :: HsRecFieldContext -> TcRnMessage+needFlagDotDot = TcRnIllegalWildcardsInRecord . toRecordFieldPart -dupFieldErr :: HsRecFieldContext -> NE.NonEmpty RdrName -> SDoc-dupFieldErr ctxt dups-  = hsep [text "duplicate field name",-          quotes (ppr (NE.head dups)),-          text "in record", pprRFC ctxt]+dupFieldErr :: HsRecFieldContext -> NE.NonEmpty RdrName -> TcRnMessage+dupFieldErr ctxt = TcRnDuplicateFieldName (toRecordFieldPart ctxt) -pprRFC :: HsRecFieldContext -> SDoc-pprRFC (HsRecFieldCon {}) = text "construction"-pprRFC (HsRecFieldPat {}) = text "pattern"-pprRFC (HsRecFieldUpd {}) = text "update"+toRecordFieldPart :: HsRecFieldContext -> RecordFieldPart+toRecordFieldPart (HsRecFieldCon n)  = RecordFieldConstructor n+toRecordFieldPart (HsRecFieldPat n)  = RecordFieldPattern     n+toRecordFieldPart (HsRecFieldUpd {}) = RecordFieldUpdate  {- ************************************************************************@@ -851,7 +948,7 @@ -}  rnLit :: HsLit p -> RnM ()-rnLit (HsChar _ c) = checkErr (inCharRange c) (bogusCharError c)+rnLit (HsChar _ c) = checkErr (inCharRange c) (TcRnCharLiteralOutOfRange c) rnLit _ = return ()  -- | Turn a Fractional-looking literal which happens to be an integer into an@@ -898,31 +995,10 @@         ; let std_name = hsOverLitName val         ; (from_thing_name, fvs1) <- lookupSyntaxName std_name         ; let rebindable = from_thing_name /= std_name-              lit' = lit { ol_witness = nl_HsVar from_thing_name-                         , ol_ext = rebindable }+              lit' = lit { ol_ext = OverLitRn { ol_rebindable = rebindable+                                              , ol_from_fun = noLocA from_thing_name } }         ; if isNegativeZeroOverLit lit'           then do { (negate_name, fvs2) <- lookupSyntaxExpr negateName                   ; return ((lit' { ol_val = negateOverLitVal val }, Just negate_name)                                   , fvs1 `plusFV` fvs2) }           else return ((lit', Nothing), fvs1) }--{--************************************************************************-*                                                                      *-\subsubsection{Errors}-*                                                                      *-************************************************************************--}--patSigErr :: Outputable a => a -> SDoc-patSigErr ty-  =  (text "Illegal signature in pattern:" <+> ppr ty)-        $$ nest 4 (text "Use ScopedTypeVariables to permit it")--bogusCharError :: Char -> SDoc-bogusCharError c-  = text "character literal out of range: '\\" <> char c  <> char '\''--badViewPat :: Pat GhcPs -> SDoc-badViewPat pat = vcat [text "Illegal view pattern: " <+> ppr pat,-                       text "Use ViewPatterns to enable view patterns"]
compiler/GHC/Rename/Splice.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP          #-}+ {-# LANGUAGE TypeFamilies #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}@@ -6,27 +6,27 @@ module GHC.Rename.Splice (         rnTopSpliceDecls,         rnSpliceType, rnSpliceExpr, rnSplicePat, rnSpliceDecl,-        rnBracket,+        rnTypedBracket, rnUntypedBracket,         checkThLocalName         , traceSplice, SpliceInfo(..)   ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Types.Name import GHC.Types.Name.Set import GHC.Hs import GHC.Types.Name.Reader+import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Driver.Env.Types  import GHC.Rename.Env-import GHC.Rename.Utils   ( HsDocContext(..), newLocalBndrRn )+import GHC.Rename.Utils   ( newLocalBndrRn ) import GHC.Rename.Unbound ( isUnboundName ) import GHC.Rename.Module  ( rnSrcDecls, findSplice ) import GHC.Rename.Pat     ( rnPat )+import GHC.Types.Error import GHC.Types.Basic    ( TopLevelFlag, isTopLevel ) import GHC.Types.SourceText ( SourceText(..) ) import GHC.Utils.Outputable@@ -42,7 +42,7 @@  import GHC.Driver.Session import GHC.Data.FastString-import GHC.Utils.Logger  ( dumpIfSet_dyn_printer, DumpFormat (..), getLogger )+import GHC.Utils.Logger import GHC.Utils.Panic import GHC.Driver.Hooks import GHC.Builtin.Names.TH ( decsQTyConName, expQTyConName, liftName@@ -73,27 +73,30 @@ ************************************************************************ -} -rnBracket :: HsExpr GhcPs -> HsBracket GhcPs -> RnM (HsExpr GhcRn, FreeVars)-rnBracket e br_body-  = addErrCtxt (quotationCtxtDoc br_body) $-    do { -- Check that -XTemplateHaskellQuotes is enabled and available-         thQuotesEnabled <- xoptM LangExt.TemplateHaskellQuotes+-- Check that -XTemplateHaskellQuotes is enabled and available+checkForTemplateHaskellQuotes :: HsExpr GhcPs ->  RnM ()+checkForTemplateHaskellQuotes e =+    do { thQuotesEnabled <- xoptM LangExt.TemplateHaskellQuotes        ; unless thQuotesEnabled $-           failWith ( vcat+           failWith ( TcRnUnknownMessage $ mkPlainError noHints $ vcat                       [ text "Syntax error on" <+> ppr e                       , text ("Perhaps you intended to use TemplateHaskell"                               ++ " or TemplateHaskellQuotes") ] )+       } +rnTypedBracket :: HsExpr GhcPs -> LHsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)+rnTypedBracket e br_body+  = addErrCtxt (typedQuotationCtxtDoc br_body) $+    do { checkForTemplateHaskellQuotes e+          -- Check for nested brackets        ; cur_stage <- getStage        ; case cur_stage of-           { Splice Typed   -> checkTc (isTypedBracket br_body)-                                       illegalUntypedBracket-           ; Splice Untyped -> checkTc (not (isTypedBracket br_body))-                                       illegalTypedBracket+           { Splice Typed   -> return ()+           ; Splice Untyped -> failWithTc illegalTypedBracket            ; RunSplice _    ->                -- See Note [RunSplice ThLevel] in GHC.Tc.Types.-               pprPanic "rnBracket: Renaming bracket when running a splice"+               pprPanic "rnTypedBracket: Renaming typed bracket when running a splice"                         (ppr e)            ; Comp           -> return ()            ; Brack {}       -> failWithTc illegalBracket@@ -102,27 +105,50 @@          -- Brackets are desugared to code that mentions the TH package        ; recordThUse -       ; case isTypedBracket br_body of-            True  -> do { traceRn "Renaming typed TH bracket" empty-                        ; (body', fvs_e) <--                          setStage (Brack cur_stage RnPendingTyped) $-                                   rn_bracket cur_stage br_body-                        ; return (HsBracket noAnn body', fvs_e) }+       ; traceRn "Renaming typed TH bracket" empty+       ; (body', fvs_e) <- setStage (Brack cur_stage RnPendingTyped) $ rnLExpr br_body -            False -> do { traceRn "Renaming untyped TH bracket" empty-                        ; ps_var <- newMutVar []-                        ; (body', fvs_e) <--                          -- See Note [Rebindable syntax and Template Haskell]-                          unsetXOptM LangExt.RebindableSyntax $-                          setStage (Brack cur_stage (RnPendingUntyped ps_var)) $-                                   rn_bracket cur_stage br_body-                        ; pendings <- readMutVar ps_var-                        ; return (HsRnBracketOut noExtField body' pendings, fvs_e) }+       ; return (HsTypedBracket noExtField body', fvs_e)+        } -rn_bracket :: ThStage -> HsBracket GhcPs -> RnM (HsBracket GhcRn, FreeVars)-rn_bracket outer_stage br@(VarBr x flg rdr_name)+rnUntypedBracket :: HsExpr GhcPs -> HsQuote GhcPs -> RnM (HsExpr GhcRn, FreeVars)+rnUntypedBracket e br_body+  = addErrCtxt (untypedQuotationCtxtDoc br_body) $+    do { checkForTemplateHaskellQuotes e++         -- Check for nested brackets+       ; cur_stage <- getStage+       ; case cur_stage of+           { Splice Typed   -> failWithTc illegalUntypedBracket+           ; Splice Untyped -> return ()+           ; RunSplice _    ->+               -- See Note [RunSplice ThLevel] in GHC.Tc.Types.+               pprPanic "rnUntypedBracket: Renaming untyped bracket when running a splice"+                        (ppr e)+           ; Comp           -> return ()+           ; Brack {}       -> failWithTc illegalBracket+           }++         -- Brackets are desugared to code that mentions the TH package+       ; recordThUse++       ; traceRn "Renaming untyped TH bracket" empty+       ; ps_var <- newMutVar []+       ; (body', fvs_e) <-+         -- See Note [Rebindable syntax and Template Haskell]+         unsetXOptM LangExt.RebindableSyntax $+         setStage (Brack cur_stage (RnPendingUntyped ps_var)) $+                  rn_utbracket cur_stage br_body+       ; pendings <- readMutVar ps_var+       ; return (HsUntypedBracket pendings body', fvs_e)++       }++rn_utbracket :: ThStage -> HsQuote GhcPs -> RnM (HsQuote GhcRn, FreeVars)+rn_utbracket outer_stage br@(VarBr x flg rdr_name)   = do { name <- lookupOccRn (unLoc rdr_name)+       ; check_namespace flg name        ; this_mod <- getModule         ; when (flg && nameIsLocalOrFrom this_mod name) $@@ -136,7 +162,7 @@                              | isTopLevel top_lvl                              -> when (isExternalName name) (keepAlive name)                              | otherwise-                             -> do { traceRn "rn_bracket VarBr"+                             -> do { traceRn "rn_utbracket VarBr"                                       (ppr name <+> ppr bind_lvl                                                 <+> ppr outer_stage)                                    ; checkTc (thLevel outer_stage + 1 == bind_lvl)@@ -145,16 +171,16 @@                     }        ; return (VarBr x flg (noLocA name), unitFV name) } -rn_bracket _ (ExpBr x e) = do { (e', fvs) <- rnLExpr e-                            ; return (ExpBr x e', fvs) }+rn_utbracket _ (ExpBr x e) = do { (e', fvs) <- rnLExpr e+                                ; return (ExpBr x e', fvs) } -rn_bracket _ (PatBr x p)+rn_utbracket _ (PatBr x p)   = rnPat ThPatQuote p $ \ p' -> return (PatBr x p', emptyFVs) -rn_bracket _ (TypBr x t) = do { (t', fvs) <- rnLHsType TypBrCtx t-                              ; return (TypBr x t', fvs) }+rn_utbracket _ (TypBr x t) = do { (t', fvs) <- rnLHsType TypBrCtx t+                                ; return (TypBr x t', fvs) } -rn_bracket _ (DecBrL x decls)+rn_utbracket _ (DecBrL x decls)   = do { group <- groupDecls decls        ; gbl_env  <- getGblEnv        ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }@@ -164,7 +190,7 @@                               rnSrcDecls group                -- Discard the tcg_env; it contains only extra info about fixity-        ; traceRn "rn_bracket dec" (ppr (tcg_dus tcg_env) $$+        ; traceRn "rn_utbracket dec" (ppr (tcg_dus tcg_env) $$                    ppr (duUses (tcg_dus tcg_env)))         ; return (DecBrG x group', duUses (tcg_dus tcg_env)) }   where@@ -180,32 +206,45 @@                   }            }} -rn_bracket _ (DecBrG {}) = panic "rn_bracket: unexpected DecBrG"+rn_utbracket _ (DecBrG {}) = panic "rn_ut_bracket: unexpected DecBrG" -rn_bracket _ (TExpBr x e) = do { (e', fvs) <- rnLExpr e-                               ; return (TExpBr x e', fvs) } -quotationCtxtDoc :: HsBracket GhcPs -> SDoc-quotationCtxtDoc br_body+-- | Ensure that we are not using a term-level name in a type-level namespace+-- or vice-versa. Throws a 'TcRnIncorrectNameSpace' error if there is a problem.+check_namespace :: Bool -> Name -> RnM ()+check_namespace is_single_tick nm+  = unless (isValNameSpace ns == is_single_tick) $+      failWithTc $ (TcRnIncorrectNameSpace nm True)+  where+    ns = nameNameSpace nm++typedQuotationCtxtDoc :: LHsExpr GhcPs -> SDoc+typedQuotationCtxtDoc br_body+  = hang (text "In the Template Haskell typed quotation")+         2 (thTyBrackets . ppr $ br_body)++untypedQuotationCtxtDoc :: HsQuote GhcPs -> SDoc+untypedQuotationCtxtDoc br_body   = hang (text "In the Template Haskell quotation")          2 (ppr br_body) -illegalBracket :: SDoc-illegalBracket =+illegalBracket :: TcRnMessage+illegalBracket = TcRnUnknownMessage $ mkPlainError noHints $     text "Template Haskell brackets cannot be nested" <+>     text "(without intervening splices)" -illegalTypedBracket :: SDoc-illegalTypedBracket =+illegalTypedBracket :: TcRnMessage+illegalTypedBracket = TcRnUnknownMessage $ mkPlainError noHints $     text "Typed brackets may only appear in typed splices." -illegalUntypedBracket :: SDoc-illegalUntypedBracket =+illegalUntypedBracket :: TcRnMessage+illegalUntypedBracket = TcRnUnknownMessage $ mkPlainError noHints $     text "Untyped brackets may only appear in untyped splices." -quotedNameStageErr :: HsBracket GhcPs -> SDoc+quotedNameStageErr :: HsQuote GhcPs -> TcRnMessage quotedNameStageErr br-  = sep [ text "Stage error: the non-top-level quoted name" <+> ppr br+  = TcRnUnknownMessage $ mkPlainError noHints $+    sep [ text "Stage error: the non-top-level quoted name" <+> ppr br         , text "must be used at the same stage at which it is bound" ]  @@ -294,7 +333,8 @@   let (herald, ext) = spliceExtension splice   extEnabled <- xoptM ext   unless extEnabled-    (failWith $ text herald <+> text "are not permitted without" <+> ppr ext)+    (failWith $ TcRnUnknownMessage $ mkPlainError noHints $+       text herald <+> text "are not permitted without" <+> ppr ext)   where      spliceExtension :: HsSplice GhcPs -> (String, LangExt.Extension)      spliceExtension (HsQuasiQuote {}) = ("Quasi-quotes", LangExt.QuasiQuotes)@@ -451,11 +491,11 @@                 runRnSplice UntypedExpSplice runMetaE ppr rn_splice            ; (lexpr3, fvs) <- checkNoErrs (rnLExpr rn_expr)              -- See Note [Delaying modFinalizers in untyped splices].-           ; return ( HsPar noAnn $ HsSpliceE noAnn-                            . HsSpliced noExtField (ThModFinalizers mod_finalizers)-                            . HsSplicedExpr <$>-                            lexpr3-                    , fvs)+           ; let e =  HsSpliceE noAnn+                    . HsSpliced noExtField (ThModFinalizers mod_finalizers)+                    . HsSplicedExpr+                        <$> lexpr3+           ; return (gHsPar e, fvs)            }  {- Note [Running splices in the Renamer]@@ -695,12 +735,11 @@            ; (pat, mod_finalizers) <-                 runRnSplice UntypedPatSplice runMetaP ppr rn_splice              -- See Note [Delaying modFinalizers in untyped splices].-           ; return ( Left $ ParPat noAnn $ ((SplicePat noExtField)-                              . HsSpliced noExtField (ThModFinalizers mod_finalizers)-                              . HsSplicedPat)  `mapLoc`-                              pat-                    , emptyFVs-                    ) }+           ; let p =  SplicePat noExtField+                    . HsSpliced noExtField (ThModFinalizers mod_finalizers)+                    . HsSplicedPat+                        <$> pat+           ; return (Left $ gParPat p, emptyFVs) }               -- Wrap the result of the quasi-quoter in parens so that we don't               -- lose the outermost location set by runQuasiQuote (#7918) @@ -819,10 +858,8 @@        traceOptTcRn Opt_D_dump_splices (spliceDebugDoc loc)         when is_decl $ do -- Raw material for -dth-dec-file-        dflags <- getDynFlags         logger <- getLogger-        liftIO $ dumpIfSet_dyn_printer alwaysQualify logger dflags Opt_D_th_dec_file-                                       "" FormatHaskell (spliceCodeDoc loc)+        liftIO $ putDumpFileMaybe logger Opt_D_th_dec_file "" FormatHaskell (spliceCodeDoc loc)   where     -- `-ddump-splices`     spliceDebugDoc :: SrcSpan -> SDoc@@ -840,11 +877,13 @@       = vcat [ text "--" <+> ppr loc <> colon <+> text "Splicing" <+> text sd              , gen ] -illegalTypedSplice :: SDoc-illegalTypedSplice = text "Typed splices may not appear in untyped brackets"+illegalTypedSplice :: TcRnMessage+illegalTypedSplice = TcRnUnknownMessage $ mkPlainError noHints $+  text "Typed splices may not appear in untyped brackets" -illegalUntypedSplice :: SDoc-illegalUntypedSplice = text "Untyped splices may not appear in typed brackets"+illegalUntypedSplice :: TcRnMessage+illegalUntypedSplice = TcRnUnknownMessage $ mkPlainError noHints $+  text "Untyped splices may not appear in typed brackets"  checkThLocalName :: Name -> RnM () checkThLocalName name@@ -912,10 +951,7 @@               pend_splice = PendingRnSplice UntypedExpSplice name lift_expr            -- Warning for implicit lift (#17804)-        ; whenWOptM Opt_WarnImplicitLift $-            addWarnTc (Reason Opt_WarnImplicitLift)-                       (text "The variable" <+> quotes (ppr name) <+>-                        text "is implicitly lifted in the TH quotation")+        ; addDetailedDiagnostic (TcRnImplicitLift name)            -- Update the pending splices         ; ps <- readMutVar ps_var
compiler/GHC/Rename/Unbound.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE PatternSynonyms #-}+ {-  This module contains helper functions for reporting and creating@@ -9,12 +11,15 @@    , mkUnboundNameRdr    , isUnboundName    , reportUnboundName+   , reportUnboundName'    , unknownNameSuggestions+   , WhatLooking(..)    , WhereLooking(..)+   , LookingFor(..)    , unboundName    , unboundNameX    , notInScopeErr-   , exactNameErr+   , nameSpacesRelated    ) where @@ -23,14 +28,20 @@ import GHC.Driver.Session import GHC.Driver.Ppr +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Builtin.Names ( mkUnboundName, isUnboundName, getUnique)-import GHC.Utils.Outputable as Outputable import GHC.Utils.Misc  import GHC.Data.Maybe import GHC.Data.FastString +import qualified GHC.LanguageExtensions as LangExt++import GHC.Types.Hint+  ( GhcHint (SuggestExtension, RemindFieldSelectorSuppressed, ImportSuggestion, SuggestSimilarNames)+  , LanguageExtensionHint (SuggestSingleExtension)+  , ImportSuggestion(..), SimilarName(..), HowInScope(..) ) import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Name import GHC.Types.Name.Reader@@ -40,7 +51,11 @@ import GHC.Unit.Module.Imported import GHC.Unit.Home.ModInfo +import GHC.Data.Bag+import GHC.Utils.Outputable (empty)+ import Data.List (sortBy, partition, nub)+import Data.List.NonEmpty ( pattern (:|), NonEmpty ) import Data.Function ( on )  {-@@ -51,140 +66,141 @@ ************************************************************************ -} -data WhereLooking = WL_Any        -- Any binding+-- What kind of suggestion are we looking for? #19843+data WhatLooking = WL_Anything    -- Any binding+                 | WL_Constructor -- Constructors and pattern synonyms+                        -- E.g. in K { f1 = True }, if K is not in scope,+                        -- suggest only constructors+                 | WL_RecField    -- Record fields+                        -- E.g. in K { f1 = True, f2 = False }, if f2 is not in+                        -- scope, suggest only constructor fields+                 | WL_None        -- No suggestions+                        -- WS_None is used for rebindable syntax, where there+                        -- is no point in suggesting alternative spellings+                 deriving Eq++data WhereLooking = WL_Anywhere   -- Any binding                   | WL_Global     -- Any top-level binding (local or imported)                   | WL_LocalTop   -- Any top-level binding in this module                   | WL_LocalOnly                         -- Only local bindings-                        -- (pattern synonyms declaractions,-                        -- see Note [Renaming pattern synonym variables])+                        -- (pattern synonyms declarations,+                        -- see Note [Renaming pattern synonym variables]+                        -- in GHC.Rename.Bind) +data LookingFor = LF { lf_which :: WhatLooking+                     , lf_where :: WhereLooking+                     }+ mkUnboundNameRdr :: RdrName -> Name mkUnboundNameRdr rdr = mkUnboundName (rdrNameOcc rdr) +reportUnboundName' :: WhatLooking -> RdrName -> RnM Name+reportUnboundName' what_look rdr = unboundName (LF what_look WL_Anywhere) rdr+ reportUnboundName :: RdrName -> RnM Name-reportUnboundName rdr = unboundName WL_Any rdr+reportUnboundName = reportUnboundName' WL_Anything -unboundName :: WhereLooking -> RdrName -> RnM Name-unboundName wl rdr = unboundNameX wl rdr Outputable.empty+unboundName :: LookingFor -> RdrName -> RnM Name+unboundName lf rdr = unboundNameX lf rdr [] -unboundNameX :: WhereLooking -> RdrName -> SDoc -> RnM Name-unboundNameX where_look rdr_name extra+unboundNameX :: LookingFor -> RdrName -> [GhcHint] -> RnM Name+unboundNameX looking_for rdr_name hints   = do  { dflags <- getDynFlags         ; let show_helpful_errors = gopt Opt_HelpfulErrors dflags-              err = notInScopeErr rdr_name $$ extra+              err = notInScopeErr (lf_where looking_for) rdr_name         ; if not show_helpful_errors-          then addErr err+          then addErr $ TcRnNotInScope err rdr_name [] hints           else do { local_env  <- getLocalRdrEnv                   ; global_env <- getGlobalRdrEnv                   ; impInfo <- getImports                   ; currmod <- getModule                   ; hpt <- getHpt-                  ; let suggestions = unknownNameSuggestions_ where_look-                          dflags hpt currmod global_env local_env impInfo-                          rdr_name-                  ; addErr (err $$ suggestions) }+                  ; let (imp_errs, suggs) =+                          unknownNameSuggestions_ looking_for+                            dflags hpt currmod global_env local_env impInfo+                            rdr_name+                  ; addErr $+                      TcRnNotInScope err rdr_name imp_errs (hints ++ suggs) }         ; return (mkUnboundNameRdr rdr_name) } -notInScopeErr :: RdrName -> SDoc-notInScopeErr rdr_name-  = case isExact_maybe rdr_name of-      Just name -> exactNameErr name-      Nothing -> hang (text "Not in scope:")-                  2 (what <+> quotes (ppr rdr_name))-  where-    what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name)) -type HowInScope = Either SrcSpan ImpDeclSpec-     -- Left loc    =>  locally bound at loc-     -- Right ispec =>  imported as specified by ispec-+notInScopeErr :: WhereLooking -> RdrName -> NotInScopeError+notInScopeErr where_look rdr_name+  | Just name <- isExact_maybe rdr_name+  = NoExactName name+  | WL_LocalTop <- where_look+  = NoTopLevelBinding+  | otherwise+  = NotInScope  -- | Called from the typechecker ("GHC.Tc.Errors") when we find an unbound variable-unknownNameSuggestions :: DynFlags+unknownNameSuggestions :: WhatLooking -> DynFlags                        -> HomePackageTable -> Module                        -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails-                       -> RdrName -> SDoc-unknownNameSuggestions = unknownNameSuggestions_ WL_Any+                       -> RdrName -> ([ImportError], [GhcHint])+unknownNameSuggestions what_look = unknownNameSuggestions_ (LF what_look WL_Anywhere) -unknownNameSuggestions_ :: WhereLooking -> DynFlags+unknownNameSuggestions_ :: LookingFor -> DynFlags                        -> HomePackageTable -> Module                        -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails-                       -> RdrName -> SDoc-unknownNameSuggestions_ where_look dflags hpt curr_mod global_env local_env-                          imports tried_rdr_name =-    similarNameSuggestions where_look dflags global_env local_env tried_rdr_name $$-    importSuggestions where_look global_env hpt-                      curr_mod imports tried_rdr_name $$-    extensionSuggestions tried_rdr_name $$-    fieldSelectorSuggestions global_env tried_rdr_name+                       -> RdrName -> ([ImportError], [GhcHint])+unknownNameSuggestions_ looking_for dflags hpt curr_mod global_env local_env+                          imports tried_rdr_name = (imp_errs, suggs)+  where+    suggs = mconcat+      [ if_ne (SuggestSimilarNames tried_rdr_name) $+          similarNameSuggestions looking_for dflags global_env local_env tried_rdr_name+      , map ImportSuggestion imp_suggs+      , extensionSuggestions tried_rdr_name+      , fieldSelectorSuggestions global_env tried_rdr_name ]+    (imp_errs, imp_suggs) = importSuggestions looking_for global_env hpt curr_mod imports tried_rdr_name +    if_ne :: (NonEmpty a -> b) -> [a] -> [b]+    if_ne _ []       = []+    if_ne f (a : as) = [f (a :| as)]+ -- | When the name is in scope as field whose selector has been suppressed by -- NoFieldSelectors, display a helpful message explaining this.-fieldSelectorSuggestions :: GlobalRdrEnv -> RdrName -> SDoc+fieldSelectorSuggestions :: GlobalRdrEnv -> RdrName -> [GhcHint] fieldSelectorSuggestions global_env tried_rdr_name-  | null gres = Outputable.empty-  | otherwise = text "NB:"-      <+> quotes (ppr tried_rdr_name)-      <+> text "is a field selector" <+> whose-      $$ text "that has been suppressed by NoFieldSelectors"+  | null gres = []+  | otherwise = [RemindFieldSelectorSuppressed tried_rdr_name parents]   where     gres = filter isNoFieldSelectorGRE $                lookupGRE_RdrName' tried_rdr_name global_env     parents = [ parent | ParentIs parent <- map gre_par gres ] -    -- parents may be empty if this is a pattern synonym field without a selector-    whose | null parents = empty-          | otherwise    = text "belonging to the type" <> plural parents-                             <+> pprQuotedList parents--similarNameSuggestions :: WhereLooking -> DynFlags-                        -> GlobalRdrEnv -> LocalRdrEnv-                        -> RdrName -> SDoc-similarNameSuggestions where_look dflags global_env-                        local_env tried_rdr_name-  = case suggest of-      []  -> Outputable.empty-      [p] -> perhaps <+> pp_item p-      ps  -> sep [ perhaps <+> text "one of these:"-                 , nest 2 (pprWithCommas pp_item ps) ]+similarNameSuggestions :: LookingFor -> DynFlags+                       -> GlobalRdrEnv -> LocalRdrEnv+                       -> RdrName -> [SimilarName]+similarNameSuggestions looking_for@(LF what_look where_look) dflags global_env+                       local_env tried_rdr_name+  = fuzzyLookup (showPpr dflags tried_rdr_name) all_possibilities   where-    all_possibilities :: [(String, (RdrName, HowInScope))]-    all_possibilities-       =  [ (showPpr dflags r, (r, Left loc))-          | (r,loc) <- local_possibilities local_env ]-       ++ [ (showPpr dflags r, rp) | (r, rp) <- global_possibilities global_env ]--    suggest = fuzzyLookup (showPpr dflags tried_rdr_name) all_possibilities-    perhaps = text "Perhaps you meant"--    pp_item :: (RdrName, HowInScope) -> SDoc-    pp_item (rdr, Left loc) = pp_ns rdr <+> quotes (ppr rdr) <+> loc' -- Locally defined-        where loc' = case loc of-                     UnhelpfulSpan l -> parens (ppr l)-                     RealSrcSpan l _ -> parens (text "line" <+> int (srcSpanStartLine l))-    pp_item (rdr, Right is) = pp_ns rdr <+> quotes (ppr rdr) <+>   -- Imported-                              parens (text "imported from" <+> ppr (is_mod is))--    pp_ns :: RdrName -> SDoc-    pp_ns rdr | ns /= tried_ns = pprNameSpace ns-              | otherwise      = Outputable.empty-      where ns = rdrNameSpace rdr+    all_possibilities :: [(String, SimilarName)]+    all_possibilities = case what_look of+      WL_None -> []+      _ -> [ (showPpr dflags r, SimilarRdrName r (LocallyBoundAt loc))+           | (r,loc) <- local_possibilities local_env ]+        ++ [ (showPpr dflags r, rp) | (r, rp) <- global_possibilities global_env ]      tried_occ     = rdrNameOcc tried_rdr_name     tried_is_sym  = isSymOcc tried_occ     tried_ns      = occNameSpace tried_occ     tried_is_qual = isQual tried_rdr_name -    correct_name_space occ =  nameSpacesRelated (occNameSpace occ) tried_ns-                           && isSymOcc occ == tried_is_sym+    correct_name_space occ =+      (nameSpacesRelated dflags what_look tried_ns (occNameSpace occ))+      && isSymOcc occ == tried_is_sym         -- Treat operator and non-operators as non-matching         -- This heuristic avoids things like         --      Not in scope 'f'; perhaps you meant '+' (from Prelude) -    local_ok = case where_look of { WL_Any -> True+    local_ok = case where_look of { WL_Anywhere  -> True                                   ; WL_LocalOnly -> True-                                  ; _ -> False }+                                  ; _            -> False }+     local_possibilities :: LocalRdrEnv -> [(RdrName, SrcSpan)]     local_possibilities env       | tried_is_qual = []@@ -194,30 +210,29 @@                         , let occ = nameOccName name                         , correct_name_space occ] -    global_possibilities :: GlobalRdrEnv -> [(RdrName, (RdrName, HowInScope))]+    global_possibilities :: GlobalRdrEnv -> [(RdrName, SimilarName)]     global_possibilities global_env-      | tried_is_qual = [ (rdr_qual, (rdr_qual, how))+      | tried_is_qual = [ (rdr_qual, SimilarRdrName rdr_qual how)                         | gre <- globalRdrEnvElts global_env-                        , isGreOk where_look gre-                        , not (isNoFieldSelectorGRE gre)+                        , isGreOk looking_for gre                         , let occ = greOccName gre                         , correct_name_space occ                         , (mod, how) <- qualsInScope gre                         , let rdr_qual = mkRdrQual mod occ ] -      | otherwise = [ (rdr_unqual, pair)+      | otherwise = [ (rdr_unqual, sim)                     | gre <- globalRdrEnvElts global_env-                    , isGreOk where_look gre-                    , not (isNoFieldSelectorGRE gre)+                    , isGreOk looking_for gre                     , let occ = greOccName gre                           rdr_unqual = mkRdrUnqual occ                     , correct_name_space occ-                    , pair <- case (unquals_in_scope gre, quals_only gre) of-                                (how:_, _)    -> [ (rdr_unqual, how) ]+                    , sim <- case (unquals_in_scope gre, quals_only gre) of+                                (how:_, _)    -> [ SimilarRdrName rdr_unqual how ]                                 ([],    pr:_) -> [ pr ]  -- See Note [Only-quals]                                 ([],    [])   -> [] ]                -- Note [Only-quals]+              -- ~~~~~~~~~~~~~~~~~               -- The second alternative returns those names with the same               -- OccName as the one we tried, but live in *qualified* imports               -- e.g. if you have:@@ -230,97 +245,43 @@     --------------------     unquals_in_scope :: GlobalRdrElt -> [HowInScope]     unquals_in_scope (gre@GRE { gre_lcl = lcl, gre_imp = is })-      | lcl       = [ Left (greDefinitionSrcSpan gre) ]-      | otherwise = [ Right ispec-                    | i <- is, let ispec = is_decl i+      | lcl       = [ LocallyBoundAt (greDefinitionSrcSpan gre) ]+      | otherwise = [ ImportedBy ispec+                    | i <- bagToList is, let ispec = is_decl i                     , not (is_qual ispec) ]       ---------------------    quals_only :: GlobalRdrElt -> [(RdrName, HowInScope)]+    quals_only :: GlobalRdrElt -> [SimilarName]     -- Ones for which *only* the qualified version is in scope     quals_only (gre@GRE { gre_imp = is })-      = [ (mkRdrQual (is_as ispec) (greOccName gre), Right ispec)-        | i <- is, let ispec = is_decl i, is_qual ispec ]+      = [ (SimilarRdrName (mkRdrQual (is_as ispec) (greOccName gre)) (ImportedBy ispec))+        | i <- bagToList is, let ispec = is_decl i, is_qual ispec ] --- | Generate helpful suggestions if a qualified name Mod.foo is not in scope.-importSuggestions :: WhereLooking++-- | Generate errors and helpful suggestions if a qualified name Mod.foo is not in scope.+importSuggestions :: LookingFor                   -> GlobalRdrEnv                   -> HomePackageTable -> Module-                  -> ImportAvails -> RdrName -> SDoc-importSuggestions where_look global_env hpt currMod imports rdr_name-  | WL_LocalOnly <- where_look                 = Outputable.empty-  | not (isQual rdr_name || isUnqual rdr_name) = Outputable.empty+                  -> ImportAvails -> RdrName -> ([ImportError], [ImportSuggestion])+importSuggestions looking_for global_env hpt currMod imports rdr_name+  | WL_LocalOnly <- lf_where looking_for       = ([], [])+  | WL_LocalTop  <- lf_where looking_for       = ([], [])+  | not (isQual rdr_name || isUnqual rdr_name) = ([], [])   | null interesting_imports   , Just name <- mod_name   , show_not_imported_line name-  = hsep-      [ text "No module named"-      , quotes (ppr name)-      , text "is imported."-      ]-  | is_qualified-  , null helpful_imports-  , [(mod,_)] <- interesting_imports-  = hsep-      [ text "Module"-      , quotes (ppr mod)-      , text "does not export"-      , quotes (ppr occ_name) <> dot-      ]+  = ([MissingModule name], [])   | is_qualified   , null helpful_imports-  , not (null interesting_imports)-  , mods <- map fst interesting_imports-  = hsep-      [ text "Neither"-      , quotedListWithNor (map ppr mods)-      , text "exports"-      , quotes (ppr occ_name) <> dot-      ]-  | [(mod,imv)] <- helpful_imports_non_hiding-  = fsep-      [ text "Perhaps you want to add"-      , quotes (ppr occ_name)-      , text "to the import list"-      , text "in the import of"-      , quotes (ppr mod)-      , parens (ppr (imv_span imv)) <> dot-      ]-  | not (null helpful_imports_non_hiding)-  = fsep-      [ text "Perhaps you want to add"-      , quotes (ppr occ_name)-      , text "to one of these import lists:"-      ]-    $$-    nest 2 (vcat-        [ quotes (ppr mod) <+> parens (ppr (imv_span imv))-        | (mod,imv) <- helpful_imports_non_hiding-        ])-  | [(mod,imv)] <- helpful_imports_hiding-  = fsep-      [ text "Perhaps you want to remove"-      , quotes (ppr occ_name)-      , text "from the explicit hiding list"-      , text "in the import of"-      , quotes (ppr mod)-      , parens (ppr (imv_span imv)) <> dot-      ]-  | not (null helpful_imports_hiding)-  = fsep-      [ text "Perhaps you want to remove"-      , quotes (ppr occ_name)-      , text "from the hiding clauses"-      , text "in one of these imports:"-      ]-    $$-    nest 2 (vcat-        [ quotes (ppr mod) <+> parens (ppr (imv_span imv))-        | (mod,imv) <- helpful_imports_hiding-        ])+  , (mod : mods) <- map fst interesting_imports+  = ([ModulesDoNotExport (mod :| mods) occ_name], [])+  | mod : mods <- helpful_imports_non_hiding+  = ([], [CouldImportFrom (mod :| mods) occ_name])+  | mod : mods <- helpful_imports_hiding+  = ([], [CouldUnhideFrom (mod :| mods) occ_name])   | otherwise-  = Outputable.empty+  = ([], [])  where   is_qualified = isQual rdr_name   (mod_name, occ_name) = case rdr_name of@@ -352,17 +313,18 @@   -- wouldn't have an out-of-scope error in the first place)   helpful_imports = filter helpful interesting_imports     where helpful (_,imv)-            = not . null $ lookupGlobalRdrEnv (imv_all_exports imv) occ_name+            = any (isGreOk looking_for) $+              lookupGlobalRdrEnv (imv_all_exports imv) occ_name    -- Which of these do that because of an explicit hiding list resp. an   -- explicit import list   (helpful_imports_hiding, helpful_imports_non_hiding)     = partition (imv_is_hiding . snd) helpful_imports -  -- See note [When to show/hide the module-not-imported line]+  -- See Note [When to show/hide the module-not-imported line]   show_not_imported_line :: ModuleName -> Bool                    -- #15611   show_not_imported_line modnam-      | modnam `elem` globMods                = False    -- #14225     -- 1+      | modnam `elem` glob_mods               = False    -- #14225     -- 1       | moduleName currMod == modnam          = False                  -- 2.1       | is_last_loaded_mod modnam hpt_uniques = False                  -- 2.2       | otherwise                             = True@@ -370,35 +332,98 @@       hpt_uniques = map fst (udfmToList hpt)       is_last_loaded_mod _ []         = False       is_last_loaded_mod modnam uniqs = last uniqs == getUnique modnam-      globMods = nub [ mod+      glob_mods = nub [ mod                      | gre <- globalRdrEnvElts global_env-                     , isGreOk where_look gre                      , (mod, _) <- qualsInScope gre                      ] -extensionSuggestions :: RdrName -> SDoc+extensionSuggestions :: RdrName -> [GhcHint] extensionSuggestions rdrName   | rdrName == mkUnqual varName (fsLit "mdo") ||     rdrName == mkUnqual varName (fsLit "rec")-      = text "Perhaps you meant to use RecursiveDo"-  | otherwise = Outputable.empty+  = [SuggestExtension $ SuggestSingleExtension empty LangExt.RecursiveDo]+  | otherwise+  = []  qualsInScope :: GlobalRdrElt -> [(ModuleName, HowInScope)] -- Ones for which the qualified version is in scope qualsInScope gre@GRE { gre_lcl = lcl, gre_imp = is }       | lcl = case greDefinitionModule gre of                 Nothing -> []-                Just m  -> [(moduleName m, Left (greDefinitionSrcSpan gre))]-      | otherwise = [ (is_as ispec, Right ispec)-                    | i <- is, let ispec = is_decl i ]+                Just m  -> [(moduleName m, LocallyBoundAt (greDefinitionSrcSpan gre))]+      | otherwise = [ (is_as ispec, ImportedBy ispec)+                    | i <- bagToList is, let ispec = is_decl i ] -isGreOk :: WhereLooking -> GlobalRdrElt -> Bool-isGreOk where_look = case where_look of-                         WL_LocalTop  -> isLocalGRE-                         WL_LocalOnly -> const False-                         _            -> const True+isGreOk :: LookingFor -> GlobalRdrElt -> Bool+isGreOk (LF what_look where_look) gre = what_ok && where_ok+  where+    -- when looking for record fields, what_ok checks whether the GRE is a+    -- record field. Otherwise, it checks whether the GRE is a record field+    -- defined in a module with -XNoFieldSelectors - it wouldn't be a useful+    -- suggestion in that case.+    what_ok  = case what_look of+                 WL_RecField -> isRecFldGRE gre+                 _           -> not (isNoFieldSelectorGRE gre) -{- Note [When to show/hide the module-not-imported line]           -- #15611+    where_ok = case where_look of+                 WL_LocalTop  -> isLocalGRE gre+                 WL_LocalOnly -> False+                 _            -> True++-- see Note [Related name spaces]+nameSpacesRelated :: DynFlags    -- ^ to find out whether -XDataKinds is enabled+                  -> WhatLooking -- ^ What kind of name are we looking for+                  -> NameSpace   -- ^ Name space of the original name+                  -> NameSpace   -- ^ Name space of a name that might have been meant+                  -> Bool+nameSpacesRelated dflags what_looking ns ns'+  = ns' `elem` ns : [ other_ns+                    | (orig_ns, others) <- other_namespaces+                    , ns == orig_ns+                    , (other_ns, wls) <- others+                    , what_looking `elem` WL_Anything : wls+                    ]+  where+    -- explanation:+    -- [(orig_ns, [(other_ns, what_looking_possibilities)])]+    -- A particular other_ns is related if the original namespace is orig_ns+    -- and what_looking is either WL_Anything or is one of+    -- what_looking_possibilities+    other_namespaces =+      [ (varName  , [(dataName, [WL_Constructor])])+      , (dataName , [(varName , [WL_RecField])])+      , (tvName   , (tcClsName, [WL_Constructor]) : promoted_datacons)+      , (tcClsName, (tvName   , []) : promoted_datacons)+      ]+    -- If -XDataKinds is enabled, the data constructor name space is also+    -- related to the type-level name spaces+    data_kinds = xopt LangExt.DataKinds dflags+    promoted_datacons = [(dataName, [WL_Constructor]) | data_kinds]++{-+Note [Related name spaces]+~~~~~~~~~~~~~~~~~~~~~~~~~+Name spaces are related if there is a chance to mean the one when one writes+the other, i.e. variables <-> data constructors and type variables <-> type+constructors.++In most contexts, this mistake can happen in both directions. Not so in+patterns:++When a user writes+        foo (just a) = ...+It is possible that they meant to use `Just` instead. However, when they write+        foo (Map a) = ...+It is unlikely that they mean to use `map`, since variables cannot be used here.++Similarly, when we look for record fields, data constructors are not in a+related namespace.++Furthermore, with -XDataKinds, the data constructor name space is related to+the type variable and type constructor name spaces.++Note [When to show/hide the module-not-imported line]           -- #15611+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For the error message:     Not in scope X.Y     Module X does not export Y@@ -414,10 +439,3 @@        and we have to check the current module in the last added entry of        the HomePackageTable. (See test T15611b) -}--exactNameErr :: Name -> SDoc-exactNameErr name =-  hang (text "The exact Name" <+> quotes (ppr name) <+> ptext (sLit "is not in scope"))-    2 (vcat [ text "Probable cause: you used a unique Template Haskell name (NameU), "-            , text "perhaps via newName, but did not bind it"-            , text "If that's it, then -ddump-splices might be useful" ])
compiler/GHC/Rename/Utils.hs view
@@ -15,11 +15,12 @@         addFvRn, mapFvRn, mapMaybeFvRn,         warnUnusedMatches, warnUnusedTypePatterns,         warnUnusedTopBinds, warnUnusedLocalBinds,+        warnForallIdentifier,         checkUnusedRecordWildcard,         mkFieldEnv,-        unknownSubordinateErr, badQualBndrErr, typeAppErr,-        HsDocContext(..), pprHsDocContext,-        inHsDocContext, withHsDocContext,+        badQualBndrErr, typeAppErr, badFieldConErr,+        wrapGenSpan, genHsVar, genLHsVar, genHsApp, genHsApps, genAppType,+        genHsIntegralLit, genHsTyLit,          newLocalBndrRn, newLocalBndrsRn, @@ -39,14 +40,18 @@ import GHC.Core.Type import GHC.Hs import GHC.Types.Name.Reader+import GHC.Tc.Errors.Types+import GHC.Tc.Errors.Ppr (withHsDocContext) import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad+import GHC.Types.Error import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env import GHC.Core.DataCon import GHC.Types.SrcLoc as SrcLoc import GHC.Types.SourceFile+import GHC.Types.SourceText ( SourceText(..), IntegralLit ) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc@@ -60,6 +65,7 @@ import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE ) import qualified Data.List.NonEmpty as NE import qualified GHC.LanguageExtensions as LangExt+import GHC.Data.Bag  {- *********************************************************@@ -86,15 +92,14 @@ newLocalBndrsRn = mapM newLocalBndrRn  bindLocalNames :: [Name] -> RnM a -> RnM a-bindLocalNames names enclosed_scope-  = do { lcl_env <- getLclEnv-       ; let th_level  = thLevel (tcl_th_ctxt lcl_env)-             th_bndrs' = extendNameEnvList (tcl_th_bndrs lcl_env)-                           [ (n, (NotTopLevel, th_level)) | n <- names ]-             rdr_env'  = extendLocalRdrEnvList (tcl_rdr lcl_env) names-       ; setLclEnv (lcl_env { tcl_th_bndrs = th_bndrs'-                            , tcl_rdr      = rdr_env' })-                    enclosed_scope }+bindLocalNames names+  = updLclEnv $ \ lcl_env ->+    let th_level  = thLevel (tcl_th_ctxt lcl_env)+        th_bndrs' = extendNameEnvList (tcl_th_bndrs lcl_env)+                    [ (n, (NotTopLevel, th_level)) | n <- names ]+        rdr_env'  = extendLocalRdrEnvList (tcl_rdr lcl_env) names+    in lcl_env { tcl_th_bndrs = th_bndrs'+               , tcl_rdr      = rdr_env' }  bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) bindLocalNamesFV names enclosed_scope@@ -158,9 +163,9 @@     check_shadow n         | startsWithUnderscore occ = return ()  -- Do not report shadowing for "_x"                                                 -- See #3262-        | Just n <- mb_local = complain [text "bound at" <+> ppr (nameSrcLoc n)]+        | Just n <- mb_local = complain (ShadowedNameProvenanceLocal (nameSrcLoc n))         | otherwise = do { gres' <- filterM is_shadowed_gre gres-                         ; complain (map pprNameProvenance gres') }+                         ; when (not . null $ gres') $ complain (ShadowedNameProvenanceGlobal gres') }         where           (loc,occ) = get_loc_occ n           mb_local  = lookupLocalRdrOcc local_env occ@@ -168,17 +173,14 @@                 -- Make an Unqualified RdrName and look that up, so that                 -- we don't find any GREs that are in scope qualified-only -          complain []      = return ()-          complain pp_locs = addWarnAt (Reason Opt_WarnNameShadowing)-                                       loc-                                       (shadowedNameWarn occ pp_locs)+          complain provenance = addDiagnosticAt loc (TcRnShadowedName occ provenance)      is_shadowed_gre :: GlobalRdrElt -> RnM Bool         -- Returns False for record selectors that are shadowed, when         -- punning or wild-cards are on (cf #2723)     is_shadowed_gre gre | isRecFldGRE gre         = do { dflags <- getDynFlags-             ; return $ not (xopt LangExt.RecordPuns dflags+             ; return $ not (xopt LangExt.NamedFieldPuns dflags                              || xopt LangExt.RecordWildCards dflags) }     is_shadowed_gre _other = return True @@ -199,7 +201,7 @@   let bndrs = sig_ty_bndrs ty   in case find ((==) InferredSpec . hsTyVarBndrFlag) bndrs of     Nothing -> return ()-    Just _  -> addErr $ withHsDocContext ctxt msg+    Just _  -> addErr $ TcRnUnknownMessage $ mkPlainError noHints (withHsDocContext ctxt msg)   where     sig_ty_bndrs :: LHsSigType GhcPs -> [HsTyVarBndr Specificity GhcPs]     sig_ty_bndrs (L _ (HsSig{sig_bndrs = outer_bndrs}))@@ -308,7 +310,7 @@ addNoNestedForallsContextsErr :: HsDocContext -> SDoc -> LHsType GhcRn -> RnM () addNoNestedForallsContextsErr ctxt what lty =   whenIsJust (noNestedForallsContextsErr what lty) $ \(l, err_msg) ->-    addErrAt l $ withHsDocContext ctxt err_msg+    addErrAt l $ TcRnUnknownMessage $ mkPlainError noHints (withHsDocContext ctxt err_msg)  {- ************************************************************************@@ -385,9 +387,12 @@ -- The `..` here doesn't bind any variables as `x` is already bound. warnRedundantRecordWildcard :: RnM () warnRedundantRecordWildcard =-  whenWOptM Opt_WarnRedundantRecordWildcards-            (addWarn (Reason Opt_WarnRedundantRecordWildcards)-                     redundantWildcardWarning)+  whenWOptM Opt_WarnRedundantRecordWildcards $+    let msg = TcRnUnknownMessage $+                mkPlainDiagnostic (WarningWithFlag Opt_WarnRedundantRecordWildcards)+                                  noHints+                                  redundantWildcardWarning+    in addDiagnostic msg   -- | Produce a warning when no variables bound by a `..` pattern are used.@@ -404,7 +409,7 @@ warnUnusedRecordWildcard ns used_names = do   let used = filter (`elemNameSet` used_names) ns   traceRn "warnUnused" (ppr ns $$ ppr used_names $$ ppr used)-  warnIfFlag Opt_WarnUnusedRecordWildcards (null used)+  warnIf (null used)     unusedRecordWildcardWarning  @@ -420,6 +425,13 @@   = whenWOptM flag (warnUnused flag (filterOut (`elemNameSet` used_names)                                                bound_names)) +warnForallIdentifier :: LocatedN RdrName -> RnM ()+warnForallIdentifier (L l rdr_name@(Unqual occ))+  | isKw (fsLit "forall") || isKw (fsLit "∀")+  = addDiagnosticAt (locA l) (TcRnForallIdentifier rdr_name)+  where isKw = (occNameFS occ ==)+warnForallIdentifier _ = return ()+ ------------------------- --      Helpers warnUnusedGREs :: [GlobalRdrElt] -> RnM ()@@ -451,13 +463,13 @@         where            span = importSpecLoc spec            pp_mod = quotes (ppr (importSpecModule spec))-           msg = text "Imported from" <+> pp_mod <+> ptext (sLit "but not used")+           msg = text "Imported from" <+> pp_mod <+> text "but not used"  -- | Make a map from selector names to field labels and parent tycon -- names, to be used when reporting unused record fields. mkFieldEnv :: GlobalRdrEnv -> NameEnv (FieldLabelString, Parent) mkFieldEnv rdr_env = mkNameEnv [ (greMangledName gre, (flLabel fl, gre_par gre))-                               | gres <- occEnvElts rdr_env+                               | gres <- nonDetOccEnvElts rdr_env                                , gre <- gres                                , Just fl <- [greFieldLabel gre]                                ]@@ -474,15 +486,17 @@   | otherwise = not (startsWithUnderscore (occName child))  addUnusedWarning :: WarningFlag -> OccName -> SrcSpan -> SDoc -> RnM ()-addUnusedWarning flag occ span msg-  = addWarnAt (Reason flag) span $-    sep [msg <> colon,-         nest 2 $ pprNonVarNameSpace (occNameSpace occ)-                        <+> quotes (ppr occ)]+addUnusedWarning flag occ span msg = do+  let diag = TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag flag) noHints $+        sep [msg <> colon,+             nest 2 $ pprNonVarNameSpace (occNameSpace occ)+                            <+> quotes (ppr occ)]+  addDiagnosticAt span diag -unusedRecordWildcardWarning :: SDoc+unusedRecordWildcardWarning :: TcRnMessage unusedRecordWildcardWarning =-  wildcardDoc $ text "No variables bound in the record wildcard match are used"+  TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnUnusedRecordWildcards) noHints $+    wildcardDoc $ text "No variables bound in the record wildcard match are used"  redundantWildcardWarning :: SDoc redundantWildcardWarning =@@ -531,7 +545,8 @@   -- already, and we don't want an error cascade.   = return ()   | otherwise-  = addErr (vcat [ text "Ambiguous occurrence" <+> quotes (ppr rdr_name)+  = addErr $ TcRnUnknownMessage $ mkPlainError noHints $+    (vcat [ text "Ambiguous occurrence" <+> quotes (ppr rdr_name)                  , text "It could refer to"                  , nest 3 (vcat (msg1 : msgs)) ])   where@@ -561,7 +576,7 @@         pp_qual name                 | lcl                 = ppr (nameModule name)-                | imp : _ <- iss  -- This 'imp' is the one that+                | Just imp  <- headMaybe iss  -- This 'imp' is the one that                                   -- pprNameProvenance chooses                 , ImpDeclSpec { is_as = mod } <- is_decl imp                 = ppr mod@@ -581,22 +596,9 @@     num_non_flds = length non_flds  -shadowedNameWarn :: OccName -> [SDoc] -> SDoc-shadowedNameWarn occ shadowed_locs-  = sep [text "This binding for" <+> quotes (ppr occ)-            <+> text "shadows the existing binding" <> plural shadowed_locs,-         nest 2 (vcat shadowed_locs)]---unknownSubordinateErr :: SDoc -> RdrName -> SDoc-unknownSubordinateErr doc op    -- Doc is "method of class" or-                                -- "field of constructor"-  = quotes (ppr op) <+> text "is not a (visible)" <+> doc-- dupNamesErr :: Outputable n => (n -> SrcSpan) -> NE.NonEmpty n -> RnM () dupNamesErr get_loc names-  = addErrAt big_loc $+  = addErrAt big_loc $ TcRnUnknownMessage $ mkPlainError noHints $     vcat [text "Conflicting definitions for" <+> quotes (ppr (NE.head names)),           locations]   where@@ -604,16 +606,24 @@     big_loc   = foldr1 combineSrcSpans locs     locations = text "Bound at:" <+> vcat (map ppr (sortBy SrcLoc.leftmost_smallest locs)) -badQualBndrErr :: RdrName -> SDoc+badQualBndrErr :: RdrName -> TcRnMessage badQualBndrErr rdr_name-  = text "Qualified name in binding position:" <+> ppr rdr_name+  = TcRnUnknownMessage $ mkPlainError noHints $+  text "Qualified name in binding position:" <+> ppr rdr_name -typeAppErr :: String -> LHsType GhcPs -> SDoc+typeAppErr :: String -> LHsType GhcPs -> TcRnMessage typeAppErr what (L _ k)-  = hang (text "Illegal visible" <+> text what <+> text "application"+  = TcRnUnknownMessage $ mkPlainError noHints $+    hang (text "Illegal visible" <+> text what <+> text "application"             <+> quotes (char '@' <> ppr k))        2 (text "Perhaps you intended to use TypeApplications") +badFieldConErr :: Name -> FieldLabelString -> TcRnMessage+badFieldConErr con field+  = TcRnUnknownMessage $ mkPlainError noHints $+    hsep [text "Constructor" <+> quotes (ppr con),+          text "does not have field", quotes (ppr field)]+ -- | Ensure that a boxed or unboxed tuple has arity no larger than -- 'mAX_TUPLE_SIZE'. checkTupSize :: Int -> TcM ()@@ -621,9 +631,10 @@   | tup_size <= mAX_TUPLE_SIZE   = return ()   | otherwise-  = addErr (sep [text "A" <+> int tup_size <> ptext (sLit "-tuple is too large for GHC"),+  = addErr $ TcRnUnknownMessage $ mkPlainError noHints $+    sep [text "A" <+> int tup_size <> text "-tuple is too large for GHC",                  nest 2 (parens (text "max size is" <+> int mAX_TUPLE_SIZE)),-                 nest 2 (text "Workaround: use nested tuples or define a data type")])+                 nest 2 (text "Workaround: use nested tuples or define a data type")]  -- | Ensure that a constraint tuple has arity no larger than 'mAX_CTUPLE_SIZE'. checkCTupSize :: Int -> TcM ()@@ -631,76 +642,40 @@   | tup_size <= mAX_CTUPLE_SIZE   = return ()   | otherwise-  = addErr (hang (text "Constraint tuple arity too large:" <+> int tup_size+  = addErr $ TcRnUnknownMessage $ mkPlainError noHints $+    hang (text "Constraint tuple arity too large:" <+> int tup_size                   <+> parens (text "max arity =" <+> int mAX_CTUPLE_SIZE))-               2 (text "Instead, use a nested tuple"))-+               2 (text "Instead, use a nested tuple") -{--************************************************************************+{- ********************************************************************* *                                                                      *-\subsection{Contexts for renaming errors}+              Generating code for HsExpanded+      See Note [Handling overloaded and rebindable constructs] *                                                                      *-************************************************************************--}+********************************************************************* -} --- AZ:TODO: Change these all to be Name instead of RdrName.---          Merge TcType.UserTypeContext in to it.-data HsDocContext-  = TypeSigCtx SDoc-  | StandaloneKindSigCtx SDoc-  | PatCtx-  | SpecInstSigCtx-  | DefaultDeclCtx-  | ForeignDeclCtx (LocatedN RdrName)-  | DerivDeclCtx-  | RuleCtx FastString-  | TyDataCtx (LocatedN RdrName)-  | TySynCtx (LocatedN RdrName)-  | TyFamilyCtx (LocatedN RdrName)-  | FamPatCtx (LocatedN RdrName)    -- The patterns of a type/data family instance-  | ConDeclCtx [LocatedN Name]-  | ClassDeclCtx (LocatedN RdrName)-  | ExprWithTySigCtx-  | TypBrCtx-  | HsTypeCtx-  | HsTypePatCtx-  | GHCiCtx-  | SpliceTypeCtx (LHsType GhcPs)-  | ClassInstanceCtx-  | GenericCtx SDoc   -- Maybe we want to use this more!+wrapGenSpan :: a -> LocatedAn an a+-- Wrap something in a "generatedSrcSpan"+-- See Note [Rebindable syntax and HsExpansion]+wrapGenSpan x = L (noAnnSrcSpan generatedSrcSpan) x -withHsDocContext :: HsDocContext -> SDoc -> SDoc-withHsDocContext ctxt doc = doc $$ inHsDocContext ctxt+genHsApps :: Name -> [LHsExpr GhcRn] -> HsExpr GhcRn+genHsApps fun args = foldl genHsApp (genHsVar fun) args -inHsDocContext :: HsDocContext -> SDoc-inHsDocContext ctxt = text "In" <+> pprHsDocContext ctxt+genHsApp :: HsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn+genHsApp fun arg = HsApp noAnn (wrapGenSpan fun) arg -pprHsDocContext :: HsDocContext -> SDoc-pprHsDocContext (GenericCtx doc)      = doc-pprHsDocContext (TypeSigCtx doc)      = text "the type signature for" <+> doc-pprHsDocContext (StandaloneKindSigCtx doc) = text "the standalone kind signature for" <+> doc-pprHsDocContext PatCtx                = text "a pattern type-signature"-pprHsDocContext SpecInstSigCtx        = text "a SPECIALISE instance pragma"-pprHsDocContext DefaultDeclCtx        = text "a `default' declaration"-pprHsDocContext DerivDeclCtx          = text "a deriving declaration"-pprHsDocContext (RuleCtx name)        = text "the rewrite rule" <+> doubleQuotes (ftext name)-pprHsDocContext (TyDataCtx tycon)     = text "the data type declaration for" <+> quotes (ppr tycon)-pprHsDocContext (FamPatCtx tycon)     = text "a type pattern of family instance for" <+> quotes (ppr tycon)-pprHsDocContext (TySynCtx name)       = text "the declaration for type synonym" <+> quotes (ppr name)-pprHsDocContext (TyFamilyCtx name)    = text "the declaration for type family" <+> quotes (ppr name)-pprHsDocContext (ClassDeclCtx name)   = text "the declaration for class" <+> quotes (ppr name)-pprHsDocContext ExprWithTySigCtx      = text "an expression type signature"-pprHsDocContext TypBrCtx              = text "a Template-Haskell quoted type"-pprHsDocContext HsTypeCtx             = text "a type argument"-pprHsDocContext HsTypePatCtx          = text "a type argument in a pattern"-pprHsDocContext GHCiCtx               = text "GHCi input"-pprHsDocContext (SpliceTypeCtx hs_ty) = text "the spliced type" <+> quotes (ppr hs_ty)-pprHsDocContext ClassInstanceCtx      = text "GHC.Tc.Gen.Splice.reifyInstances"+genLHsVar :: Name -> LHsExpr GhcRn+genLHsVar nm = wrapGenSpan $ genHsVar nm -pprHsDocContext (ForeignDeclCtx name)-   = text "the foreign declaration for" <+> quotes (ppr name)-pprHsDocContext (ConDeclCtx [name])-   = text "the definition of data constructor" <+> quotes (ppr name)-pprHsDocContext (ConDeclCtx names)-   = text "the definition of data constructors" <+> interpp'SP names+genHsVar :: Name -> HsExpr GhcRn+genHsVar nm = HsVar noExtField $ wrapGenSpan nm++genAppType :: HsExpr GhcRn -> HsType (NoGhcTc GhcRn) -> HsExpr GhcRn+genAppType expr = HsAppType noExtField (wrapGenSpan expr) . mkEmptyWildCardBndrs . wrapGenSpan++genHsIntegralLit :: IntegralLit -> LocatedAn an (HsExpr GhcRn)+genHsIntegralLit lit = wrapGenSpan $ HsLit noAnn (HsInt noExtField lit)++genHsTyLit :: FastString -> HsType GhcRn+genHsTyLit = HsTyLit noExtField . HsStrTy NoSourceText
+ compiler/GHC/Runtime/Debugger.hs view
@@ -0,0 +1,270 @@+-----------------------------------------------------------------------------+--+-- GHCi Interactive debugging commands+--+-- Pepe Iborra (supported by Google SoC) 2006+--+-- ToDo: lots of violation of layering here.  This module should+-- decide whether it is above the GHC API (import GHC and nothing+-- else) or below it.+--+-----------------------------------------------------------------------------++module GHC.Runtime.Debugger (pprintClosureCommand, showTerm, pprTypeAndContents) where++import GHC.Prelude++import GHC++import GHC.Driver.Session+import GHC.Driver.Ppr+import GHC.Driver.Monad+import GHC.Driver.Env++import GHC.Linker.Loader++import GHC.Runtime.Heap.Inspect+import GHC.Runtime.Interpreter+import GHC.Runtime.Context++import GHC.Iface.Syntax ( showToHeader )+import GHC.Iface.Env    ( newInteractiveBinder )+import GHC.Core.Type++import GHC.Utils.Outputable+import GHC.Utils.Error+import GHC.Utils.Monad+import GHC.Utils.Exception+import GHC.Utils.Logger++import GHC.Types.Id+import GHC.Types.Id.Make (ghcPrimIds)+import GHC.Types.Name+import GHC.Types.Var hiding ( varName )+import GHC.Types.Var.Set+import GHC.Types.Unique.Set+import GHC.Types.TyThing.Ppr+import GHC.Types.TyThing++import Control.Monad+import Control.Monad.Catch as MC+import Data.List ( (\\), partition )+import Data.Maybe+import Data.IORef++-------------------------------------+-- | The :print & friends commands+-------------------------------------+pprintClosureCommand :: GhcMonad m => Bool -> Bool -> String -> m ()+pprintClosureCommand bindThings force str = do+  tythings <- (catMaybes . concat) `liftM`+                 mapM (\w -> GHC.parseName w >>=+                                mapM GHC.lookupName)+                      (words str)++  -- Sort out good and bad tythings for :print and friends+  let (pprintables, unpprintables) = partition can_pprint tythings++  -- Obtain the terms and the recovered type information+  let ids = [id | AnId id <- pprintables]+  (subst, terms) <- mapAccumLM go emptyTCvSubst ids++  -- Apply the substitutions obtained after recovering the types+  modifySession $ \hsc_env ->+    hsc_env{hsc_IC = substInteractiveContext (hsc_IC hsc_env) subst}++  -- Finally, print the Results+  docterms <- mapM showTerm terms+  let sdocTerms = zipWith (\id docterm -> ppr id <+> char '=' <+> docterm)+                          ids+                          docterms+  printSDocs $ (no_pprint <$> unpprintables) ++ sdocTerms+ where+   -- Check whether a TyThing can be processed by :print and friends.+   -- Take only Ids, exclude pseudoops, they don't have any HValues.+   can_pprint :: TyThing -> Bool                              -- #19394+   can_pprint (AnId x)+       | x `notElem` ghcPrimIds = True+       | otherwise              = False+   can_pprint _                 = False++   -- Create a short message for a TyThing, that cannot processed by :print+   no_pprint :: TyThing -> SDoc+   no_pprint tything = ppr tything <+>+          text "is not eligible for the :print, :sprint or :force commands."++   -- Helper to print out the results of :print and friends+   printSDocs :: GhcMonad m => [SDoc] -> m ()+   printSDocs sdocs = do+      logger <- getLogger+      unqual <- GHC.getPrintUnqual+      liftIO $ printOutputForUser logger unqual $ vcat sdocs++   -- Do the obtainTerm--bindSuspensions-computeSubstitution dance+   go :: GhcMonad m => TCvSubst -> Id -> m (TCvSubst, Term)+   go subst id = do+       let id' = updateIdTypeAndMult (substTy subst) id+           id_ty' = idType id'+       term_    <- GHC.obtainTermFromId maxBound force id'+       term     <- tidyTermTyVars term_+       term'    <- if bindThings+                     then bindSuspensions term+                     else return term+     -- Before leaving, we compare the type obtained to see if it's more specific+     --  Then, we extract a substitution,+     --  mapping the old tyvars to the reconstructed types.+       let reconstructed_type = termType term+       hsc_env <- getSession+       case (improveRTTIType hsc_env id_ty' reconstructed_type) of+         Nothing     -> return (subst, term')+         Just subst' -> do { logger <- getLogger+                           ; liftIO $+                               putDumpFileMaybe logger Opt_D_dump_rtti "RTTI"+                                 FormatText+                                 (fsep $ [text "RTTI Improvement for", ppr id,+                                  text "old substitution:" , ppr subst,+                                  text "new substitution:" , ppr subst'])+                           ; return (subst `unionTCvSubst` subst', term')}++   tidyTermTyVars :: GhcMonad m => Term -> m Term+   tidyTermTyVars t =+     withSession $ \hsc_env -> do+     let env_tvs      = tyThingsTyCoVars $ ic_tythings $ hsc_IC hsc_env+         my_tvs       = termTyCoVars t+         tvs          = env_tvs `minusVarSet` my_tvs+         tyvarOccName = nameOccName . tyVarName+         tidyEnv      = (initTidyOccEnv (map tyvarOccName (nonDetEltsUniqSet tvs))+           -- It's OK to use nonDetEltsUniqSet here because initTidyOccEnv+           -- forgets the ordering immediately by creating an env+                        , getUniqSet $ env_tvs `intersectVarSet` my_tvs)+     return $ mapTermType (snd . tidyOpenType tidyEnv) t++-- | Give names, and bind in the interactive environment, to all the suspensions+--   included (inductively) in a term+bindSuspensions :: GhcMonad m => Term -> m Term+bindSuspensions t = do+      hsc_env <- getSession+      inScope <- GHC.getBindings+      let ictxt        = hsc_IC hsc_env+          prefix       = "_t"+          alreadyUsedNames = map (occNameString . nameOccName . getName) inScope+          availNames   = map ((prefix++) . show) [(1::Int)..] \\ alreadyUsedNames+      availNames_var  <- liftIO $ newIORef availNames+      (t', stuff)     <- liftIO $ foldTerm (nameSuspensionsAndGetInfos hsc_env availNames_var) t+      let (names, tys, fhvs) = unzip3 stuff+      let ids = [ mkVanillaGlobal name ty+                | (name,ty) <- zip names tys]+          new_ic = extendInteractiveContextWithIds ictxt ids+          interp = hscInterp hsc_env+      liftIO $ extendLoadedEnv interp (zip names fhvs)+      setSession hsc_env {hsc_IC = new_ic }+      return t'+     where++--    Processing suspensions. Give names and recopilate info+        nameSuspensionsAndGetInfos :: HscEnv -> IORef [String]+                                   -> TermFold (IO (Term, [(Name,Type,ForeignHValue)]))+        nameSuspensionsAndGetInfos hsc_env freeNames = TermFold+                      {+                        fSuspension = doSuspension hsc_env freeNames+                      , fTerm = \ty dc v tt -> do+                                    tt' <- sequence tt+                                    let (terms,names) = unzip tt'+                                    return (Term ty dc v terms, concat names)+                      , fPrim    = \ty n ->return (Prim ty n,[])+                      , fNewtypeWrap  =+                                \ty dc t -> do+                                    (term, names) <- t+                                    return (NewtypeWrap ty dc term, names)+                      , fRefWrap = \ty t -> do+                                    (term, names) <- t+                                    return (RefWrap ty term, names)+                      }+        doSuspension hsc_env freeNames ct ty hval _name = do+          name <- atomicModifyIORef' freeNames (\x->(tail x, head x))+          n <- newGrimName hsc_env name+          return (Suspension ct ty hval (Just n), [(n,ty,hval)])+++--  A custom Term printer to enable the use of Show instances+showTerm :: GhcMonad m => Term -> m SDoc+showTerm term = do+    dflags       <- GHC.getSessionDynFlags+    if gopt Opt_PrintEvldWithShow dflags+       then cPprTerm (liftM2 (++) (\_y->[cPprShowable]) cPprTermBase) term+       else cPprTerm cPprTermBase term+ where+  cPprShowable prec t@Term{ty=ty, val=fhv} =+    if not (isFullyEvaluatedTerm t)+     then return Nothing+     else do+        let set_session = do+                hsc_env <- getSession+                (new_env, bname) <- bindToFreshName hsc_env ty "showme"+                setSession new_env++                -- this disables logging of errors+                let noop_log _ _ _ _ = return ()+                pushLogHookM (const noop_log)++                return (hsc_env, bname)++            reset_session (old_env,_) = setSession old_env++        MC.bracket set_session reset_session $ \(_,bname) -> do+           hsc_env <- getSession+           dflags  <- GHC.getSessionDynFlags+           let expr = "Prelude.return (Prelude.show " +++                         showPpr dflags bname +++                      ") :: Prelude.IO Prelude.String"+               interp = hscInterp hsc_env+           txt_ <- withExtendedLoadedEnv interp+                                       [(bname, fhv)]+                                       (GHC.compileExprRemote expr)+           let myprec = 10 -- application precedence. TODO Infix constructors+           txt <- liftIO $ evalString interp txt_+           if not (null txt) then+             return $ Just $ cparen (prec >= myprec && needsParens txt)+                                    (text txt)+            else return Nothing++  cPprShowable prec NewtypeWrap{ty=new_ty,wrapped_term=t} =+      cPprShowable prec t{ty=new_ty}+  cPprShowable _ _ = return Nothing++  needsParens ('"':_) = False   -- some simple heuristics to see whether parens+                                -- are redundant in an arbitrary Show output+  needsParens ('(':_) = False+  needsParens txt = ' ' `elem` txt+++  bindToFreshName hsc_env ty userName = do+    name <- newGrimName hsc_env userName+    let id       = mkVanillaGlobal name ty+        new_ic   = extendInteractiveContextWithIds (hsc_IC hsc_env) [id]+    return (hsc_env {hsc_IC = new_ic }, name)++--    Create new uniques and give them sequentially numbered names+newGrimName :: MonadIO m => HscEnv -> String -> m Name+newGrimName hsc_env userName+  = liftIO (newInteractiveBinder hsc_env occ noSrcSpan)+  where+    occ = mkOccName varName userName++pprTypeAndContents :: GhcMonad m => Id -> m SDoc+pprTypeAndContents id = do+  dflags  <- GHC.getSessionDynFlags+  let pcontents = gopt Opt_PrintBindContents dflags+      pprdId    = (pprTyThing showToHeader . AnId) id+  if pcontents+    then do+      let depthBound = 100+      -- If the value is an exception, make sure we catch it and+      -- show the exception, rather than propagating the exception out.+      e_term <- MC.try $ GHC.obtainTermFromId depthBound False id+      docs_term <- case e_term of+                      Right term -> showTerm term+                      Left  exn  -> return (text "*** Exception:" <+>+                                            text (show (exn :: SomeException)))+      return $ pprdId <+> equals <+> docs_term+    else return pprdId
compiler/GHC/Runtime/Eval.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE RecordWildCards #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}@@ -44,15 +44,15 @@         Term(..), obtainTermFromId, obtainTermFromVal, reconstructType         ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Driver.Monad import GHC.Driver.Main+import GHC.Driver.Errors.Types ( hoistTcRnMessage ) import GHC.Driver.Env import GHC.Driver.Session import GHC.Driver.Ppr+import GHC.Driver.Config  import GHC.Runtime.Eval.Types import GHC.Runtime.Interpreter as GHCi@@ -81,7 +81,6 @@ import GHC.Tc.Types.Origin  import GHC.Builtin.Names ( toDynName, pretendNameIsInScope )-import GHC.Builtin.Types ( isCTupleTyConName )  import GHC.Data.Maybe import GHC.Data.FastString@@ -93,6 +92,7 @@ import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Logger+import GHC.Utils.Trace  import GHC.Types.RepType import GHC.Types.Fixity.Env@@ -105,7 +105,10 @@ import GHC.Types.SrcLoc import GHC.Types.Unique import GHC.Types.Unique.Supply+import GHC.Types.Unique.DSet import GHC.Types.TyThing+import GHC.Types.BreakInfo+import GHC.Types.Unique.Map  import GHC.Unit import GHC.Unit.Module.Graph@@ -119,7 +122,6 @@ import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Data.List (find,intercalate)-import qualified Data.Map as Map import Control.Monad import Control.Monad.Catch as MC import Data.Array@@ -133,6 +135,7 @@ import GHC.Tc.Solver (simplifyWantedsTcM) import GHC.Tc.Utils.Monad import GHC.Core.Class (classTyCon)+import GHC.Unit.Env  -- ----------------------------------------------------------------------------- -- running a statement interactively@@ -149,7 +152,7 @@ getHistorySpan :: HscEnv -> History -> SrcSpan getHistorySpan hsc_env History{..} =   let BreakInfo{..} = historyBreakInfo in-  case lookupHpt (hsc_HPT hsc_env) (moduleName breakInfo_module) of+  case lookupHugByModule breakInfo_module (hsc_HUG hsc_env) of     Just hmi -> modBreaks_locs (getModBreaks hmi) ! breakInfo_number     _ -> panic "getHistorySpan" @@ -160,7 +163,7 @@ findEnclosingDecls :: HscEnv -> BreakInfo -> [String] findEnclosingDecls hsc_env (BreakInfo modl ix) =    let hmi = expectJust "findEnclosingDecls" $-             lookupHpt (hsc_HPT hsc_env) (moduleName modl)+             lookupHugByModule modl (hsc_HUG hsc_env)        mb = getModBreaks hmi    in modBreaks_decls mb ! ix @@ -227,11 +230,12 @@          status <-           withVirtualCWD $-            liftIO $-              evalStmt interp idflags' (isStep execSingleStep) (execWrap hval)+            liftIO $ do+              let eval_opts = initEvalOpts idflags' (isStep execSingleStep)+              evalStmt interp eval_opts (execWrap hval)          let ic = hsc_IC hsc_env-            bindings = (ic_tythings ic, ic_rn_gbl_env ic)+            bindings = (ic_tythings ic, ic_gre_cache ic)              size = ghciHistSize idflags' @@ -308,7 +312,9 @@ emptyHistory size = nilBL size  handleRunStatus :: GhcMonad m-                => SingleStep -> String-> ([TyThing],GlobalRdrEnv) -> [Id]+                => SingleStep -> String+                -> ResumeBindings+                -> [Id]                 -> EvalStatus_ [ForeignHValue] [HValueRef]                 -> BoundedList History                 -> m ExecResult@@ -342,7 +348,8 @@                !history' = mkHistory hsc_env apStack_fhv bi `consBL` history                  -- history is strict, otherwise our BoundedList is pointless.            fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt-           status <- liftIO $ GHCi.resumeStmt interp dflags True fhv+           let eval_opts = initEvalOpts dflags True+           status <- liftIO $ GHCi.resumeStmt interp eval_opts fhv            handleRunStatus RunAndLogSteps expr bindings final_ids                            status history'     | otherwise@@ -415,9 +422,9 @@         -- unbind the temporary locals by restoring the TypeEnv from         -- before the breakpoint, and drop this Resume from the         -- InteractiveContext.-        let (resume_tmp_te,resume_rdr_env) = resumeBindings r+        let (resume_tmp_te,resume_gre_cache) = resumeBindings r             ic' = ic { ic_tythings = resume_tmp_te,-                       ic_rn_gbl_env = resume_rdr_env,+                       ic_gre_cache = resume_gre_cache,                        ic_resume   = rs }         setSession hsc_env{ hsc_IC = ic' } @@ -442,7 +449,8 @@                   setupBreakpoint hsc_env (fromJust mb_brkpt) (fromJust mbCnt)                     -- When the user specified a break ignore count, set it                     -- in the interpreter-                status <- liftIO $ GHCi.resumeStmt interp dflags (isStep step) fhv+                let eval_opts = initEvalOpts dflags (isStep step)+                status <- liftIO $ GHCi.resumeStmt interp eval_opts fhv                 let prevHistoryLst = fromListBL 50 hist                     hist' = case mb_brkpt of                        Nothing -> prevHistoryLst@@ -566,7 +574,7 @@         (ids, offsets, occs') = syncOccs mbPointers occs -       free_tvs = tyCoVarsOfTypesList (result_ty:map idType ids)+       free_tvs = tyCoVarsOfTypesWellScoped (result_ty:map idType ids)     -- It might be that getIdValFromApStack fails, because the AP_STACK    -- has been accidentally evaluated, or something else has gone wrong.@@ -575,7 +583,7 @@    mb_hValues <-       mapM (getBreakpointVar interp apStack_fhv . fromIntegral) offsets    when (any isNothing mb_hValues) $-      debugTraceMsg (hsc_logger hsc_env) (hsc_dflags hsc_env) 1 $+      debugTraceMsg (hsc_logger hsc_env) 1 $           text "Warning: _result has been evaluated, some bindings have been lost"     us <- mkSplitUniqSupply 'I'   -- Dodgy; will give the same uniques every time@@ -616,10 +624,11 @@    newTyVars :: UniqSupply -> [TcTyVar] -> TCvSubst      -- Similarly, clone the type variables mentioned in the types      -- we have here, *and* make them all RuntimeUnk tyvars-   newTyVars us tvs-     = mkTvSubstPrs [ (tv, mkTyVarTy (mkRuntimeUnkTyVar name (tyVarKind tv)))-                    | (tv, uniq) <- tvs `zip` uniqsFromSupply us-                    , let name = setNameUnique (tyVarName tv) uniq ]+   newTyVars us tvs = foldl' new_tv emptyTCvSubst (tvs `zip` uniqsFromSupply us)+   new_tv subst (tv,uniq) = extendTCvSubstWithClone subst tv new_tv+    where+     new_tv = mkRuntimeUnkTyVar (setNameUnique (tyVarName tv) uniq)+                                (substTy subst (tyVarKind tv))     isPointer id | [rep] <- typePrimRep (idType id)                 , isGcPtrRep rep                   = True@@ -662,12 +671,11 @@              Just new_ty -> do               case improveRTTIType hsc_env old_ty new_ty of                Nothing -> return $-                        WARN(True, text (":print failed to calculate the "-                                           ++ "improvement for a type")) hsc_env+                        warnPprTrace True (":print failed to calculate the "+                                           ++ "improvement for a type") empty hsc_env                Just subst -> do-                 let dflags = hsc_dflags hsc_env                  let logger = hsc_logger hsc_env-                 dumpIfSet_dyn logger dflags Opt_D_dump_rtti "RTTI"+                 putDumpFileMaybe logger Opt_D_dump_rtti "RTTI"                    FormatText                    (fsep [text "RTTI Improvement for", ppr id, equals,                           ppr subst])@@ -684,7 +692,7 @@    {-   Note [Syncing breakpoint info]-+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~   To display the values of the free variables for a single breakpoint, the   function `GHC.Runtime.Eval.bindLocalsAtBreakpoint` pulls   out the information from the fields `modBreaks_breakInfo` and@@ -770,7 +778,7 @@ -- -- (setContext imports) sets the ic_imports field (which in turn -- determines what is in scope at the prompt) to 'imports', and--- constructs the ic_rn_glb_env environment to reflect it.+-- updates the icReaderEnv environment to reflect it. -- -- We retain in scope all the things defined at the prompt, and kept -- in ic_tythings.  (Indeed, they shadow stuff from ic_imports.)@@ -785,10 +793,10 @@                liftIO $ throwGhcExceptionIO (formatError dflags mod err)            Right all_env -> do {        ; let old_ic         = hsc_IC hsc_env-             !final_rdr_env = all_env `icExtendGblRdrEnv` ic_tythings old_ic+             !final_gre_cache = ic_gre_cache old_ic `replaceImportEnv` all_env        ; setSession-         hsc_env{ hsc_IC = old_ic { ic_imports    = imports-                                  , ic_rn_gbl_env = final_rdr_env }}}}+         hsc_env{ hsc_IC = old_ic { ic_imports   = imports+                                  , ic_gre_cache = final_gre_cache }}}}   where     formatError dflags mod err = ProgramError . showSDoc dflags $       text "Cannot add module" <+> ppr mod <+>@@ -853,7 +861,7 @@        case mb_stuff of          Nothing -> return Nothing          Just (thing, fixity, cls_insts, fam_insts, docs) -> do-           let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env)+           let rdr_env = icReaderEnv (hsc_IC hsc_env)             -- Filter the instances based on whether the constituent names of their            -- instance heads are all in scope.@@ -862,7 +870,7 @@            return (Just (thing, fixity, cls_insts', fam_insts', docs))   where     plausible rdr_env names-          -- Dfun involving only names that are in ic_rn_glb_env+          -- Dfun involving only names that are in icReaderEnv         = allInfo        || nameSetAll ok names         where   -- A name is ok if it's in the rdr_env,@@ -870,15 +878,14 @@           ok n | n == name              = True                        -- The one we looked for in the first place!                | pretendNameIsInScope n = True-               | isBuiltInSyntax n      = True-               | isCTupleTyConName n    = True+                   -- See Note [pretendNameIsInScope] in GHC.Builtin.Names                | isExternalName n       = isJust (lookupGRE_Name rdr_env n)                | otherwise              = True  -- | Returns all names in scope in the current interactive context getNamesInScope :: GhcMonad m => m [Name] getNamesInScope = withSession $ \hsc_env ->-  return (map greMangledName (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))+  return (map greMangledName (globalRdrEnvElts (icReaderEnv (hsc_IC hsc_env))))  -- | Returns all 'RdrName's in scope in the current interactive -- context, excluding any that are internally-generated.@@ -886,7 +893,7 @@ getRdrNamesInScope = withSession $ \hsc_env -> do   let       ic = hsc_IC hsc_env-      gbl_rdrenv = ic_rn_gbl_env ic+      gbl_rdrenv = icReaderEnv ic       gbl_names = concatMap greRdrNames $ globalRdrEnvElts gbl_rdrenv   -- Exclude internally generated names; see e.g. #11328   return (filter (not . isDerivedOccName . rdrNameOcc) gbl_names)@@ -902,7 +909,7 @@  getDocs :: GhcMonad m         => Name-        -> m (Either GetDocsFailure (Maybe HsDocString, IntMap HsDocString))+        -> m (Either GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn)))            -- TODO: What about docs for constructors etc.? getDocs name =   withSession $ \hsc_env -> do@@ -912,14 +919,14 @@          if isInteractiveModule mod            then pure (Left InteractiveName)            else do-             ModIface { mi_doc_hdr = mb_doc_hdr-                      , mi_decl_docs = DeclDocMap dmap-                      , mi_arg_docs = ArgDocMap amap-                      } <- liftIO $ hscGetModuleInterface hsc_env mod-             if isNothing mb_doc_hdr && Map.null dmap && Map.null amap-               then pure (Left (NoDocsInIface mod compiled))-               else pure (Right ( Map.lookup name dmap-                                , Map.findWithDefault mempty name amap))+             iface <- liftIO $ hscGetModuleInterface hsc_env mod+             case mi_docs iface of+               Nothing -> pure (Left (NoDocsInIface mod compiled))+               Just Docs { docs_decls = decls+                         , docs_args = args+                         } ->+                 pure (Right ( lookupUniqMap decls name+                             , fromMaybe mempty $ lookupUniqMap args name))   where     compiled =       -- TODO: Find a more direct indicator.@@ -928,16 +935,12 @@         UnhelpfulLoc {} -> True  -- | Failure modes for 'getDocs'.---- TODO: Find a way to differentiate between modules loaded without '-haddock'--- and modules that contain no docs. data GetDocsFailure      -- | 'nameModule_maybe' returned 'Nothing'.   = NameHasNoModule Name -    -- | This is probably because the module was loaded without @-haddock@,-    -- but it's also possible that the entire module contains no documentation.+    -- | The module was loaded without @-haddock@,   | NoDocsInIface       Module       Bool -- ^ 'True': The module was compiled.@@ -951,11 +954,6 @@     quotes (ppr name) <+> text "has no module where we could look for docs."   ppr (NoDocsInIface mod compiled) = vcat     [ text "Can't find any documentation for" <+> ppr mod <> char '.'-    , text "This is probably because the module was"-        <+> text (if compiled then "compiled" else "loaded")-        <+> text "without '-haddock',"-    , text "but it's also possible that the module contains no documentation."-    , text ""     , if compiled         then text "Try re-compiling with '-haddock'."         else text "Try running ':set -haddock' and :load the file again."@@ -1032,7 +1030,7 @@ getInstancesForType :: GhcMonad m => Type -> m [ClsInst] getInstancesForType ty = withSession $ \hsc_env ->   liftIO $ runInteractiveHsc hsc_env $-    ioMsgMaybe $ runTcInteractive hsc_env $ do+    ioMsgMaybe $ hoistTcRnMessage $ runTcInteractive hsc_env $ do       -- Bring class and instances from unqualified modules into scope, this fixes #16793.       loadUnqualIfaces hsc_env (hsc_IC hsc_env)       matches <- findMatchingInstances ty@@ -1045,7 +1043,7 @@   (ty, _) <- liftIO $ runInteractiveHsc hsc_env0 $ do     hsc_env <- getHscEnv     ty <- hscParseType str-    ioMsgMaybe $ tcRnType hsc_env SkolemiseFlexi True ty+    ioMsgMaybe $ hoistTcRnMessage $ tcRnType hsc_env SkolemiseFlexi True ty    return ty @@ -1054,24 +1052,20 @@ getDictionaryBindings theta = do   dictName <- newName (mkDictOcc (mkVarOcc "magic"))   let dict_var = mkVanillaGlobal dictName theta-  loc <- getCtLocM (GivenOrigin UnkSkol) Nothing+  loc <- getCtLocM (GivenOrigin (getSkolemInfo unkSkol)) Nothing -  -- Generate a wanted here because at the end of constraint-  -- solving, most derived constraints get thrown away, which in certain-  -- cases, notably with quantified constraints makes it impossible to rule-  -- out instances as invalid. (See #18071)   return CtWanted {     ctev_pred = varType dict_var,     ctev_dest = EvVarDest dict_var,-    ctev_nosh = WDeriv,-    ctev_loc = loc+    ctev_loc = loc,+    ctev_rewriters = emptyRewriterSet   }  -- Find instances where the head unifies with the provided type findMatchingInstances :: Type -> TcM [(ClsInst, [DFunInstType])] findMatchingInstances ty = do   ies@(InstEnvs {ie_global = ie_global, ie_local = ie_local}) <- tcGetInstEnvs-  let allClasses = instEnvClasses ie_global ++ instEnvClasses ie_local+  let allClasses = uniqDSetToList $ instEnvClasses ie_global `unionUniqDSets` instEnvClasses ie_local   return $ concatMap (try_cls ies) allClasses   where   {- Check that a class instance is well-kinded.@@ -1125,13 +1119,19 @@   -- which otherwise appear as opaque type variables. (See #18262).   WC { wc_simple = simples, wc_impl = impls } <- simplifyWantedsTcM wanteds -  if allBag allowedSimple simples && solvedImplics impls-  then return . Just $ substInstArgs tys (bagToList (mapBag ctPred simples)) clsInst+  -- The simples might contain superclasses. This clutters up the output+  -- (we want e.g. instance Ord a => Ord (Maybe a), not+  -- instance (Ord a, Eq a) => Ord (Maybe a)). So we use mkMinimalBySCs+  let simple_preds = map ctPred (bagToList simples)+  let minimal_simples = mkMinimalBySCs id simple_preds++  if all allowedSimple minimal_simples && solvedImplics impls+  then return . Just $ substInstArgs tys minimal_simples clsInst   else return Nothing    where-  allowedSimple :: Ct -> Bool-  allowedSimple ct = isSatisfiablePred (ctPred ct)+  allowedSimple :: PredType -> Bool+  allowedSimple pred = isSatisfiablePred pred    solvedImplics :: Bag Implication -> Bool   solvedImplics impls = allBag (isSolvedStatus . ic_status) impls@@ -1211,7 +1211,8 @@         _ -> panic "compileParsedExprRemote"    updateFixityEnv fix_env-  status <- liftIO $ evalStmt interp dflags False (EvalThis hvals_io)+  let eval_opts = initEvalOpts dflags False+  status <- liftIO $ evalStmt interp eval_opts (EvalThis hvals_io)   case status of     EvalComplete _ (EvalSuccess [hval]) -> return hval     EvalComplete _ (EvalException e) ->@@ -1243,8 +1244,7 @@     withSession $ \hsc_env -> do         interpreted <- moduleIsBootOrNotObjectLinkable mod_summary         let dflags = hsc_dflags hsc_env-        -- extendModSummaryNoDeps because the message doesn't look at the deps-        return (showSDoc dflags $ showModMsg dflags interpreted (ModuleNode (extendModSummaryNoDeps mod_summary)))+        return (showSDoc dflags $ showModMsg dflags interpreted (ModuleNode [] mod_summary))  moduleIsBootOrNotObjectLinkable :: GhcMonad m => ModSummary -> m Bool moduleIsBootOrNotObjectLinkable mod_summary = withSession $ \hsc_env ->@@ -1271,13 +1271,13 @@  obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term obtainTermFromId hsc_env bound force id =  do-  hv <- Loader.loadName (hscInterp hsc_env) hsc_env (varName id)+  (hv, _, _) <- Loader.loadName (hscInterp hsc_env) hsc_env (varName id)   cvObtainTerm hsc_env bound force (idType id) hv  -- Uses RTTI to reconstruct the type of an Id, making it less polymorphic reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type) reconstructType hsc_env bound id = do-  hv <- Loader.loadName (hscInterp hsc_env) hsc_env (varName id)+  (hv, _, _) <- Loader.loadName (hscInterp hsc_env) hsc_env (varName id)   cvReconstructType hsc_env bound (idType id) hv  mkRuntimeUnkTyVar :: Name -> Kind -> TyVar
compiler/GHC/Runtime/Heap/Inspect.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables, MagicHash #-}+{-# LANGUAGE BangPatterns, ScopedTypeVariables, MagicHash #-}  ----------------------------------------------------------------------------- --@@ -23,8 +23,6 @@      constrClosToName -- exported to use in test T4891  ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Platform @@ -60,6 +58,7 @@ import GHC.Driver.Ppr import GHC.Utils.Outputable as Ppr import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Char import GHC.Exts.Heap import GHC.Runtime.Heap.Layout ( roundUpTo )@@ -134,7 +133,7 @@ constrClosToName hsc_env ConstrClosure{pkg=pkg,modl=mod,name=occ} = do    let occName = mkOccName OccName.dataName occ        modName = mkModule (stringToUnit pkg) (mkModuleName mod)-   Right `fmap` lookupOrigIO hsc_env modName occName+   Right `fmap` lookupNameCache (hsc_NC hsc_env) modName occName constrClosToName _hsc_env clos =    return (Left ("conClosToName: Expected ConstrClosure, got " ++ show (fmap (const ()) clos))) @@ -267,17 +266,16 @@ ppr_termM1 Prim{valRaw=words, ty=ty} =     return $ repPrim (tyConAppTyCon ty) words ppr_termM1 Suspension{ty=ty, bound_to=Nothing} =-    return (char '_' <+> whenPprDebug (text "::" <> ppr ty))+    return (char '_' <+> whenPprDebug (dcolon <> pprSigmaType ty)) ppr_termM1 Suspension{ty=ty, bound_to=Just n}---  | Just _ <- splitFunTy_maybe ty = return$ ptext (sLit("<function>")-  | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty+  | otherwise = return$ parens$ ppr n <> dcolon <> pprSigmaType ty ppr_termM1 Term{}        = panic "ppr_termM1 - Term" ppr_termM1 RefWrap{}     = panic "ppr_termM1 - RefWrap" ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap"  pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}   | Just (tc,_) <- tcSplitTyConApp_maybe ty-  , ASSERT(isNewTyCon tc) True+  , assert (isNewTyCon tc) True   , Just new_dc <- tyConSingleDataCon_maybe tc = do              real_term <- y max_prec t              return $ cparen (p >= app_prec) (ppr new_dc <+> real_term)@@ -519,10 +517,7 @@ -}  --- A (non-mutable) tau type containing--- existentially quantified tyvars.---    (since GHC type language currently does not support---     existentials, we leave these variables unquantified)+-- See Note [RttiType] type RttiType = Type  -- An incomplete type as stored in GHCi:@@ -573,6 +568,37 @@ newOpenVar = liftTcM (do { kind <- newOpenTypeKind                          ; newVar kind }) +{- Note [RttiType]+~~~~~~~~~~~~~~~~~~+The type synonym `type RttiType = Type` is the type synonym used+by the debugger for the types of the data type `Term`.++For a long time the `RttiType` carried the following comment:++>     A (non-mutable) tau type containing+>     existentially quantified tyvars.+>          (since GHC type language currently does not support+>          existentials, we leave these variables unquantified)++The tau type part is only correct for terms representing the results+of fully saturated functions that return non-function (data) values+and not functions.++For non-function values, the GHC runtime always works with concrete+types eg `[Maybe Int]`, but never with polymorphic types like eg+`(Traversable t, Monad m) => t (m a)`. The concrete types, don't+need a quantification. They are always tau types.++The debugger binds the terms of :print commands and of the free+variables at a breakpoint to names. These newly bound names can+be used in new GHCi expressions. If these names represent functions,+then the type checker expects that the types of these functions are+fully-fledged. They must contain the necessary `forall`s and type+constraints. Hence the types of terms that represent functions must+be sigmas and not taus.+(See #12449)+-}+ {- Note [RuntimeUnkTv] ~~~~~~~~~~~~~~~~~~~~~~ In the GHCi debugger we use unification variables whose MetaInfo is@@ -606,7 +632,8 @@ This allows metavariables to unify with types that have nested (or higher-rank) `forall`s/`=>`s, which makes `:print fmap` display as-`fmap = (_t1::forall a b. Functor f => (a -> b) -> f a -> f b)`, as expected.+`fmap = (_t1::forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b)`,+as expected. -}  @@ -690,23 +717,22 @@   -- we quantify existential tyvars as universal,   -- as this is needed to be able to manipulate   -- them properly-   let quant_old_ty@(old_tvs, old_tau) = quantifyType old_ty-       sigma_old_ty = mkInfForAllTys old_tvs old_tau+   let quant_old_ty@(old_tvs, _) = quantifyType old_ty    traceTR (text "Term reconstruction started with initial type " <> ppr old_ty)    term <-      if null old_tvs       then do-        term  <- go max_depth sigma_old_ty sigma_old_ty hval+        term  <- go max_depth old_ty old_ty hval         term' <- zonkTerm term         return $ fixFunDictionaries $ expandNewtypes term'       else do               (old_ty', rev_subst) <- instScheme quant_old_ty               my_ty <- newOpenVar-              when (check1 quant_old_ty) (traceTR (text "check1 passed") >>+              when (check1 old_tvs) (traceTR (text "check1 passed") >>                                           addConstraint my_ty old_ty')-              term  <- go max_depth my_ty sigma_old_ty hval+              term  <- go max_depth my_ty old_ty hval               new_ty <- zonkTcType (termType term)-              if isMonomorphic new_ty || check2 (quantifyType new_ty) quant_old_ty+              if isMonomorphic new_ty || check2 new_ty old_ty                  then do                       traceTR (text "check2 passed")                       addConstraint new_ty old_ty'@@ -731,12 +757,9 @@    return term     where   interp = hscInterp hsc_env+  unit_env = hsc_unit_env hsc_env    go :: Int -> Type -> Type -> ForeignHValue -> TcM Term-   -- I believe that my_ty should not have any enclosing-   -- foralls, nor any free RuntimeUnk skolems;-   -- that is partly what the quantifyType stuff achieved-   --    -- [SPJ May 11] I don't understand the difference between my_ty and old_ty    go 0 my_ty _old_ty a = do@@ -753,7 +776,7 @@ -- Thunks we may want to force       t | isThunk t && force -> do          traceTR (text "Forcing a " <> text (show (fmap (const ()) t)))-         evalRslt <- liftIO $ GHCi.seqHValue interp hsc_env a+         evalRslt <- liftIO $ GHCi.seqHValue interp unit_env a          case evalRslt of                                            -- #2950            EvalSuccess _ -> go (pred max_depth) my_ty old_ty a            EvalException ex -> do@@ -784,17 +807,19 @@          go max_depth my_ty old_ty ind -- We also follow references       MutVarClosure{var=contents}-         | Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty+         | Just (tycon,[lev,world,contents_ty]) <- tcSplitTyConApp_maybe old_ty              -> do                   -- Deal with the MutVar# primitive                   -- It does not have a constructor at all,                   -- so we simulate the following one                   -- MutVar# :: contents_ty -> MutVar# s contents_ty+         massert (tycon == mutVarPrimTyCon)+         massert (isUnliftedType my_ty)          traceTR (text "Following a MutVar")-         contents_tv <- newVar liftedTypeKind-         MASSERT(isUnliftedType my_ty)+         let contents_kind = mkTYPEapp (mkTyConApp boxedRepDataConTyCon [lev])+         contents_tv <- newVar contents_kind          (mutvar_ty,_) <- instScheme $ quantifyType $ mkVisFunTyMany-                            contents_ty (mkTyConApp tycon [world,contents_ty])+                            contents_ty (mkTyConApp tycon [lev, world,contents_ty])          addConstraint (mkVisFunTyMany contents_tv my_ty) mutvar_ty          x <- go (pred max_depth) contents_tv contents_ty contents          return (RefWrap my_ty x)@@ -816,8 +841,7 @@                        traceTR (text "Not constructor" <+> ppr dcname)                        let dflags = hsc_dflags hsc_env                            tag = showPpr dflags dcname-                       vars     <- replicateM (length pArgs)-                                              (newVar liftedTypeKind)+                       vars     <- mapM (const (newVar liftedTypeKind)) pArgs                        subTerms <- sequence $ zipWith (\x tv ->                            go (pred max_depth) tv tv x) pArgs vars                        return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms)@@ -912,7 +936,7 @@                      [index size_b aligned_idx word_size endian]                  | otherwise =                      let (q, r) = size_b `quotRem` word_size-                     in ASSERT( r == 0 )+                     in assert (r == 0 )                         [ array!!i                         | o <- [0.. q - 1]                         , let i = (aligned_idx `quot` word_size) + o@@ -979,14 +1003,14 @@         else do           (old_ty', rev_subst) <- instScheme sigma_old_ty           my_ty <- newOpenVar-          when (check1 sigma_old_ty) (traceTR (text "check1 passed") >>+          when (check1 old_tvs) (traceTR (text "check1 passed") >>                                       addConstraint my_ty old_ty')           search (isMonomorphic `fmap` zonkTcType my_ty)                  (\(ty,a) -> go ty a)                  (Seq.singleton (my_ty, hval))                  max_depth           new_ty <- zonkTcType my_ty-          if isMonomorphic new_ty || check2 (quantifyType new_ty) sigma_old_ty+          if isMonomorphic new_ty || check2 new_ty old_ty             then do                  traceTR (text "check2 passed" <+> ppr old_ty $$ ppr new_ty)                  addConstraint my_ty old_ty'@@ -1017,11 +1041,17 @@     case clos of       BlackholeClosure{indirectee=ind} -> go my_ty ind       IndClosure{indirectee=ind} -> go my_ty ind-      MutVarClosure{var=contents} -> do-         tv'   <- newVar liftedTypeKind-         world <- newVar liftedTypeKind-         addConstraint my_ty (mkTyConApp mutVarPrimTyCon [world,tv'])-         return [(tv', contents)]+      MutVarClosure{var=contents}+        | Just (_tycon,[lev,_world,_contents_ty]) <- tcSplitTyConApp_maybe my_ty+        -> do+        massert (_tycon == mutVarPrimTyCon)+        tv'   <- newVar $ mkTYPEapp (mkTyConApp boxedRepDataConTyCon [lev])+        world <- newVar liftedTypeKind+        addConstraint my_ty $ mkMutVarPrimTy world tv'+        return [(tv', contents)]+      APClosure {payload=pLoad} -> do                -- #19559 (incr)+        mapM_ (go my_ty) pLoad+        return []       ConstrClosure{ptrArgs=pArgs} -> do         Right dcname <- liftIO $ constrClosToName hsc_env clos         traceTR (text "Constr1" <+> ppr dcname)@@ -1079,13 +1109,11 @@ -- return the types of the arguments.  This is RTTI-land, so 'ty' might -- not be fully known.  Moreover, the arg types might involve existentials; -- if so, make up fresh RTTI type variables for them------ I believe that con_app_ty should not have any enclosing foralls getDataConArgTys dc con_app_ty   = do { let rep_con_app_ty = unwrapType con_app_ty        ; traceTR (text "getDataConArgTys 1" <+> (ppr con_app_ty $$ ppr rep_con_app_ty                    $$ ppr (tcSplitTyConApp_maybe rep_con_app_ty)))-       ; ASSERT( all isTyVar ex_tvs ) return ()+       ; assert (all isTyVar ex_tvs ) return ()                  -- ex_tvs can only be tyvars as data types in source                  -- Haskell cannot mention covar yet (Aug 2018)        ; (subst, _) <- instTyVars (univ_tvs ++ ex_tvs)@@ -1239,21 +1267,37 @@  -} -check1 :: QuantifiedType -> Bool-check1 (tvs, _) = not $ any isHigherKind (map tyVarKind tvs)+check1 :: [TyVar] -> Bool+check1 tvs = not $ any isHigherKind (map tyVarKind tvs)  where    isHigherKind = not . null . fst . splitPiTys -check2 :: QuantifiedType -> QuantifiedType -> Bool-check2 (_, rtti_ty) (_, old_ty)-  | Just (_, rttis) <- tcSplitTyConApp_maybe rtti_ty-  = case () of-      _ | Just (_,olds) <- tcSplitTyConApp_maybe old_ty-        -> and$ zipWith check2 (map quantifyType rttis) (map quantifyType olds)-      _ | Just _ <- splitAppTy_maybe old_ty-        -> isMonomorphicOnNonPhantomArgs rtti_ty-      _ -> True-  | otherwise = True+check2 :: Type -> Type -> Bool+check2 rtti_ty old_ty = check2' (tauPart rtti_ty) (tauPart old_ty)+  -- The function `tcSplitTyConApp_maybe` doesn't split foralls or types+  -- headed with (=>). Hence here we need only the tau part of a type.+  -- See Note [Missing test case].+  where+    check2' rtti_ty old_ty+      | Just (_, rttis) <- tcSplitTyConApp_maybe rtti_ty+      = case () of+          _ | Just (_,olds) <- tcSplitTyConApp_maybe old_ty+            -> and$ zipWith check2 rttis olds+          _ | Just _ <- splitAppTy_maybe old_ty+            -> isMonomorphicOnNonPhantomArgs rtti_ty+          _ -> True+      | otherwise = True+    tauPart ty = tau+      where+        (_, _, tau) = tcSplitNestedSigmaTys ty+{-+Note [Missing test case]+~~~~~~~~~~~~~~~~~~~~~~~~+Her we miss a test case. It should be a term, with a function `f`+with a non-empty sigma part and an unsound type. The result of+`check2 f` should be different if we omit or do the calls to `tauPart`.+I (R.Senn) was unable to find such a term, and I'm in doubt, whether it exists.+-}  -- Dealing with newtypes --------------------------@@ -1383,18 +1427,12 @@  type QuantifiedType = ([TyVar], Type)    -- Make the free type variables explicit-   -- The returned Type should have no top-level foralls (I believe)  quantifyType :: Type -> QuantifiedType--- Generalize the type: find all free and forall'd tyvars--- and return them, together with the type inside, which--- should not be a forall type.------ Thus (quantifyType (forall a. a->[b]))--- returns ([a,b], a -> [b])-+-- Find all free and forall'd tyvars and return them+-- together with the unmodified input type. quantifyType ty = ( filter isTyVar $                     tyCoVarsOfTypeWellScoped rho-                  , rho)+                  , ty)   where-    (_tvs, rho) = tcSplitForAllInvisTyVars ty+    (_tvs, _, rho) = tcSplitNestedSigmaTys ty
− compiler/GHC/Runtime/Interpreter.hs 
@@ -1,770 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# 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-  , 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_-  , hscInterp, stopInterp-  , iservCall, readIServ, writeIServ-  , purgeLookupSymbolCache-  , freeHValueRefs-  , mkFinalizedHValue-  , wormhole, wormholeRef-  , mkEvalOpts-  , fromEvalResult-  ) where--import GHC.Prelude--import GHC.Driver.Ppr (showSDoc)-import GHC.Driver.Env-import GHC.Driver.Session--import GHC.Runtime.Interpreter.Types-import GHCi.Message-import GHCi.RemoteTypes-import GHCi.ResolvedBCO-import GHCi.BreakArray (BreakArray)-import GHC.Runtime.Eval.Types(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)-import GHC.Utils.Fingerprint-import GHC.Utils.Misc--import GHC.Unit.Module-import GHC.Unit.Module.ModIface-import GHC.Unit.Home.ModInfo--#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 (getNumProcessors, pseq, par)--{- Note [Remote GHCi]--When the flag -fexternal-interpreter is given to GHC, interpreted code-is run in a separate process called iserv, and we communicate with the-external process over a pipe using Binary-encoded messages.--Motivation-~~~~~~~~~~--When the interpreted code is running in a separate process, it can-use a different "way", e.g. profiled or dynamic.  This means--- compiling Template Haskell code with -prof does not require-  building the code without -prof first--- when GHC itself is profiled, it can interpret unprofiled code,-  and the same applies to dynamic linking.--- An unprofiled GHCi can load and run profiled code, which means it-  can use the stack-trace functionality provided by profiling without-  taking the performance hit on the compiler that profiling would-  entail.--For other reasons see remote-GHCi on the wiki.--Implementation Overview-~~~~~~~~~~~~~~~~~~~~~~~--The main pieces are:--- libraries/ghci, containing:-  - types for talking about remote values (GHCi.RemoteTypes)-  - the message protocol (GHCi.Message),-  - implementation of the messages (GHCi.Run)-  - implementation of Template Haskell (GHCi.TH)-  - a few other things needed to run interpreted code--- top-level iserv directory, containing the codefor the external-  server.  This is a fairly simple wrapper, most of the functionality-  is provided by modules in libraries/ghci.--- This module 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----- | Retrieve the target code interpreter------ Fails if no target code interpreter is available-hscInterp :: HscEnv -> Interp-hscInterp hsc_env = case hsc_interp hsc_env of-   Nothing -> throw (InstallationError "Couldn't find a target code interpreter. Try with -fexternal-interpreter")-   Just i  -> i---- Note [uninterruptibleMask_ and interpCmd]------ If we receive an async exception, such as ^C, while communicating--- with the iserv process then we will be out-of-sync and not be able--- to recover.  Thus we use uninterruptibleMask_ during--- 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-  -> DynFlags -- used by mkEvalOpts-  -> Bool     -- "step" for mkEvalOpts-  -> EvalExpr ForeignHValue-  -> IO (EvalStatus_ [ForeignHValue] [HValueRef])-evalStmt interp dflags step foreign_expr = do-  status <- withExpr foreign_expr $ \expr ->-    interpCmd interp (EvalStmt (mkEvalOpts dflags step) 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-  -> DynFlags -- used by mkEvalOpts-  -> Bool     -- "step" for mkEvalOpts-  -> ForeignRef (ResumeContext [HValueRef])-  -> IO (EvalStatus_ [ForeignHValue] [HValueRef])-resumeStmt interp dflags step resume_ctxt = do-  status <- withForeignRef resume_ctxt $ \rhv ->-    interpCmd interp (ResumeStmt (mkEvalOpts dflags step) 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)---- | Create a set of BCOs that may be mutually recursive.-createBCOs :: Interp -> DynFlags -> [ResolvedBCO] -> IO [HValueRef]-createBCOs interp dflags rbcos = do-  n_jobs <- case parMakeCount dflags of-              Nothing -> liftIO getNumProcessors-              Just n  -> return n-  -- Serializing ResolvedBCO is expensive, so if we're in parallel mode-  -- (-j<n>) parallelise the serialization.-  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 -> HscEnv -> ForeignHValue -> IO (EvalResult ())-seqHValue interp hsc_env ref =-  withForeignRef ref $ \hval -> do-    status <- interpCmd interp (Seq hval)-    handleSeqHValueStatus interp hsc_env status---- | Process the result of a Seq or ResumeSeq message.             #2950-handleSeqHValueStatus :: Interp -> HscEnv -> EvalStatus () -> IO (EvalResult ())-handleSeqHValueStatus interp hsc_env eval_status =-  case eval_status of-    (EvalBreak is_exception _ ix mod_uniq resume_ctxt _) -> do-      -- A breakpoint was hit; inform the user and tell them-      -- which breakpoint was hit.-      resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt-      let hmi = expectJust "handleRunStatus" $-                  lookupHptDirectly (hsc_HPT hsc_env)-                    (mkUniqueGrimily mod_uniq)-          modl = mi_module (hm_iface hmi)-          bp | is_exception = Nothing-             | otherwise = Just (BreakInfo modl ix)-          sdocBpLoc = brackets . ppr . getSeqBpSpan-      putStrLn ("*** Ignoring breakpoint " ++-            (showSDoc (hsc_dflags hsc_env) $ sdocBpLoc bp))-      -- resume the seq (:force) processing in the iserv process-      withForeignRef resume_ctxt_fhv $ \hval -> do-        status <- interpCmd interp (ResumeSeq hval)-        handleSeqHValueStatus interp hsc_env status-    (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 (hsc_HPT hsc_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-    `catch` \(e :: SomeException) -> handleIServFailure iserv e---- | Read a value from the iserv process-readIServ :: IServInstance -> Get a -> IO a-readIServ iserv get =-  readPipe (iservPipe iserv) get-    `catch` \(e :: SomeException) -> handleIServFailure iserv e---- | Send a value to the iserv process-writeIServ :: IServInstance -> Put -> IO ()-writeIServ iserv put =-  writePipe (iservPipe iserv) put-    `catch` \(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--mkEvalOpts :: DynFlags -> Bool -> EvalOpts-mkEvalOpts dflags step =-  EvalOpts-    { useSandboxThread = gopt Opt_GhciSandbox dflags-    , singleStep = step-    , breakOnException = gopt Opt_BreakOnException dflags-    , breakOnError = gopt Opt_BreakOnError dflags }--fromEvalResult :: EvalResult a -> IO a-fromEvalResult (EvalException e) = throwIO (fromSerializableException e)-fromEvalResult (EvalSuccess a) = return a--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/Runtime/Loader.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + -- | Dynamically lookup up values from modules and loading them. module GHC.Runtime.Loader (         initializePlugins,@@ -28,7 +28,7 @@ import GHC.Driver.Plugins  import GHC.Linker.Loader       ( loadModule, loadName )-import GHC.Runtime.Interpreter ( wormhole, hscInterp )+import GHC.Runtime.Interpreter ( wormhole ) import GHC.Runtime.Interpreter.Types  import GHC.Tc.Utils.Monad      ( initTcInteractive, initIfaceTcRn )@@ -51,8 +51,10 @@                                , greMangledName, mkRdrQual )  import GHC.Unit.Finder         ( findPluginModule, FindResult(..) )+import GHC.Driver.Config.Finder ( initFinderOpts ) import GHC.Unit.Module   ( Module, ModuleName ) import GHC.Unit.Module.ModIface+import GHC.Unit.Env  import GHC.Utils.Panic import GHC.Utils.Logger@@ -60,11 +62,12 @@ import GHC.Utils.Outputable import GHC.Utils.Exception -import GHC.Data.FastString- import Control.Monad     ( unless ) import Data.Maybe        ( mapMaybe ) import Unsafe.Coerce     ( unsafeCoerce )+import GHC.Linker.Types+import GHC.Types.Unique.DFM+import Data.List (unzip4)  -- | Loads the plugins specified in the pluginModNames field of the dynamic -- flags. Should be called after command line arguments are parsed, but before@@ -73,29 +76,33 @@ initializePlugins :: HscEnv -> IO HscEnv initializePlugins hsc_env     -- plugins not changed-  | map lpModuleName (hsc_plugins hsc_env) == pluginModNames dflags+  | loaded_plugins <- loadedPlugins (hsc_plugins hsc_env)+  , map lpModuleName loaded_plugins == reverse (pluginModNames dflags)    -- arguments not changed-  , all same_args (hsc_plugins hsc_env)-  = return hsc_env -- no need to reload plugins+  , all same_args loaded_plugins+  = return hsc_env -- no need to reload plugins FIXME: doesn't take static plugins into account   | otherwise-  = do loaded_plugins <- loadPlugins hsc_env-       let hsc_env' = hsc_env { hsc_plugins = loaded_plugins }-       withPlugins hsc_env' driverPlugin hsc_env'+  = do (loaded_plugins, links, pkgs) <- loadPlugins hsc_env+       let plugins' = (hsc_plugins hsc_env) { loadedPlugins = loaded_plugins, loadedPluginDeps = (links, pkgs) }+       let hsc_env' = hsc_env { hsc_plugins = plugins' }+       withPlugins (hsc_plugins hsc_env') driverPlugin hsc_env'   where     plugin_args = pluginModNameOpts dflags     same_args p = paArguments (lpPlugin p) == argumentsForPlugin p plugin_args     argumentsForPlugin p = map snd . filter ((== lpModuleName p) . fst)     dflags = hsc_dflags hsc_env -loadPlugins :: HscEnv -> IO [LoadedPlugin]+loadPlugins :: HscEnv -> IO ([LoadedPlugin], [Linkable], PkgsLoaded) loadPlugins hsc_env   = do { unless (null to_load) $            checkExternalInterpreter hsc_env-       ; plugins <- mapM loadPlugin to_load-       ; return $ zipWith attachOptions to_load plugins }+       ; plugins_with_deps <- mapM loadPlugin to_load+       ; let (plugins, ifaces, links, pkgs) = unzip4 plugins_with_deps+       ; return (zipWith attachOptions to_load (zip plugins ifaces), concat links, foldl' plusUDFM emptyUDFM pkgs)+       }   where     dflags  = hsc_dflags hsc_env-    to_load = pluginModNames dflags+    to_load = reverse $ pluginModNames dflags      attachOptions mod_nm (plug, mod) =         LoadedPlugin (PluginWithArgs plug (reverse options)) mod@@ -105,11 +112,13 @@     loadPlugin = loadPlugin' (mkVarOcc "plugin") pluginTyConName hsc_env  -loadFrontendPlugin :: HscEnv -> ModuleName -> IO FrontendPlugin+loadFrontendPlugin :: HscEnv -> ModuleName -> IO (FrontendPlugin, [Linkable], PkgsLoaded) loadFrontendPlugin hsc_env mod_name = do     checkExternalInterpreter hsc_env-    fst <$> loadPlugin' (mkVarOcc "frontendPlugin") frontendPluginTyConName-                hsc_env mod_name+    (plugin, _iface, links, pkgs)+      <- loadPlugin' (mkVarOcc "frontendPlugin") frontendPluginTyConName+           hsc_env mod_name+    return (plugin, links, pkgs)  -- #14335 checkExternalInterpreter :: HscEnv -> IO ()@@ -118,7 +127,7 @@     -> throwIO (InstallationError "Plugins require -fno-external-interpreter")   _ -> pure () -loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO (a, ModIface)+loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO (a, ModIface, [Linkable], PkgsLoaded) loadPlugin' occ_name plugin_name hsc_env mod_name   = do { let plugin_rdr_name = mkRdrQual mod_name occ_name              dflags = hsc_dflags hsc_env@@ -133,14 +142,18 @@             Just (name, mod_iface) ->       do { plugin_tycon <- forceLoadTyCon hsc_env plugin_name-        ; mb_plugin <- getValueSafely hsc_env name (mkTyConTy plugin_tycon)-        ; case mb_plugin of-            Nothing ->-                throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep+        ; eith_plugin <- getValueSafely hsc_env name (mkTyConTy plugin_tycon)+        ; case eith_plugin of+            Left actual_type ->+                throwGhcExceptionIO (CmdLineError $+                    showSDocForUser dflags (ue_units (hsc_unit_env hsc_env))+                      alwaysQualify $ hsep                           [ text "The value", ppr name+                          , text "with type", ppr actual_type                           , text "did not have the type"-                          , ppr pluginTyConName, text "as required"])-            Just plugin -> return (plugin, mod_iface) } } }+                          , text "GHC.Plugins.Plugin"+                          , text "as required"])+            Right (plugin, links, pkgs) -> return (plugin, mod_iface, links, pkgs) } } }   -- | Force the interfaces for the given modules to be loaded. The 'SDoc' parameter is used@@ -178,30 +191,29 @@ -- | Loads the value corresponding to a 'Name' if that value has the given 'Type'. This only provides limited safety -- in that it is up to the user to ensure that that type corresponds to the type you try to use the return value at! ----- If the value found was not of the correct type, returns @Nothing@. Any other condition results in an exception:+-- If the value found was not of the correct type, returns @Left <actual_type>@. Any other condition results in an exception: -- -- * If we could not load the names module -- * If the thing being loaded is not a value -- * If the Name does not exist in the module -- * If the link failed -getValueSafely :: HscEnv -> Name -> Type -> IO (Maybe a)+getValueSafely :: HscEnv -> Name -> Type -> IO (Either Type (a, [Linkable], PkgsLoaded)) getValueSafely hsc_env val_name expected_type = do-  mb_hval <- case getValueSafelyHook hooks of+  eith_hval <- case getValueSafelyHook hooks of     Nothing -> getHValueSafely interp hsc_env val_name expected_type     Just h  -> h                      hsc_env val_name expected_type-  case mb_hval of-    Nothing   -> return Nothing-    Just hval -> do-      value <- lessUnsafeCoerce logger dflags "getValueSafely" hval-      return (Just value)+  case eith_hval of+    Left actual_type -> return (Left actual_type)+    Right (hval, links, pkgs) -> do+      value <- lessUnsafeCoerce logger "getValueSafely" hval+      return (Right (value, links, pkgs))   where     interp = hscInterp hsc_env-    dflags = hsc_dflags hsc_env     logger = hsc_logger hsc_env     hooks  = hsc_hooks hsc_env -getHValueSafely :: Interp -> HscEnv -> Name -> Type -> IO (Maybe HValue)+getHValueSafely :: Interp -> HscEnv -> Name -> Type -> IO (Either Type (HValue, [Linkable], PkgsLoaded)) getHValueSafely interp hsc_env val_name expected_type = do     forceLoadNameModuleInterface hsc_env (text "contains a name used in an invocation of getHValueSafely") val_name     -- Now look up the names for the value and type constructor in the type environment@@ -220,10 +232,11 @@                     Nothing ->  return ()                 -- Find the value that we just linked in and cast it given that we have proved it's type                 hval <- do-                  v <- loadName interp hsc_env val_name-                  wormhole interp v-                return (Just hval)-             else return Nothing+                  (v, links, pkgs) <- loadName interp hsc_env val_name+                  hv <- wormhole interp v+                  return (hv, links, pkgs)+                return (Right hval)+             else return (Left (idType id))         Just val_thing -> throwCmdLineErrorS dflags $ wrongTyThingError val_name val_thing    where dflags = hsc_dflags hsc_env @@ -233,12 +246,12 @@ -- -- 2) Wrap it in some debug messages at verbosity 3 or higher so we can see what happened --    if it /does/ segfault-lessUnsafeCoerce :: Logger -> DynFlags -> String -> a -> IO b-lessUnsafeCoerce logger dflags context what = do-    debugTraceMsg logger dflags 3 $+lessUnsafeCoerce :: Logger -> String -> a -> IO b+lessUnsafeCoerce logger context what = do+    debugTraceMsg logger 3 $         (text "Coercing a value in") <+> (text context) <> (text "...")     output <- evaluate (unsafeCoerce what)-    debugTraceMsg logger dflags 3 (text "Successfully evaluated coercion")+    debugTraceMsg logger 3 (text "Successfully evaluated coercion")     return output  @@ -259,8 +272,14 @@ lookupRdrNameInModuleForPlugins :: HscEnv -> ModuleName -> RdrName                                 -> IO (Maybe (Name, ModIface)) lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do+    let dflags     = hsc_dflags hsc_env+    let fopts      = initFinderOpts dflags+    let fc         = hsc_FC hsc_env+    let unit_env   = hsc_unit_env hsc_env+    let unit_state = ue_units unit_env+    let mhome_unit = hsc_home_unit_maybe hsc_env     -- First find the unit the module resides in by searching exposed units and home modules-    found_module <- findPluginModule hsc_env mod_name+    found_module <- findPluginModule fc fopts unit_state mhome_unit mod_name     case found_module of         Found _ mod -> do             -- Find the exports of the module@@ -282,14 +301,13 @@                 Nothing -> throwCmdLineErrorS dflags $ hsep [text "Could not determine the exports of the module", ppr mod_name]         err -> throwCmdLineErrorS dflags $ cannotFindModule hsc_env mod_name err   where-    dflags = hsc_dflags hsc_env     doc = text "contains a name used in an invocation of lookupRdrNameInModule"  wrongTyThingError :: Name -> TyThing -> SDoc-wrongTyThingError name got_thing = hsep [text "The name", ppr name, ptext (sLit "is not that of a value but rather a"), pprTyThingCategory got_thing]+wrongTyThingError name got_thing = hsep [text "The name", ppr name, text "is not that of a value but rather a", pprTyThingCategory got_thing]  missingTyThingError :: Name -> SDoc-missingTyThingError name = hsep [text "The name", ppr name, ptext (sLit "is not in the type environment: are you sure it exists?")]+missingTyThingError name = hsep [text "The name", ppr name, text "is not in the type environment: are you sure it exists?"]  throwCmdLineErrorS :: DynFlags -> SDoc -> IO a throwCmdLineErrorS dflags = throwCmdLineError . showSDoc dflags
compiler/GHC/Settings/IO.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -7,8 +7,6 @@  , initSettings  ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Settings.Utils@@ -37,12 +35,6 @@   => String -- ^ TopDir path   -> ExceptT SettingsError m Settings initSettings top_dir = do-  -- see Note [topdir: How GHC finds its files]-  -- NB: top_dir is assumed to be in standard Unix-  -- format, '/' separated-  mtool_dir <- liftIO $ findToolDir top_dir-        -- see Note [tooldir: How GHC finds mingw on Windows]-   let installed :: FilePath -> FilePath       installed file = top_dir </> file       libexec :: FilePath -> FilePath@@ -60,25 +52,33 @@     Nothing -> throwE $ SettingsError_BadData $       "Can't parse " ++ show settingsFile   let mySettings = Map.fromList settingsList+      getBooleanSetting :: String -> ExceptT SettingsError m Bool+      getBooleanSetting key = either pgmError pure $+        getRawBooleanSetting settingsFile mySettings key++  -- On Windows, by mingw is often distributed with GHC,+  -- so we look in TopDir/../mingw/bin,+  -- as well as TopDir/../../mingw/bin for hadrian.+  -- But we might be disabled, in which we we don't do that.+  useInplaceMinGW <- getBooleanSetting "Use inplace MinGW toolchain"++  -- see Note [topdir: How GHC finds its files]+  -- NB: top_dir is assumed to be in standard Unix+  -- format, '/' separated+  mtool_dir <- liftIO $ findToolDir useInplaceMinGW top_dir+        -- see Note [tooldir: How GHC finds mingw on Windows]+   -- See Note [Settings file] for a little more about this file. We're   -- just partially applying those functions and throwing 'Left's; they're   -- written in a very portable style to keep ghc-boot light.   let getSetting key = either pgmError pure $         getRawFilePathSetting top_dir settingsFile mySettings key       getToolSetting :: String -> ExceptT SettingsError m String-      getToolSetting key = expandToolDir mtool_dir <$> getSetting key-      getBooleanSetting :: String -> ExceptT SettingsError m Bool-      getBooleanSetting key = either pgmError pure $-        getRawBooleanSetting settingsFile mySettings key+      getToolSetting key = expandToolDir useInplaceMinGW mtool_dir <$> getSetting key   targetPlatformString <- getSetting "target platform string"   myExtraGccViaCFlags <- getSetting "GCC extra via C opts"-  -- On Windows, mingw is distributed with GHC,-  -- so we look in TopDir/../mingw/bin,-  -- as well as TopDir/../../mingw/bin for hadrian.-  -- It would perhaps be nice to be able to override this-  -- with the settings file, but it would be a little fiddly-  -- to make that possible, so for now you can't.   cc_prog <- getToolSetting "C compiler command"+  cxx_prog <- getToolSetting "C++ compiler command"   cc_args_str <- getSetting "C compiler flags"   cxx_args_str <- getSetting "C++ compiler flags"   gccSupportsNoPie <- getBooleanSetting "C compiler supports -no-pie"@@ -97,6 +97,7 @@   ldSupportsBuildId       <- getBooleanSetting "ld supports build-id"   ldSupportsFilelist      <- getBooleanSetting "ld supports filelist"   ldIsGnuLd               <- getBooleanSetting "ld is GNU ld"+  arSupportsDashL         <- getBooleanSetting "ar supports -L"    let globalpkgdb_path = installed "package.conf.d"       ghc_usage_msg_path  = installed "ghc-usage.txt"@@ -113,10 +114,6 @@   install_name_tool_path <- getToolSetting "install_name_tool command"   ranlib_path <- getToolSetting "ranlib command" -  -- TODO this side-effect doesn't belong here. Reading and parsing the settings-  -- should be idempotent and accumulate no resources.-  tmpdir <- liftIO $ getTemporaryDirectory-   touch_path <- getToolSetting "touch command"    mkdll_prog <- getToolSetting "dllwrap command"@@ -135,6 +132,9 @@         ld_args  = map Option (cc_args ++ words cc_link_args_str)   ld_r_prog <- getToolSetting "Merge objects command"   ld_r_args <- getSetting "Merge objects flags"+  let ld_r+        | null ld_r_prog = Nothing+        | otherwise      = Just (ld_r_prog, map Option $ words ld_r_args)    llvmTarget <- getSetting "LLVM target" @@ -146,10 +146,7 @@   let iserv_prog = libexec "ghc-iserv"    ghcWithInterpreter <- getBooleanSetting "Use interpreter"-  ghcWithSMP <- getBooleanSetting "Support SMP"-  ghcRTSWays <- getSetting "RTS ways"   useLibFFI <- getBooleanSetting "Use LibFFI"-  ghcRtsWithLibdw <- getBooleanSetting "RTS expects libdw"    return $ Settings     { sGhcNameVersion = GhcNameVersion@@ -158,8 +155,7 @@       }      , sFileSettings = FileSettings-      { fileSettings_tmpDir         = normalise tmpdir-      , fileSettings_ghcUsagePath   = ghc_usage_msg_path+      { fileSettings_ghcUsagePath   = ghc_usage_msg_path       , fileSettings_ghciUsagePath  = ghci_usage_msg_path       , fileSettings_toolDir        = mtool_dir       , fileSettings_topDir         = top_dir@@ -172,14 +168,17 @@       , toolSettings_ldSupportsFilelist      = ldSupportsFilelist       , toolSettings_ldIsGnuLd               = ldIsGnuLd       , toolSettings_ccSupportsNoPie         = gccSupportsNoPie+      , toolSettings_useInplaceMinGW         = useInplaceMinGW+      , toolSettings_arSupportsDashL         = arSupportsDashL        , toolSettings_pgm_L   = unlit_path       , toolSettings_pgm_P   = (cpp_prog, cpp_args)       , toolSettings_pgm_F   = ""       , toolSettings_pgm_c   = cc_prog+      , toolSettings_pgm_cxx = cxx_prog       , toolSettings_pgm_a   = (as_prog, as_args)       , toolSettings_pgm_l   = (ld_prog, ld_args)-      , toolSettings_pgm_lm  = (ld_r_prog, map Option $ words ld_r_args)+      , toolSettings_pgm_lm  = ld_r       , toolSettings_pgm_dll = (mkdll_prog,mkdll_args)       , toolSettings_pgm_T   = touch_path       , toolSettings_pgm_windres = windres_path@@ -214,10 +213,7 @@     , sPlatformMisc = PlatformMisc       { platformMisc_targetPlatformString = targetPlatformString       , platformMisc_ghcWithInterpreter = ghcWithInterpreter-      , platformMisc_ghcWithSMP = ghcWithSMP-      , platformMisc_ghcRTSWays = ghcRTSWays       , platformMisc_libFFI = useLibFFI-      , platformMisc_ghcRtsWithLibdw = ghcRtsWithLibdw       , platformMisc_llvmTarget = llvmTarget       } @@ -242,6 +238,7 @@   targetHasGnuNonexecStack <- getBooleanSetting "target has GNU nonexec stack"   targetHasIdentDirective <- getBooleanSetting "target has .ident directive"   targetHasSubsectionsViaSymbols <- getBooleanSetting "target has subsections via symbols"+  targetHasLibm <- getBooleanSetting "target has libm"   crossCompiling <- getBooleanSetting "cross compiling"   tablesNextToCode <- getBooleanSetting "Tables next to code" @@ -256,5 +253,6 @@     , platformIsCrossCompiling = crossCompiling     , platformLeadingUnderscore = targetLeadingUnderscore     , platformTablesNextToCode  = tablesNextToCode+    , platformHasLibm = targetHasLibm     , platform_constants = Nothing -- will be filled later when loading (or building) the RTS unit     }
+ compiler/GHC/Stg/BcPrep.hs view
@@ -0,0 +1,214 @@+{-|+  Prepare the STG for bytecode generation:++   - Ensure that all breakpoints are directly under+        a let-binding, introducing a new binding for+        those that aren't already.++   - Protect Not-necessarily lifted join points, see+        Note [Not-necessarily-lifted join points]++ -}++module GHC.Stg.BcPrep ( bcPrep ) where++import GHC.Prelude++import GHC.Types.Id.Make+import GHC.Types.Id+import GHC.Core.Type+import GHC.Builtin.Types ( unboxedUnitTy )+import GHC.Builtin.Types.Prim+import GHC.Types.Unique+import GHC.Data.FastString+import GHC.Utils.Panic.Plain+import GHC.Types.Tickish+import GHC.Types.Unique.Supply+import qualified GHC.Types.CostCentre as CC+import GHC.Stg.Syntax+import GHC.Utils.Monad.State.Strict++data BcPrepM_State+   = BcPrepM_State+        { prepUniqSupply :: !UniqSupply      -- for generating fresh variable names+        }++type BcPrepM a = State BcPrepM_State a++bcPrepRHS :: StgRhs -> BcPrepM StgRhs+-- explicitly match all constructors so we get a warning if we miss any+bcPrepRHS (StgRhsClosure fvs cc upd args (StgTick bp@Breakpoint{} expr)) = do+  {- If we have a breakpoint directly under an StgRhsClosure we don't+     need to introduce a new binding for it.+   -}+  expr' <- bcPrepExpr expr+  pure (StgRhsClosure fvs cc upd args (StgTick bp expr'))+bcPrepRHS (StgRhsClosure fvs cc upd args expr) =+  StgRhsClosure fvs cc upd args <$> bcPrepExpr expr+bcPrepRHS con@StgRhsCon{} = pure con++bcPrepExpr :: StgExpr -> BcPrepM StgExpr+-- explicitly match all constructors so we get a warning if we miss any+bcPrepExpr (StgTick bp@(Breakpoint tick_ty _ _) rhs)+  | isLiftedTypeKind (typeKind tick_ty) = do+      id <- newId tick_ty+      rhs' <- bcPrepExpr rhs+      let expr' = StgTick bp rhs'+          bnd = StgNonRec id (StgRhsClosure noExtFieldSilent+                                            CC.dontCareCCS+                                            ReEntrant+                                            []+                                            expr'+                             )+          letExp = StgLet noExtFieldSilent bnd (StgApp id [])+      pure letExp+  | otherwise = do+      id <- newId (mkVisFunTyMany realWorldStatePrimTy tick_ty)+      rhs' <- bcPrepExpr rhs+      let expr' = StgTick bp rhs'+          bnd = StgNonRec id (StgRhsClosure noExtFieldSilent+                                            CC.dontCareCCS+                                            ReEntrant+                                            [voidArgId]+                                            expr'+                             )+      pure $ StgLet noExtFieldSilent bnd (StgApp id [StgVarArg realWorldPrimId])+bcPrepExpr (StgTick tick rhs) =+  StgTick tick <$> bcPrepExpr rhs+bcPrepExpr (StgLet xlet bnds expr) =+  StgLet xlet <$> bcPrepBind bnds+              <*> bcPrepExpr expr+bcPrepExpr (StgLetNoEscape xlne bnds expr) =+  StgLet xlne <$> bcPrepBind bnds+              <*> bcPrepExpr expr+bcPrepExpr (StgCase expr bndr alt_type alts) =+  StgCase <$> bcPrepExpr expr+          <*> pure bndr+          <*> pure alt_type+          <*> mapM bcPrepAlt alts+bcPrepExpr lit@StgLit{} = pure lit+-- See Note [Not-necessarily-lifted join points], step 3.+bcPrepExpr (StgApp x [])+  | isNNLJoinPoint x = pure $+      StgApp (protectNNLJoinPointId x) [StgVarArg voidPrimId]+bcPrepExpr app@StgApp{} = pure app+bcPrepExpr app@StgConApp{} = pure app+bcPrepExpr app@StgOpApp{} = pure app++bcPrepAlt :: StgAlt -> BcPrepM StgAlt+bcPrepAlt (GenStgAlt con bndrs rhs) = GenStgAlt con bndrs <$> bcPrepExpr rhs++bcPrepBind :: StgBinding -> BcPrepM StgBinding+-- explicitly match all constructors so we get a warning if we miss any+bcPrepBind (StgNonRec bndr rhs) =+  let (bndr', rhs') = bcPrepSingleBind (bndr, rhs)+  in  StgNonRec bndr' <$> bcPrepRHS rhs'+bcPrepBind (StgRec bnds) =+  StgRec <$> mapM ((\(b,r) -> (,) b <$> bcPrepRHS r) . bcPrepSingleBind)+                  bnds++bcPrepSingleBind :: (Id, StgRhs) -> (Id, StgRhs)+-- If necessary, modify this Id and body to protect not-necessarily-lifted join points.+-- See Note [Not-necessarily-lifted join points], step 2.+bcPrepSingleBind (x, StgRhsClosure ext cc upd_flag args body)+  | isNNLJoinPoint x+  = ( protectNNLJoinPointId x+    , StgRhsClosure ext cc upd_flag (args ++ [voidArgId]) body)+bcPrepSingleBind bnd = bnd++bcPrepTopLvl :: StgTopBinding -> BcPrepM StgTopBinding+bcPrepTopLvl lit@StgTopStringLit{} = pure lit+bcPrepTopLvl (StgTopLifted bnd) = StgTopLifted <$> bcPrepBind bnd++bcPrep :: UniqSupply -> [InStgTopBinding] -> [OutStgTopBinding]+bcPrep us bnds = evalState (mapM bcPrepTopLvl bnds) (BcPrepM_State us)++-- Is this Id a not-necessarily-lifted join point?+-- See Note [Not-necessarily-lifted join points], step 1+isNNLJoinPoint :: Id -> Bool+isNNLJoinPoint x = isJoinId x && mightBeUnliftedType (idType x)++-- Update an Id's type to take a Void# argument.+-- Precondition: the Id is a not-necessarily-lifted join point.+-- See Note [Not-necessarily-lifted join points]+protectNNLJoinPointId :: Id -> Id+protectNNLJoinPointId x+  = assert (isNNLJoinPoint x )+    updateIdTypeButNotMult (unboxedUnitTy `mkVisFunTyMany`) x++newUnique :: BcPrepM Unique+newUnique = state $+  \st -> case takeUniqFromSupply (prepUniqSupply st) of+            (uniq, us) -> (uniq, st { prepUniqSupply = us })++newId :: Type -> BcPrepM Id+newId ty = do+    uniq <- newUnique+    return $ mkSysLocal prepFS uniq Many ty++prepFS :: FastString+prepFS = fsLit "bcprep"++{-++Note [Not-necessarily-lifted join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A join point variable is essentially a goto-label: it is, for example,+never used as an argument to another function, and it is called only+in tail position. See Note [Join points] and Note [Invariants on join points],+both in GHC.Core. Because join points do not compile to true, red-blooded+variables (with, e.g., registers allocated to them), they are allowed+to be representation-polymorphic.+(See invariant #6 in Note [Invariants on join points] in GHC.Core.)++However, in this byte-code generator, join points *are* treated just as+ordinary variables. There is no check whether a binding is for a join point+or not; they are all treated uniformly. (Perhaps there is a missed optimization+opportunity here, but that is beyond the scope of my (Richard E's) Thursday.)++We thus must have *some* strategy for dealing with representation-polymorphic+and unlifted join points. Representation-polymorphic variables are generally+not allowed (though representation -polymorphic join points *are*; see+Note [Invariants on join points] in GHC.Core, point 6), and we don't wish to+evaluate unlifted join points eagerly.+The questionable join points are *not-necessarily-lifted join points*+(NNLJPs). (Not having such a strategy led to #16509, which panicked in the+isUnliftedType check in the AnnVar case of schemeE.) Here is the strategy:++1. Detect NNLJPs. This is done in isNNLJoinPoint.++2. When binding an NNLJP, add a `\ (_ :: (# #)) ->` to its RHS, and modify the+   type to tack on a `(# #) ->`.+   Note that functions are never representation-polymorphic, so this+   transformation changes an NNLJP to a non-representation-polymorphic+   join point. This is done in bcPrepSingleBind.++3. At an occurrence of an NNLJP, add an application to void# (called voidPrimId),+   being careful to note the new type of the NNLJP. This is done in the AnnVar+   case of schemeE, with help from protectNNLJoinPointId.++Here is an example. Suppose we have++  f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T).+      join j :: a+           j = error @r @a "bloop"+      in case x of+           A -> j+           B -> j+           C -> error @r @a "blurp"++Our plan is to behave is if the code was++  f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T).+      let j :: (Void# -> a)+          j = \ _ -> error @r @a "bloop"+      in case x of+           A -> j void#+           B -> j void#+           C -> error @r @a "blurp"++It's a bit hacky, but it works well in practice and is local. I suspect the+Right Fix is to take advantage of join points as goto-labels.++-}+
compiler/GHC/Stg/CSE.hs view
@@ -11,8 +11,8 @@ This was originally reported as #9291.  There are two types of common code occurrences that we aim for, see-note [Case 1: CSEing allocated closures] and-note [Case 2: CSEing case binders] below.+Note [Case 1: CSEing allocated closures] and+Note [Case 2: CSEing case binders] below.   Note [Case 1: CSEing allocated closures]@@ -147,7 +147,7 @@ -- The CSE Env -- ----------------- --- | The CSE environment. See note [CseEnv Example]+-- | The CSE environment. See Note [CseEnv Example] data CseEnv = CseEnv     { ce_conAppMap :: ConAppMap OutId         -- ^ The main component of the environment is the trie that maps@@ -203,31 +203,54 @@     , ce_in_scope  = in_scope     } +-------------------+normaliseConArgs :: CseEnv -> [OutStgArg] -> [OutStgArg]+-- See Note [Trivial case scrutinee]+normaliseConArgs env args+  = map go args+  where+    bndr_map = ce_bndrMap env+    go (StgVarArg v  ) = StgVarArg (normaliseId bndr_map v)+    go (StgLitArg lit) = StgLitArg lit++normaliseId :: IdEnv OutId -> OutId -> OutId+normaliseId bndr_map v = case lookupVarEnv bndr_map v of+                           Just v' -> v'+                           Nothing -> v++addTrivCaseBndr :: OutId -> OutId -> CseEnv -> CseEnv+-- See Note [Trivial case scrutinee]+addTrivCaseBndr from to env+    = env { ce_bndrMap = extendVarEnv bndr_map from norm_to }+    where+      bndr_map = ce_bndrMap env+      norm_to = normaliseId bndr_map to+ envLookup :: DataCon -> [OutStgArg] -> CseEnv -> Maybe OutId-envLookup dataCon args env = lookupTM (dataCon, args') (ce_conAppMap env)-  where args' = map go args -- See Note [Trivial case scrutinee]-        go (StgVarArg v  ) = StgVarArg (fromMaybe v $ lookupVarEnv (ce_bndrMap env) v)-        go (StgLitArg lit) = StgLitArg lit+envLookup dataCon args env+  = lookupTM (dataCon, normaliseConArgs env args)+             (ce_conAppMap env)+    -- normaliseConArgs: See Note [Trivial case scrutinee]  addDataCon :: OutId -> DataCon -> [OutStgArg] -> CseEnv -> CseEnv--- do not bother with nullary data constructors, they are static anyways+-- Do not bother with nullary data constructors; they are static anyway addDataCon _ _ [] env = env-addDataCon bndr dataCon args env = env { ce_conAppMap = new_env }+addDataCon bndr dataCon args env+  = env { ce_conAppMap = new_env }   where-    new_env = insertTM (dataCon, args) bndr (ce_conAppMap env)+    new_env = insertTM (dataCon, normaliseConArgs env args)+                       bndr (ce_conAppMap env)+    -- normaliseConArgs: See Note [Trivial case scrutinee] +------------------- forgetCse :: CseEnv -> CseEnv forgetCse env = env { ce_conAppMap = emptyTM }-    -- See note [Free variables of an StgClosure]+    -- See Note [Free variables of an StgClosure]  addSubst :: OutId -> OutId -> CseEnv -> CseEnv addSubst from to env     = env { ce_subst = extendVarEnv (ce_subst env) from to } -addTrivCaseBndr :: OutId -> OutId -> CseEnv -> CseEnv-addTrivCaseBndr from to env-    = env { ce_bndrMap = extendVarEnv (ce_bndrMap env) from to }- substArgs :: CseEnv -> [InStgArg] -> [OutStgArg] substArgs env = map (substArg env) @@ -318,9 +341,11 @@   where     scrut' = stgCseExpr env scrut     (env1, bndr') = substBndr env bndr-    env2 | StgApp trivial_scrut [] <- scrut' = addTrivCaseBndr bndr trivial_scrut env1+    env2 | StgApp trivial_scrut [] <- scrut'+         = addTrivCaseBndr bndr trivial_scrut env1                  -- See Note [Trivial case scrutinee]-         | otherwise                         = env1+         | otherwise+         = env1     alts' = map (stgCseAlt env2 ty bndr') alts  @@ -349,7 +374,7 @@ -- Case alternatives -- Extend the CSE environment stgCseAlt :: CseEnv -> AltType -> OutId -> InStgAlt -> OutStgAlt-stgCseAlt env ty case_bndr (DataAlt dataCon, args, rhs)+stgCseAlt env ty case_bndr GenStgAlt{alt_con=DataAlt dataCon, alt_bndrs=args, alt_rhs=rhs}     = let (env1, args') = substBndrs env args           env2             -- To avoid dealing with unboxed sums StgCse runs after unarise and@@ -362,13 +387,13 @@             = addDataCon case_bndr dataCon (map StgVarArg args') env1             | otherwise             = env1-            -- see note [Case 2: CSEing case binders]+            -- see Note [Case 2: CSEing case binders]           rhs' = stgCseExpr env2 rhs-      in (DataAlt dataCon, args', rhs')-stgCseAlt env _ _ (altCon, args, rhs)+      in GenStgAlt (DataAlt dataCon) args' rhs'+stgCseAlt env _ _ g@GenStgAlt{alt_con=_, alt_bndrs=args, alt_rhs=rhs}     = let (env1, args') = substBndrs env args           rhs' = stgCseExpr env1 rhs-      in (altCon, args', rhs')+      in g {alt_bndrs=args', alt_rhs=rhs'}  -- Bindings stgCseBind :: CseEnv -> InStgBinding -> (Maybe OutStgBinding, CseEnv)@@ -402,14 +427,14 @@       in (Nothing, env')     | otherwise     = let env' = addDataCon bndr dataCon args' env-            -- see note [Case 1: CSEing allocated closures]+            -- see Note [Case 1: CSEing allocated closures]           pair = (bndr, StgRhsCon ccs dataCon mu ticks args')       in (Just pair, env')   where args' = substArgs env args  stgCseRhs env bndr (StgRhsClosure ext ccs upd args body)     = let (env1, args') = substBndrs env args-          env2 = forgetCse env1 -- See note [Free variables of an StgClosure]+          env2 = forgetCse env1 -- See Note [Free variables of an StgClosure]           body' = stgCseExpr env2 body       in (Just (substVar env bndr, StgRhsClosure ext ccs upd args' body'), env) @@ -420,8 +445,8 @@    where     -- see Note [All alternatives are the binder]-    isBndr (_, _, StgApp f []) = f == bndr-    isBndr _                   = False+    isBndr GenStgAlt{alt_con=_,alt_bndrs=_,alt_rhs=StgApp f []} = f == bndr+    isBndr _                                                    = False   {- Note [Care with loop breakers]@@ -468,25 +493,70 @@  Note [Trivial case scrutinee] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We want to be able to handle nested reconstruction of constructors as in+We want to be able to CSE nested reconstruction of constructors as in      nested :: Either Int (Either Int a) -> Either Bool (Either Bool a)     nested (Right (Right v)) = Right (Right v)-    nested _ = Left True--So if we come across+    nested _                 = Left True +We want the RHS of the first branch to be just the original argument.+The RHS of 'nested' will look like     case x of r1       Right a -> case a of r2               Right b -> let v = Right b                          in Right v+Then:+* We create the ce_conAppMap [Right a :-> r1, Right b :-> r2].+* When we encounter v = Right b, we'll drop the binding and extend+  the substitution with [v :-> r2]+* But now when we see (Right v), we'll substitute to get (Right r2)...and+  fail to find that in the ce_conAppMap! -we first replace v with r2. Next we want to replace Right r2 with r1. But the-ce_conAppMap contains Right a!+Solution: -Therefore, we add r1 ↦ x to ce_bndrMap when analysing the outer case, and use-this substitution before looking Right r2 up in ce_conAppMap, and everything-works out.+* When passing (case x of bndr { alts }), where 'x' is a variable, we+  add [bndr :-> x] to the ce_bndrMap.  In our example the ce_bndrMap will+  be [r1 :-> x, r2 :-> a]. This is done in addTrivCaseBndr.++* Before doing the /lookup/ in ce_conAppMap, we "normalise" the+  arguments with the ce_bndrMap.  In our example, we normalise+  (Right r2) to (Right a), and then find it in the map.  Normalisation+  is done by normaliseConArgs.++* Similarly before /inserting/ in ce_conAppMap, we normalise the arguments.+  This is a bit more subtle. Suppose we have+       case x of y+         DEFAULT -> let a = Just y+                    let b = Just y+                    in ...+  We'll have [y :-> x] in the ce_bndrMap.  When looking up (Just y) in+  the map, we'll normalise it to (Just x).  So we'd better normalise+  the (Just y) in the defn of 'a', before inserting it!++* When inserting into cs_bndrMap, we must normalise that too!+      case x of y+        DEFAULT -> case y of z+                      DEFAULT -> ...+  We want the cs_bndrMap to be [y :-> x, z :-> x]!+  Hence the call to normaliseId in addTrivCaseBinder.++All this is a bit tricky.  Why does it not occur for the Core version+of CSE?  See Note [CSE for bindings] in GHC.Core.Opt.CSE.  The reason+is this: in Core CSE we augment the /main substitution/ with [y :-> x]+etc, so as a side consequence we transform+    case x of y       ===>    case x of y+      pat -> ...y...             pat -> ...x...+That is, the /exact reverse/ of the binder-swap transformation done by+the occurrence analyser.  However, it's easy for CSE to do on-the-fly,+and it completely solves the above tricky problem, using only two maps:+the main reverse-map, and the substitution.  The occurrence analyser+puts it back the way it should be, the next time it runs.++However in STG there is no occurrence analyser, and we don't want to+require another pass.  So the ce_bndrMap is a little swizzle that we+apply just when manipulating the ce_conAppMap, but that does not+affect the output program.+  Note [Free variables of an StgClosure] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Stg/Debug.hs view
@@ -1,8 +1,11 @@ {-# LANGUAGE TupleSections #-}+ -- This module contains functions which implement -- the -finfo-table-map and -fdistinct-constructor-tables flags-module GHC.Stg.Debug(collectDebugInformation) where-+module GHC.Stg.Debug+  ( StgDebugOpts(..)+  , collectDebugInformation+  ) where  import GHC.Prelude @@ -15,11 +18,10 @@ import GHC.Unit.Module import GHC.Types.Name   ( getName, getOccName, occNameString, nameSrcSpan) import GHC.Data.FastString-import GHC.Driver.Session  import Control.Monad (when) import Control.Monad.Trans.Reader-import Control.Monad.Trans.State+import GHC.Utils.Monad.State.Strict import Control.Monad.Trans.Class import GHC.Types.Unique.Map import GHC.Types.SrcLoc@@ -29,11 +31,16 @@  data SpanWithLabel = SpanWithLabel RealSrcSpan String -data R = R { rDynFlags :: DynFlags, rModLocation :: ModLocation, rSpan :: Maybe SpanWithLabel }+data StgDebugOpts = StgDebugOpts+  { stgDebug_infoTableMap              :: !Bool+  , stgDebug_distinctConstructorTables :: !Bool+  } +data R = R { rOpts :: StgDebugOpts, rModLocation :: ModLocation, rSpan :: Maybe SpanWithLabel }+ type M a = ReaderT R (State InfoTableProvMap) a -withSpan :: (RealSrcSpan, String) -> M a -> M a+withSpan :: IpeSourceLocation -> M a -> M a withSpan (new_s, new_l) act = local maybe_replace act   where     maybe_replace r@R{ rModLocation = cur_mod, rSpan = Just (SpanWithLabel old_s _old_l) }@@ -44,9 +51,9 @@     maybe_replace r       = r { rSpan = Just (SpanWithLabel new_s new_l) } -collectDebugInformation :: DynFlags -> ModLocation -> [StgTopBinding] -> ([StgTopBinding], InfoTableProvMap)-collectDebugInformation dflags ml bs =-    runState (runReaderT (mapM collectTop bs) (R dflags ml Nothing)) emptyInfoTableProvMap+collectDebugInformation :: StgDebugOpts -> ModLocation -> [StgTopBinding] -> ([StgTopBinding], InfoTableProvMap)+collectDebugInformation opts ml bs =+    runState (runReaderT (mapM collectTop bs) (R opts ml Nothing)) emptyInfoTableProvMap  collectTop :: StgTopBinding -> M StgTopBinding collectTop (StgTopLifted t) = StgTopLifted <$> collectStgBind t@@ -117,7 +124,8 @@        return (StgTick tick e')  collectAlt :: StgAlt -> M StgAlt-collectAlt (ac, bs, e) = (ac, bs, ) <$> collectExpr e+collectAlt alt = do e' <- collectExpr $ alt_rhs alt+                    return $! alt { alt_rhs = e' }  -- | Try to find the best source position surrounding a 'StgExpr'. The -- heuristic strips ticks from the current expression until it finds one which@@ -135,8 +143,8 @@  recordStgIdPosition :: Id -> Maybe SpanWithLabel -> Maybe SpanWithLabel -> M () recordStgIdPosition id best_span ss = do-  dflags <- asks rDynFlags-  when (gopt Opt_InfoTableMap dflags) $ do+  opts <- asks rOpts+  when (stgDebug_infoTableMap opts) $ do     cc <- asks rSpan     --Useful for debugging why a certain Id gets given a certain span     --pprTraceM "recordStgIdPosition" (ppr id $$ ppr cc $$ ppr best_span $$ ppr ss)@@ -149,13 +157,13 @@ numberDataCon dc _ | isUnboxedTupleDataCon dc = return NoNumber numberDataCon dc _ | isUnboxedSumDataCon dc = return NoNumber numberDataCon dc ts = do-  dflags <- asks rDynFlags-  if not (gopt Opt_DistinctConstructorTables dflags) then return NoNumber else do+  opts <- asks rOpts+  if not (stgDebug_distinctConstructorTables opts) then return NoNumber else do     env <- lift get     mcc <- asks rSpan-    let mbest_span = (\(SpanWithLabel rss l) -> (rss, l)) <$> (selectTick ts <|> mcc)-    let dcMap' = alterUniqMap (maybe (Just ((0, mbest_span) :| [] ))-                        (\xs@((k, _):|_) -> Just ((k + 1, mbest_span) `NE.cons` xs))) (provDC env) dc+    let !mbest_span = (\(SpanWithLabel rss l) -> (rss, l)) <$> (selectTick ts <|> mcc)+    let !dcMap' = alterUniqMap (maybe (Just ((0, mbest_span) :| [] ))+                        (\xs@((k, _):|_) -> Just $! ((k + 1, mbest_span) `NE.cons` xs))) (provDC env) dc     lift $ put (env { provDC = dcMap' })     let r = lookupUniqMap dcMap' dc     return $ case r of@@ -178,16 +186,21 @@ a specific place in the source program, the mapping is usually quite precise because a fresh info table is created for each distinct THUNK. +The info table map is also used to generate stacktraces.+See Note [Stacktraces from Info Table Provenance Entries (IPE based stack unwinding)]+for details.+ There are three parts to the implementation -1. In GHC.Stg.Debug, the SourceNote information is used in order to give a source location to-some specific closures.-2. In StgToCmm, the actually used info tables are recorded in an IORef, this-is important as it's hard to predict beforehand what code generation will do-and which ids will end up in the generated program.-3. During code generation, a mapping from the info table to the statically-determined location is emitted which can then be queried at runtime by-various tools.+1. In GHC.Stg.Debug, the SourceNote information is used in order to give a source location+   to some specific closures.+2. In GHC.Driver.GenerateCgIPEStub, the actually used info tables are collected after the+   Cmm pipeline. This is important as it's hard to predict beforehand what code generation+   will do and which ids will end up in the generated program. Additionally, info tables of+   return frames (used to create stacktraces) are generated in the Cmm pipeline and aren't+   available before.+3. During code generation, a mapping from the info table to the statically determined location+   is emitted which can then be queried at runtime by various tools.  -- Giving Source Locations to Closures @@ -196,6 +209,8 @@  1. Data constructors to a list of where they are used. 2. `Name`s and where they originate from.+3. Stack represented info tables (return frames) to an approximated source location+   of the call that pushed a contiunation on the stacks.  During the CoreToStg phase, this map is populated whenever something is turned into a StgRhsClosure or an StgConApp. The current source position is recorded@@ -204,28 +219,27 @@ The functions which add information to the map are `recordStgIdPosition` and `numberDataCon`. -When the -fdistinct-constructor-tables` flag is turned on then every+When the `-fdistinct-constructor-tables` flag is turned on then every usage of a data constructor gets its own distinct info table. This is orchestrated in `collectExpr` where an incrementing number is used to distinguish each occurrence of a data constructor. --- StgToCmm+-- GenerateCgIPEStub -The info tables which are actually used in the generated program are recorded during the-conversion from STG to Cmm. The used info tables are recorded in the `emitProc` function.-All the used info tables are recorded in the `cgs_used_info` field. This step-is necessary because when the information about names is collected in the previous-phase it's unpredictable about which names will end up needing info tables. If-you don't record which ones are actually used then you end up generating code-which references info tables which don't exist.+The info tables which are actually used in the generated program are collected after+the Cmm pipeline. `initInfoTableProv` is used to create a CStub, that initializes the+map in C code. +This step has to be done after the Cmm pipeline to make sure that all info tables are+really used and, even more importantly, return frame info tables are generated by the+pipeline.+ -- Code Generation  The output of these two phases is combined together during code generation.-A C stub is generated which-creates the static map from info table pointer to the information about where that-info table was created from. This is created by `ipInitCode` in the same manner as a-C stub is generated for cost centres.+A C stub is generated which creates the static map from info table pointer to the+information about where that info table was created from. This is created by+`ipInitCode` in the same manner as a C stub is generated for cost centres.  This information can be consumed in two ways.
− compiler/GHC/Stg/DepAnal.hs 
@@ -1,146 +0,0 @@-{-# LANGUAGE CPP #-}--module GHC.Stg.DepAnal (depSortStgPgm) where--import GHC.Prelude--import GHC.Stg.Syntax-import GHC.Types.Id-import GHC.Types.Name (Name, nameIsLocalOrFrom)-import GHC.Types.Name.Env-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Types.Unique.Set (nonDetEltsUniqSet)-import GHC.Types.Var.Set-import GHC.Unit.Module (Module)--import Data.Graph (SCC (..))-import Data.Bifunctor (first)------------------------------------------------------------------------------------- * Dependency analysis---- | Set of bound variables-type BVs = VarSet---- | Set of free variables-type FVs = VarSet---- | Dependency analysis on STG terms.------ Dependencies of a binding are just free variables in the binding. This--- includes imported ids and ids in the current module. For recursive groups we--- just return one set of free variables which is just the union of dependencies--- of all bindings in the group.------ Implementation: pass bound variables (BVs) to recursive calls, get free--- variables (FVs) back. We ignore imported FVs as they do not change the--- ordering but it improves performance.----annTopBindingsDeps :: Module -> [StgTopBinding] -> [(StgTopBinding, FVs)]-annTopBindingsDeps this_mod bs = zip bs (map top_bind bs)-  where-    top_bind :: StgTopBinding -> FVs-    top_bind StgTopStringLit{} =-      emptyVarSet--    top_bind (StgTopLifted bs) =-      binding emptyVarSet bs--    binding :: BVs -> StgBinding -> FVs-    binding bounds (StgNonRec _ r) =-      rhs bounds r-    binding bounds (StgRec bndrs) =-      unionVarSets $-        map (bind_non_rec (extendVarSetList bounds (map fst bndrs))) bndrs--    bind_non_rec :: BVs -> (Id, StgRhs) -> FVs-    bind_non_rec bounds (_, r) =-        rhs bounds r--    rhs :: BVs -> StgRhs -> FVs-    rhs bounds (StgRhsClosure _ _ _ as e) =-      expr (extendVarSetList bounds as) e--    rhs bounds (StgRhsCon _ _ _ _ as) =-      args bounds as--    var :: BVs -> Var -> FVs-    var bounds v-      | not (elemVarSet v bounds)-      , nameIsLocalOrFrom this_mod (idName v)-      = unitVarSet v-      | otherwise-      = emptyVarSet--    arg :: BVs -> StgArg -> FVs-    arg bounds (StgVarArg v) = var bounds v-    arg _ StgLitArg{} = emptyVarSet--    args :: BVs -> [StgArg] -> FVs-    args bounds as = unionVarSets (map (arg bounds) as)--    expr :: BVs -> StgExpr -> FVs-    expr bounds (StgApp f as) =-      var bounds f `unionVarSet` args bounds as--    expr _ StgLit{} =-      emptyVarSet--    expr bounds (StgConApp _ _ as _) =-      args bounds as-    expr bounds (StgOpApp _ as _) =-      args bounds as-    expr bounds (StgCase scrut scrut_bndr _ as) =-      expr bounds scrut `unionVarSet`-        alts (extendVarSet bounds scrut_bndr) as-    expr bounds (StgLet _ bs e) =-      binding bounds bs `unionVarSet`-        expr (extendVarSetList bounds (bindersOf bs)) e-    expr bounds (StgLetNoEscape _ bs e) =-      binding bounds bs `unionVarSet`-        expr (extendVarSetList bounds (bindersOf bs)) e--    expr bounds (StgTick _ e) =-      expr bounds e--    alts :: BVs -> [StgAlt] -> FVs-    alts bounds = unionVarSets . map (alt bounds)--    alt :: BVs -> StgAlt -> FVs-    alt bounds (_, bndrs, e) =-      expr (extendVarSetList bounds bndrs) e------------------------------------------------------------------------------------- * Dependency sorting---- | Dependency sort a STG program so that dependencies come before uses.-depSortStgPgm :: Module -> [StgTopBinding] -> [StgTopBinding]-depSortStgPgm this_mod =-    {-# SCC "STG.depSort" #-}-    map fst . depSort . annTopBindingsDeps this_mod---- | Sort free-variable-annotated STG bindings so that dependencies come before--- uses.-depSort :: [(StgTopBinding, FVs)] -> [(StgTopBinding, FVs)]-depSort = concatMap get_binds . depAnal defs uses-  where-    uses, defs :: (StgTopBinding, FVs) -> [Name]--    -- TODO (osa): I'm unhappy about two things in this code:-    ---    --     * Why do we need Name instead of Id for uses and dependencies?-    --     * Why do we need a [Name] instead of `Set Name`? Surely depAnal-    --       doesn't need any ordering.--    uses (StgTopStringLit{}, _) = []-    uses (StgTopLifted{}, fvs)  = map idName (nonDetEltsUniqSet fvs)--    defs (bind, _) = map idName (bindersOfTop bind)--    get_binds (AcyclicSCC bind) =-      [bind]-    get_binds (CyclicSCC binds) =-      pprPanic "depSortStgBinds"-               (text "Found cyclic SCC:"-               $$ ppr (map (first (pprStgTopBinding panicStgPprOpts)) binds))
compiler/GHC/Stg/FVs.hs view
@@ -40,129 +40,238 @@ variables are global. -} module GHC.Stg.FVs (-    annTopBindingsFreeVars,+    depSortWithAnnotStgPgm,     annBindingFreeVars   ) where -import GHC.Prelude+import GHC.Prelude hiding (mod)  import GHC.Stg.Syntax+import GHC.Stg.Utils (bindersOf) import GHC.Types.Id-import GHC.Types.Var.Set+import GHC.Types.Name (Name, nameIsLocalOrFrom) import GHC.Types.Tickish ( GenTickish(Breakpoint) )+import GHC.Types.Unique.Set (nonDetEltsUniqSet)+import GHC.Types.Var.Set+import GHC.Unit.Module (Module) import GHC.Utils.Misc -import Data.Maybe ( mapMaybe )+import Data.Graph (SCC (..))+import GHC.Data.Graph.Directed( Node(..), stronglyConnCompFromEdgedVerticesUniq ) -newtype Env+{- Note [Why do we need dependency analysis?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The program needs to be in dependency order for the SRT algorithm to+work (see CmmBuildInfoTables, which also includes a detailed+description of the algorithm).++But isn't it in correct dependency order already?  No:++* The simplifier does not guarantee to produce programs in dependency+  order (see #16192 and Note [Glomming] in GHC.Core.Opt.OccurAnal).+  This could be solved by a final run of the occurrence analyser, but+  that's more work++* We also don't guarantee that StgLiftLams will preserve the order or+  only create minimal recursive groups.+-}++--------------------------------------------------------------------------------+-- | Dependency sort a STG program, and annotate it with free variables+-- The returned bindings:+--   * Are in dependency order+--   * Each StgRhsClosure is correctly annotated (in its extension field)+--     with the free variables needed in the closure+--   * Each StgCase is correctly annotated (in its extension field) with+--     the variables that must be saved across the case+depSortWithAnnotStgPgm :: Module -> [StgTopBinding] -> [CgStgTopBinding]+depSortWithAnnotStgPgm this_mod binds+  = {-# SCC "STG.depSortWithAnnotStgPgm" #-}+    lit_binds ++ map from_scc sccs+  where+    lit_binds :: [CgStgTopBinding]+    pairs     :: [(Id, StgRhs)]+    (lit_binds, pairs) = flattenTopStgBindings binds++    nodes :: [Node Name (Id, CgStgRhs)]+    nodes = map (annotateTopPair env0) pairs+    env0 = Env { locals = emptyVarSet, mod = this_mod }++    -- Do strongly connected component analysis.  Why?+    -- See Note [Why do we need dependency analysis?]+    sccs :: [SCC (Id,CgStgRhs)]+    sccs  = stronglyConnCompFromEdgedVerticesUniq nodes++    from_scc (CyclicSCC pairs)       = StgTopLifted (StgRec pairs)+    from_scc (AcyclicSCC (bndr,rhs)) = StgTopLifted (StgNonRec bndr rhs)+++flattenTopStgBindings :: [StgTopBinding] -> ([CgStgTopBinding], [(Id,StgRhs)])+flattenTopStgBindings binds+  = go [] [] binds+  where+    go lits pairs [] = (lits, pairs)+    go lits pairs (bind:binds)+      = case bind of+          StgTopStringLit bndr rhs -> go (StgTopStringLit bndr rhs:lits) pairs binds+          StgTopLifted stg_bind -> go lits (flatten_one stg_bind ++ pairs) binds++    flatten_one (StgNonRec b r) = [(b,r)]+    flatten_one (StgRec pairs)  = pairs++annotateTopPair :: Env -> (Id, StgRhs) -> Node Name (Id, CgStgRhs)+annotateTopPair env0 (bndr, rhs)+  = DigraphNode { node_key          = idName bndr+                , node_payload      = (bndr, rhs')+                , node_dependencies = map idName (nonDetEltsUniqSet top_fvs) }+  where+    (rhs', top_fvs, _) = rhsFVs env0 rhs++--------------------------------------------------------------------------------+-- * Non-global free variable analysis++data Env   = Env-  { locals :: IdSet+  { -- | Set of locally-bound, not-top-level binders in scope.+    -- That is, variables bound by a let (but not let-no-escape), a lambda+    -- (in a StgRhsClsoure), a case binder, or a case alternative.  These+    -- are the variables that must be captured in a function closure, if they+    -- are free in the RHS. Example+    --   f = \x. let g = \y. x+1+    --           let h = \z. g z + 1+    --           in h x+    -- In the body of h we have locals = {x, g, z}.  Note that f is top level+    -- and does not appear in locals.+    locals :: IdSet+  , mod    :: Module   } -emptyEnv :: Env-emptyEnv = Env emptyVarSet- addLocals :: [Id] -> Env -> Env addLocals bndrs env   = env { locals = extendVarSetList (locals env) bndrs } --- | Annotates a top-level STG binding group with its free variables.-annTopBindingsFreeVars :: [StgTopBinding] -> [CgStgTopBinding]-annTopBindingsFreeVars = map go-  where-    go (StgTopStringLit id bs) = StgTopStringLit id bs-    go (StgTopLifted bind)-      = StgTopLifted (annBindingFreeVars bind)---- | Annotates an STG binding with its free variables.-annBindingFreeVars :: StgBinding -> CgStgBinding-annBindingFreeVars = fst . binding emptyEnv emptyDVarSet+--------------------------------------------------------------------------------+-- | TopFVs: set of variables that are:+--    (a) bound at the top level of this module, and+--    (b) appear free in the expression+-- It is a /non-deterministic/ set because we use it only to perform dependency+-- analysis on the top-level bindings.+type TopFVs   = IdSet -boundIds :: StgBinding -> [Id]-boundIds (StgNonRec b _) = [b]-boundIds (StgRec pairs)  = map fst pairs+-- | LocalFVs: set of variable that are:+--     (a) bound locally (by a lambda, non-top-level let, or case); that is,+--         it appears in the 'locals' field of 'Env'+--     (b) appear free in the expression+-- It is a /deterministic/ set because it is used to annotate closures with+-- their free variables, and we want closure layout to be deterministic.+--+-- Invariant: the LocalFVs returned is a subset of the 'locals' field of Env+type LocalFVs = DIdSet --- Note [Tracking local binders]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- 'locals' contains non-toplevel, non-imported binders.--- We maintain the set in 'expr', 'alt' and 'rhs', which are the only--- places where new local binders are introduced.--- Why do it there rather than in 'binding'? Two reasons:+-- | Dependency analysis on STG terms. -----   1. We call 'binding' from 'annTopBindingsFreeVars', which would---      add top-level bindings to the 'locals' set.---   2. In the let(-no-escape) case, we need to extend the environment---      prior to analysing the body, but we also need the fvs from the---      body to analyse the RHSs. No way to do this without some---      knot-tying.+-- Dependencies of a binding are just free variables in the binding. This+-- includes imported ids and ids in the current module. For recursive groups we+-- just return one set of free variables which is just the union of dependencies+-- of all bindings in the group.+--+-- Implementation: pass bound variables (NestedIds) to recursive calls, get free+-- variables (TopFVs) back. We ignore imported TopFVs as they do not change the+-- ordering but it improves performance (see `nameIsExternalFrom` call in `vars_fvs`).+-- --- | This makes sure that only local, non-global free vars make it into the set.-mkFreeVarSet :: Env -> [Id] -> DIdSet-mkFreeVarSet env = mkDVarSet . filter (`elemVarSet` locals env)+annBindingFreeVars :: Module -> StgBinding -> CgStgBinding+annBindingFreeVars this_mod = fstOf3 . bindingFVs (Env emptyVarSet this_mod) emptyDVarSet -args :: Env -> [StgArg] -> DIdSet-args env = mkFreeVarSet env . mapMaybe f-  where-    f (StgVarArg occ) = Just occ-    f _               = Nothing+bindingFVs :: Env -> LocalFVs -> StgBinding -> (CgStgBinding, TopFVs, LocalFVs)+bindingFVs env body_fv b =+  case b of+    StgNonRec bndr r -> (StgNonRec bndr r', fvs, lcl_fvs)+      where+        (r', fvs, rhs_lcl_fvs) = rhsFVs env r+        lcl_fvs = delDVarSet body_fv bndr `unionDVarSet` rhs_lcl_fvs -binding :: Env -> DIdSet -> StgBinding -> (CgStgBinding, DIdSet)-binding env body_fv (StgNonRec bndr r) = (StgNonRec bndr r', fvs)-  where-    -- See Note [Tracking local binders]-    (r', rhs_fvs) = rhs env r-    fvs = delDVarSet body_fv bndr `unionDVarSet` rhs_fvs-binding env body_fv (StgRec pairs) = (StgRec pairs', fvs)-  where-    -- See Note [Tracking local binders]-    bndrs = map fst pairs-    (rhss, rhs_fvss) = mapAndUnzip (rhs env . snd) pairs-    pairs' = zip bndrs rhss-    fvs = delDVarSetList (unionDVarSets (body_fv:rhs_fvss)) bndrs+    StgRec pairs -> (StgRec pairs', fvs, lcl_fvss)+      where+        bndrs = map fst pairs+        env' = addLocals bndrs env+        (rhss, rhs_fvss, rhs_lcl_fvss) = mapAndUnzip3 (rhsFVs env' . snd) pairs+        fvs = unionVarSets rhs_fvss+        pairs' = zip bndrs rhss+        lcl_fvss = delDVarSetList (unionDVarSets (body_fv:rhs_lcl_fvss)) bndrs -expr :: Env -> StgExpr -> (CgStgExpr, DIdSet)-expr env = go+varFVs :: Env -> Id -> (TopFVs, LocalFVs) -> (TopFVs, LocalFVs)+varFVs env v (top_fvs, lcl_fvs)+  | v `elemVarSet` locals env                -- v is locally bound+  = (top_fvs, lcl_fvs `extendDVarSet` v)+  | nameIsLocalOrFrom (mod env) (idName v)   -- v is bound at top level+  = (top_fvs `extendVarSet` v, lcl_fvs)+  | otherwise                                -- v is imported+  = (top_fvs, lcl_fvs)++exprFVs :: Env -> StgExpr -> (CgStgExpr, TopFVs, LocalFVs)+exprFVs env = go   where-    go (StgApp occ as)-      = (StgApp occ as, unionDVarSet (args env as) (mkFreeVarSet env [occ]))-    go (StgLit lit) = (StgLit lit, emptyDVarSet)-    go (StgConApp dc n as tys) = (StgConApp dc n as tys, args env as)-    go (StgOpApp op as ty) = (StgOpApp op as ty, args env as)-    go (StgCase scrut bndr ty alts) = (StgCase scrut' bndr ty alts', fvs)-      where-        (scrut', scrut_fvs) = go scrut-        -- See Note [Tracking local binders]-        (alts', alt_fvss) = mapAndUnzip (alt (addLocals [bndr] env)) alts-        alt_fvs = unionDVarSets alt_fvss-        fvs = delDVarSet (unionDVarSet scrut_fvs alt_fvs) bndr-    go (StgLet ext bind body) = go_bind (StgLet ext) bind body+    go (StgApp f as)+      | (top_fvs, lcl_fvs) <- varFVs env f (argsFVs env as)+      = (StgApp f as, top_fvs, lcl_fvs)++    go (StgLit lit) = (StgLit lit, emptyVarSet, emptyDVarSet)++    go (StgConApp dc n as tys)+      | (top_fvs, lcl_fvs) <- argsFVs env as+      = (StgConApp dc n as tys, top_fvs, lcl_fvs)++    go (StgOpApp op as ty)+      | (top_fvs, lcl_fvs) <- argsFVs env as+      = (StgOpApp op as ty, top_fvs, lcl_fvs)++    go (StgCase scrut bndr ty alts)+      | (scrut',scrut_top_fvs,scrut_lcl_fvs) <- exprFVs env scrut+      , (alts',alts_top_fvss,alts_lcl_fvss)+          <- mapAndUnzip3 (altFVs (addLocals [bndr] env)) alts+      , let top_fvs = scrut_top_fvs `unionVarSet` unionVarSets alts_top_fvss+            alts_lcl_fvs = unionDVarSets alts_lcl_fvss+            lcl_fvs = delDVarSet (unionDVarSet scrut_lcl_fvs alts_lcl_fvs) bndr+      = (StgCase scrut' bndr ty alts', top_fvs,lcl_fvs)++    go (StgLet ext         bind body) = go_bind (StgLet ext) bind body     go (StgLetNoEscape ext bind body) = go_bind (StgLetNoEscape ext) bind body-    go (StgTick tick e) = (StgTick tick e', fvs')-      where-        (e', fvs) = go e-        fvs' = unionDVarSet (tickish tick) fvs-        tickish (Breakpoint _ _ ids) = mkDVarSet ids-        tickish _                    = emptyDVarSet -    go_bind dc bind body = (dc bind' body', fvs)+    go (StgTick tick e)+      | (e', top_fvs, lcl_fvs) <- exprFVs env e+      , let lcl_fvs' = unionDVarSet (tickish tick) lcl_fvs+      = (StgTick tick e', top_fvs, lcl_fvs')+        where+          tickish (Breakpoint _ _ ids) = mkDVarSet ids+          tickish _                    = emptyDVarSet++    go_bind dc bind body = (dc bind' body', top_fvs, lcl_fvs)       where-        -- See Note [Tracking local binders]-        env' = addLocals (boundIds bind) env-        (body', body_fvs) = expr env' body-        (bind', fvs) = binding env' body_fvs bind+        env' = addLocals (bindersOf bind) env+        (body', body_top_fvs, body_lcl_fvs) = exprFVs env' body+        (bind', bind_top_fvs, lcl_fvs)      = bindingFVs env' body_lcl_fvs bind+        top_fvs = bind_top_fvs `unionVarSet` body_top_fvs -rhs :: Env -> StgRhs -> (CgStgRhs, DIdSet)-rhs env (StgRhsClosure _ ccs uf bndrs body)-  = (StgRhsClosure fvs ccs uf bndrs body', fvs)-  where-    -- See Note [Tracking local binders]-    (body', body_fvs) = expr (addLocals bndrs env) body-    fvs = delDVarSetList body_fvs bndrs-rhs env (StgRhsCon ccs dc mu ts as) = (StgRhsCon ccs dc mu ts as, args env as) -alt :: Env -> StgAlt -> (CgStgAlt, DIdSet)-alt env (con, bndrs, e) = ((con, bndrs, e'), fvs)+rhsFVs :: Env -> StgRhs -> (CgStgRhs, TopFVs, LocalFVs)+rhsFVs env (StgRhsClosure _ ccs uf bs body)+  | (body', top_fvs, lcl_fvs) <- exprFVs (addLocals bs env) body+  , let lcl_fvs' = delDVarSetList lcl_fvs bs+  = (StgRhsClosure lcl_fvs' ccs uf bs body', top_fvs, lcl_fvs')+rhsFVs env (StgRhsCon ccs dc mu ts bs)+  | (top_fvs, lcl_fvs) <- argsFVs env bs+  = (StgRhsCon ccs dc mu ts bs, top_fvs, lcl_fvs)++argsFVs :: Env -> [StgArg] -> (TopFVs, LocalFVs)+argsFVs env = foldl' f (emptyVarSet, emptyDVarSet)   where-    -- See Note [Tracking local binders]-    (e', rhs_fvs) = expr (addLocals bndrs env) e-    fvs = delDVarSetList rhs_fvs bndrs+    f (fvs,ids) StgLitArg{}   = (fvs, ids)+    f (fvs,ids) (StgVarArg v) = varFVs env v (fvs, ids)++altFVs :: Env -> StgAlt -> (CgStgAlt, TopFVs, LocalFVs)+altFVs env GenStgAlt{alt_con=con, alt_bndrs=bndrs, alt_rhs=e}+  | (e', top_fvs, lcl_fvs) <- exprFVs (addLocals bndrs env) e+  , let lcl_fvs' = delDVarSetList lcl_fvs bndrs+  , let newAlt   = GenStgAlt{alt_con=con, alt_bndrs=bndrs, alt_rhs=e'}+  = (newAlt, top_fvs, lcl_fvs')
+ compiler/GHC/Stg/InferTags.hs view
@@ -0,0 +1,643 @@+{-# LANGUAGE TypeFamilies, DataKinds, GADTs, FlexibleInstances #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+ -- To permit: type instance XLet 'InferTaggedBinders = XLet 'SomePass++{-# OPTIONS_GHC -Wname-shadowing #-}+module GHC.Stg.InferTags ( inferTags ) where++import GHC.Prelude hiding (id)++import GHC.Core.DataCon+import GHC.Core.Type+import GHC.Types.Id+import GHC.Types.Id.Info (tagSigInfo)+import GHC.Types.Name+import GHC.Stg.Syntax+import GHC.Types.Basic ( CbvMark (..) )+import GHC.Types.Unique.Supply (mkSplitUniqSupply)+import GHC.Types.RepType (dataConRuntimeRepStrictness)+import GHC.Core (AltCon(..))+import Data.List (mapAccumL)+import GHC.Utils.Outputable+import GHC.Utils.Misc( zipWithEqual, zipEqual, notNull )++import GHC.Stg.InferTags.Types+import GHC.Stg.InferTags.Rewrite (rewriteTopBinds)+import Data.Maybe+import GHC.Types.Name.Env (mkNameEnv, NameEnv)+import GHC.Driver.Config.Stg.Ppr+import GHC.Driver.Session+import GHC.Utils.Logger+import qualified GHC.Unit.Types++{- Note [Tag Inference]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The purpose of this pass is to attach to every binder a flag+to indicate whether or not it is "properly tagged".  A binder+is properly tagged if it is guaranteed:+ - to point to a heap-allocated *value*+ - and to have the tag of the value encoded in the pointer++For example+  let x = Just y in ...++Here x will be properly tagged: it will point to the heap-allocated+values for (Just y), and the tag-bits of the pointer will encode+the tag for Just so there is no need to re-enter the closure or even+check for the presence of tag bits. The impacts of this can be very large.++For containers the reduction in runtimes with this optimization was as follows:++intmap-benchmarks:    89.30%+intset-benchmarks:    90.87%+map-benchmarks:       88.00%+sequence-benchmarks:  99.84%+set-benchmarks:       85.00%+set-operations-intmap:88.64%+set-operations-map:   74.23%+set-operations-set:   76.50%+lookupge-intmap:      89.57%+lookupge-map:         70.95%++With nofib being ~0.3% faster as well.++See Note [Tag inference passes] for how we proceed to generate and use this information.++Note [Strict Field Invariant]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As part of tag inference we introduce the Strict Field Invariant.+Which consists of us saying that:++* Pointers in strict fields must (a) point directly to the value, and+  (b) must be properly tagged.++For example, given+  data T = MkT ![Int]++the Strict Field Invariant guarantees that the first field of any `MkT` constructor+will either point directly to nil, or directly to a cons cell;+and will be tagged with `001` or `010` respectively.+It will never point to a thunk, nor will it be tagged `000` (meaning "might be a thunk").+NB: Note that the proper tag for some objects is indeed `000`. Currently this is the case for PAPs.++This works analogous to how `WorkerLikeId`s work. See also Note [CBV Function Ids].++Why do we care? Because if we have code like:++case strictPair of+  SP x y ->+    case x of ...++It allows us to safely omit the code to enter x and the check+for the presence of a tag that goes along with it.+However we might still branch on the tag as usual.+See Note [Tag Inference] for how much impact this can have for+some code.++This is enforced by the code GHC.Stg.InferTags.Rewrite+where we:++* Look at all constructor allocations.+* Check if arguments to their strict fields are known to be properly tagged+* If not we convert `StrictJust x` into `case x of x' -> StrictJust x'`++This is usually very beneficial but can cause regressions in rare edge cases where+we fail to proof that x is properly tagged, or where it simply isn't.+See Note [How untagged pointers can end up in strict fields] for how the second case+can arise.++For a full example of the worst case consider this code:++foo ... = ...+  let c = StrictJust x+  in ...++Here we would rewrite `let c = StrictJust x` into `let c = case x of x' -> StrictJust x'`+However that is horrible! We end up allocating a thunk for `c` first, which only when+evaluated will allocate the constructor.++So we do our best to establish that `x` is already tagged (which it almost always is)+to avoid this cost. In my benchmarks I haven't seen any cases where this causes regressions.++Note that there are similar constraints around Note [CBV Function Ids].++Note [How untagged pointers can end up in strict fields]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  data Set a = Tip | Bin !a (Set a) (Set a)++We make a wrapper for Bin that evaluates its arguments+  $WBin x a b = case x of xv -> Bin xv a b+Here `xv` will always be evaluated and properly tagged, just as the+Strict Field Invariant requires.++But alas the Simplifier can destroy the invariant: see #15696.+We start with+  thk = f ()+  g x = ...(case thk of xv -> Bin xv Tip Tip)...++So far so good; the argument to Bin (which is strict) is evaluated.+Now we do float-out. And in doing so we do a reverse binder-swap (see+Note [Binder-swap during float-out] in SetLevels) thus++  g x = ...(case thk of xv -> Bin thk Nil Nil)...++The goal of the reverse binder-swap is to allow more floating -- and+indeed it does! We float the Bin to top level:++  lvl = Bin thk Tip Tip+  g x = ...(case thk of xv -> lvl)...++Now you can see that the argument of Bin, namely thk, points to the+thunk, not to the value as it did before.++In short, although it may be rare, the output of optimisation passes+cannot guarantee to obey the Strict Field Invariant. For this reason+we run tag inference. See Note [Tag inference passes].++Note [Tag inference passes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Tag inference proceeds in two passes:+* The first pass is an analysis to compute which binders are properly tagged.+  The result is then attached to /binders/.+  This is implemented by `inferTagsAnal` in GHC.Stg.InferTags+* The second pass walks over the AST checking if the Strict Field Invariant is upheld.+  See Note [Strict Field Invariant].+  If required this pass modifies the program to uphold this invariant.+  Tag information is also moved from /binders/ to /occurrences/ during this pass.+  This is done by `GHC.Stg.InferTags.Rewrite (rewriteTopBinds)`.+* Finally the code generation uses this information to skip the thunk check when branching on+  values. This is done by `cgExpr`/`cgCase` in the backend.++Last but not least we also export the tag sigs of top level bindings to allow this optimization+ to work across module boundaries.++Note [TagInfo of functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+The purpose of tag inference is really to figure out when we don't have to enter+value closures. There the meaning of the tag is fairly obvious.+For functions we never make use of the tag info so we have two choices:+* Treat them as TagDunno+* Treat them as TagProper (as they *are* tagged with their arity) and be really+  careful to make sure we still enter them when needed.+As it makes little difference for runtime performance I've treated functions as TagDunno in a few places where+it made the code simpler. But besides implementation complexity there isn't any reason+why we couldn't be more rigourous in dealing with functions.++NB: It turned in #21193 that PAPs get tag zero, so the tag check can't be omitted for functions.+So option two isn't really an option without reworking this anyway.++Note [Tag inference debugging]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There is a flag -dtag-inference-checks which inserts various+compile/runtime checks in order to ensure the Strict Field Invariant+holds. It should cover all places+where tags matter and disable optimizations which interfere with checking+the invariant like generation of AP-Thunks.++Note [Polymorphic StgPass for inferTagExpr]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In order to reach a fixpoint we sometimes have to re-analyse an expression+multiple times. But after the initial run the Ast will be parameterized by+a different StgPass! To handle this a large part of the analysis is polymorphic+over the exact StgPass we are using. Which allows us to run the analysis on+the output of itself.++-}++{- *********************************************************************+*                                                                      *+                         Tag inference pass+*                                                                      *+********************************************************************* -}++-- doCodeGen :: HscEnv -> Module -> InfoTableProvMap -> [TyCon]+--           -> CollectedCCs+--           -> [CgStgTopBinding] -- ^ Bindings come already annotated with fvs+--           -> HpcInfo+--           -> IO (Stream IO CmmGroupSRTs CgInfos)+--          -- Note we produce a 'Stream' of CmmGroups, so that the+--          -- backend can be run incrementally.  Otherwise it generates all+--          -- the C-- up front, which has a significant space cost.+inferTags :: DynFlags -> Logger -> (GHC.Unit.Types.Module) -> [CgStgTopBinding] -> IO ([TgStgTopBinding], NameEnv TagSig)+inferTags dflags logger this_mod stg_binds = do++    -- Annotate binders with tag information.+    let (!stg_binds_w_tags) = {-# SCC "StgTagFields" #-}+                                        inferTagsAnal stg_binds+    putDumpFileMaybe logger Opt_D_dump_stg_tags "CodeGenAnal STG:" FormatSTG (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds_w_tags)++    let export_tag_info = collectExportInfo stg_binds_w_tags++    -- Rewrite STG to uphold the strict field invariant+    us_t <- mkSplitUniqSupply 't'+    let rewritten_binds = {-# SCC "StgTagRewrite" #-} rewriteTopBinds this_mod us_t stg_binds_w_tags :: [TgStgTopBinding]++    return (rewritten_binds,export_tag_info)++{- *********************************************************************+*                                                                      *+                         Main inference algorithm+*                                                                      *+********************************************************************* -}++type OutputableInferPass p = (Outputable (TagEnv p)+                              , Outputable (GenStgExpr p)+                              , Outputable (BinderP p)+                              , Outputable (GenStgRhs p))++-- | This constraint encodes the fact that no matter what pass+-- we use the Let/Closure extension points are the same as these for+-- 'InferTaggedBinders.+type InferExtEq i = ( XLet i ~ XLet 'InferTaggedBinders+                    , XLetNoEscape i ~ XLetNoEscape 'InferTaggedBinders+                    , XRhsClosure i ~ XRhsClosure 'InferTaggedBinders)++inferTagsAnal :: [GenStgTopBinding 'CodeGen] -> [GenStgTopBinding 'InferTaggedBinders]+inferTagsAnal binds =+  -- pprTrace "Binds" (pprGenStgTopBindings shortStgPprOpts $ binds) $+  snd (mapAccumL inferTagTopBind initEnv binds)++-----------------------+inferTagTopBind :: TagEnv 'CodeGen -> GenStgTopBinding 'CodeGen+                -> (TagEnv 'CodeGen, GenStgTopBinding 'InferTaggedBinders)+inferTagTopBind env (StgTopStringLit id bs)+  = (env, StgTopStringLit id bs)+inferTagTopBind env (StgTopLifted bind)+  = (env', StgTopLifted bind')+  where+    (env', bind') = inferTagBind env bind+++-- Why is this polymorphic over the StgPass? See Note [Polymorphic StgPass for inferTagExpr]+-----------------------+inferTagExpr :: forall p. (OutputableInferPass p, InferExtEq p)+  => TagEnv p -> GenStgExpr p -> (TagInfo, GenStgExpr 'InferTaggedBinders)+inferTagExpr env (StgApp fun args)+  =  --pprTrace "inferTagExpr1"+      -- (ppr fun <+> ppr args $$ ppr info $$+      --  text "deadEndInfo:" <> ppr (isDeadEndId fun, idArity fun, length args)+      -- )+    (info, StgApp fun args)+  where+    !fun_arity = idArity fun+    info | fun_arity == 0 -- Unknown arity => Thunk or unknown call+         = TagDunno++         | isDeadEndId fun+         , fun_arity == length args -- Implies we will simply call the function.+         = TagTagged -- See Note [Bottom functions are TagTagged]++         | Just (TagSig res_info) <- tagSigInfo (idInfo fun)+         , fun_arity == length args  -- Saturated+         = res_info++         | Just (TagSig res_info) <- lookupSig env fun+         , fun_arity == length args  -- Saturated+         = res_info++         | otherwise+         = --pprTrace "inferAppUnknown" (ppr fun) $+           TagDunno+-- TODO:+-- If we have something like:+--   let x = thunk in+--   f g = case g of g' -> (# x, g' #)+-- then we *do* know that g' will be properly tagged,+-- so we should return TagTagged [TagDunno,TagProper] but currently we infer+-- TagTagged [TagDunno,TagDunno] because of the unknown arity case in inferTagExpr.+-- Seems not to matter much but should be changed eventually.++inferTagExpr env (StgConApp con cn args tys)+  = (inferConTag env con args, StgConApp con cn args tys)++inferTagExpr _ (StgLit l)+  = (TagTagged, StgLit l)++inferTagExpr env (StgTick tick body)+  = (info, StgTick tick body')+  where+    (info, body') = inferTagExpr env body++inferTagExpr _ (StgOpApp op args ty)+  = -- Do any primops guarantee to return a properly tagged value?+    -- I think not.  Ditto foreign calls.+    (TagDunno, StgOpApp op args ty)++inferTagExpr env (StgLet ext bind body)+  = (info, StgLet ext bind' body')+  where+    (env', bind') = inferTagBind env bind+    (info, body') = inferTagExpr env' body++inferTagExpr env (StgLetNoEscape ext bind body)+  = (info, StgLetNoEscape ext bind' body')+  where+    (env', bind') = inferTagBind env bind+    (info, body') = inferTagExpr env' body++inferTagExpr in_env (StgCase scrut bndr ty alts)+  -- Unboxed tuples get their info from the expression we scrutinise if any+  | [GenStgAlt{alt_con=DataAlt con, alt_bndrs=bndrs, alt_rhs=rhs}] <- alts+  , isUnboxedTupleDataCon con+  , Just infos <- scrut_infos bndrs+  , let bndrs' = zipWithEqual "inferTagExpr" mk_bndr bndrs infos+        mk_bndr :: BinderP p -> TagInfo -> (Id, TagSig)+        mk_bndr tup_bndr tup_info =+            --  pprTrace "mk_ubx_bndr_info" ( ppr bndr <+> ppr info ) $+            (getBinderId in_env tup_bndr, TagSig tup_info)+        -- no case binder in alt_env here, unboxed tuple binders are dead after unarise+        alt_env = extendSigEnv in_env bndrs'+        (info, rhs') = inferTagExpr alt_env rhs+  =+    -- pprTrace "inferCase1" (+    --   text "scrut:" <> ppr scrut $$+    --   text "bndr:" <> ppr bndr $$+    --   text "infos" <> ppr infos $$+    --   text "out_bndrs" <> ppr bndrs') $+    (info, StgCase scrut' (noSig in_env bndr) ty [GenStgAlt{ alt_con=DataAlt con+                                                           , alt_bndrs=bndrs'+                                                           , alt_rhs=rhs'}])++  | null alts -- Empty case, but I might just be paranoid.+  = -- pprTrace "inferCase2" empty $+    (TagDunno, StgCase scrut' bndr' ty [])+  -- More than one alternative OR non-TagTuple single alternative.+  | otherwise+  =+    let+        case_env = extendSigEnv in_env [bndr']++        (infos, alts')+          = unzip [ (info, g {alt_bndrs=bndrs', alt_rhs=rhs'})+                  | g@GenStgAlt{ alt_con = con+                               , alt_bndrs = bndrs+                               , alt_rhs   = rhs+                               } <- alts+                  , let (alt_env,bndrs') = addAltBndrInfo case_env con bndrs+                        (info, rhs') = inferTagExpr alt_env rhs+                  ]+        alt_info = foldr combineAltInfo TagTagged infos+    in ( alt_info, StgCase scrut' bndr' ty alts')+  where+    -- Single unboxed tuple alternative+    scrut_infos bndrs = case scrut_info of+      TagTagged -> Just $ replicate (length bndrs) TagProper+      TagTuple infos -> Just infos+      _ -> Nothing+    (scrut_info, scrut') = inferTagExpr in_env scrut+    bndr' = (getBinderId in_env bndr, TagSig TagProper)++-- Compute binder sigs based on the constructors strict fields.+-- NB: Not used if we have tuple info from the scrutinee.+addAltBndrInfo :: forall p. TagEnv p -> AltCon -> [BinderP p] -> (TagEnv p, [BinderP 'InferTaggedBinders])+addAltBndrInfo env (DataAlt con) bndrs+  | not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con)+  = (out_env, out_bndrs)+  where+    marks = dataConRuntimeRepStrictness con :: [StrictnessMark]+    out_bndrs = zipWith mk_bndr bndrs marks+    out_env = extendSigEnv env out_bndrs++    mk_bndr :: (BinderP p -> StrictnessMark -> (Id, TagSig))+    mk_bndr bndr mark+      | isUnliftedType (idType id) || isMarkedStrict mark+      = (id, TagSig TagProper)+      | otherwise+      = noSig env bndr+        where+          id = getBinderId env bndr++addAltBndrInfo env _ bndrs = (env, map (noSig env) bndrs)++-----------------------------+inferTagBind :: (OutputableInferPass p, InferExtEq p)+  => TagEnv p -> GenStgBinding p -> (TagEnv p, GenStgBinding 'InferTaggedBinders)+inferTagBind in_env (StgNonRec bndr rhs)+  =+    -- pprTrace "inferBindNonRec" (+    --   ppr bndr $$+    --   ppr (isDeadEndId id) $$+    --   ppr sig)+    (env', StgNonRec (id, sig) rhs')+  where+    id   = getBinderId in_env bndr+    env' = extendSigEnv in_env [(id, sig)]+    (sig,rhs') = inferTagRhs id in_env rhs++inferTagBind in_env (StgRec pairs)+  = -- pprTrace "rec" (ppr (map fst pairs) $$ ppr (in_env { te_env = out_env }, StgRec pairs')) $+    (in_env { te_env = out_env }, StgRec pairs')+  where+    (bndrs, rhss)     = unzip pairs+    in_ids            = map (getBinderId in_env) bndrs+    init_sigs         = map (initSig) $ zip in_ids rhss+    (out_env, pairs') = go in_env init_sigs rhss++    go :: forall q. (OutputableInferPass q , InferExtEq q) => TagEnv q -> [TagSig] -> [GenStgRhs q]+                 -> (TagSigEnv, [((Id,TagSig), GenStgRhs 'InferTaggedBinders)])+    go go_env in_sigs go_rhss+      --   | pprTrace "go" (ppr in_ids $$ ppr in_sigs $$ ppr out_sigs $$ ppr rhss') False+      --  = undefined+       | in_sigs == out_sigs = (te_env rhs_env, out_bndrs `zip` rhss')+       | otherwise     = go env' out_sigs rhss'+       where+         out_bndrs = map updateBndr in_bndrs -- TODO: Keeps in_ids alive+         in_bndrs = in_ids `zip` in_sigs+         rhs_env = extendSigEnv go_env in_bndrs+         (out_sigs, rhss') = unzip (zipWithEqual "inferTagBind" anaRhs in_ids go_rhss)+         env' = makeTagged go_env++         anaRhs :: Id -> GenStgRhs q -> (TagSig, GenStgRhs 'InferTaggedBinders)+         anaRhs bnd rhs = inferTagRhs bnd rhs_env rhs++         updateBndr :: (Id,TagSig) -> (Id,TagSig)+         updateBndr (v,sig) = (setIdTagSig v sig, sig)++initSig :: forall p. (Id, GenStgRhs p) -> TagSig+-- Initial signature for the fixpoint loop+initSig (_bndr, StgRhsCon {})               = TagSig TagTagged+initSig (bndr, StgRhsClosure _ _ _ _ _) =+  fromMaybe defaultSig (idTagSig_maybe bndr)+  where defaultSig = (TagSig TagTagged)++{- Note [Bottom functions are TagTagged]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have a function with two branches with one+being bottom, and the other returning a tagged+unboxed tuple what is the result? We give it TagTagged!+To answer why consider this function:++foo :: Bool -> (# Bool, Bool #)+foo x = case x of+    True -> (# True,True #)+    False -> undefined++The true branch is obviously tagged. The other branch isn't.+We want to treat the *result* of foo as tagged as well so that+the combination of the branches also is tagged if all non-bottom+branches are tagged.+This is safe because the function is still always called/entered as long+as it's applied to arguments. Since the function will never return we can give+it safely any tag sig we like.+So we give it TagTagged, as it allows the combined tag sig of the case expression+to be the combination of all non-bottoming branches.++-}++-----------------------------+inferTagRhs :: forall p.+     (OutputableInferPass p, InferExtEq p)+  => Id -- ^ Id we are binding to.+  -> TagEnv p -- ^+  -> GenStgRhs p -- ^+  -> (TagSig, GenStgRhs 'InferTaggedBinders)+inferTagRhs bnd_id in_env (StgRhsClosure ext cc upd bndrs body)+  | isDeadEndId bnd_id && (notNull) bndrs+  -- See Note [Bottom functions are TagTagged]+  = (TagSig TagTagged, StgRhsClosure ext cc upd out_bndrs body')+  | otherwise+  = --pprTrace "inferTagRhsClosure" (ppr (_top, _grp_ids, env,info')) $+    (TagSig info', StgRhsClosure ext cc upd out_bndrs body')+  where+    out_bndrs+      | Just marks <- idCbvMarks_maybe bnd_id+      -- Sometimes an we eta-expand foo with additional arguments after ww, and we also trim+      -- the list of marks to the last strict entry. So we can conservatively+      -- assume these are not strict+      = zipWith (mkArgSig) bndrs (marks ++ repeat NotMarkedCbv)+      | otherwise = map (noSig env') bndrs :: [(Id,TagSig)]++    env' = extendSigEnv in_env out_bndrs+    (info, body') = inferTagExpr env' body+    info'+      -- It's a thunk+      | null bndrs+      = TagDunno+      -- TODO: We could preserve tuple fields for thunks+      -- as well. But likely not worth the complexity.++      | otherwise  = info++    mkArgSig :: BinderP p -> CbvMark -> (Id,TagSig)+    mkArgSig bndp mark =+      let id = getBinderId in_env bndp+          tag = case mark of+            MarkedCbv -> TagProper+            _+              | isUnliftedType (idType id) -> TagProper+              | otherwise -> TagDunno+      in (id, TagSig tag)++inferTagRhs _ env _rhs@(StgRhsCon cc con cn ticks args)+-- Constructors, which have untagged arguments to strict fields+-- become thunks. We encode this by giving changing RhsCon nodes the info TagDunno+  = --pprTrace "inferTagRhsCon" (ppr grp_ids) $+    (TagSig (inferConTag env con args), StgRhsCon cc con cn ticks args)++{- Note [Constructor TagSigs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+@inferConTag@ will infer the proper tag signature for a binding who's RHS is a constructor+or a StgConApp expression.+Usually these will simply be TagProper. But there are exceptions.+If any of the fields in the constructor are strict, but any argument to these+fields is not tagged then we will have to case on the argument before storing+in the constructor. Which means for let bindings the RHS turns into a thunk+which obviously is no longer properly tagged.+For example we might start with:++    let x<TagDunno> = f ...+    let c<TagProper> = StrictPair x True++But we know during the rewrite stage x will need to be evaluated in the RHS+of `c` so we will infer:++    let x<TagDunno> = f ...+    let c<TagDunno> = StrictPair x True++Which in the rewrite stage will then be rewritten into:++    let x<TagDunno> = f ...+    let c<TagDunno> = case x of x' -> StrictPair x' True++The other exception is unboxed tuples. These will get a TagTuple+signature with a list of TagInfo about their individual binders+as argument. As example:++    let c<TagProper> = True+    let x<TagDunno> = ...+    let f<?> z = case z of z'<TagProper> -> (# c, x #)++Here we will infer for f the Signature <TagTuple[TagProper,TagDunno]>.+This information will be used if we scrutinze a saturated application of+`f` in order to determine the taggedness of the result.+That is for `case f x of (# r1,r2 #) -> rhs` we can infer+r1<TagProper> and r2<TagDunno> which allows us to skip all tag checks on `r1`+in `rhs`.++Things get a bit more complicated with nesting:++    let closeFd<TagTuple[...]> = ...+    let f x = ...+        case x of+          _ -> Solo# closeFd++The "natural" signature for the Solo# branch in `f` would be <TagTuple[TagTuple[...]]>.+But we flatten this out to <TagTuple[TagDunno]> for the time being as it improves compile+time and there doesn't seem to huge benefit to doing differently.++  -}++-- See Note [Constructor TagSigs]+inferConTag :: TagEnv p -> DataCon -> [StgArg] -> TagInfo+inferConTag env con args+  | isUnboxedTupleDataCon con+  = TagTuple $ map (flatten_arg_tag . lookupInfo env) args+  | otherwise =+    -- pprTrace "inferConTag"+    --   ( text "con:" <> ppr con $$+    --     text "args:" <> ppr args $$+    --     text "marks:" <> ppr (dataConRuntimeRepStrictness con) $$+    --     text "arg_info:" <> ppr (map (lookupInfo env) args) $$+    --     text "info:" <> ppr info) $+    info+  where+    info = if any arg_needs_eval strictArgs then TagDunno else TagProper+    strictArgs = zipEqual "inferTagRhs" args (dataConRuntimeRepStrictness con) :: ([(StgArg, StrictnessMark)])+    arg_needs_eval (arg,strict)+      -- lazy args+      | not (isMarkedStrict strict) = False+      | tag <- (lookupInfo env arg)+      -- banged args need to be tagged, or require eval+      = not (isTaggedInfo tag)++    flatten_arg_tag (TagTagged) = TagProper+    flatten_arg_tag (TagProper ) = TagProper+    flatten_arg_tag (TagTuple _) = TagDunno -- See Note [Constructor TagSigs]+    flatten_arg_tag (TagDunno) = TagDunno+++collectExportInfo :: [GenStgTopBinding 'InferTaggedBinders] -> NameEnv TagSig+collectExportInfo binds =+  mkNameEnv bndr_info+  where+    bndr_info = concatMap collect binds :: [(Name,TagSig)]++    collect (StgTopStringLit {}) = []+    collect (StgTopLifted bnd) =+      case bnd of+        StgNonRec (id,sig) _rhs+          | TagSig TagDunno <- sig -> []+          | otherwise -> [(idName id,sig)]+        StgRec bnds -> collectRec bnds++    collectRec :: [(BinderP 'InferTaggedBinders, rhs)] -> [(Name,TagSig)]+    collectRec [] = []+    collectRec (bnd:bnds)+      | (p,_rhs)  <- bnd+      , (id,sig) <- p+      , TagSig TagDunno <- sig+      = (idName id,sig) : collectRec bnds+      | otherwise = collectRec bnds
+ compiler/GHC/Stg/InferTags/Rewrite.hs view
@@ -0,0 +1,493 @@+--+-- Copyright (c) 2019 Andreas Klebinger+--++{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE GeneralisedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TupleSections              #-}+{-# LANGUAGE TypeFamilies               #-}++module GHC.Stg.InferTags.Rewrite (rewriteTopBinds)+where++import GHC.Prelude++import GHC.Types.Id+import GHC.Types.Name+import GHC.Types.Unique.Supply+import GHC.Types.Unique.FM+import GHC.Types.RepType+import GHC.Unit.Types (Module)++import GHC.Core.DataCon+import GHC.Core (AltCon(..) )+import GHC.Core.Type++import GHC.StgToCmm.Types++import GHC.Stg.Utils+import GHC.Stg.Syntax as StgSyn++import GHC.Data.Maybe+import GHC.Utils.Panic+import GHC.Utils.Panic.Plain++import GHC.Utils.Outputable+import GHC.Utils.Monad.State.Strict+import GHC.Utils.Misc++import GHC.Stg.InferTags.Types++import Control.Monad+import GHC.Types.Basic (CbvMark (NotMarkedCbv, MarkedCbv), isMarkedCbv, TopLevelFlag(..), isTopLevel)+import GHC.Types.Var.Set+-- import GHC.Utils.Trace+-- import GHC.Driver.Ppr++newtype RM a = RM { unRM :: (State (UniqFM Id TagSig, UniqSupply, Module, IdSet) a) }+    deriving (Functor, Monad, Applicative)++------------------------------------------------------------+-- Add cases around strict fields where required.+------------------------------------------------------------+{-+The work of this pass is simple:+* We traverse the STG AST looking for constructor allocations.+* For all allocations we check if there are strict fields in the constructor.+* For any strict field we check if the argument is known to be properly tagged.+* If it's not known to be properly tagged, we wrap the whole thing in a case,+  which will force the argument before allocation.+This is described in detail in Note [Strict Field Invariant].++The only slight complication is that we have to make sure not to invalidate free+variable analysis in the process.++Note [Partially applied workers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Sometimes we will get a function f of the form+    -- Arity 1+    f :: Dict a -> a -> b -> (c -> d)+    f dict a b = case dict of+        C m1 m2 -> m1 a b++Which will result in a W/W split along the lines of+    -- Arity 1+    f :: Dict a -> a -> b -> (c -> d)+    f dict a = case dict of+        C m1 m2 -> $wf m1 a b++    -- Arity 4+    $wf :: (a -> b -> d -> c) -> a -> b -> c -> d+    $wf m1 a b c = m1 a b c++It's notable that the worker is called *undersatured* in the wrapper.+At runtime what happens is that the wrapper will allocate a PAP which+once fully applied will call the worker. And all is fine.++But what about a call by value function! Well the function returned by `f` would+be a unknown call, so we lose the ability to enfore the invariant that+cbv marked arguments from StictWorkerId's are actually properly tagged+as the annotations would be unavailable at the (unknown) call site.++The fix is easy. We eta-expand all calls to functions taking call-by-value+arguments during CorePrep just like we do with constructor allocations.++Note [Upholding free variable annotations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The code generator requires us to maintain exact information+about free variables about closures. Since we convert some+RHSs from constructor allocations to closures we have to provide+fvs of these closures. Not all constructor arguments will become+free variables. Only these which are not bound at the top level+have to be captured.+To facilitate this we keep track of a set of locally bound variables in+the current context which we then use to filter constructor arguments+when building the free variable list.+-}++--------------------------------+-- Utilities+--------------------------------++instance MonadUnique RM where+    getUniqueSupplyM = RM $ do+        (m, us, mod,lcls) <- get+        let (us1, us2) = splitUniqSupply us+        (put) (m,us2,mod,lcls)+        return us1++getMap :: RM (UniqFM Id TagSig)+getMap = RM $ ((\(fst,_,_,_) -> fst) <$> get)++setMap :: (UniqFM Id TagSig) -> RM ()+setMap m = RM $ do+    (_,us,mod,lcls) <- get+    put (m, us,mod,lcls)++getMod :: RM Module+getMod = RM $ ( (\(_,_,thrd,_) -> thrd) <$> get)++getFVs :: RM IdSet+getFVs = RM $ ((\(_,_,_,lcls) -> lcls) <$> get)++setFVs :: IdSet -> RM ()+setFVs fvs = RM $ do+    (tag_map,us,mod,_lcls) <- get+    put (tag_map, us,mod,fvs)++-- Rewrite the RHS(s) while making the id and it's sig available+-- to determine if things are tagged/need to be captured as FV.+withBind :: TopLevelFlag -> GenStgBinding 'InferTaggedBinders -> RM a -> RM a+withBind top_flag (StgNonRec bnd _) cont = withBinder top_flag bnd cont+withBind top_flag (StgRec binds) cont = do+    let (bnds,_rhss) = unzip binds :: ([(Id, TagSig)], [GenStgRhs 'InferTaggedBinders])+    withBinders top_flag bnds cont++addTopBind :: GenStgBinding 'InferTaggedBinders -> RM ()+addTopBind (StgNonRec (id, tag) _) = do+    s <- getMap+    -- pprTraceM "AddBind" (ppr id)+    setMap $ addToUFM s id tag+    return ()+addTopBind (StgRec binds) = do+    let (bnds,_rhss) = unzip binds+    !s <- getMap+    -- pprTraceM "AddBinds" (ppr $ map fst bnds)+    setMap $! addListToUFM s bnds++withBinder :: TopLevelFlag ->  (Id, TagSig) -> RM a -> RM a+withBinder top_flag (id,sig) cont = do+    oldMap <- getMap+    setMap $ addToUFM oldMap id sig+    a <- if isTopLevel top_flag+            then cont+            else withLcl id cont+    setMap oldMap+    return a++withBinders :: TopLevelFlag -> [(Id, TagSig)] -> RM a -> RM a+withBinders TopLevel sigs cont = do+    oldMap <- getMap+    setMap $ addListToUFM oldMap sigs+    a <- cont+    setMap oldMap+    return a+withBinders NotTopLevel sigs cont = do+    oldMap <- getMap+    oldFvs <- getFVs+    setMap $ addListToUFM oldMap sigs+    setFVs $ extendVarSetList oldFvs (map fst sigs)+    a <- cont+    setMap oldMap+    setFVs oldFvs+    return a++-- | Compute the argument with the given set of ids treated as requiring capture+-- as free variables.+withClosureLcls :: DIdSet -> RM a -> RM a+withClosureLcls fvs act = do+    old_fvs <- getFVs+    let fvs' = nonDetStrictFoldDVarSet (flip extendVarSet) old_fvs fvs+    setFVs fvs'+    r <- act+    setFVs old_fvs+    return r++-- | Compute the argument with the given id treated as requiring capture+-- as free variables in closures.+withLcl :: Id -> RM a -> RM a+withLcl fv act = do+    old_fvs <- getFVs+    let fvs' = extendVarSet old_fvs fv+    setFVs fvs'+    r <- act+    setFVs old_fvs+    return r++isTagged :: Id -> RM Bool+isTagged v = do+    this_mod <- getMod+    case nameIsLocalOrFrom this_mod (idName v) of+        True+            | isUnliftedType (idType v)+            -> return True+            | otherwise -> do -- Local binding+                !s <- getMap+                let !sig = lookupWithDefaultUFM s (pprPanic "unknown Id:" (ppr v)) v+                return $ case sig of+                    TagSig info ->+                        case info of+                            TagDunno -> False+                            TagProper -> True+                            TagTagged -> True+                            TagTuple _ -> True -- Consider unboxed tuples tagged.+        False -- Imported+            | Just con <- (isDataConWorkId_maybe v)+            , isNullaryRepDataCon con+            -> return True+            | Just lf_info <- idLFInfo_maybe v+            -> return $+                -- Can we treat the thing as tagged based on it's LFInfo?+                case lf_info of+                    -- Function, applied not entered.+                    LFReEntrant {}+                        -> True+                    -- Thunks need to be entered.+                    LFThunk {}+                        -> False+                    -- LFCon means we already know the tag, and it's tagged.+                    LFCon {}+                        -> True+                    LFUnknown {}+                        -> False+                    LFUnlifted {}+                        -> True+                    LFLetNoEscape {}+                    -- Shouldn't be possible. I don't think we can export letNoEscapes+                        -> True++            | otherwise+            -> return False+++isArgTagged :: StgArg -> RM Bool+isArgTagged (StgLitArg _) = return True+isArgTagged (StgVarArg v) = isTagged v++mkLocalArgId :: Id -> RM Id+mkLocalArgId id = do+    !u <- getUniqueM+    return $! setIdUnique (localiseId id) u++---------------------------+-- Actual rewrite pass+---------------------------+++rewriteTopBinds :: Module -> UniqSupply -> [GenStgTopBinding 'InferTaggedBinders] -> [TgStgTopBinding]+rewriteTopBinds mod us binds =+    let doBinds = mapM rewriteTop binds++    in evalState (unRM doBinds) (mempty, us, mod, mempty)++rewriteTop :: InferStgTopBinding -> RM TgStgTopBinding+rewriteTop (StgTopStringLit v s) = return $! (StgTopStringLit v s)+rewriteTop (StgTopLifted bind)   = do+    -- Top level bindings can, and must remain in scope+    addTopBind bind+    (StgTopLifted) <$!> (rewriteBinds TopLevel bind)++-- For top level binds, the wrapper is guaranteed to be `id`+rewriteBinds :: TopLevelFlag -> InferStgBinding -> RM (TgStgBinding)+rewriteBinds _top_flag (StgNonRec v rhs) = do+        (!rhs) <-  rewriteRhs v rhs+        return $! (StgNonRec (fst v) rhs)+rewriteBinds top_flag b@(StgRec binds) =+    -- Bring sigs of binds into scope for all rhss+    withBind top_flag b $ do+        (rhss) <- mapM (uncurry rewriteRhs) binds+        return $! (mkRec rhss)+        where+            mkRec :: [TgStgRhs] -> TgStgBinding+            mkRec rhss = StgRec (zip (map (fst . fst) binds) rhss)++-- Rewrite a RHS+rewriteRhs :: (Id,TagSig) -> InferStgRhs+           -> RM (TgStgRhs)+rewriteRhs (_id, _tagSig) (StgRhsCon ccs con cn ticks args) = {-# SCC rewriteRhs_ #-} do+    -- pprTraceM "rewriteRhs" (ppr _id)++    -- Look up the nodes representing the constructor arguments.+    fieldInfos <- mapM isArgTagged args++    -- Filter out non-strict fields.+    let strictFields =+            getStrictConArgs con (zip args fieldInfos) :: [(StgArg,Bool)] -- (nth-argument, tagInfo)+    -- Filter out already tagged arguments.+    let needsEval = map fst . --get the actual argument+                        filter (not . snd) $ -- Keep untagged (False) elements.+                        strictFields :: [StgArg]+    let evalArgs = [v | StgVarArg v <- needsEval] :: [Id]++    if (null evalArgs)+        then return $! (StgRhsCon ccs con cn ticks args)+        else do+            --assert not (isTaggedSig tagSig)+            -- pprTraceM "CreatingSeqs for " $ ppr _id <+> ppr node_id++            -- At this point iff we have  possibly untagged arguments to strict fields+            -- we convert the RHS into a RhsClosure which will evaluate the arguments+            -- before allocating the constructor.+            let ty_stub = panic "mkSeqs shouldn't use the type arg"+            conExpr <- mkSeqs args evalArgs (\taggedArgs -> StgConApp con cn taggedArgs ty_stub)++            fvs <- fvArgs args+            -- lcls <- getFVs+            -- pprTraceM "RhsClosureConversion" (ppr (StgRhsClosure fvs ccs ReEntrant [] $! conExpr) $$ text "lcls:" <> ppr lcls)+            return $! (StgRhsClosure fvs ccs ReEntrant [] $! conExpr)+rewriteRhs _binding (StgRhsClosure fvs ccs flag args body) = do+    withBinders NotTopLevel args $+        withClosureLcls fvs $+            StgRhsClosure fvs ccs flag (map fst args) <$> rewriteExpr False body+        -- return (closure)++fvArgs :: [StgArg] -> RM DVarSet+fvArgs args = do+    fv_lcls <- getFVs+    -- pprTraceM "fvArgs" (text "args:" <> ppr args $$ text "lcls:" <> pprVarSet (fv_lcls) (braces . fsep . map ppr) )+    return $ mkDVarSet [ v | StgVarArg v <- args, elemVarSet v fv_lcls]++type IsScrut = Bool++rewriteExpr :: IsScrut -> InferStgExpr -> RM TgStgExpr+rewriteExpr _ (e@StgCase {})          = rewriteCase e+rewriteExpr _ (e@StgLet {})           = rewriteLet e+rewriteExpr _ (e@StgLetNoEscape {})   = rewriteLetNoEscape e+rewriteExpr isScrut (StgTick t e)     = StgTick t <$!> rewriteExpr isScrut e+rewriteExpr _ e@(StgConApp {})        = rewriteConApp e++rewriteExpr isScrut e@(StgApp {})     = rewriteApp isScrut e+rewriteExpr _ (StgLit lit)           = return $! (StgLit lit)+rewriteExpr _ (StgOpApp op args res_ty) = return $! (StgOpApp op args res_ty)++rewriteCase :: InferStgExpr -> RM TgStgExpr+rewriteCase (StgCase scrut bndr alt_type alts) =+    withBinder NotTopLevel bndr $+        pure StgCase <*>+            rewriteExpr True scrut <*>+            pure (fst bndr) <*>+            pure alt_type <*>+            mapM rewriteAlt alts++rewriteCase _ = panic "Impossible: nodeCase"++rewriteAlt :: InferStgAlt -> RM TgStgAlt+rewriteAlt alt@GenStgAlt{alt_con=_, alt_bndrs=bndrs, alt_rhs=rhs} =+    withBinders NotTopLevel bndrs $ do+        !rhs' <- rewriteExpr False rhs+        return $! alt {alt_bndrs = map fst bndrs, alt_rhs = rhs'}++rewriteLet :: InferStgExpr -> RM TgStgExpr+rewriteLet (StgLet xt bind expr) = do+    (!bind') <- rewriteBinds NotTopLevel bind+    withBind NotTopLevel bind $ do+        -- pprTraceM "withBindLet" (ppr $ bindersOfX bind)+        !expr' <- rewriteExpr False expr+        return $! (StgLet xt bind' expr')+rewriteLet _ = panic "Impossible"++rewriteLetNoEscape :: InferStgExpr -> RM TgStgExpr+rewriteLetNoEscape (StgLetNoEscape xt bind expr) = do+    (!bind') <- rewriteBinds NotTopLevel bind+    withBind NotTopLevel bind $ do+        !expr' <- rewriteExpr False expr+        return $! (StgLetNoEscape xt bind' expr')+rewriteLetNoEscape _ = panic "Impossible"++rewriteConApp :: InferStgExpr -> RM TgStgExpr+rewriteConApp (StgConApp con cn args tys) = do+    -- We check if the strict field arguments are already known to be tagged.+    -- If not we evaluate them first.+    fieldInfos <- mapM isArgTagged args+    let strictIndices = getStrictConArgs con (zip fieldInfos args) :: [(Bool, StgArg)]+    let needsEval = map snd . filter (not . fst) $ strictIndices :: [StgArg]+    let evalArgs = [v | StgVarArg v <- needsEval] :: [Id]+    if (not $ null evalArgs)+        then do+            -- pprTraceM "Creating conAppSeqs for " $ ppr nodeId <+> parens ( ppr evalArgs ) -- <+> parens ( ppr fieldInfos )+            mkSeqs args evalArgs (\taggedArgs -> StgConApp con cn taggedArgs tys)+        else return $! (StgConApp con cn args tys)++rewriteConApp _ = panic "Impossible"++-- Special case: Expressions like `case x of { ... }`+rewriteApp :: IsScrut -> InferStgExpr -> RM TgStgExpr+rewriteApp True (StgApp f []) = do+    -- pprTraceM "rewriteAppScrut" (ppr f)+    f_tagged <- isTagged f+    -- isTagged looks at more than the result of our analysis.+    -- So always update here if useful.+    let f' = if f_tagged+                then setIdTagSig f (TagSig TagProper)+                else f+    return $! StgApp f' []+rewriteApp _ (StgApp f args)+    -- pprTrace "rewriteAppOther" (ppr f <+> ppr args) False+    -- = undefined+    | Just marks <- idCbvMarks_maybe f+    , relevant_marks <- dropWhileEndLE (not . isMarkedCbv) marks+    , any isMarkedCbv relevant_marks+    = assert (length relevant_marks <= length args)+      unliftArg relevant_marks++    where+      -- If the function expects any argument to be call-by-value ensure the argument is already+      -- evaluated.+      unliftArg relevant_marks = do+        argTags <- mapM isArgTagged args+        let argInfo = zipWith3 ((,,)) args (relevant_marks++repeat NotMarkedCbv)  argTags :: [(StgArg, CbvMark, Bool)]++            -- untagged cbv argument positions+            cbvArgInfo = filter (\x -> sndOf3 x == MarkedCbv && thdOf3 x == False) argInfo+            cbvArgIds = [x | StgVarArg x <- map fstOf3 cbvArgInfo] :: [Id]+        mkSeqs args cbvArgIds (\cbv_args -> StgApp f cbv_args)++rewriteApp _ (StgApp f args) = return $ StgApp f args+rewriteApp _ _ = panic "Impossible"++-- `mkSeq` x x' e generates `case x of x' -> e`+-- We could also substitute x' for x in e but that's so rarely beneficial+-- that we don't bother.+mkSeq :: Id -> Id -> TgStgExpr -> TgStgExpr+mkSeq id bndr !expr =+    -- pprTrace "mkSeq" (ppr (id,bndr)) $+    let altTy = mkStgAltTypeFromStgAlts bndr alt+        alt   = [GenStgAlt {alt_con = DEFAULT, alt_bndrs = [], alt_rhs = expr}]+    in StgCase (StgApp id []) bndr altTy alt++-- `mkSeqs args vs mkExpr` will force all vs, and construct+-- an argument list args' where each v is replaced by it's evaluated+-- counterpart v'.+-- That is if we call `mkSeqs [StgVar x, StgLit l] [x] mkExpr` then+-- the result will be (case x of x' { _DEFAULT -> <mkExpr [StgVar x', StgLit l]>}+{-# INLINE mkSeqs #-} -- We inline to avoid allocating mkExpr+mkSeqs  :: [StgArg] -- ^ Original arguments+        -> [Id]     -- ^ var args to be evaluated ahead of time+        -> ([StgArg] -> TgStgExpr)+                    -- ^ Function that reconstructs the expressions when passed+                    -- the list of evaluated arguments.+        -> RM TgStgExpr+mkSeqs args untaggedIds mkExpr = do+    argMap <- mapM (\arg -> (arg,) <$> mkLocalArgId arg ) untaggedIds :: RM [(InId, OutId)]+    -- mapM_ (pprTraceM "Forcing strict args before allocation:" . ppr) argMap+    let taggedArgs :: [StgArg]+            = map   (\v -> case v of+                        StgVarArg v' -> StgVarArg $ fromMaybe v' $ lookup v' argMap+                        lit -> lit)+                    args++    let conBody = mkExpr taggedArgs+    let body = foldr (\(v,bndr) expr -> mkSeq v bndr expr) conBody argMap+    return $! body++-- Out of all arguments passed at runtime only return these ending up in a+-- strict field+getStrictConArgs :: DataCon -> [a] -> [a]+getStrictConArgs con args+    -- These are always lazy in their arguments.+    | isUnboxedTupleDataCon con = []+    | isUnboxedSumDataCon con = []+    -- For proper data cons we have to check.+    | otherwise =+        [ arg | (arg,MarkedStrict)+                    <- zipEqual "getStrictConArgs"+                                args+                                (dataConRuntimeRepStrictness con)]
+ compiler/GHC/Stg/InferTags/Types.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE TypeFamilies, DataKinds, GADTs, FlexibleInstances #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}++{-# LANGUAGE UndecidableInstances #-}+ -- To permit: type instance XLet 'InferTaggedBinders = XLet 'CodeGen++module GHC.Stg.InferTags.Types+    ( module GHC.Stg.InferTags.Types+    , module TagSig)+where++import GHC.Prelude++import GHC.Core.DataCon+import GHC.Core.Type (isUnliftedType)+import GHC.Types.Id+import GHC.Stg.Syntax+import GHC.Stg.InferTags.TagSig as TagSig+import GHC.Types.Var.Env+import GHC.Utils.Outputable+import GHC.Utils.Misc( zipWithEqual )+import GHC.Utils.Panic++import GHC.StgToCmm.Types++{- *********************************************************************+*                                                                      *+                         Supporting data types+*                                                                      *+********************************************************************* -}++type instance BinderP      'InferTaggedBinders = (Id, TagSig)+type instance XLet         'InferTaggedBinders = XLet         'CodeGen+type instance XLetNoEscape 'InferTaggedBinders = XLetNoEscape 'CodeGen+type instance XRhsClosure  'InferTaggedBinders = XRhsClosure  'CodeGen++type InferStgTopBinding = GenStgTopBinding 'InferTaggedBinders+type InferStgBinding    = GenStgBinding    'InferTaggedBinders+type InferStgExpr       = GenStgExpr       'InferTaggedBinders+type InferStgRhs        = GenStgRhs        'InferTaggedBinders+type InferStgAlt        = GenStgAlt        'InferTaggedBinders++combineAltInfo :: TagInfo -> TagInfo -> TagInfo+combineAltInfo TagDunno         _              = TagDunno+combineAltInfo _                TagDunno       = TagDunno+combineAltInfo (TagTuple {})    TagProper      = panic "Combining unboxed tuple with non-tuple result"+combineAltInfo TagProper       (TagTuple {})   = panic "Combining unboxed tuple with non-tuple result"+combineAltInfo TagProper        TagProper      = TagProper+combineAltInfo (TagTuple is1)  (TagTuple is2)  = TagTuple (zipWithEqual "combineAltInfo" combineAltInfo is1 is2)+combineAltInfo (TagTagged)      ti             = ti+combineAltInfo ti               TagTagged      = ti++type TagSigEnv = IdEnv TagSig+data TagEnv p = TE { te_env :: TagSigEnv+                   , te_get :: BinderP p -> Id+                   }++instance Outputable (TagEnv p) where+    ppr te = ppr (te_env te)+++getBinderId :: TagEnv p -> BinderP p -> Id+getBinderId = te_get++initEnv :: TagEnv 'CodeGen+initEnv = TE { te_env = emptyVarEnv+             , te_get = \x -> x}++-- | Simple convert env to a env of the 'InferTaggedBinders pass+-- with no other changes.+makeTagged :: TagEnv p -> TagEnv 'InferTaggedBinders+makeTagged env = TE { te_env = te_env env+                    , te_get = fst }++noSig :: TagEnv p -> BinderP p -> (Id, TagSig)+noSig env bndr+  | isUnliftedType (idType var) = (var, TagSig TagProper)+  | otherwise = (var, TagSig TagDunno)+  where+    var = getBinderId env bndr++lookupSig :: TagEnv p -> Id -> Maybe TagSig+lookupSig env fun = lookupVarEnv (te_env env) fun++lookupInfo :: TagEnv p -> StgArg -> TagInfo+lookupInfo env (StgVarArg var)+  -- Nullary data constructors like True, False+  | Just dc <- isDataConWorkId_maybe var+  , isNullaryRepDataCon dc+  = TagProper++  | isUnliftedType (idType var)+  = TagProper++  -- Variables in the environment.+  | Just (TagSig info) <- lookupVarEnv (te_env env) var+  = info++  | Just lf_info <- idLFInfo_maybe var+  =   case lf_info of+          -- Function, tagged (with arity)+          LFReEntrant {}+              -> TagProper+          -- Thunks need to be entered.+          LFThunk {}+              -> TagDunno+          -- Constructors, already tagged.+          LFCon {}+              -> TagProper+          LFUnknown {}+              -> TagDunno+          LFUnlifted {}+              -> TagProper+          -- Shouldn't be possible. I don't think we can export letNoEscapes+          LFLetNoEscape {} -> panic "LFLetNoEscape exported"++  | otherwise+  = TagDunno++lookupInfo _ (StgLitArg {})+  = TagProper++isDunnoSig :: TagSig -> Bool+isDunnoSig (TagSig TagDunno) = True+isDunnoSig (TagSig TagProper) = False+isDunnoSig (TagSig TagTuple{}) = False+isDunnoSig (TagSig TagTagged{}) = False++isTaggedInfo :: TagInfo -> Bool+isTaggedInfo TagProper = True+isTaggedInfo TagTagged = True+isTaggedInfo _         = False++extendSigEnv :: TagEnv p -> [(Id,TagSig)] -> TagEnv p+extendSigEnv env@(TE { te_env = sig_env }) bndrs+  = env { te_env = extendVarEnvList sig_env bndrs }
compiler/GHC/Stg/Lift.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + -- | Implements a selective lambda lifter, running late in the optimisation -- pipeline. --@@ -11,24 +11,23 @@    (     -- * Late lambda lifting in STG     -- $note+   StgLiftConfig (..),    stgLiftLams    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Types.Basic-import GHC.Driver.Session import GHC.Types.Id import GHC.Stg.FVs ( annBindingFreeVars )+import GHC.Stg.Lift.Config import GHC.Stg.Lift.Analysis import GHC.Stg.Lift.Monad import GHC.Stg.Syntax-import GHC.Utils.Outputable+import GHC.Unit.Module (Module) import GHC.Types.Unique.Supply-import GHC.Utils.Misc+import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Types.Var.Set import Control.Monad ( when )@@ -127,17 +126,17 @@ -- -- (Mostly) textbook instance of the lambda lifting transformation, selecting -- which bindings to lambda lift by consulting 'goodToLift'.-stgLiftLams :: DynFlags -> UniqSupply -> [InStgTopBinding] -> [OutStgTopBinding]-stgLiftLams dflags us = runLiftM dflags us . foldr liftTopLvl (pure ())+stgLiftLams :: Module -> StgLiftConfig -> UniqSupply -> [InStgTopBinding] -> [OutStgTopBinding]+stgLiftLams this_mod cfg us = runLiftM cfg us . foldr (liftTopLvl this_mod) (pure ()) -liftTopLvl :: InStgTopBinding -> LiftM () -> LiftM ()-liftTopLvl (StgTopStringLit bndr lit) rest = withSubstBndr bndr $ \bndr' -> do+liftTopLvl :: Module -> InStgTopBinding -> LiftM () -> LiftM ()+liftTopLvl _ (StgTopStringLit bndr lit) rest = withSubstBndr bndr $ \bndr' -> do   addTopStringLit bndr' lit   rest-liftTopLvl (StgTopLifted bind) rest = do+liftTopLvl this_mod (StgTopLifted bind) rest = do   let is_rec = isRec $ fst $ decomposeStgBinding bind   when is_rec startBindingGroup-  let bind_w_fvs = annBindingFreeVars bind+  let bind_w_fvs = annBindingFreeVars this_mod bind   withLiftedBind TopLevel (tagSkeletonTopBind bind_w_fvs) NilSk $ \mb_bind' -> do     -- We signal lifting of a binding through returning Nothing.     -- Should never happen for a top-level binding, though, since we are already@@ -170,8 +169,8 @@   let (infos, rhss) = unzip pairs   let bndrs = map binderInfoBndr infos   expander <- liftedIdsExpander-  dflags <- getDynFlags-  case goodToLift dflags top rec expander pairs scope of+  cfg <- getConfig+  case goodToLift cfg top rec expander pairs scope of     -- @abs_ids@ is the set of all variables that need to become parameters.     Just abs_ids -> withLiftedBndrs abs_ids bndrs $ \bndrs' -> do       -- Within this block, all binders in @bndrs@ will be noted as lifted, so@@ -200,7 +199,9 @@   -> LlStgRhs   -> LiftM OutStgRhs liftRhs mb_former_fvs rhs@(StgRhsCon ccs con mn ts args)-  = ASSERT2(isNothing mb_former_fvs, text "Should never lift a constructor" $$ pprStgRhs panicStgPprOpts rhs)+  = assertPpr (isNothing mb_former_fvs)+              (text "Should never lift a constructor"+               $$ pprStgRhs panicStgPprOpts rhs) $     StgRhsCon ccs con mn ts <$> traverse liftArgs args liftRhs Nothing (StgRhsClosure _ ccs upd infos body) =   -- This RHS wasn't lifted.@@ -215,7 +216,7 @@ liftArgs :: InStgArg -> LiftM OutStgArg liftArgs a@(StgLitArg _) = pure a liftArgs (StgVarArg occ) = do-  ASSERTM2( not <$> isLifted occ, text "StgArgs should never be lifted" $$ ppr occ )+  assertPprM (not <$> isLifted occ) (text "StgArgs should never be lifted" $$ ppr occ)   StgVarArg <$> substOcc occ  liftExpr :: LlStgExpr -> LiftM OutStgExpr@@ -248,5 +249,7 @@         Just bind' -> pure (StgLetNoEscape noExtFieldSilent bind' body')  liftAlt :: LlStgAlt -> LiftM OutStgAlt-liftAlt (con, infos, rhs) = withSubstBndrs (map binderInfoBndr infos) $ \bndrs' ->-  (,,) con bndrs' <$> liftExpr rhs+liftAlt alt@GenStgAlt{alt_con=_, alt_bndrs=infos, alt_rhs=rhs} =+  withSubstBndrs (map binderInfoBndr infos) $ \bndrs' ->+    do !rhs' <- liftExpr rhs+       return $! alt {alt_bndrs = bndrs', alt_rhs = rhs'}
compiler/GHC/Stg/Lift/Analysis.hs view
@@ -26,9 +26,9 @@  import GHC.Types.Basic import GHC.Types.Demand-import GHC.Driver.Session import GHC.Types.Id import GHC.Runtime.Heap.Layout ( WordOff )+import GHC.Stg.Lift.Config import GHC.Stg.Syntax import qualified GHC.StgToCmm.ArgRep  as StgToCmm.ArgRep import qualified GHC.StgToCmm.Closure as StgToCmm.Closure@@ -114,7 +114,6 @@ type instance XRhsClosure  'LiftLams = DIdSet type instance XLet         'LiftLams = Skeleton type instance XLetNoEscape 'LiftLams = Skeleton-type instance XConApp      'LiftLams = ConstructorNumber   -- | Captures details of the syntax tree relevant to the cost model, such as@@ -334,8 +333,8 @@     n :* cd = idDemandInfo bndr  tagSkeletonAlt :: CgStgAlt -> (Skeleton, IdSet, LlStgAlt)-tagSkeletonAlt (con, bndrs, rhs)-  = (alt_skel, arg_occs, (con, map BoringBinder bndrs, rhs'))+tagSkeletonAlt old@GenStgAlt{alt_con=_, alt_bndrs=bndrs, alt_rhs=rhs}+  = (alt_skel, arg_occs, old {alt_bndrs=fmap BoringBinder bndrs, alt_rhs=rhs'})   where     (alt_skel, alt_arg_occs, rhs') = tagSkeletonExpr rhs     arg_occs = alt_arg_occs `delVarSetList` bndrs@@ -343,7 +342,7 @@ -- | Combines several heuristics to decide whether to lambda-lift a given -- @let@-binding to top-level. See "GHC.Stg.Lift.Analysis#when" for details. goodToLift-  :: DynFlags+  :: StgLiftConfig   -> TopLevelFlag   -> RecFlag   -> (DIdSet -> DIdSet) -- ^ An expander function, turning 'InId's into@@ -353,7 +352,7 @@   -> Maybe DIdSet       -- ^ @Just abs_ids@ <=> This binding is beneficial to                         -- lift and @abs_ids@ are the variables it would                         -- abstract over-goodToLift dflags top_lvl rec_flag expander pairs scope = decide+goodToLift cfg top_lvl rec_flag expander pairs scope = decide   [ ("top-level", isTopLevel top_lvl) -- keep in sync with Note [When to lift]   , ("memoized", any_memoized)   , ("argument occurrences", arg_occs)@@ -363,7 +362,7 @@   , ("args spill on stack", args_spill_on_stack)   , ("increases allocation", inc_allocs)   ] where-      profile  = targetProfile dflags+      profile  = c_targetProfile cfg       platform = profilePlatform profile       decide deciders         | not (fancy_or deciders)@@ -432,7 +431,7 @@       -- idArity f > 0 ==> known       known_fun id = idArity id > 0       abstracts_known_local_fun-        = not (liftLamsKnown dflags) && any known_fun (dVarSetElems abs_ids)+        = not (c_liftLamsKnown cfg) && any known_fun (dVarSetElems abs_ids)        -- Number of arguments of a RHS in the current binding group if we decide       -- to lift it@@ -442,8 +441,8 @@         . (dVarSetElems abs_ids ++)         . rhsLambdaBndrs       max_n_args-        | isRec rec_flag = liftLamsRecArgs dflags-        | otherwise      = liftLamsNonRecArgs dflags+        | isRec rec_flag = c_liftLamsRecArgs cfg+        | otherwise      = c_liftLamsNonRecArgs cfg       -- We have 5 hardware registers on x86_64 to pass arguments in. Any excess       -- args are passed on the stack, which means slow memory accesses       args_spill_on_stack
+ compiler/GHC/Stg/Lift/Config.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE TypeFamilies #-}++-- | Configuration options for Lift the lambda lifter.+module GHC.Stg.Lift.Config (+    StgLiftConfig (..),+  ) where++import GHC.Prelude++import GHC.Platform.Profile++data StgLiftConfig = StgLiftConfig+  { c_targetProfile         :: !Profile+  , c_liftLamsRecArgs       :: !(Maybe Int)+  -- ^ Maximum number of arguments after lambda lifting a recursive function.+  , c_liftLamsNonRecArgs    :: !(Maybe Int)+  -- ^ Maximum number of arguments after lambda lifting non-recursive function.+  , c_liftLamsKnown         :: !Bool+  -- ^ Lambda lift even when this turns a known call into an unknown call.+  }+  deriving (Show, Read, Eq, Ord)
compiler/GHC/Stg/Lift/Monad.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies #-} @@ -12,6 +12,8 @@     FloatLang (..), collectFloats, -- Exported just for the docs     -- * Transformation monad     LiftM, runLiftM,+    -- ** Get config+    getConfig,     -- ** Adding bindings     startBindingGroup, endBindingGroup, addTopStringLit, addLiftedBinding,     -- ** Substitution and binders@@ -20,24 +22,24 @@     substOcc, isLifted, formerFreeVars, liftedIdsExpander   ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Types.Basic import GHC.Types.CostCentre ( isCurrentCCS, dontCareCCS )-import GHC.Driver.Session import GHC.Data.FastString import GHC.Types.Id import GHC.Types.Name import GHC.Utils.Outputable import GHC.Data.OrdList++import GHC.Stg.Lift.Config import GHC.Stg.Subst import GHC.Stg.Syntax+ import GHC.Core.Utils import GHC.Types.Unique.Supply-import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Core.Multiplicity@@ -61,7 +63,7 @@ -- | Environment threaded around in a scoped, @Reader@-like fashion. data Env   = Env-  { e_dflags     :: !DynFlags+  { e_config     :: StgLiftConfig   -- ^ Read-only.   , e_subst      :: !Subst   -- ^ We need to track the renamings of local 'InId's to their lifted 'OutId',@@ -84,8 +86,12 @@   -- Invariant: 'Id's not present in this map won't be substituted.   } -emptyEnv :: DynFlags -> Env-emptyEnv dflags = Env dflags emptySubst emptyVarEnv+emptyEnv :: StgLiftConfig -> Env+emptyEnv cfg = Env+  { e_config = cfg+  , e_subst = emptySubst+  , e_expansions = emptyVarEnv+  }   -- Note [Handling floats]@@ -183,7 +189,7 @@      map_rhss f = uncurry mkStgBinding . second (map (second f)) . decomposeStgBinding     rm_cccs = map_rhss removeRhsCCCS-    merge_binds binds = ASSERT( any is_rec binds )+    merge_binds binds = assert (any is_rec binds) $                         StgRec (concatMap (snd . decomposeStgBinding . rm_cccs) binds)     is_rec StgRec{} = True     is_rec _ = False@@ -202,8 +208,8 @@ -- | The analysis monad consists of the following 'RWST' components: -- --     * 'Env': Reader-like context. Contains a substitution, info about how---       how lifted identifiers are to be expanded into applications and details---       such as 'DynFlags'.+--       how lifted identifiers are to be expanded into applications and+--       configuration options. -- --     * @'OrdList' 'FloatLang'@: Writer output for the resulting STG program. --@@ -216,18 +222,18 @@   = LiftM { unwrapLiftM :: RWST Env (OrdList FloatLang) () UniqSM a }   deriving (Functor, Applicative, Monad) -instance HasDynFlags LiftM where-  getDynFlags = LiftM (RWS.asks e_dflags)- instance MonadUnique LiftM where   getUniqueSupplyM = LiftM (lift getUniqueSupplyM)   getUniqueM = LiftM (lift getUniqueM)   getUniquesM = LiftM (lift getUniquesM) -runLiftM :: DynFlags -> UniqSupply -> LiftM () -> [OutStgTopBinding]-runLiftM dflags us (LiftM m) = collectFloats (fromOL floats)+runLiftM :: StgLiftConfig -> UniqSupply -> LiftM () -> [OutStgTopBinding]+runLiftM cfg us (LiftM m) = collectFloats (fromOL floats)   where-    (_, _, floats) = initUs_ us (runRWST m (emptyEnv dflags) ())+    (_, _, floats) = initUs_ us (runRWST m (emptyEnv cfg) ())++getConfig :: LiftM StgLiftConfig+getConfig = LiftM $ e_config <$> RWS.ask  -- | Writes a plain 'StgTopStringLit' to the output. addTopStringLit :: OutId -> ByteString -> LiftM ()
compiler/GHC/Stg/Lint.hs view
@@ -30,6 +30,56 @@ Since then there were some attempts at enabling it again, as summarised in #14787. It's finally decided that we remove all type checking and only look for basic properties listed above.++Note [Linting StgApp]+~~~~~~~~~~~~~~~~~~~~~+To lint an application of the form `f a_1 ... a_n`, we check that+the representations of the arguments `a_1`, ..., `a_n` match those+that the function expects.++More precisely, suppose the types in the application `f a_1 ... a_n`+are as follows:++  f :: t_1 -> ... -> t_n -> res+  a_1 :: s_1, ..., a_n :: s_n++  t_1 :: TYPE r_1, ..., t_n :: TYPE r_n+  s_1 :: TYPE p_1, ..., a_n :: TYPE p_n++Then we must check that each r_i is compatible with s_i. Compatibility+is weaker than on-the-nose equality: for example, IntRep and WordRep are+compatible. See Note [Bad unsafe coercion] in GHC.Core.Lint.++Wrinkle: it can sometimes happen that an argument type in the type of+the function does not have a fixed runtime representation, i.e.+there is an r_i such that runtimeRepPrimRep r_i crashes.+See https://gitlab.haskell.org/ghc/ghc/-/issues/21399 for an example.+Fixing this issue would require significant changes to the type system+of STG, so for now we simply skip the Lint check when we detect such+representation-polymorphic situations.++Note [Typing the STG language]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In Core, programs must be /well-typed/.  So if f :: ty1 -> ty2,+then in the application (f e), we must have  e :: ty1++STG is still a statically typed language, but the type system+is much coarser. In particular, STG programs must be /well-kinded/.+More precisely, if f :: ty1 -> ty2, then in the application (f e)+where e :: ty1', we must have kind(ty1) = kind(ty1').++So the STG type system does not distinguish beteen Int and Bool,+but it /does/ distinguish beteen Int and Int#, because they have+different kinds.  Actually, since all terms have kind (TYPE rep),+we might say that the STG language is well-runtime-rep'd.++This coarser type system makes fewer distinctions, and that allows+many nonsensical programs (such as ('x' && "foo")) -- but all type+systems accept buggy programs!  But the coarseness also permits+some optimisations that are ill-typed in Core.  For example, see+the module STG.CSE, which is all about doing CSE in STG that would+be ill-typed in Core.  But it must still be well-kinded!+ -}  {-# LANGUAGE ScopedTypeVariables, FlexibleContexts, TypeFamilies,@@ -40,32 +90,46 @@ import GHC.Prelude  import GHC.Stg.Syntax+import GHC.Stg.Utils -import GHC.Driver.Session import GHC.Core.Lint        ( interactiveInScope )-import GHC.Data.Bag         ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )-import GHC.Types.Basic      ( TopLevelFlag(..), isTopLevel )+import GHC.Core.DataCon+import GHC.Core             ( AltCon(..) )+import GHC.Core.Type++import GHC.Types.Basic      ( TopLevelFlag(..), isTopLevel, isMarkedCbv ) import GHC.Types.CostCentre ( isCurrentCCS )+import GHC.Types.Error      ( DiagnosticReason(WarningWithoutFlag) ) import GHC.Types.Id import GHC.Types.Var.Set-import GHC.Core.DataCon-import GHC.Core             ( AltCon(..) ) import GHC.Types.Name       ( getSrcLoc, nameIsLocalOrFrom )-import GHC.Utils.Error      ( Severity(..), mkLocMessage )-import GHC.Core.Type import GHC.Types.RepType import GHC.Types.SrcLoc+ import GHC.Utils.Logger import GHC.Utils.Outputable+import GHC.Utils.Error      ( mkLocMessage, DiagOpts )+import qualified GHC.Utils.Error as Err+ import GHC.Unit.Module            ( Module ) import GHC.Runtime.Context        ( InteractiveContext )-import qualified GHC.Utils.Error as Err++import GHC.Data.Bag         ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )+ import Control.Applicative ((<|>)) import Control.Monad+import Data.Maybe+import GHC.Utils.Misc+import GHC.Core.Multiplicity (scaledThing)+import GHC.Settings (Platform)+import GHC.Core.TyCon (primRepCompatible)+import GHC.Utils.Panic.Plain (panic)  lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id)-                   => Logger-                   -> DynFlags+                   => Platform+                   -> Logger+                   -> DiagOpts+                   -> StgPprOpts                    -> InteractiveContext                    -> Module -- ^ module being compiled                    -> Bool   -- ^ have we run Unarise yet?@@ -73,13 +137,13 @@                    -> [GenStgTopBinding a]                    -> IO () -lintStgTopBindings logger dflags ictxt this_mod unarised whodunnit binds+lintStgTopBindings platform logger diag_opts opts ictxt this_mod unarised whodunnit binds   = {-# SCC "StgLint" #-}-    case initL this_mod unarised opts top_level_binds (lint_binds binds) of+    case initL platform diag_opts this_mod unarised opts top_level_binds (lint_binds binds) of       Nothing  ->         return ()       Just msg -> do-        putLogMsg logger dflags NoReason Err.SevDump noSrcSpan+        logMsg logger Err.MCDump noSrcSpan           $ withPprStyle defaultDumpStyle           (vcat [ text "*** Stg Lint ErrMsgs: in" <+>                         text whodunnit <+> text "***",@@ -87,9 +151,8 @@                   text "*** Offending Program ***",                   pprGenStgTopBindings opts binds,                   text "*** End of Offense ***"])-        Err.ghcExit logger dflags 1+        Err.ghcExit logger 1   where-    opts = initStgPprOpts dflags     -- Bring all top-level binds into scope because CoreToStg does not generate     -- bindings in dependency order (so we may see a use before its definition).     top_level_binds = extendVarSetList (mkVarSet (bindersOfTopBinds binds))@@ -172,10 +235,13 @@         lintStgExpr expr  lintStgRhs rhs@(StgRhsCon _ con _ _ args) = do+    opts <- getStgPprOpts     when (isUnboxedTupleDataCon con || isUnboxedSumDataCon con) $ do-      opts <- getStgPprOpts       addErrL (text "StgRhsCon is an unboxed tuple or sum application" $$                pprStgRhs opts rhs)++    lintConApp con args (pprStgRhs opts rhs)+     mapM_ lintStgArg args     mapM_ checkPostUnariseConArg args @@ -183,17 +249,23 @@  lintStgExpr (StgLit _) = return () -lintStgExpr (StgApp fun args) = do-    lintStgVar fun-    mapM_ lintStgArg args+lintStgExpr e@(StgApp fun args) = do+  lintStgVar fun+  mapM_ lintStgArg args +  lintAppCbvMarks e+  lintStgAppReps fun args+ lintStgExpr app@(StgConApp con _n args _arg_tys) = do     -- unboxed sums should vanish during unarise     lf <- getLintFlags+    opts <- getStgPprOpts     when (lf_unarised lf && isUnboxedSumDataCon con) $ do-      opts <- getStgPprOpts       addErrL (text "Unboxed sum after unarise:" $$                pprStgExpr opts app)++    lintConApp con args (pprStgExpr opts app)+     mapM_ lintStgArg args     mapM_ checkPostUnariseConArg args @@ -224,18 +296,100 @@  lintAlt     :: (OutputablePass a, BinderP a ~ Id)-    => (AltCon, [Id], GenStgExpr a) -> LintM ()+    => GenStgAlt a -> LintM () -lintAlt (DEFAULT, _, rhs) =-    lintStgExpr rhs+lintAlt GenStgAlt{ alt_con   = DEFAULT+                 , alt_bndrs = _+                 , alt_rhs   = rhs} = lintStgExpr rhs -lintAlt (LitAlt _, _, rhs) =-    lintStgExpr rhs+lintAlt GenStgAlt{ alt_con   = LitAlt _+                 , alt_bndrs = _+                 , alt_rhs   = rhs} = lintStgExpr rhs -lintAlt (DataAlt _, bndrs, rhs) = do+lintAlt GenStgAlt{ alt_con   = DataAlt _+                 , alt_bndrs = bndrs+                 , alt_rhs   = rhs} =+  do     mapM_ checkPostUnariseBndr bndrs     addInScopeVars bndrs (lintStgExpr rhs) +-- Post unarise check we apply constructors to the right number of args.+-- This can be violated by invalid use of unsafeCoerce as showcased by test+-- T9208+lintConApp :: Foldable t => DataCon -> t a -> SDoc -> LintM ()+lintConApp con args app = do+    unarised <- lf_unarised <$> getLintFlags+    when (unarised &&+          not (isUnboxedTupleDataCon con) &&+          length (dataConRuntimeRepStrictness con) /= length args) $ do+      addErrL (text "Constructor applied to incorrect number of arguments:" $$+               text "Application:" <> app)++-- See Note [Linting StgApp]+-- See Note [Typing the STG language]+lintStgAppReps :: Id -> [StgArg] -> LintM ()+lintStgAppReps _fun [] = return ()+lintStgAppReps fun args = do+  lf <- getLintFlags+  let platform = lf_platform lf+      (fun_arg_tys, _res) = splitFunTys (idType fun)+      fun_arg_tys' = map (scaledThing ) fun_arg_tys :: [Type]+      fun_arg_tys_reps, actual_arg_reps :: [Maybe [PrimRep]]+      fun_arg_tys_reps = map typePrimRep_maybe fun_arg_tys'+      actual_arg_reps = map (typePrimRep_maybe . stgArgType) args++      match_args :: [Maybe [PrimRep]] -> [Maybe [PrimRep]] -> LintM ()+      -- Might be wrongly typed as polymorphic. See #21399+      match_args (Nothing:_) _   = return ()+      match_args (_) (Nothing:_) = return ()+      match_args (Just actual_rep:actual_reps_left) (Just expected_rep:expected_reps_left)+        -- Common case, reps are exactly the same+        | actual_rep == expected_rep+        = match_args actual_reps_left expected_reps_left++        -- Check for void rep which can be either an empty list *or* [VoidRep]+        | isVoidRep actual_rep && isVoidRep expected_rep+        = match_args actual_reps_left expected_reps_left++        -- Some reps are compatible *even* if they are not the same. E.g. IntRep and WordRep.+        -- We check for that here with primRepCompatible+        | and $ zipWith (primRepCompatible platform) actual_rep expected_rep+        = match_args actual_reps_left expected_reps_left++        | otherwise = addErrL $ hang (text "Function type reps and function argument reps missmatched") 2 $+            (text "In application " <> ppr fun <+> ppr args $$+              text "argument rep:" <> ppr actual_rep $$+              text "expected rep:" <> ppr expected_rep $$+              -- text "expected reps:" <> ppr arg_ty_reps $$+              text "unarised?:" <> ppr (lf_unarised lf))+        where+          isVoidRep [] = True+          isVoidRep [VoidRep] = True+          isVoidRep _ = False++          -- n_arg_ty_reps = length arg_ty_reps++      match_args _ _ = return () -- Functions are allowed to be over/under applied.++  match_args actual_arg_reps fun_arg_tys_reps++lintAppCbvMarks :: OutputablePass pass+                => GenStgExpr pass -> LintM ()+lintAppCbvMarks e@(StgApp fun args) = do+  lf <- getLintFlags+  when (lf_unarised lf) $ do+    -- A function which expects a unlifted argument as n'th argument+    -- always needs to be applied to n arguments.+    -- See Note [CBV Function Ids].+    let marks = fromMaybe [] $ idCbvMarks_maybe fun+    when (length (dropWhileEndLE (not . isMarkedCbv) marks) > length args) $ do+      addErrL $ hang (text "Undersatured cbv marked ID in App" <+> ppr e ) 2 $+        (text "marks" <> ppr marks $$+        text "args" <> ppr args $$+        text "arity" <> ppr (idArity fun) $$+        text "join_arity" <> ppr (isJoinId_maybe fun))+lintAppCbvMarks _ = panic "impossible - lintAppCbvMarks"+ {- ************************************************************************ *                                                                      *@@ -247,6 +401,7 @@ newtype LintM a = LintM     { unLintM :: Module               -> LintFlags+              -> DiagOpts          -- Diagnostic options               -> StgPprOpts        -- Pretty-printing options               -> [LintLocInfo]     -- Locations               -> IdSet             -- Local vars in scope@@ -256,6 +411,7 @@     deriving (Functor)  data LintFlags = LintFlags { lf_unarised :: !Bool+                           , lf_platform :: !Platform                              -- ^ have we run the unariser yet?                            } @@ -281,16 +437,16 @@     pp_binder b       = hsep [ppr b, dcolon, ppr (idType b)] -initL :: Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe SDoc-initL this_mod unarised opts locals (LintM m) = do-  let (_, errs) = m this_mod (LintFlags unarised) opts [] locals emptyBag+initL :: Platform -> DiagOpts -> Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe SDoc+initL platform diag_opts this_mod unarised opts locals (LintM m) = do+  let (_, errs) = m this_mod (LintFlags unarised platform) diag_opts opts [] locals emptyBag   if isEmptyBag errs then       Nothing   else       Just (vcat (punctuate blankLine (bagToList errs)))  instance Applicative LintM where-      pure a = LintM $ \_mod _lf _opts _loc _scope errs -> (a, errs)+      pure a = LintM $ \_mod _lf _df _opts _loc _scope errs -> (a, errs)       (<*>) = ap       (*>)  = thenL_ @@ -299,14 +455,14 @@     (>>)  = (*>)  thenL :: LintM a -> (a -> LintM b) -> LintM b-thenL m k = LintM $ \mod lf opts loc scope errs-  -> case unLintM m mod lf opts loc scope errs of-      (r, errs') -> unLintM (k r) mod lf opts loc scope errs'+thenL m k = LintM $ \mod lf diag_opts opts loc scope errs+  -> case unLintM m mod lf diag_opts opts loc scope errs of+      (r, errs') -> unLintM (k r) mod lf diag_opts opts loc scope errs'  thenL_ :: LintM a -> LintM b -> LintM b-thenL_ m k = LintM $ \mod lf opts loc scope errs-  -> case unLintM m mod lf opts loc scope errs of-      (_, errs') -> unLintM k mod lf opts loc scope errs'+thenL_ m k = LintM $ \mod lf diag_opts opts loc scope errs+  -> case unLintM m mod lf diag_opts opts loc scope errs of+      (_, errs') -> unLintM k mod lf diag_opts opts loc scope errs'  checkL :: Bool -> SDoc -> LintM () checkL True  _   = return ()@@ -346,42 +502,43 @@       is_sum, is_tuple, is_void :: Maybe String       is_sum = guard (isUnboxedSumType id_ty) >> return "unboxed sum"       is_tuple = guard (isUnboxedTupleType id_ty) >> return "unboxed tuple"-      is_void = guard (isVoidTy id_ty) >> return "void"+      is_void = guard (isZeroBitTy id_ty) >> return "void"     in       is_sum <|> is_tuple <|> is_void  addErrL :: SDoc -> LintM ()-addErrL msg = LintM $ \_mod _lf _opts loc _scope errs -> ((), addErr errs msg loc)+addErrL msg = LintM $ \_mod _lf df _opts loc _scope errs -> ((), addErr df errs msg loc) -addErr :: Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc-addErr errs_so_far msg locs+addErr :: DiagOpts -> Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc+addErr diag_opts errs_so_far msg locs   = errs_so_far `snocBag` mk_msg locs   where     mk_msg (loc:_) = let (l,hdr) = dumpLoc loc-                     in  mkLocMessage SevWarning l (hdr $$ msg)+                     in  mkLocMessage (Err.mkMCDiagnostic diag_opts WarningWithoutFlag)+                                      l (hdr $$ msg)     mk_msg []      = msg  addLoc :: LintLocInfo -> LintM a -> LintM a-addLoc extra_loc m = LintM $ \mod lf opts loc scope errs-   -> unLintM m mod lf opts (extra_loc:loc) scope errs+addLoc extra_loc m = LintM $ \mod lf diag_opts opts loc scope errs+   -> unLintM m mod lf diag_opts opts (extra_loc:loc) scope errs  addInScopeVars :: [Id] -> LintM a -> LintM a-addInScopeVars ids m = LintM $ \mod lf opts loc scope errs+addInScopeVars ids m = LintM $ \mod lf diag_opts opts loc scope errs  -> let         new_set = mkVarSet ids-    in unLintM m mod lf opts loc (scope `unionVarSet` new_set) errs+    in unLintM m mod lf diag_opts opts loc (scope `unionVarSet` new_set) errs  getLintFlags :: LintM LintFlags-getLintFlags = LintM $ \_mod lf _opts _loc _scope errs -> (lf, errs)+getLintFlags = LintM $ \_mod lf _df _opts _loc _scope errs -> (lf, errs)  getStgPprOpts :: LintM StgPprOpts-getStgPprOpts = LintM $ \_mod _lf opts _loc _scope errs -> (opts, errs)+getStgPprOpts = LintM $ \_mod _lf _df opts _loc _scope errs -> (opts, errs)  checkInScope :: Id -> LintM ()-checkInScope id = LintM $ \mod _lf _opts loc scope errs+checkInScope id = LintM $ \mod _lf diag_opts _opts loc scope errs  -> if nameIsLocalOrFrom mod (idName id) && not (id `elemVarSet` scope) then-        ((), addErr errs (hsep [ppr id, dcolon, ppr (idType id),-                                text "is out of scope"]) loc)+        ((), addErr diag_opts errs (hsep [ppr id, dcolon, ppr (idType id),+                                    text "is out of scope"]) loc)     else         ((), errs)
compiler/GHC/Stg/Pipeline.hs view
@@ -4,14 +4,16 @@ \section[SimplStg]{Driver for simplifying @STG@ programs} -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} -module GHC.Stg.Pipeline ( stg2stg ) where--#include "GhclibHsVersions.h"+module GHC.Stg.Pipeline+  ( StgPipelineOpts (..)+  , StgToDo (..)+  , stg2stg+  ) where  import GHC.Prelude @@ -19,47 +21,57 @@  import GHC.Stg.Lint     ( lintStgTopBindings ) import GHC.Stg.Stats    ( showStgStats )-import GHC.Stg.DepAnal  ( depSortStgPgm )+import GHC.Stg.FVs      ( depSortWithAnnotStgPgm ) import GHC.Stg.Unarise  ( unarise )+import GHC.Stg.BcPrep   ( bcPrep ) import GHC.Stg.CSE      ( stgCse )-import GHC.Stg.Lift     ( stgLiftLams )+import GHC.Stg.Lift     ( StgLiftConfig, stgLiftLams ) import GHC.Unit.Module ( Module ) import GHC.Runtime.Context ( InteractiveContext ) -import GHC.Driver.Session+import GHC.Driver.Flags (DumpFlag(..)) import GHC.Utils.Error import GHC.Types.Unique.Supply import GHC.Utils.Outputable-import GHC.Utils.Panic import GHC.Utils.Logger import Control.Monad import Control.Monad.IO.Class-import Control.Monad.Trans.State.Strict+import Control.Monad.Trans.Reader+import GHC.Settings (Platform) -newtype StgM a = StgM { _unStgM :: StateT Char IO a }+data StgPipelineOpts = StgPipelineOpts+  { stgPipeline_phases      :: ![StgToDo]+  -- ^ Spec of what stg-to-stg passes to do+  , stgPipeline_lint        :: !(Maybe DiagOpts)+  -- ^ Should we lint the STG at various stages of the pipeline?+  , stgPipeline_pprOpts     :: !StgPprOpts+  , stgPlatform             :: !Platform+  }++newtype StgM a = StgM { _unStgM :: ReaderT Char IO a }   deriving (Functor, Applicative, Monad, MonadIO)  instance MonadUnique StgM where-  getUniqueSupplyM = StgM $ do { mask <- get+  getUniqueSupplyM = StgM $ do { mask <- ask                                ; liftIO $! mkSplitUniqSupply mask}-  getUniqueM = StgM $ do { mask <- get+  getUniqueM = StgM $ do { mask <- ask                          ; liftIO $! uniqFromMask mask}  runStgM :: Char -> StgM a -> IO a-runStgM mask (StgM m) = evalStateT m mask+runStgM mask (StgM m) = runReaderT m mask  stg2stg :: Logger-        -> DynFlags                  -- includes spec of what stg-to-stg passes to do         -> InteractiveContext+        -> StgPipelineOpts         -> Module                    -- module being compiled         -> [StgTopBinding]           -- input program-        -> IO [StgTopBinding]        -- output program-stg2stg logger dflags ictxt this_mod binds+        -> IO [CgStgTopBinding]        -- output program+stg2stg logger ictxt opts this_mod binds   = do  { dump_when Opt_D_dump_stg_from_core "Initial STG:" binds-        ; showPass logger dflags "Stg2Stg"+        ; showPass logger "Stg2Stg"         -- Do the main business!         ; binds' <- runStgM 'g' $-            foldM do_stg_pass binds (getStgToDo dflags)+            foldM (do_stg_pass this_mod) binds (stgPipeline_phases opts)            -- Dependency sort the program as last thing. The program needs to be           -- in dependency order for the SRT algorithm to work (see@@ -69,52 +81,63 @@           -- dependency order. We also don't guarantee that StgLiftLams will           -- preserve the order or only create minimal recursive groups, so a           -- sorting pass is necessary.-        ; let binds_sorted = depSortStgPgm this_mod binds'-        ; return binds_sorted+          -- This pass will also augment each closure with non-global free variables+          -- annotations (which is used by code generator to compute offsets into closures)+        ; let binds_sorted_with_fvs = depSortWithAnnotStgPgm this_mod binds'+        ; return binds_sorted_with_fvs    }    where     stg_linter unarised-      | gopt Opt_DoStgLinting dflags-      = lintStgTopBindings logger dflags ictxt this_mod unarised+      | Just diag_opts <- stgPipeline_lint opts+      = lintStgTopBindings+          (stgPlatform opts) logger+          diag_opts ppr_opts+          ictxt this_mod unarised       | otherwise       = \ _whodunnit _binds -> return ()      --------------------------------------------    do_stg_pass :: [StgTopBinding] -> StgToDo -> StgM [StgTopBinding]-    do_stg_pass binds to_do+    do_stg_pass :: Module -> [StgTopBinding] -> StgToDo -> StgM [StgTopBinding]+    do_stg_pass this_mod binds to_do       = case to_do of           StgDoNothing ->             return binds            StgStats ->-            trace (showStgStats binds) (return binds)+            logTraceMsg logger "STG stats" (text (showStgStats binds)) (return binds)            StgCSE -> do             let binds' = {-# SCC "StgCse" #-} stgCse binds             end_pass "StgCse" binds' -          StgLiftLams -> do+          StgLiftLams cfg -> do             us <- getUniqueSupplyM-            let binds' = {-# SCC "StgLiftLams" #-} stgLiftLams dflags us binds+            --+            let binds' = {-# SCC "StgLiftLams" #-} stgLiftLams this_mod cfg us binds             end_pass "StgLiftLams" binds' +          StgBcPrep -> do+            us <- getUniqueSupplyM+            let binds' = {-# SCC "StgBcPrep" #-} bcPrep us binds+            end_pass "StgBcPrep" binds'+           StgUnarise -> do             us <- getUniqueSupplyM             liftIO (stg_linter False "Pre-unarise" binds)-            let binds' = unarise us binds+            let binds' = {-# SCC "StgUnarise" #-} unarise us binds             liftIO (dump_when Opt_D_dump_stg_unarised "Unarised STG:" binds')             liftIO (stg_linter True "Unarise" binds')             return binds' -    opts = initStgPprOpts dflags+    ppr_opts = stgPipeline_pprOpts opts     dump_when flag header binds-      = dumpIfSet_dyn logger dflags flag header FormatSTG (pprStgTopBindings opts binds)+      = putDumpFileMaybe logger flag header FormatSTG (pprStgTopBindings ppr_opts binds)      end_pass what binds2       = liftIO $ do -- report verbosely, if required-          dumpIfSet_dyn logger dflags Opt_D_verbose_stg2stg what-            FormatSTG (vcat (map (pprStgTopBinding opts) binds2))+          putDumpFileMaybe logger Opt_D_verbose_stg2stg what+            FormatSTG (vcat (map (pprStgTopBinding ppr_opts) binds2))           stg_linter False what binds2           return binds2 @@ -125,30 +148,14 @@ data StgToDo   = StgCSE   -- ^ Common subexpression elimination-  | StgLiftLams+  | StgLiftLams StgLiftConfig   -- ^ Lambda lifting closure variables, trading stack/register allocation for   -- heap allocation   | StgStats   | StgUnarise   -- ^ Mandatory unarise pass, desugaring unboxed tuple and sum binders+  | StgBcPrep+  -- ^ Mandatory when compiling to bytecode   | StgDoNothing   -- ^ Useful for building up 'getStgToDo'-  deriving Eq---- | Which Stg-to-Stg passes to run. Depends on flags, ways etc.-getStgToDo :: DynFlags -> [StgToDo]-getStgToDo dflags =-  filter (/= StgDoNothing)-    [ mandatory StgUnarise-    -- Important that unarisation comes first-    -- See Note [StgCse after unarisation] in GHC.Stg.CSE-    , optional Opt_StgCSE StgCSE-    , optional Opt_StgLiftLams StgLiftLams-    , optional Opt_StgStats StgStats-    ] where-      optional opt = runWhen (gopt opt dflags)-      mandatory = id--runWhen :: Bool -> StgToDo -> StgToDo-runWhen True todo = todo-runWhen _    _    = StgDoNothing+  deriving (Show, Read, Eq, Ord)
compiler/GHC/Stg/Stats.hs view
@@ -21,11 +21,9 @@ \end{enumerate} -} -{-# LANGUAGE CPP #-} -module GHC.Stg.Stats ( showStgStats ) where -#include "GhclibHsVersions.h"+module GHC.Stg.Stats ( showStgStats ) where  import GHC.Prelude @@ -148,7 +146,7 @@  statExpr (StgApp _ _)     = countOne Applications statExpr (StgLit _)       = countOne Literals-statExpr (StgConApp _ _ _ _)= countOne ConstructorApps+statExpr (StgConApp {})   = countOne ConstructorApps statExpr (StgOpApp _ _ _) = countOne PrimitiveApps statExpr (StgTick _ e)    = statExpr e @@ -166,5 +164,4 @@     stat_alts alts      `combineSE`     countOne StgCases   where-    stat_alts alts-        = combineSEs (map statExpr [ e | (_,_,e) <- alts ])+    stat_alts = combineSEs . fmap (statExpr . alt_rhs)
compiler/GHC/Stg/Subst.hs view
@@ -1,20 +1,17 @@-{-# LANGUAGE CPP #-} -module GHC.Stg.Subst where -#include "GhclibHsVersions.h"+module GHC.Stg.Subst where  import GHC.Prelude  import GHC.Types.Id import GHC.Types.Var.Env-import Control.Monad.Trans.State.Strict+import GHC.Utils.Monad.State.Strict  import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic--import GHC.Driver.Ppr+import GHC.Utils.Trace  -- | A renaming substitution from 'Id's to 'Id's. Like 'RnEnv2', but not -- maintaining pairs of substitutions. Like 'GHC.Core.Subst.Subst', but@@ -57,8 +54,7 @@   | not (isLocalId id) = id   | Just id' <- lookupVarEnv env id = id'   | Just id' <- lookupInScope in_scope id = id'-  | otherwise = WARN( True, text "StgSubst.lookupIdSubst" <+> ppr id $$ ppr in_scope)-                id+  | otherwise = warnPprTrace True "StgSubst.lookupIdSubst" (ppr id $$ ppr in_scope) id  -- | Substitutes an occurrence of an identifier for its counterpart recorded -- in the 'Subst'. Does not generate a debug warning if the identifier to@@ -80,5 +76,5 @@ -- holds after extending the substitution like this. extendSubst :: Id -> Id -> Subst -> Subst extendSubst id new_id (Subst in_scope env)-  = ASSERT2( new_id `elemInScopeSet` in_scope, ppr id <+> ppr new_id $$ ppr in_scope )+  = assertPpr (new_id `elemInScopeSet` in_scope) (ppr id <+> ppr new_id $$ ppr in_scope) $     Subst in_scope (extendVarEnv env id new_id)
compiler/GHC/Stg/Unarise.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP              #-}+ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TupleSections    #-} @@ -130,20 +130,44 @@    (# 2#, rubbish, 2#, 3# #). ++Note [Don't merge lifted and unlifted slots]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When merging slots, one might be tempted to collapse lifted and unlifted-points. However, as seen in #19645, this is wrong. Imagine that you have+pointers. However, as seen in #19645, this is wrong. Imagine that you have the program: -    test :: (# Char | ByteArray# #) -> ByteArray#-    test (# | ba #) = ba-    test (# c | #) = ...+  test :: (# Char | ByteArray# #) -> ByteArray#+  test (# c | #) = doSomething c+  test (# | ba #) = ba -If we were to collapse the sum argument to (# Tag#, Any #) we would end up treating-the ByteArray# as a lifted object. This would cause the code generator to-attempt to enter it upon returning, causing a runtime crash. For this reason we-treat unlifted and lifted things as distinct slot types, despite both being GC-pointers.+Collapsing the Char and ByteArray# slots would produce STG like: +  test :: forall {t}. (# t | GHC.Prim.ByteArray# #) -> GHC.Prim.ByteArray#+    = {} \r [ (tag :: Int#) (slot0 :: (Any :: Type)) ]+          case tag of tag'+            1# -> doSomething slot0+            2# -> slot0;++Note how `slot0` has a lifted type, despite being bound to an unlifted+ByteArray# in the 2# alternative. This liftedness would cause the code generator to+attempt to enter it upon returning. As unlifted objects do not have entry code,+this causes a runtime crash.++For this reason, Unarise treats unlifted and lifted things as distinct slot+types, despite both being GC pointers. This approach is a slight pessimisation+(since we need to pass more arguments) but appears to be the simplest way to+avoid #19645. Other alternatives considered include:++ a. Giving unlifted objects "trivial" entry code. However, we ultimately+    concluded that the value of the "unlifted things are never entered" invariant+    outweighed the simplicity of this approach.++ b. Annotating occurrences with calling convention information instead of+    relying on the binder's type. This seemed like a very complicated+    way to fix what is ultimately a corner-case.++ Note [Types in StgConApp] ~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have this unboxed sum term:@@ -229,8 +253,6 @@  module GHC.Stg.Unarise (unarise) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Types.Basic@@ -245,10 +267,12 @@ import GHC.Utils.Monad (mapAccumLM) import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Types.RepType import GHC.Stg.Syntax+import GHC.Stg.Utils import GHC.Core.Type-import GHC.Builtin.Types.Prim (intPrimTy, primRepToRuntimeRep)+import GHC.Builtin.Types.Prim (intPrimTy) import GHC.Builtin.Types import GHC.Types.Unique.Supply import GHC.Utils.Misc@@ -297,10 +321,10 @@ -- See Note [UnariseEnv] extendRho :: UnariseEnv -> Id -> UnariseVal -> UnariseEnv extendRho rho x (MultiVal args)-  = ASSERT(all (isNvUnaryType . stgArgType) args)+  = assert (all (isNvUnaryType . stgArgType) args)     extendVarEnv rho x (MultiVal args) extendRho rho x (UnaryVal val)-  = ASSERT(isNvUnaryType (stgArgType val))+  = assert (isNvUnaryType (stgArgType val))     extendVarEnv rho x (UnaryVal val) -- Properly shadow things from an outer scope. -- See Note [UnariseEnv]@@ -334,7 +358,7 @@        return (StgRhsClosure ext ccs update_flag args1 expr')  unariseRhs rho (StgRhsCon ccs con mu ts args)-  = ASSERT(not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con))+  = assert (not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con))     return (StgRhsCon ccs con mu ts (unariseConArgs rho args))  --------------------------------------------------------------------------------@@ -418,7 +442,7 @@   = Just (unariseConArgs rho args)    | isUnboxedSumDataCon dc-  , let args1 = ASSERT(isSingleton args) (unariseConArgs rho args)+  , let args1 = assert (isSingleton args) (unariseConArgs rho args)   = Just (mkUbxSum dc ty_args args1)    | otherwise@@ -445,13 +469,15 @@          -> [OutStgArg] -- non-void args          -> InId -> AltType -> [InStgAlt] -> UniqSM OutStgExpr -elimCase rho args bndr (MultiValAlt _) [(_, bndrs, rhs)]+elimCase rho args bndr (MultiValAlt _) [GenStgAlt{ alt_con   = _+                                                 , alt_bndrs = bndrs+                                                 , alt_rhs   = rhs}]   = do let rho1 = extendRho rho bndr (MultiVal args)            rho2              | isUnboxedTupleBndr bndr              = mapTupleIdBinders bndrs args rho1              | otherwise-             = ASSERT(isUnboxedSumBndr bndr)+             = assert (isUnboxedSumBndr bndr) $                if null bndrs then rho1                              else mapSumIdBinders bndrs args rho1 @@ -477,47 +503,55 @@ --------------------------------------------------------------------------------  unariseAlts :: UnariseEnv -> AltType -> InId -> [StgAlt] -> UniqSM [StgAlt]-unariseAlts rho (MultiValAlt n) bndr [(DEFAULT, [], e)]+unariseAlts rho (MultiValAlt n) bndr [GenStgAlt{ alt_con   = DEFAULT+                                               , alt_bndrs = []+                                               , alt_rhs   = e}]   | isUnboxedTupleBndr bndr   = do (rho', ys) <- unariseConArgBinder rho bndr-       e' <- unariseExpr rho' e-       return [(DataAlt (tupleDataCon Unboxed n), ys, e')]+       !e' <- unariseExpr rho' e+       return [GenStgAlt (DataAlt (tupleDataCon Unboxed n)) ys e'] -unariseAlts rho (MultiValAlt n) bndr [(DataAlt _, ys, e)]+unariseAlts rho (MultiValAlt n) bndr [GenStgAlt{ alt_con   = DataAlt _+                                               , alt_bndrs = ys+                                               , alt_rhs   = e}]   | isUnboxedTupleBndr bndr   = do (rho', ys1) <- unariseConArgBinders rho ys-       MASSERT(ys1 `lengthIs` n)+       massert (ys1 `lengthIs` n)        let rho'' = extendRho rho' bndr (MultiVal (map StgVarArg ys1))-       e' <- unariseExpr rho'' e-       return [(DataAlt (tupleDataCon Unboxed n), ys1, e')]+       !e' <- unariseExpr rho'' e+       return [GenStgAlt (DataAlt (tupleDataCon Unboxed n)) ys1 e']  unariseAlts _ (MultiValAlt _) bndr alts   | isUnboxedTupleBndr bndr   = pprPanic "unariseExpr: strange multi val alts" (pprPanicAlts alts)  -- In this case we don't need to scrutinize the tag bit-unariseAlts rho (MultiValAlt _) bndr [(DEFAULT, _, rhs)]+unariseAlts rho (MultiValAlt _) bndr [GenStgAlt{ alt_con    = DEFAULT+                                               , alt_bndrs = []+                                               , alt_rhs   = rhs}]   | isUnboxedSumBndr bndr   = do (rho_sum_bndrs, sum_bndrs) <- unariseConArgBinder rho bndr        rhs' <- unariseExpr rho_sum_bndrs rhs-       return [(DataAlt (tupleDataCon Unboxed (length sum_bndrs)), sum_bndrs, rhs')]+       return [GenStgAlt (DataAlt (tupleDataCon Unboxed (length sum_bndrs))) sum_bndrs rhs']  unariseAlts rho (MultiValAlt _) bndr alts   | isUnboxedSumBndr bndr   = do (rho_sum_bndrs, scrt_bndrs@(tag_bndr : real_bndrs)) <- unariseConArgBinder rho bndr        alts' <- unariseSumAlts rho_sum_bndrs (map StgVarArg real_bndrs) alts        let inner_case = StgCase (StgApp tag_bndr []) tag_bndr tagAltTy alts'-       return [ (DataAlt (tupleDataCon Unboxed (length scrt_bndrs)),-                 scrt_bndrs,-                 inner_case) ]+       return [GenStgAlt{ alt_con   = DataAlt (tupleDataCon Unboxed (length scrt_bndrs))+                        , alt_bndrs = scrt_bndrs+                        , alt_rhs   = inner_case+                        }]  unariseAlts rho _ _ alts   = mapM (\alt -> unariseAlt rho alt) alts  unariseAlt :: UnariseEnv -> StgAlt -> UniqSM StgAlt-unariseAlt rho (con, xs, e)+unariseAlt rho alt@GenStgAlt{alt_con=_,alt_bndrs=xs,alt_rhs=e}   = do (rho', xs') <- unariseConArgBinders rho xs-       (con, xs',) <$> unariseExpr rho' e+       !e' <- unariseExpr rho' e+       return $! alt {alt_bndrs = xs', alt_rhs = e'}  -------------------------------------------------------------------------------- @@ -535,13 +569,16 @@               -> [StgArg] -- sum components _excluding_ the tag bit.               -> StgAlt   -- original alternative with sum LHS               -> UniqSM StgAlt-unariseSumAlt rho _ (DEFAULT, _, e)-  = ( DEFAULT, [], ) <$> unariseExpr rho e+unariseSumAlt rho _ GenStgAlt{alt_con=DEFAULT,alt_bndrs=_,alt_rhs=e}+  = GenStgAlt DEFAULT mempty <$> unariseExpr rho e -unariseSumAlt rho args (DataAlt sumCon, bs, e)-  = do let rho' = mapSumIdBinders bs args rho-       e' <- unariseExpr rho' e-       return ( LitAlt (LitNumber LitNumInt (fromIntegral (dataConTag sumCon))), [], e' )+unariseSumAlt rho args GenStgAlt{ alt_con   = DataAlt sumCon+                                , alt_bndrs = bs+                                , alt_rhs   = e+                                }+  = do let rho'     = mapSumIdBinders bs args rho+           lit_case = LitAlt (LitNumber LitNumInt (fromIntegral (dataConTag sumCon)))+       GenStgAlt lit_case mempty <$> unariseExpr rho' e  unariseSumAlt _ scrt alt   = pprPanic "unariseSumAlt" (ppr scrt $$ pprPanicAlt alt)@@ -556,7 +593,7 @@   -> UnariseEnv   -> UnariseEnv mapTupleIdBinders ids args0 rho0-  = ASSERT(not (any (isVoidTy . stgArgType) args0))+  = assert (not (any (isZeroBitTy . stgArgType) args0)) $     let       ids_unarised :: [(Id, [PrimRep])]       ids_unarised = map (\id -> (id, typePrimRep (idType id))) ids@@ -567,12 +604,12 @@         let           x_arity = length x_reps           (x_args, args') =-            ASSERT(args `lengthAtLeast` x_arity)+            assert (args `lengthAtLeast` x_arity)             splitAt x_arity args            rho'             | x_arity == 1-            = ASSERT(x_args `lengthIs` 1)+            = assert (x_args `lengthIs` 1)               extendRho rho x (UnaryVal (head x_args))             | otherwise             = extendRho rho x (MultiVal x_args)@@ -590,7 +627,7 @@   -> UnariseEnv  mapSumIdBinders [id] args rho0-  = ASSERT(not (any (isVoidTy . stgArgType) args))+  = assert (not (any (isZeroBitTy . stgArgType) args)) $     let       arg_slots = map primRepSlot $ concatMap (typePrimRep . stgArgType) args       id_slots  = map primRepSlot $ typePrimRep (idType id)@@ -598,7 +635,7 @@     in       if isMultiValBndr id         then extendRho rho0 id (MultiVal [ args !! i | i <- layout1 ])-        else ASSERT(layout1 `lengthIs` 1)+        else assert (layout1 `lengthIs` 1)              extendRho rho0 id (UnaryVal (args !! head layout1))  mapSumIdBinders ids sum_args _@@ -657,8 +694,6 @@ ubxSumRubbishArg Word64Slot = StgLitArg (LitNumber LitNumWord64 0) ubxSumRubbishArg FloatSlot  = StgLitArg (LitFloat 0) ubxSumRubbishArg DoubleSlot = StgLitArg (LitDouble 0)-ubxSumRubbishArg (VecSlot n e) = StgLitArg (LitRubbish vec_rep)-  where vec_rep = primRepToRuntimeRep (VecRep n e)  -------------------------------------------------------------------------------- @@ -778,15 +813,15 @@     Just (UnaryVal arg) -> [arg]     Just (MultiVal as) -> as      -- 'as' can be empty     Nothing-      | isVoidTy (idType x) -> [] -- e.g. C realWorld#-                                  -- Here realWorld# is not in the envt, but-                                  -- is a void, and so should be eliminated+      | isZeroBitTy (idType x) -> [] -- e.g. C realWorld#+                                     -- Here realWorld# is not in the envt, but+                                     -- is a void, and so should be eliminated       | otherwise -> [StgVarArg x] unariseConArg _ arg@(StgLitArg lit)   | Just as <- unariseRubbish_maybe lit   = as   | otherwise-  = ASSERT(not (isVoidTy (literalType lit))) -- We have no non-rubbish void literals+  = assert (not (isZeroBitTy (literalType lit))) -- We have no non-rubbish void literals     [arg]  unariseConArgs :: UnariseEnv -> [InStgArg] -> [OutStgArg]@@ -803,10 +838,10 @@ --------------------------------------------------------------------------------  mkIds :: FastString -> [UnaryType] -> UniqSM [Id]-mkIds fs tys = mapM (mkId fs) tys+mkIds fs tys = mkUnarisedIds fs tys  mkId :: FastString -> UnaryType -> UniqSM Id-mkId s t = mkSysLocalM s Many t+mkId s t = mkUnarisedId s t  isMultiValBndr :: Id -> Bool isMultiValBndr id@@ -840,12 +875,12 @@ -- Since they are exhaustive, we can replace one with DEFAULT, to avoid -- generating a final test. Remember, the DEFAULT comes first if it exists. mkDefaultLitAlt [] = pprPanic "elimUbxSumExpr.mkDefaultAlt" (text "Empty alts")-mkDefaultLitAlt alts@((DEFAULT, _, _) : _) = alts-mkDefaultLitAlt ((LitAlt{}, [], rhs) : alts) = (DEFAULT, [], rhs) : alts+mkDefaultLitAlt alts@(GenStgAlt{alt_con=DEFAULT,alt_bndrs=_,alt_rhs=_} : _)   = alts+mkDefaultLitAlt (alt@GenStgAlt{alt_con=LitAlt{}, alt_bndrs=[]} : alts) = alt {alt_con = DEFAULT} : alts mkDefaultLitAlt alts = pprPanic "mkDefaultLitAlt" (text "Not a lit alt:" <+> pprPanicAlts alts) -pprPanicAlts :: (Outputable a, Outputable b, OutputablePass pass) => [(a,b,GenStgExpr pass)] -> SDoc+pprPanicAlts :: OutputablePass pass => [GenStgAlt pass] -> SDoc pprPanicAlts alts = ppr (map pprPanicAlt alts) -pprPanicAlt :: (Outputable a, Outputable b, OutputablePass pass) => (a,b,GenStgExpr pass) -> SDoc-pprPanicAlt (c,b,e) = ppr (c,b,pprStgExpr panicStgPprOpts e)+pprPanicAlt :: OutputablePass pass => GenStgAlt pass -> SDoc+pprPanicAlt GenStgAlt{alt_con=c,alt_bndrs=b,alt_rhs=e} = ppr (c,b,pprStgExpr panicStgPprOpts e)
+ compiler/GHC/Stg/Utils.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE CPP, ScopedTypeVariables, TypeFamilies #-}+{-# LANGUAGE DataKinds #-}++module GHC.Stg.Utils+    ( mkStgAltTypeFromStgAlts+    , bindersOf, bindersOfX, bindersOfTop, bindersOfTopBinds++    , stripStgTicksTop, stripStgTicksTopE+    , idArgs++    , mkUnarisedId, mkUnarisedIds+    ) where++import GHC.Prelude++import GHC.Types.Id+import GHC.Core.Type+import GHC.Core.TyCon+import GHC.Core.DataCon+import GHC.Core ( AltCon(..) )+import GHC.Types.Tickish+import GHC.Types.Unique.Supply++import GHC.Types.RepType+import GHC.Stg.Syntax++import GHC.Utils.Outputable++import GHC.Utils.Panic.Plain+import GHC.Utils.Panic++import GHC.Data.FastString++mkUnarisedIds :: MonadUnique m => FastString -> [UnaryType] -> m [Id]+mkUnarisedIds fs tys = mapM (mkUnarisedId fs) tys++mkUnarisedId :: MonadUnique m => FastString -> UnaryType -> m Id+mkUnarisedId s t = mkSysLocalM s Many t++-- Checks if id is a top level error application.+-- isErrorAp_maybe :: Id ->++-- | Extract the default case alternative+-- findDefaultStg :: [Alt b] -> ([Alt b], Maybe (Expr b))+findDefaultStg+  :: [GenStgAlt p]+  -> ([GenStgAlt p], Maybe (GenStgExpr p))+findDefaultStg (GenStgAlt{ alt_con    = DEFAULT+                         , alt_bndrs  = args+                         , alt_rhs    = rhs} : alts) = assert( null args ) (alts, Just rhs)+findDefaultStg alts                                  = (alts, Nothing)++mkStgAltTypeFromStgAlts :: forall p. Id -> [GenStgAlt p] -> AltType+mkStgAltTypeFromStgAlts bndr alts+  | isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty+  = MultiValAlt (length prim_reps)  -- always use MultiValAlt for unboxed tuples++  | otherwise+  = case prim_reps of+      [rep] | isGcPtrRep rep ->+        case tyConAppTyCon_maybe (unwrapType bndr_ty) of+          Just tc+            | isAbstractTyCon tc -> look_for_better_tycon+            | isAlgTyCon tc      -> AlgAlt tc+            | otherwise          -> assertPpr ( _is_poly_alt_tycon tc) (ppr tc)+                                    PolyAlt+          Nothing                -> PolyAlt+      [non_gcd] -> PrimAlt non_gcd+      not_unary -> MultiValAlt (length not_unary)+  where+   bndr_ty   = idType bndr+   prim_reps = typePrimRep bndr_ty++   _is_poly_alt_tycon tc+        =  isFunTyCon tc+        || isPrimTyCon tc   -- "Any" is lifted but primitive+        || isFamilyTyCon tc -- Type family; e.g. Any, or arising from strict+                            -- function application where argument has a+                            -- type-family type++   -- Sometimes, the TyCon is a AbstractTyCon which may not have any+   -- constructors inside it.  Then we may get a better TyCon by+   -- grabbing the one from a constructor alternative+   -- if one exists.+   look_for_better_tycon+        | (DataAlt con : _) <- alt_con <$> data_alts =+                AlgAlt (dataConTyCon con)+        | otherwise =+                assert(null data_alts)+                PolyAlt+        where+                (data_alts, _deflt) = findDefaultStg alts++bindersOf :: BinderP a ~ Id => GenStgBinding a -> [Id]+bindersOf (StgNonRec binder _) = [binder]+bindersOf (StgRec pairs)       = [binder | (binder, _) <- pairs]++bindersOfX :: GenStgBinding a -> [BinderP a]+bindersOfX (StgNonRec binder _) = [binder]+bindersOfX (StgRec pairs)       = [binder | (binder, _) <- pairs]++bindersOfTop :: BinderP a ~ Id => GenStgTopBinding a -> [Id]+bindersOfTop (StgTopLifted bind) = bindersOf bind+bindersOfTop (StgTopStringLit binder _) = [binder]++-- All ids we bind something to on the top level.+bindersOfTopBinds :: BinderP a ~ Id => [GenStgTopBinding a] -> [Id]+-- bindersOfTopBinds binds = mapUnionVarSet (mkVarSet . bindersOfTop) binds+bindersOfTopBinds binds = foldr ((++) . bindersOfTop) [] binds++idArgs :: [StgArg] -> [Id]+idArgs args = [v | StgVarArg v <- args]++-- | Strip ticks of a given type from an STG expression.+stripStgTicksTop :: (StgTickish -> Bool) -> GenStgExpr p -> ([StgTickish], GenStgExpr p)+stripStgTicksTop p = go []+   where go ts (StgTick t e) | p t = go (t:ts) e+         -- This special case avoid building a thunk for "reverse ts" when there are no ticks+         go [] other               = ([], other)+         go ts other               = (reverse ts, other)++-- | Strip ticks of a given type from an STG expression returning only the expression.+stripStgTicksTopE :: (StgTickish -> Bool) -> GenStgExpr p -> GenStgExpr p+stripStgTicksTopE p = go+   where go (StgTick t e) | p t = go e+         go other               = other
compiler/GHC/StgToByteCode.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE CPP                        #-}+ {-# LANGUAGE DeriveFunctor              #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE FlexibleContexts           #-}  {-# OPTIONS_GHC -fprof-auto-top #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}@@ -13,8 +14,6 @@ -- | GHC.StgToByteCode: Generate bytecode from STG module GHC.StgToByteCode ( UnlinkedBCO, byteCodeGen) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Driver.Session@@ -38,12 +37,12 @@ import GHC.Types.Basic import GHC.Utils.Outputable import GHC.Types.Name-import GHC.Types.Id.Make import GHC.Types.Id import GHC.Types.ForeignCall import GHC.Core import GHC.Types.Literal import GHC.Builtin.PrimOps+import GHC.Builtin.PrimOps.Ids (primOpId) import GHC.Core.Type import GHC.Types.RepType import GHC.Core.DataCon@@ -51,15 +50,15 @@ import GHC.Utils.Misc import GHC.Utils.Logger import GHC.Types.Var.Set-import GHC.Builtin.Types ( unboxedUnitTy ) import GHC.Builtin.Types.Prim import GHC.Core.TyCo.Ppr ( pprType ) import GHC.Utils.Error import GHC.Types.Unique import GHC.Builtin.Uniques-import GHC.Builtin.Utils ( primOpId ) import GHC.Data.FastString import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Utils.Exception (evaluate) import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, nonVoidIds ) import GHC.StgToCmm.Layout import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes)@@ -75,10 +74,8 @@ import Control.Monad import Data.Char -import GHC.Types.Unique.Supply import GHC.Unit.Module -import Control.Exception import Data.Array import Data.Coerce (coerce) import Data.ByteString (ByteString)@@ -91,9 +88,7 @@ import GHC.Stack.CCS import Data.Either ( partitionEithers ) -import qualified GHC.Types.CostCentre as CC import GHC.Stg.Syntax-import GHC.Stg.FVs import qualified Data.IntSet as IntSet  -- -----------------------------------------------------------------------------@@ -101,12 +96,12 @@  byteCodeGen :: HscEnv             -> Module-            -> [StgTopBinding]+            -> [CgStgTopBinding]             -> [TyCon]             -> Maybe ModBreaks             -> IO CompiledByteCode byteCodeGen hsc_env this_mod binds tycs mb_modBreaks-   = withTiming logger dflags+   = withTiming logger                 (text "GHC.StgToByteCode"<+>brackets (ppr this_mod))                 (const ()) $ do         -- Split top-level binds into strings and others.@@ -120,18 +115,15 @@             flattenBind (StgRec bs)     = bs         stringPtrs <- allocateTopStrings interp strings -        us <- mkSplitUniqSupply 'y'         (BcM_State{..}, proto_bcos) <--           runBc hsc_env us this_mod mb_modBreaks (mkVarEnv stringPtrs) $ do-             prepd_binds <- mapM bcPrepBind lifted_binds-             let flattened_binds =-                   concatMap (flattenBind . annBindingFreeVars) (reverse prepd_binds)+           runBc hsc_env this_mod mb_modBreaks (mkVarEnv stringPtrs) $ do+             let flattened_binds = concatMap flattenBind (reverse lifted_binds)              mapM schemeTopBind flattened_binds          when (notNull ffis)              (panic "GHC.StgToByteCode.byteCodeGen: missing final emitBc?") -        dumpIfSet_dyn logger dflags Opt_D_dump_BCOs+        putDumpFileMaybe logger Opt_D_dump_BCOs            "Proto-BCOs" FormatByteCode            (vcat (intersperse (char ' ') (map ppr proto_bcos))) @@ -150,8 +142,8 @@          return cbc -  where dflags = hsc_dflags hsc_env-        logger = hsc_logger hsc_env+  where dflags  = hsc_dflags hsc_env+        logger  = hsc_logger hsc_env         interp  = hscInterp hsc_env         profile = targetProfile dflags @@ -166,7 +158,7 @@  {- Note [generating code for top-level string literal bindings]-+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Here is a summary on how the byte code generator deals with top-level string literals: @@ -178,100 +170,6 @@    BcM and used when generating code for variable references. -} -{--  Prepare the STG for bytecode generation:--   - Ensure that all breakpoints are directly under-        a let-binding, introducing a new binding for-        those that aren't already.--   - Protect Not-necessarily lifted join points, see-        Note [Not-necessarily-lifted join points]-- -}--bcPrepRHS :: StgRhs -> BcM StgRhs--- explicitly match all constructors so we get a warning if we miss any-bcPrepRHS (StgRhsClosure fvs cc upd args (StgTick bp@Breakpoint{} expr)) = do-  {- If we have a breakpoint directly under an StgRhsClosure we don't-     need to introduce a new binding for it.-   -}-  expr' <- bcPrepExpr expr-  pure (StgRhsClosure fvs cc upd args (StgTick bp expr'))-bcPrepRHS (StgRhsClosure fvs cc upd args expr) =-  StgRhsClosure fvs cc upd args <$> bcPrepExpr expr-bcPrepRHS con@StgRhsCon{} = pure con--bcPrepExpr :: StgExpr -> BcM StgExpr--- explicitly match all constructors so we get a warning if we miss any-bcPrepExpr (StgTick bp@(Breakpoint tick_ty _ _) rhs)-  | isLiftedTypeKind (typeKind tick_ty) = do-      id <- newId tick_ty-      rhs' <- bcPrepExpr rhs-      let expr' = StgTick bp rhs'-          bnd = StgNonRec id (StgRhsClosure noExtFieldSilent-                                            CC.dontCareCCS-                                            ReEntrant-                                            []-                                            expr'-                             )-          letExp = StgLet noExtFieldSilent bnd (StgApp id [])-      pure letExp-  | otherwise = do-      id <- newId (mkVisFunTyMany realWorldStatePrimTy tick_ty)-      st <- newId realWorldStatePrimTy-      rhs' <- bcPrepExpr rhs-      let expr' = StgTick bp rhs'-          bnd = StgNonRec id (StgRhsClosure noExtFieldSilent-                                            CC.dontCareCCS-                                            ReEntrant-                                            [voidArgId]-                                            expr'-                             )-      pure $ StgLet noExtFieldSilent bnd (StgApp id [StgVarArg st])-bcPrepExpr (StgTick tick rhs) =-  StgTick tick <$> bcPrepExpr rhs-bcPrepExpr (StgLet xlet bnds expr) =-  StgLet xlet <$> bcPrepBind bnds-              <*> bcPrepExpr expr-bcPrepExpr (StgLetNoEscape xlne bnds expr) =-  StgLet xlne <$> bcPrepBind bnds-              <*> bcPrepExpr expr-bcPrepExpr (StgCase expr bndr alt_type alts) =-  StgCase <$> bcPrepExpr expr-          <*> pure bndr-          <*> pure alt_type-          <*> mapM bcPrepAlt alts-bcPrepExpr lit@StgLit{} = pure lit--- See Note [Not-necessarily-lifted join points], step 3.-bcPrepExpr (StgApp x [])-  | isNNLJoinPoint x = pure $-      StgApp (protectNNLJoinPointId x) [StgVarArg voidPrimId]-bcPrepExpr app@StgApp{} = pure app-bcPrepExpr app@StgConApp{} = pure app-bcPrepExpr app@StgOpApp{} = pure app--bcPrepAlt :: StgAlt -> BcM StgAlt-bcPrepAlt (ac, bndrs, expr) = (,,) ac bndrs <$> bcPrepExpr expr--bcPrepBind :: StgBinding -> BcM StgBinding--- explicitly match all constructors so we get a warning if we miss any-bcPrepBind (StgNonRec bndr rhs) =-  let (bndr', rhs') = bcPrepSingleBind (bndr, rhs)-  in  StgNonRec bndr' <$> bcPrepRHS rhs'-bcPrepBind (StgRec bnds) =-  StgRec <$> mapM ((\(b,r) -> (,) b <$> bcPrepRHS r) . bcPrepSingleBind)-                  bnds--bcPrepSingleBind :: (Id, StgRhs) -> (Id, StgRhs)--- If necessary, modify this Id and body to protect not-necessarily-lifted join points.--- See Note [Not-necessarily-lifted join points], step 2.-bcPrepSingleBind (x, StgRhsClosure ext cc upd_flag args body)-  | isNNLJoinPoint x-  = ( protectNNLJoinPointId x-    , StgRhsClosure ext cc upd_flag (args ++ [voidArgId]) body)-bcPrepSingleBind bnd = bnd- -- ----------------------------------------------------------------------------- -- Compilation schema for the bytecode generator @@ -318,11 +216,11 @@    -> name    -> BCInstrList    -> Either  [CgStgAlt] (CgStgRhs)-        -- ^ original expression; for debugging only-   -> Int-   -> Word16-   -> [StgWord]-   -> Bool      -- True <=> is a return point, rather than a function+                -- ^ original expression; for debugging only+   -> Int       -- ^ arity+   -> Word16    -- ^ bitmap size+   -> [StgWord] -- ^ bitmap+   -> Bool      -- ^ True <=> is a return point, rather than a function    -> [FFIInfo]    -> ProtoBCO name mkProtoBCO platform nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffis@@ -399,10 +297,7 @@         -- by just re-using the single top-level definition.  So         -- for the worker itself, we must allocate it directly.     -- ioToBc (putStrLn $ "top level BCO")-    let enter = if isUnliftedTypeKind (tyConResKind (dataConTyCon data_con))-                then RETURN_UNLIFTED P-                else ENTER-    emitBc (mkProtoBCO platform (getName id) (toOL [PACK data_con 0, enter])+    emitBc (mkProtoBCO platform (getName id) (toOL [PACK data_con 0, RETURN])                        (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})    | otherwise@@ -593,7 +488,7 @@         (tuple_info, tuple_components) = layoutTuple profile d arg_ty es         go _   pushes [] = return (reverse pushes)         go !dd pushes ((a, off):cs) = do (push, szb) <- pushAtom dd p a-                                         MASSERT(off == dd + szb)+                                         massert (off == dd + szb)                                          go (dd + szb) (push:pushes) cs     pushes <- go d [] tuple_components     ret <- returnUnliftedReps d@@ -608,7 +503,7 @@     :: StackDepth -> Sequel -> BCEnv -> CgStgExpr -> BcM BCInstrList schemeE d s p (StgLit lit) = returnUnliftedAtom d s p (StgLitArg lit) schemeE d s p (StgApp x [])-   | isUnliftedType (idType x) = returnUnliftedAtom d s p (StgVarArg x)+   | not (usePlainReturn (idType x)) = returnUnliftedAtom d s p (StgVarArg x) -- Delegate tail-calls to schemeT. schemeE d s p e@(StgApp {}) = schemeT d s p e schemeE d s p e@(StgConApp {}) = schemeT d s p e@@ -709,20 +604,7 @@ schemeE d s p (StgCase scrut bndr _ alts)    = doCase d s p scrut bndr alts --- Is this Id a not-necessarily-lifted join point?--- See Note [Not-necessarily-lifted join points], step 1-isNNLJoinPoint :: Id -> Bool-isNNLJoinPoint x = isJoinId x &&-                   Just True /= isLiftedType_maybe (idType x) --- Update an Id's type to take a Void# argument.--- Precondition: the Id is a not-necessarily-lifted join point.--- See Note [Not-necessarily-lifted join points]-protectNNLJoinPointId :: Id -> Id-protectNNLJoinPointId x-  = ASSERT( isNNLJoinPoint x )-    updateIdTypeButNotMult (unboxedUnitTy `mkVisFunTyMany`) x- {-    Ticked Expressions    ------------------@@ -730,65 +612,6 @@   The idea is that the "breakpoint<n,fvs> E" is really just an annotation on   the code. When we find such a thing, we pull out the useful information,   and then compile the code as if it was just the expression E.--Note [Not-necessarily-lifted join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A join point variable is essentially a goto-label: it is, for example,-never used as an argument to another function, and it is called only-in tail position. See Note [Join points] and Note [Invariants on join points],-both in GHC.Core. Because join points do not compile to true, red-blooded-variables (with, e.g., registers allocated to them), they are allowed-to be levity-polymorphic. (See invariant #6 in Note [Invariants on join points]-in GHC.Core.)--However, in this byte-code generator, join points *are* treated just as-ordinary variables. There is no check whether a binding is for a join point-or not; they are all treated uniformly. (Perhaps there is a missed optimization-opportunity here, but that is beyond the scope of my (Richard E's) Thursday.)--We thus must have *some* strategy for dealing with levity-polymorphic and-unlifted join points. Levity-polymorphic variables are generally not allowed-(though levity-polymorphic join points *are*; see Note [Invariants on join points]-in GHC.Core, point 6), and we don't wish to evaluate unlifted join points eagerly.-The questionable join points are *not-necessarily-lifted join points*-(NNLJPs). (Not having such a strategy led to #16509, which panicked in the-isUnliftedType check in the AnnVar case of schemeE.) Here is the strategy:--1. Detect NNLJPs. This is done in isNNLJoinPoint.--2. When binding an NNLJP, add a `\ (_ :: (# #)) ->` to its RHS, and modify the-   type to tack on a `(# #) ->`.-   Note that functions are never levity-polymorphic, so this transformation-   changes an NNLJP to a non-levity-polymorphic join point. This is done-   in bcPrepSingleBind.--3. At an occurrence of an NNLJP, add an application to void# (called voidPrimId),-   being careful to note the new type of the NNLJP. This is done in the AnnVar-   case of schemeE, with help from protectNNLJoinPointId.--Here is an example. Suppose we have--  f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T).-      join j :: a-           j = error @r @a "bloop"-      in case x of-           A -> j-           B -> j-           C -> error @r @a "blurp"--Our plan is to behave is if the code was--  f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T).-      let j :: (Void# -> a)-          j = \ _ -> error @r @a "bloop"-      in case x of-           A -> j void#-           B -> j void#-           C -> error @r @a "blurp"--It's a bit hacky, but it works well in practice and is local. I suspect the-Right Fix is to take advantage of join points as goto-labels.- -}  -- Compile code to do a tail call.  Specifically, push the fn,@@ -836,7 +659,7 @@    = unsupportedCConvException     -- Case 2: Unboxed tuple-schemeT d s p (StgConApp con _ext args _tys)+schemeT d s p (StgConApp con _cn args _tys)    | isUnboxedTupleDataCon con || isUnboxedSumDataCon con    = returnUnboxedTuple d s p args @@ -845,10 +668,7 @@    = do alloc_con <- mkConAppCode d s p con args         platform <- profilePlatform <$> getProfile         return (alloc_con         `appOL`-                mkSlideW 1 (bytesToWords platform $ d - s) `snocOL`-                if isUnliftedTypeKind (tyConResKind (dataConTyCon con))-                then RETURN_UNLIFTED P-                else ENTER)+                mkSlideW 1 (bytesToWords platform $ d - s) `snocOL` RETURN)     -- Case 4: Tail call of function schemeT d s p (StgApp fn args)@@ -911,15 +731,12 @@    do_pushes init_d args (map (atomRep platform) args)   where   do_pushes !d [] reps = do-        ASSERT( null reps ) return ()+        assert (null reps) return ()         (push_fn, sz) <- pushAtom d p (StgVarArg fn)         platform <- profilePlatform <$> getProfile-        ASSERT( sz == wordSize platform ) return ()+        assert (sz == wordSize platform) return ()         let slide = mkSlideB platform (d - init_d + wordSize platform) (init_d - s)-            enter = if isUnliftedType (idType fn)-                    then RETURN_UNLIFTED P-                    else ENTER-        return (push_fn `appOL` (slide `appOL` unitOL enter))+        return (push_fn `appOL` (slide `appOL` unitOL ENTER))   do_pushes !d args reps = do       let (push_apply, n, rest_of_reps) = findPushSeq reps           (these_args, rest_of_args) = splitAt n args@@ -959,6 +776,9 @@   = (PUSH_APPLY_D, 1, rest) findPushSeq (L: rest)   = (PUSH_APPLY_L, 1, rest)+findPushSeq argReps+  | any (`elem` [V16, V32, V64]) argReps+  = sorry "SIMD vector operations are not available in GHCi" findPushSeq _   = panic "GHC.StgToByteCode.findPushSeq" @@ -992,6 +812,8 @@           (isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty) &&           length non_void_arg_reps > 1 +        ubx_frame = not ubx_tuple_frame && not (usePlainReturn bndr_ty)+         non_void_arg_reps = non_void (typeArgReps platform bndr_ty)          profiling@@ -1013,12 +835,11 @@                           not ubx_tuple_frame = 2 * wordSize platform                         | otherwise = 0 -        -- An unlifted value gets an extra info table pushed on top-        -- when it is returned.+        -- The size of the return frame info table pointer if one exists         unlifted_itbl_size_b :: StackDepth-        unlifted_itbl_size_b | ubx_tuple_frame              = 3 * wordSize platform-                             | not (isUnliftedType bndr_ty) = 0-                             | otherwise                    = wordSize platform+        unlifted_itbl_size_b | ubx_tuple_frame = wordSize platform+                             | ubx_frame       = wordSize platform+                             | otherwise       = 0          (bndr_size, tuple_info, args_offsets)            | ubx_tuple_frame =@@ -1052,11 +873,12 @@         isAlgCase = isAlgType bndr_ty          -- given an alt, return a discr and code for it.-        codeAlt (DEFAULT, _, rhs)+        codeAlt :: CgStgAlt -> BcM (Discr, BCInstrList)+        codeAlt GenStgAlt{alt_con=DEFAULT,alt_bndrs=_,alt_rhs=rhs}            = do rhs_code <- schemeE d_alts s p_alts rhs                 return (NoDiscr, rhs_code) -        codeAlt alt@(_, bndrs, rhs)+        codeAlt alt@GenStgAlt{alt_con=_, alt_bndrs=bndrs, alt_rhs=rhs}            -- primitive or nullary constructor alt: no need to UNPACK            | null real_bndrs = do                 rhs_code <- schemeE d_alts s p_alts rhs@@ -1099,37 +921,33 @@                         | (NonVoid arg, offset) <- args_offsets ]                         p_alts -                 -- unlifted datatypes have an infotable word on top-                 unpack = if isUnliftedType bndr_ty-                          then PUSH_L 1 `consOL`-                               UNPACK (trunc16W size) `consOL`-                               unitOL (SLIDE (trunc16W size) 1)-                          else unitOL (UNPACK (trunc16W size))              in do-             MASSERT(isAlgCase)+             massert isAlgCase              rhs_code <- schemeE stack_bot s p' rhs-             return (my_discr alt, unpack `appOL` rhs_code)+             return (my_discr alt,+                     unitOL (UNPACK (trunc16W size)) `appOL` rhs_code)            where              real_bndrs = filterOut isTyVar bndrs -        my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-}-        my_discr (DataAlt dc, _, _)-           | isUnboxedTupleDataCon dc || isUnboxedSumDataCon dc-           = NoDiscr-           | otherwise-           = DiscrP (fromIntegral (dataConTag dc - fIRST_TAG))-        my_discr (LitAlt l, _, _)-           = case l of LitNumber LitNumInt i  -> DiscrI (fromInteger i)-                       LitNumber LitNumWord w -> DiscrW (fromInteger w)-                       LitFloat r   -> DiscrF (fromRational r)-                       LitDouble r  -> DiscrD (fromRational r)-                       LitChar i    -> DiscrI (ord i)-                       _ -> pprPanic "schemeE(StgCase).my_discr" (ppr l)+        my_discr alt = case alt_con alt of+            DEFAULT    -> NoDiscr {-shouldn't really happen-}+            DataAlt dc+              | isUnboxedTupleDataCon dc || isUnboxedSumDataCon dc+              -> NoDiscr+              | otherwise+              -> DiscrP (fromIntegral (dataConTag dc - fIRST_TAG))+            LitAlt l -> case l of+              LitNumber LitNumInt i  -> DiscrI (fromInteger i)+              LitNumber LitNumWord w -> DiscrW (fromInteger w)+              LitFloat r             -> DiscrF (fromRational r)+              LitDouble r            -> DiscrD (fromRational r)+              LitChar i              -> DiscrI (ord i)+              _ -> pprPanic "schemeE(StgCase).my_discr" (ppr l)          maybe_ncons            | not isAlgCase = Nothing            | otherwise-           = case [dc | (DataAlt dc, _, _) <- alts] of+           = case [dc | DataAlt dc <- alt_con <$> alts] of                 []     -> Nothing                 (dc:_) -> Just (tyConFamilySize (dataConTyCon dc)) @@ -1178,8 +996,12 @@         bitmap = intsToReverseBitmap platform bitmap_size'{-size-} pointers       alt_stuff <- mapM codeAlt alts-     alt_final <- mkMultiBranch maybe_ncons alt_stuff+     alt_final0 <- mkMultiBranch maybe_ncons alt_stuff +     let alt_final+           | ubx_tuple_frame    = mkSlideW 0 2 `mappend` alt_final0+           | otherwise          = alt_final0+      let          alt_bco_name = getName bndr          alt_bco = mkProtoBCO platform alt_bco_name alt_final (Left alts)@@ -1197,7 +1019,7 @@               return (PUSH_ALTS_TUPLE alt_bco' tuple_info tuple_bco                       `consOL` scrut_code)        else let push_alts-                  | not (isUnliftedType bndr_ty)+                  | not ubx_frame                   = PUSH_ALTS alt_bco'                   | otherwise                   = let unlifted_rep =@@ -1275,9 +1097,21 @@                   (orig_stk_params ++ map get_byte_off new_stk_params)      ) +{-+  We use the plain return convention (ENTER/PUSH_ALTS) for+  lifted types and unlifted algebraic types.++  Other types use PUSH_ALTS_UNLIFTED/PUSH_ALTS_TUPLE which expect+  additional data on the stack.+ -}+usePlainReturn :: Type -> Bool+usePlainReturn t+  | isUnboxedTupleType t || isUnboxedSumType t = False+  | otherwise = typePrimRep t == [LiftedRep] ||+                (typePrimRep t == [UnliftedRep] && isAlgType t)+ {- Note [unboxed tuple bytecodes and tuple_BCO] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-   We have the bytecode instructions RETURN_TUPLE and PUSH_ALTS_TUPLE to   return and receive arbitrary unboxed tuples, respectively. These   instructions use the helper data tuple_BCO and tuple_info.@@ -1617,7 +1451,9 @@      AddrRep     -> FFIPointer      FloatRep    -> FFIFloat      DoubleRep   -> FFIDouble-     _           -> panic "primRepToFFIType"+     LiftedRep   -> FFIPointer+     UnliftedRep -> FFIPointer+     _           -> pprPanic "primRepToFFIType" (ppr r)   where     (signed_word, unsigned_word) = case platformWordSize platform of        PW4 -> (FFISInt32, FFIUInt32)@@ -1628,19 +1464,21 @@ mkDummyLiteral :: Platform -> PrimRep -> Literal mkDummyLiteral platform pr    = case pr of-        IntRep    -> mkLitInt  platform 0-        WordRep   -> mkLitWord platform 0-        Int8Rep   -> mkLitInt8 0-        Word8Rep  -> mkLitWord8 0-        Int16Rep  -> mkLitInt16 0-        Word16Rep -> mkLitWord16 0-        Int32Rep  -> mkLitInt32 0-        Word32Rep -> mkLitWord32 0-        Int64Rep  -> mkLitInt64 0-        Word64Rep -> mkLitWord64 0-        AddrRep   -> LitNullAddr-        DoubleRep -> LitDouble 0-        FloatRep  -> LitFloat 0+        IntRep      -> mkLitInt  platform 0+        WordRep     -> mkLitWord platform 0+        Int8Rep     -> mkLitInt8 0+        Word8Rep    -> mkLitWord8 0+        Int16Rep    -> mkLitInt16 0+        Word16Rep   -> mkLitWord16 0+        Int32Rep    -> mkLitInt32 0+        Word32Rep   -> mkLitWord32 0+        Int64Rep    -> mkLitInt64 0+        Word64Rep   -> mkLitWord64 0+        AddrRep     -> LitNullAddr+        DoubleRep   -> LitDouble 0+        FloatRep    -> LitFloat 0+        LiftedRep   -> LitNullAddr+        UnliftedRep -> LitNullAddr         _         -> pprPanic "mkDummyLiteral" (ppr pr)  @@ -1671,9 +1509,7 @@        case r_reps of          []            -> panic "empty typePrimRepArgs"          [VoidRep]     -> Nothing-         [rep]-           | isGcPtrRep rep -> blargh-           | otherwise      -> Just rep+         [rep]         -> Just rep                   -- if it was, it would be impossible to create a                  -- valid return value placeholder on the stack@@ -1742,7 +1578,7 @@     -> BcM BCInstrList -- See Note [Implementing tagToEnum#] implement_tagToId d s p arg names-  = ASSERT( notNull names )+  = assert (notNull names) $     do (push_arg, arg_bytes) <- pushAtom d p (StgVarArg arg)        labels <- getLabelsBc (genericLength names)        label_fail <- getLabelBc@@ -1835,7 +1671,7 @@               fromIntegral $ ptrToWordPtr $ fromRemotePtr ptr             Nothing -> do                 let sz = idSizeCon platform var-                MASSERT( sz == wordSize platform )+                massert (sz == wordSize platform)                 return (unitOL (PUSH_G (getName var)), sz)  @@ -1889,11 +1725,9 @@           LitNumWord32  -> code Word32Rep           LitNumInt64   -> code Int64Rep           LitNumWord64  -> code Word64Rep-          -- No LitInteger's or LitNatural's should be left by the time this is-          -- called. CorePrep should have converted them all to a real core-          -- representation.-          LitNumInteger -> panic "pushAtom: LitInteger"-          LitNumNatural -> panic "pushAtom: LitNatural"+          -- No LitNumBigNat should be left by the time this is called. CorePrep+          -- should have converted them all to a real core representation.+          LitNumBigNat  -> panic "pushAtom: LitNumBigNat"  -- | Push an atom for constructor (i.e., PACK instruction) onto the stack. -- This is slightly different to @pushAtom@ due to the fact that we allow@@ -1957,7 +1791,9 @@             | otherwise             = return (testEQ (fst val) lbl_default `consOL` snd val) -            -- Note [CASEFAIL] It may be that this case has no default+            -- Note [CASEFAIL]+            -- ~~~~~~~~~~~~~~~+            -- It may be that this case has no default             -- branch, but the alternatives are not exhaustive - this             -- happens for GADT cases for example, where the types             -- prove that certain branches are impossible.  We could@@ -2160,7 +1996,6 @@ data BcM_State    = BcM_State         { bcm_hsc_env :: HscEnv-        , uniqSupply  :: UniqSupply      -- for generating fresh variable names         , thisModule  :: Module          -- current module (for breakpoints)         , nextlabel   :: Word32          -- for generating local labels         , ffis        :: [FFIInfo]       -- ffi info blocks, to free later@@ -2178,12 +2013,12 @@   x <- io   return (st, x) -runBc :: HscEnv -> UniqSupply -> Module -> Maybe ModBreaks+runBc :: HscEnv -> Module -> Maybe ModBreaks       -> IdEnv (RemotePtr ())       -> BcM r       -> IO (BcM_State, r)-runBc hsc_env us this_mod modBreaks topStrings (BcM m)-   = m (BcM_State hsc_env us this_mod 0 [] modBreaks IntMap.empty topStrings)+runBc hsc_env this_mod modBreaks topStrings (BcM m)+   = m (BcM_State hsc_env this_mod 0 [] modBreaks IntMap.empty topStrings)  thenBc :: BcM a -> (a -> BcM b) -> BcM b thenBc (BcM expr) cont = BcM $ \st0 -> do@@ -2249,22 +2084,11 @@ newBreakInfo ix info = BcM $ \st ->   return (st{breakInfo = IntMap.insert ix info (breakInfo st)}, ()) -newUnique :: BcM Unique-newUnique = BcM $-   \st -> case takeUniqFromSupply (uniqSupply st) of-             (uniq, us) -> let newState = st { uniqSupply = us }-                           in  return (newState, uniq)- getCurrentModule :: BcM Module getCurrentModule = BcM $ \st -> return (st, thisModule st)  getTopStrings :: BcM (IdEnv (RemotePtr ())) getTopStrings = BcM $ \st -> return (st, topStrings st)--newId :: Type -> BcM Id-newId ty = do-    uniq <- newUnique-    return $ mkSysLocal tickFS uniq Many ty  tickFS :: FastString tickFS = fsLit "ticked"
compiler/GHC/StgToCmm.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE DataKinds #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-}@@ -13,14 +13,9 @@  module GHC.StgToCmm ( codeGen ) where -#include "GhclibHsVersions.h"- import GHC.Prelude as Prelude -import GHC.Driver.Backend-import GHC.Driver.Session--import GHC.StgToCmm.Prof (initInfoTableProv, initCostCentres, ldvEnter)+import GHC.StgToCmm.Prof (initCostCentres, ldvEnter) import GHC.StgToCmm.Monad import GHC.StgToCmm.Env import GHC.StgToCmm.Bind@@ -28,6 +23,7 @@ import GHC.StgToCmm.Layout import GHC.StgToCmm.Utils import GHC.StgToCmm.Closure+import GHC.StgToCmm.Config import GHC.StgToCmm.Hpc import GHC.StgToCmm.Ticky import GHC.StgToCmm.Types (ModuleLFInfos)@@ -49,7 +45,6 @@ import GHC.Types.Var.Set ( isEmptyDVarSet ) import GHC.Types.Unique.FM import GHC.Types.Name.Env-import GHC.Types.ForeignStubs  import GHC.Core.DataCon import GHC.Core.TyCon@@ -59,7 +54,7 @@  import GHC.Utils.Error import GHC.Utils.Outputable-import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Logger  import GHC.Utils.TmpFs@@ -72,50 +67,38 @@ import GHC.Utils.Misc import System.IO.Unsafe import qualified Data.ByteString as BS-import Data.Maybe import Data.IORef--data CodeGenState = CodeGenState { codegen_used_info :: !(OrdList CmmInfoTable)-                                 , codegen_state :: !CgState }-+import GHC.Utils.Panic (assertPpr)  codeGen :: Logger         -> TmpFs-        -> DynFlags-        -> Module+        -> StgToCmmConfig         -> InfoTableProvMap         -> [TyCon]         -> CollectedCCs                -- (Local/global) cost-centres needing declaring/registering.         -> [CgStgTopBinding]           -- Bindings to convert         -> HpcInfo-        -> Stream IO CmmGroup (CStub, ModuleLFInfos)       -- Output as a stream, so codegen can+        -> Stream IO CmmGroup ModuleLFInfos       -- Output as a stream, so codegen can                                        -- be interleaved with output -codeGen logger tmpfs dflags this_mod ip_map@(InfoTableProvMap (UniqMap denv) _) data_tycons+codeGen logger tmpfs cfg (InfoTableProvMap (UniqMap denv) _ _) data_tycons         cost_centre_info stg_binds hpc_info   = do  {     -- cg: run the code generator, and yield the resulting CmmGroup               -- Using an IORef to store the state is a bit crude, but otherwise               -- we would need to add a state monad layer which regresses               -- allocations by 0.5-2%.-        ; cgref <- liftIO $ initC >>= \s -> newIORef (CodeGenState mempty s)+        ; cgref <- liftIO $ initC >>= \s -> newIORef s         ; let cg :: FCode a -> Stream IO CmmGroup a               cg fcode = do-                (a, cmm) <- liftIO . withTimingSilent logger dflags (text "STG -> Cmm") (`seq` ()) $ do-                         CodeGenState ts st <- readIORef cgref-                         let (a,st') = runC dflags this_mod st (getCmm fcode)+                (a, cmm) <- liftIO . withTimingSilent logger (text "STG -> Cmm") (`seq` ()) $ do+                         st <- readIORef cgref+                         let fstate = initFCodeState $ stgToCmmPlatform cfg+                         let (a,st') = runC cfg fstate st (getCmm fcode)                           -- NB. stub-out cgs_tops and cgs_stmts.  This fixes                          -- a big space leak.  DO NOT REMOVE!                          -- This is observed by the #3294 test-                         let !used_info-                                | gopt Opt_InfoTableMap dflags = toOL (mapMaybe topInfoTable (snd a)) `mappend` ts-                                | otherwise = mempty-                         writeIORef cgref $!-                                    CodeGenState used_info-                                      (st'{ cgs_tops = nilOL,-                                            cgs_stmts = mkNop-                                          })-+                         writeIORef cgref $! (st'{ cgs_tops = nilOL, cgs_stmts = mkNop })                          return a                 yield cmm                 return a@@ -124,9 +107,9 @@                -- FIRST.  This is because when -split-objs is on we need to                -- combine this block with its initialisation routines; see                -- Note [pipeline-split-init].-        ; cg (mkModuleInit cost_centre_info this_mod hpc_info)+        ; cg (mkModuleInit cost_centre_info (stgToCmmThisModule cfg) hpc_info) -        ; mapM_ (cg . cgTopBinding logger tmpfs dflags) stg_binds+        ; mapM_ (cg . cgTopBinding logger tmpfs cfg) stg_binds                 -- Put datatype_stuff after code_stuff, because the                 -- datatype closure table (for enumeration types) to                 -- (say) PrelBase_True_closure, which is defined in@@ -143,13 +126,10 @@          -- Emit special info tables for everything used in this module         -- This will only do something if  `-fdistinct-info-tables` is turned on.-        ; mapM_ (\(dc, ns) -> forM_ ns $ \(k, _ss) -> cg (cgDataCon (UsageSite this_mod k) dc)) (nonDetEltsUFM denv)+        ; mapM_ (\(dc, ns) -> forM_ ns $ \(k, _ss) -> cg (cgDataCon (UsageSite (stgToCmmThisModule cfg) k) dc)) (nonDetEltsUFM denv)          ; final_state <- liftIO (readIORef cgref)-        ; let cg_id_infos = cgs_binds . codegen_state $ final_state-              used_info = fromOL . codegen_used_info $ final_state--        ; !foreign_stub <- cg (initInfoTableProv used_info ip_map this_mod)+        ; let cg_id_infos = cgs_binds final_state            -- See Note [Conveying CAF-info and LFInfo between modules] in           -- GHC.StgToCmm.Types@@ -159,12 +139,12 @@                   !lf = cg_lf info                !generatedInfo-                | gopt Opt_OmitInterfacePragmas dflags+                | stgToCmmOmitIfPragmas cfg                 = emptyNameEnv                 | otherwise-                = mkNameEnv (Prelude.map extractInfo (eltsUFM cg_id_infos))+                = mkNameEnv (Prelude.map extractInfo (nonDetEltsUFM cg_id_infos)) -        ; return (foreign_stub, generatedInfo)+        ; return generatedInfo         }  ---------------------------------------------------------------@@ -181,17 +161,17 @@ style, with the increasing static environment being plumbed as a state variable. -} -cgTopBinding :: Logger -> TmpFs -> DynFlags -> CgStgTopBinding -> FCode ()-cgTopBinding logger tmpfs dflags = \case+cgTopBinding :: Logger -> TmpFs -> StgToCmmConfig -> CgStgTopBinding -> FCode ()+cgTopBinding logger tmpfs cfg = \case     StgTopLifted (StgNonRec id rhs) -> do-        let (info, fcode) = cgTopRhs dflags NonRecursive id rhs+        let (info, fcode) = cgTopRhs cfg NonRecursive id rhs         fcode         addBindC info      StgTopLifted (StgRec pairs) -> do         let (bndrs, rhss) = unzip pairs         let pairs' = zip bndrs rhss-            r = unzipWith (cgTopRhs dflags Recursive) pairs'+            r = unzipWith (cgTopRhs cfg Recursive) pairs'             (infos, fcodes) = unzip r         addBindsC infos         sequence_ fcodes@@ -201,31 +181,31 @@         -- emit either a CmmString literal or dump the string in a file and emit a         -- CmmFileEmbed literal.         -- See Note [Embedding large binary blobs] in GHC.CmmToAsm.Ppr-        let isNCG    = backend dflags == NCG-            isSmall  = fromIntegral (BS.length str) <= binBlobThreshold dflags-            asString = binBlobThreshold dflags == 0 || isSmall+        let asString = case stgToCmmBinBlobThresh cfg of+              Just bin_blob_threshold -> fromIntegral (BS.length str) <= bin_blob_threshold+              Nothing                -> True -            (lit,decl) = if not isNCG || asString+            (lit,decl) = if asString               then mkByteStringCLit label str               else mkFileEmbedLit label $ unsafePerformIO $ do-                     bFile <- newTempName logger tmpfs dflags TFL_CurrentModule ".dat"+                     bFile <- newTempName logger tmpfs (stgToCmmTmpDir cfg) TFL_CurrentModule ".dat"                      BS.writeFile bFile str                      return bFile         emitDecl decl-        addBindC (litIdInfo (targetPlatform dflags) id mkLFStringLit lit)+        addBindC (litIdInfo (stgToCmmPlatform cfg) id mkLFStringLit lit)  -cgTopRhs :: DynFlags -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ())+cgTopRhs :: StgToCmmConfig -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ())         -- The Id is passed along for setting up a binding... -cgTopRhs dflags _rec bndr (StgRhsCon _cc con mn _ts args)-  = cgTopRhsCon dflags bndr con mn (assertNonVoidStgArgs args)+cgTopRhs cfg _rec bndr (StgRhsCon _cc con mn _ts args)+  = cgTopRhsCon cfg bndr con mn (assertNonVoidStgArgs args)       -- con args are always non-void,       -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise -cgTopRhs dflags rec bndr (StgRhsClosure fvs cc upd_flag args body)-  = ASSERT(isEmptyDVarSet fvs)    -- There should be no free variables-    cgTopRhsClosure (targetPlatform dflags) rec bndr cc upd_flag args body+cgTopRhs cfg rec bndr (StgRhsClosure fvs cc upd_flag args body)+  = assertPpr (isEmptyDVarSet fvs) (text "fvs:" <> ppr fvs) $   -- There should be no free variables+    cgTopRhsClosure (stgToCmmPlatform cfg) rec bndr cc upd_flag args body   ---------------------------------------------------------------@@ -252,8 +232,8 @@ cgEnumerationTyCon :: TyCon -> FCode () cgEnumerationTyCon tycon   = do platform <- getPlatform-       emitRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs)-             [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs)+       emitRODataLits (mkClosureTableLabel (tyConName tycon) NoCafRefs)+             [ CmmLabelOff (mkClosureLabel (dataConName con) NoCafRefs)                            (tagForCon platform con)              | con <- tyConDataCons tycon] @@ -262,7 +242,7 @@ -- Generate the entry code, info tables, and (for niladic constructor) -- the static closure, for a constructor. cgDataCon mn data_con-  = do  { MASSERT( not (isUnboxedTupleDataCon data_con || isUnboxedSumDataCon data_con) )+  = do  { massert (not (isUnboxedTupleDataCon data_con || isUnboxedSumDataCon data_con))         ; profile <- getProfile         ; platform <- getPlatform         ; let
compiler/GHC/StgToCmm/ArgRep.hs view
@@ -52,6 +52,7 @@             | V16 -- 16-byte (128-bit) vectors of Float/Double/Int8/Word32/etc.             | V32 -- 32-byte (256-bit) vectors of Float/Double/Int8/Word32/etc.             | V64 -- 64-byte (512-bit) vectors of Float/Double/Int8/Word32/etc.+            deriving Eq instance Outputable ArgRep where ppr = text . argRepString  argRepString :: ArgRep -> String@@ -120,11 +121,11 @@ --  * GHC.StgToCmm.Layout.stdPattern maybe to some degree? -- --  * the RTS_RET(stg_ap_*) and RTS_FUN_DECL(stg_ap_*_fast)---  declarations in includes/stg/MiscClosures.h+--  declarations in rts/include/stg/MiscClosures.h -----  * the SLOW_CALL_*_ctr declarations in includes/stg/Ticky.h,+--  * the SLOW_CALL_*_ctr declarations in rts/include/stg/Ticky.h, -----  * the TICK_SLOW_CALL_*() #defines in includes/Cmm.h,+--  * the TICK_SLOW_CALL_*() #defines in rts/include/Cmm.h, -- --  * the PR_CTR(SLOW_CALL_*_ctr) calls in rts/Ticky.c, --
compiler/GHC/StgToCmm/Bind.hs view
@@ -15,9 +15,16 @@  import GHC.Prelude hiding ((<*>)) +import GHC.Core          ( AltCon(..) )+import GHC.Runtime.Heap.Layout+import GHC.Unit.Module++import GHC.Stg.Syntax+ import GHC.Platform import GHC.Platform.Profile +import GHC.StgToCmm.Config import GHC.StgToCmm.Expr import GHC.StgToCmm.Monad import GHC.StgToCmm.Env@@ -25,6 +32,7 @@ import GHC.StgToCmm.Heap import GHC.StgToCmm.Prof (ldvEnterClosure, enterCostCentreFun, enterCostCentreThunk,                    initUpdFrameProf)+import GHC.StgToCmm.TagCheck import GHC.StgToCmm.Ticky import GHC.StgToCmm.Layout import GHC.StgToCmm.Utils@@ -32,29 +40,27 @@ import GHC.StgToCmm.Foreign    (emitPrimCall)  import GHC.Cmm.Graph-import GHC.Core          ( AltCon(..) ) import GHC.Cmm.BlockId-import GHC.Runtime.Heap.Layout import GHC.Cmm import GHC.Cmm.Info import GHC.Cmm.Utils import GHC.Cmm.CLabel-import GHC.Stg.Syntax++import GHC.Stg.Utils import GHC.Types.CostCentre import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Name-import GHC.Unit.Module-import GHC.Data.List.SetOps-import GHC.Utils.Misc import GHC.Types.Var.Set import GHC.Types.Basic import GHC.Types.Tickish ( tickishIsCode )++import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic+ import GHC.Data.FastString-import GHC.Driver.Session-import GHC.Driver.Ppr+import GHC.Data.List.SetOps  import Control.Monad @@ -75,7 +81,7 @@                 -> (CgIdInfo, FCode ())  cgTopRhsClosure platform rec id ccs upd_flag args body =-  let closure_label = mkLocalClosureLabel (idName id) (idCafInfo id)+  let closure_label = mkClosureLabel (idName id) (idCafInfo id)       cg_id_info    = litIdInfo platform id lf_info (CmmLabel closure_label)       lf_info       = mkClosureLFInfo platform id TopLevel [] upd_flag args   in (cg_id_info, gen_code lf_info closure_label)@@ -86,7 +92,7 @@   -- shortcutting the whole process, and generating a lot less code   -- (#7308). Eventually the IND_STATIC closure will be eliminated   -- by assembly '.equiv' directives, where possible (#15155).-  -- See note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel".+  -- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel".   --   -- Note: we omit the optimisation when this binding is part of a   -- recursive group, because the optimisation would inhibit the black@@ -101,10 +107,9 @@    gen_code lf_info _closure_label    = do { profile <- getProfile-        ; dflags <- getDynFlags         ; let name = idName id         ; mod_name <- getModuleName-        ; let descr         = closureDescription dflags mod_name name+        ; let descr         = closureDescription mod_name name               closure_info  = mkClosureInfo profile True id lf_info 0 0 descr          -- We don't generate the static closure here, because we might@@ -144,7 +149,7 @@         ;  emit (catAGraphs inits <*> body) }  {- Note [cgBind rec]-+   ~~~~~~~~~~~~~~~~~    Recursive let-bindings are tricky.    Consider the following pseudocode: @@ -207,21 +212,28 @@                )  cgRhs id (StgRhsCon cc con mn _ts args)-  = withNewTickyCounterCon (idName id) con $+  = withNewTickyCounterCon id con mn $     buildDynCon id mn True cc con (assertNonVoidStgArgs args)       -- con args are always non-void,       -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise  {- See Note [GC recovery] in "GHC.StgToCmm.Closure" -} cgRhs id (StgRhsClosure fvs cc upd_flag args body)-  = do profile <- getProfile-       mkRhsClosure profile id cc (nonVoidIds (dVarSetElems fvs)) upd_flag args body+  = do+    checkFunctionArgTags (text "TagCheck Failed: Rhs of" <> ppr id) id args+    profile <- getProfile+    check_tags <- stgToCmmDoTagCheck <$> getStgToCmmConfig+    use_std_ap_thunk <- stgToCmmTickyAP <$> getStgToCmmConfig+    mkRhsClosure profile use_std_ap_thunk check_tags id cc (nonVoidIds (dVarSetElems fvs)) upd_flag args body  ------------------------------------------------------------------------ --              Non-constructor right hand sides ------------------------------------------------------------------------ -mkRhsClosure :: Profile -> Id -> CostCentreStack+mkRhsClosure :: Profile+             -> Bool                            -- Omit AP Thunks to improve profiling+             -> Bool                            -- Lint tag inference checks+             -> Id -> CostCentreStack              -> [NonVoid Id]                    -- Free vars              -> UpdateFlag              -> [Id]                            -- Args@@ -263,8 +275,8 @@  -} ----------- Note [Selectors] -------------------mkRhsClosure    profile bndr _cc+---------- See Note [Selectors] ------------------+mkRhsClosure    profile _ _check_tags bndr _cc                 [NonVoid the_fv]                -- Just one free var                 upd_flag                -- Updatable thunk                 []                      -- A thunk@@ -273,7 +285,9 @@   , StgCase (StgApp scrutinee [{-no args-}])          _   -- ignore bndr          (AlgAlt _)-         [(DataAlt _, params, sel_expr)] <- strip expr+         [GenStgAlt{ alt_con   = DataAlt _+                   , alt_bndrs = params+                   , alt_rhs   = sel_expr}] <- strip expr   , StgApp selectee [{-no args-}] <- strip sel_expr   , the_fv == scrutinee                -- Scrutinee is the only free variable @@ -285,7 +299,7 @@   , let offset_into_int = bytesToWordsRoundUp (profilePlatform profile) the_offset                           - fixedHdrSizeW profile   , offset_into_int <= pc_MAX_SPEC_SELECTEE_SIZE (profileConstants profile) -- Offset is small enough-  = -- NOT TRUE: ASSERT(is_single_constructor)+  = -- NOT TRUE: assert (is_single_constructor)     -- The simplifier may have statically determined that the single alternative     -- is the only possible case and eliminated the others, even if there are     -- other constructors in the datatype.  It's still ok to make a selector@@ -296,8 +310,8 @@     let lf_info = mkSelectorLFInfo bndr offset_into_int (isUpdatable upd_flag)     in cgRhsStdThunk bndr lf_info [StgVarArg the_fv] ----------- Note [Ap thunks] -------------------mkRhsClosure    profile bndr _cc+---------- See Note [Ap thunks] ------------------+mkRhsClosure    profile use_std_ap check_tags bndr _cc                 fvs                 upd_flag                 []                      -- No args; a thunk@@ -306,7 +320,8 @@   -- We are looking for an "ApThunk"; see data con ApThunk in GHC.StgToCmm.Closure   -- of form (x1 x2 .... xn), where all the xi are locals (not top-level)   -- So the xi will all be free variables-  | args `lengthIs` (n_fvs-1)  -- This happens only if the fun_id and+  | use_std_ap+  , args `lengthIs` (n_fvs-1)  -- This happens only if the fun_id and                                -- args are all distinct local variables                                -- The "-1" is for fun_id     -- Missed opportunity:   (f x x) is not detected@@ -318,8 +333,8 @@                          -- lose information about this particular                          -- thunk (e.g. its type) (#949)   , idArity fun_id == unknownArity -- don't spoil a known call-           -- Ha! an Ap thunk+  , not check_tags -- See Note [Tag inference debugging]   = cgRhsStdThunk bndr lf_info payload    where@@ -330,7 +345,7 @@     payload = StgVarArg fun_id : args  ---------- Default case -------------------mkRhsClosure profile bndr cc fvs upd_flag args body+mkRhsClosure profile _use_ap _check_tags bndr cc fvs upd_flag args body   = do  { let lf_info = mkClosureLFInfo (profilePlatform profile) bndr NotTopLevel fvs upd_flag args         ; (id_info, reg) <- rhsIdInfo bndr lf_info         ; return (id_info, gen_code lf_info reg) }@@ -351,9 +366,8 @@          -- MAKE CLOSURE INFO FOR THIS CLOSURE         ; mod_name <- getModuleName-        ; dflags <- getDynFlags         ; let   name  = idName bndr-                descr = closureDescription dflags mod_name name+                descr = closureDescription mod_name name                 fv_details :: [(NonVoid Id, ByteOff)]                 header = if isLFThunk lf_info then ThunkHeader else StdHeader                 (tot_wds, ptr_wds, fv_details)@@ -395,19 +409,19 @@        }  where  gen_code reg  -- AHA!  A STANDARD-FORM THUNK-  = withNewTickyCounterStdThunk (lfUpdatable lf_info) (idName bndr) $+  = withNewTickyCounterStdThunk (lfUpdatable lf_info) (bndr) payload $     do   {     -- LAY OUT THE OBJECT     mod_name <- getModuleName-  ; dflags <- getDynFlags-  ; profile <- getProfile-  ; let platform = profilePlatform profile+  ; profile  <- getProfile+  ; platform <- getPlatform+  ; let         header = if isLFThunk lf_info then ThunkHeader else StdHeader         (tot_wds, ptr_wds, payload_w_offsets)             = mkVirtHeapOffsets profile header                 (addArgReps (nonVoidStgArgs payload)) -        descr = closureDescription dflags mod_name (idName bndr)+        descr = closureDescription mod_name (idName bndr)         closure_info = mkClosureInfo profile False       -- Not static                                      bndr lf_info tot_wds ptr_wds                                      descr@@ -467,7 +481,8 @@   = withNewTickyCounterThunk         (isStaticClosure cl_info)         (closureUpdReqd cl_info)-        (closureName cl_info) $+        (closureName cl_info)+        (map fst fv_details) $     emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $       \(_, node, _) -> thunkCode cl_info fv_details cc node body    where@@ -479,7 +494,7 @@         arity = length args     in     -- See Note [OneShotInfo overview] in GHC.Types.Basic.-    withNewTickyCounterFun (isOneShotBndr arg0) (closureName cl_info)+    withNewTickyCounterFun (isOneShotBndr arg0) (closureName cl_info) (map fst fv_details)         nv_args $ do {          ; let@@ -515,6 +530,7 @@                 -- Load free vars out of closure *after*                 -- heap check, to reduce live vars over check                 ; when node_points $ load_fvs node lf_info fv_bindings+                ; checkFunctionArgTags (text "TagCheck failed - Argument to local function:" <> ppr bndr) bndr (map fromNonVoid nv_args)                 ; void $ cgExpr body                 }}} @@ -522,7 +538,6 @@  -- Note [NodeReg clobbered with loopification] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- -- Previously we used to pass nodeReg (aka R1) here. With profiling, upon -- entering a closure, enterFunCCS was called with R1 passed to it. But since R1 -- may get clobbered inside the body of a closure, and since a self-recursive@@ -558,16 +573,18 @@ -- Here, we emit the slow-entry code. mkSlowEntryCode bndr cl_info arg_regs -- function closure is already in `Node'   | Just (_, ArgGen _) <- closureFunInfo cl_info-  = do profile <- getProfile-       platform <- getPlatform+  = do cfg       <- getStgToCmmConfig+       upd_frame <- getUpdFrameOff        let node = idToReg platform (NonVoid bndr)+           profile  = stgToCmmProfile  cfg+           platform = stgToCmmPlatform cfg            slow_lbl = closureSlowEntryLabel  platform cl_info            fast_lbl = closureLocalEntryLabel platform cl_info            -- mkDirectJump does not clobber `Node' containing function closure            jump = mkJump profile NativeNodeCall                                 (mkLblExpr fast_lbl)                                 (map (CmmReg . CmmLocal) (node : arg_regs))-                                (initUpdFrameOff platform)+                                upd_frame        tscope <- getTickScope        emitProcWithConvention Slow Nothing slow_lbl          (node : arg_regs) (jump, tscope)@@ -615,9 +632,10 @@  emitBlackHoleCode :: CmmExpr -> FCode () emitBlackHoleCode node = do-  dflags <- getDynFlags-  profile <- getProfile-  let platform = profilePlatform profile+  cfg <- getStgToCmmConfig+  let profile     = stgToCmmProfile  cfg+      platform    = stgToCmmPlatform cfg+      is_eager_bh = stgToCmmEagerBlackHole cfg    -- Eager blackholing is normally disabled, but can be turned on with   -- -feager-blackholing.  When it is on, we replace the info pointer@@ -637,8 +655,7 @@   -- Note the eager-blackholing check is here rather than in blackHoleOnEntry,   -- because emitBlackHoleCode is called from GHC.Cmm.Parser. -  let  eager_blackholing =  not (profileIsProfiling profile)-                         && gopt Opt_EagerBlackHoling dflags+  let  eager_blackholing =  not (profileIsProfiling profile) && is_eager_bh              -- Profiling needs slop filling (to support LDV              -- profiling), so currently eager blackholing doesn't              -- work with profiling.@@ -663,11 +680,11 @@       then do tickyUpdateFrameOmitted; body       else do           tickyPushUpdateFrame-          dflags <- getDynFlags+          cfg <- getStgToCmmConfig           let-              bh = blackHoleOnEntry closure_info &&-                   not (sccProfilingEnabled dflags) &&-                   gopt Opt_EagerBlackHoling dflags+              bh = blackHoleOnEntry closure_info+                && not (stgToCmmSCCProfiling cfg)+                && stgToCmmEagerBlackHole cfg                lbl | bh        = mkBHUpdInfoLabel                   | otherwise = mkUpdInfoLabel@@ -725,11 +742,12 @@ -- This function returns the address of the black hole, so it can be -- updated with the new value when available. link_caf node = do-  { profile <- getProfile+  { cfg <- getStgToCmmConfig         -- Call the RTS function newCAF, returning the newly-allocated         -- blackhole indirection closure   ; let newCAF_lbl = mkForeignLabel (fsLit "newCAF") Nothing                                     ForeignLabelInExternalPackage IsFunction+  ; let profile  = stgToCmmProfile cfg   ; let platform = profilePlatform profile   ; bh <- newTemp (bWord platform)   ; emitRtsCallGen [(bh,AddrHint)] newCAF_lbl@@ -739,8 +757,9 @@    -- see Note [atomic CAF entry] in rts/sm/Storage.c   ; updfr  <- getUpdFrameOff-  ; ptr_opts <- getPtrOpts-  ; let target = entryCode platform (closureInfoPtr ptr_opts (CmmReg (CmmLocal node)))+  ; let align_check = stgToCmmAlignCheck cfg+  ; let target      = entryCode platform+                        (closureInfoPtr platform align_check (CmmReg (CmmLocal node)))   ; emit =<< mkCmmIfThen       (cmmEqWord platform (CmmReg (CmmLocal bh)) (zeroExpr platform))         -- re-enter the CAF@@ -757,16 +776,11 @@ -- @closureDescription@ from the let binding information.  closureDescription-   :: DynFlags-   -> Module            -- Module+   :: Module            -- Module    -> Name              -- Id of closure binding    -> String         -- Not called for StgRhsCon which have global info tables built in         -- CgConTbls.hs with a description generated from the data constructor-closureDescription dflags mod_name name-  = showSDocDump (initSDocContext dflags defaultDumpStyle) (char '<' <>-                    (if isExternalName name-                      then ppr name -- ppr will include the module name prefix-                      else pprModule mod_name <> char '.' <> ppr name) <>-                    char '>')-   -- showSDocDump, because we want to see the unique on the Name.+closureDescription mod_name name+  = renderWithContext defaultSDocContext+    (char '<' <> pprFullName mod_name name <> char '>')
compiler/GHC/StgToCmm/Closure.hs view
@@ -1,10 +1,9 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} - ----------------------------------------------------------------------------- -- -- Stg to C-- code generation:@@ -35,9 +34,9 @@         isLFThunk, isLFReEntrant, lfUpdatable,          -- * Used by other modules-        CgLoc(..), SelfLoopInfo, CallMethod(..),+        CgLoc(..), CallMethod(..),         nodeMustPointToIt, isKnownFun, funTag, tagForArity,-        CallOpts(..), getCallMethod,+        getCallMethod,          -- * ClosureInfo         ClosureInfo,@@ -66,10 +65,9 @@         cafBlackHoleInfoTable,         indStaticInfoTable,         staticClosureNeedsLink,+        mkClosureInfoTableLabel     ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Platform import GHC.Platform.Profile@@ -80,6 +78,7 @@ import GHC.Cmm.Utils import GHC.Cmm.Ppr.Expr() -- For Outputable instances import GHC.StgToCmm.Types+import GHC.StgToCmm.Sequel  import GHC.Types.CostCentre import GHC.Cmm.BlockId@@ -96,10 +95,13 @@ import GHC.Types.Basic import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Misc  import Data.Coerce (coerce) import qualified Data.ByteString.Char8 as BS8+import GHC.StgToCmm.Config+import GHC.Stg.InferTags.TagSig (isTaggedSig)  ----------------------------------------------------------------------------- --                Data types and synonyms@@ -127,8 +129,6 @@    CmmLoc e    -> text "cmm" <+> pdoc platform e    LneLoc b rs -> text "lne" <+> ppr b <+> ppr rs -type SelfLoopInfo = (Id, BlockId, [LocalReg])- -- used by ticky profiling isKnownFun :: LambdaFormInfo -> Bool isKnownFun LFReEntrant{} = True@@ -152,23 +152,23 @@   ppr (NonVoid a) = ppr a  nonVoidIds :: [Id] -> [NonVoid Id]-nonVoidIds ids = [NonVoid id | id <- ids, not (isVoidTy (idType id))]+nonVoidIds ids = [NonVoid id | id <- ids, not (isZeroBitTy (idType id))]  -- | Used in places where some invariant ensures that all these Ids are -- non-void; e.g. constructor field binders in case expressions. -- See Note [Post-unarisation invariants] in "GHC.Stg.Unarise". assertNonVoidIds :: [Id] -> [NonVoid Id]-assertNonVoidIds ids = ASSERT(not (any (isVoidTy . idType) ids))+assertNonVoidIds ids = assert (not (any (isZeroBitTy . idType) ids)) $                        coerce ids  nonVoidStgArgs :: [StgArg] -> [NonVoid StgArg]-nonVoidStgArgs args = [NonVoid arg | arg <- args, not (isVoidTy (stgArgType arg))]+nonVoidStgArgs args = [NonVoid arg | arg <- args, not (isZeroBitTy (stgArgType arg))]  -- | Used in places where some invariant ensures that all these arguments are -- non-void; e.g. constructor arguments. -- See Note [Post-unarisation invariants] in "GHC.Stg.Unarise". assertNonVoidStgArgs :: [StgArg] -> [NonVoid StgArg]-assertNonVoidStgArgs args = ASSERT(not (any (isVoidTy . stgArgType) args))+assertNonVoidStgArgs args = assert (not (any (isZeroBitTy . stgArgType) args)) $                             coerce args  @@ -209,7 +209,7 @@ mkLFArgument :: Id -> LambdaFormInfo mkLFArgument id   | isUnliftedType ty      = LFUnlifted-  | might_be_a_function ty = LFUnknown True+  | mightBeFunTy ty = LFUnknown True   | otherwise              = LFUnknown False   where     ty = idType id@@ -233,23 +233,11 @@ ------------- mkLFThunk :: Type -> TopLevelFlag -> [Id] -> UpdateFlag -> LambdaFormInfo mkLFThunk thunk_ty top fvs upd_flag-  = ASSERT( not (isUpdatable upd_flag) || not (isUnliftedType thunk_ty) )+  = assert (not (isUpdatable upd_flag) || not (isUnliftedType thunk_ty)) $     LFThunk top (null fvs)             (isUpdatable upd_flag)             NonStandardThunk-            (might_be_a_function thunk_ty)-----------------might_be_a_function :: Type -> Bool--- Return False only if we are *sure* it's a data type--- Look through newtypes etc as much as poss-might_be_a_function ty-  | [LiftedRep] <- typePrimRep ty-  , Just tc <- tyConAppTyCon_maybe (unwrapType ty)-  , isDataTyCon tc-  = False-  | otherwise-  = True+            (mightBeFunTy thunk_ty)  ------------- mkConLFInfo :: DataCon -> LambdaFormInfo@@ -259,13 +247,13 @@ mkSelectorLFInfo :: Id -> Int -> Bool -> LambdaFormInfo mkSelectorLFInfo id offset updatable   = LFThunk NotTopLevel False updatable (SelectorThunk offset)-        (might_be_a_function (idType id))+        (mightBeFunTy (idType id))  ------------- mkApLFInfo :: Id -> UpdateFlag -> Arity -> LambdaFormInfo mkApLFInfo id upd_flag arity   = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity)-        (might_be_a_function (idType id))+        (mightBeFunTy (idType id))  ------------- mkLFImported :: Id -> LambdaFormInfo@@ -479,27 +467,39 @@ (rather than directly) to catch double-entry. -}  data CallMethod-  = EnterIt             -- No args, not a function+  = EnterIt             -- ^ No args, not a function    | JumpToIt BlockId [LocalReg] -- A join point or a header of a local loop    | ReturnIt            -- It's a value (function, unboxed value,                         -- or constructor), so just return it. -  | SlowCall                -- Unknown fun, or known fun with+  | InferedReturnIt     -- A properly tagged value, as determined by tag inference.+                        -- See Note [Tag Inference] and Note [Tag inference passes] in+                        -- GHC.Stg.InferTags.+                        -- It behaves /precisely/ like `ReturnIt`, except that when debugging is+                        -- enabled we emit an extra assertion to check that the returned value is+                        -- properly tagged.  We can use this as a check that tag inference is working+                        -- correctly.+                        -- TODO: SPJ suggested we could combine this with EnterIt, but for now I decided+                        -- not to do so.++  | SlowCall            -- Unknown fun, or known fun with                         -- too few args.    | DirectEntry         -- Jump directly, with args in regs         CLabel          --   The code label         RepArity        --   Its arity -data CallOpts = CallOpts-   { co_profile       :: !Profile   -- ^ Platform profile-   , co_loopification :: !Bool      -- ^ Loopification enabled (cf @-floopification@)-   , co_ticky         :: !Bool      -- ^ Ticky profiling enabled (cf @-ticky@)-   }+instance Outputable CallMethod where+  ppr (EnterIt) = text "Enter"+  ppr (JumpToIt {}) = text "JumpToIt"+  ppr (ReturnIt ) = text "ReturnIt"+  ppr (InferedReturnIt) = text "InferedReturnIt"+  ppr (SlowCall ) = text "SlowCall"+  ppr (DirectEntry {}) = text "DirectEntry" -getCallMethod :: CallOpts+getCallMethod :: StgToCmmConfig               -> Name           -- Function being applied               -> Id             -- Function Id used to chech if it can refer to                                 -- CAF's and whether the function is tail-calling@@ -512,12 +512,11 @@                                 -- tail calls using the same data constructor,                                 -- JumpToIt. This saves us one case branch in                                 -- cgIdApp-              -> Maybe SelfLoopInfo -- can we perform a self-recursive tail call?+              -> Maybe SelfLoopInfo -- can we perform a self-recursive tail-call               -> CallMethod -getCallMethod opts _ id _ n_args v_args _cg_loc-              (Just (self_loop_id, block_id, args))-  | co_loopification opts+getCallMethod cfg _ id _  n_args v_args _cg_loc (Just (self_loop_id, block_id, args))+  | stgToCmmLoopification cfg   , id == self_loop_id   , args `lengthIs` (n_args - v_args)   -- If these patterns match then we know that:@@ -528,31 +527,36 @@   -- self-recursive tail calls] in GHC.StgToCmm.Expr for more details   = JumpToIt block_id args -getCallMethod opts name id (LFReEntrant _ arity _ _) n_args _v_args _cg_loc-              _self_loop_info+getCallMethod cfg name id (LFReEntrant _ arity _ _) n_args _v_args _cg_loc _self_loop_info   | n_args == 0 -- No args at all-  && not (profileIsProfiling (co_profile opts))+  && not (profileIsProfiling (stgToCmmProfile cfg))      -- See Note [Evaluating functions with profiling] in rts/Apply.cmm-  = ASSERT( arity /= 0 ) ReturnIt+  = assert (arity /= 0) ReturnIt   | n_args < arity = SlowCall        -- Not enough args-  | otherwise      = DirectEntry (enterIdLabel (profilePlatform (co_profile opts)) name (idCafInfo id)) arity+  | otherwise      = DirectEntry (enterIdLabel (stgToCmmPlatform cfg) name (idCafInfo id)) arity  getCallMethod _ _name _ LFUnlifted n_args _v_args _cg_loc _self_loop_info-  = ASSERT( n_args == 0 ) ReturnIt+  = assert (n_args == 0) ReturnIt  getCallMethod _ _name _ (LFCon _) n_args _v_args _cg_loc _self_loop_info-  = ASSERT( n_args == 0 ) ReturnIt+  = assert (n_args == 0) ReturnIt     -- n_args=0 because it'd be ill-typed to apply a saturated     --          constructor application to anything -getCallMethod opts name id (LFThunk _ _ updatable std_form_info is_fun)+getCallMethod cfg name id (LFThunk _ _ updatable std_form_info is_fun)               n_args _v_args _cg_loc _self_loop_info++  | Just sig <- idTagSig_maybe id+  , isTaggedSig sig -- Infered to be already evaluated by Tag Inference+  , n_args == 0     -- See Note [Tag Inference]+  = InferedReturnIt+   | is_fun      -- it *might* be a function, so we must "call" it (which is always safe)   = SlowCall    -- We cannot just enter it [in eval/apply, the entry code                 -- is the fast-entry code]    -- Since is_fun is False, we are *definitely* looking at a data value-  | updatable || co_ticky opts -- to catch double entry+  | updatable || stgToCmmDoTicky cfg -- to catch double entry       {- OLD: || opt_SMP          I decided to remove this, because in SMP mode it doesn't matter          if we enter the same thunk multiple times, so the optimisation@@ -565,7 +569,7 @@   | SelectorThunk{} <- std_form_info   = EnterIt -    -- We used to have ASSERT( n_args == 0 ), but actually it is+    -- We used to have assert (n_args == 0 ), but actually it is     -- possible for the optimiser to generate     --   let bot :: Int = error Int "urk"     --   in (bot `cast` unsafeCoerce Int (Int -> Int)) 3@@ -573,19 +577,33 @@     -- So the right thing to do is just to enter the thing    | otherwise        -- Jump direct to code for single-entry thunks-  = ASSERT( n_args == 0 )-    DirectEntry (thunkEntryLabel (profilePlatform (co_profile opts)) name (idCafInfo id) std_form_info+  = assert (n_args == 0) $+    DirectEntry (thunkEntryLabel (stgToCmmPlatform cfg) name (idCafInfo id) std_form_info                 updatable) 0 -getCallMethod _ _name _ (LFUnknown True) _n_arg _v_args _cg_locs _self_loop_info-  = SlowCall -- might be a function+-- Imported(Unknown) Ids+getCallMethod cfg name id (LFUnknown might_be_a_function) n_args _v_args _cg_locs _self_loop_info+  | n_args == 0+  , Just sig <- idTagSig_maybe id+  , isTaggedSig sig -- Infered to be already evaluated by Tag Inference+  -- When profiling we must enter all potential functions to make sure we update the SCC+  -- even if the function itself is already evaluated.+  -- See Note [Evaluating functions with profiling] in rts/Apply.cmm+  , not (profileIsProfiling (stgToCmmProfile cfg) && might_be_a_function)+  = InferedReturnIt -- See Note [Tag Inference] -getCallMethod _ name _ (LFUnknown False) n_args _v_args _cg_loc _self_loop_info-  = ASSERT2( n_args == 0, ppr name <+> ppr n_args )-    EnterIt -- Not a function+  | might_be_a_function = SlowCall -getCallMethod _ _name _ LFLetNoEscape _n_args _v_args (LneLoc blk_id lne_regs)-              _self_loop_info+  | otherwise =+      assertPpr ( n_args == 0) ( ppr name <+> ppr n_args )+      EnterIt   -- Not a function++-- TODO: Redundant with above match?+-- getCallMethod _ name _ (LFUnknown False) n_args _v_args _cg_loc _self_loop_info+--   = assertPpr (n_args == 0) (ppr name <+> ppr n_args)+--     EnterIt -- Not a function++getCallMethod _ _name _ LFLetNoEscape _n_args _v_args (LneLoc blk_id lne_regs) _self_loop_info   = JumpToIt blk_id lne_regs  getCallMethod _ _ _ _ _ _ _ _ = panic "Unknown call method"@@ -613,7 +631,7 @@  data ClosureInfo   = ClosureInfo {-        closureName :: !Name,           -- The thing bound to this closure+        closureName :: !Id,           -- The thing bound to this closure            -- we don't really need this field: it's only used in generating            -- code for ticky and profiling, and we could pass the information            -- around separately, but it doesn't do much harm to keep it here.@@ -650,13 +668,12 @@               -> String         -- String descriptor               -> ClosureInfo mkClosureInfo profile is_static id lf_info tot_wds ptr_wds val_descr-  = ClosureInfo { closureName      = name+  = ClosureInfo { closureName      = id                 , closureLFInfo    = lf_info                 , closureInfoLabel = info_lbl   -- These three fields are                 , closureSMRep     = sm_rep     -- (almost) an info table                 , closureProf      = prof }     -- (we don't have an SRT yet)   where-    name       = idName id     sm_rep     = mkHeapRep profile is_static ptr_wds nonptr_wds (lfClosureType lf_info)     prof       = mkProfilingInfo profile id val_descr     nonptr_wds = tot_wds - ptr_wds@@ -810,6 +827,7 @@   | platformTablesNextToCode platform = toInfoLbl  platform . closureInfoLabel   | otherwise                         = toEntryLbl platform . closureInfoLabel +-- | Get the info table label for a *thunk*. mkClosureInfoTableLabel :: Platform -> Id -> LambdaFormInfo -> CLabel mkClosureInfoTableLabel platform id lf_info   = case lf_info of@@ -819,23 +837,14 @@         LFThunk _ _ upd_flag (ApThunk arity) _                       -> mkApInfoTableLabel platform upd_flag arity -        LFThunk{}     -> std_mk_lbl name cafs-        LFReEntrant{} -> std_mk_lbl name cafs+        LFThunk{}     -> mkInfoTableLabel name cafs+        LFReEntrant{} -> mkInfoTableLabel name cafs         _other        -> panic "closureInfoTableLabel"    where     name = idName id -    std_mk_lbl | is_local  = mkLocalInfoTableLabel-               | otherwise = mkInfoTableLabel-     cafs     = idCafInfo id-    is_local = isDataConWorkId id-       -- Make the _info pointer for the implicit datacon worker-       -- binding local. The reason we can do this is that importing-       -- code always either uses the _closure or _con_info. By the-       -- invariants in "GHC.CoreToStg.Prep" anything else gets eta expanded.-  -- | thunkEntryLabel is a local help function, not exported.  It's used from -- getCallMethod.
compiler/GHC/StgToCmm/DataCon.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Stg to C--: code generation for constructors@@ -15,12 +15,9 @@         cgTopRhsCon, buildDynCon, bindConArgs     ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Platform-import GHC.Platform.Profile  import GHC.Stg.Syntax import GHC.Core  ( AltCon(..) )@@ -40,7 +37,6 @@ import GHC.Types.CostCentre import GHC.Unit import GHC.Core.DataCon-import GHC.Driver.Session import GHC.Data.FastString import GHC.Types.Id import GHC.Types.Id.Info( CafInfo( NoCafRefs ) )@@ -49,24 +45,28 @@ import GHC.Types.Literal import GHC.Builtin.Utils import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Misc import GHC.Utils.Monad (mapMaybeM)  import Control.Monad import Data.Char+import GHC.StgToCmm.Config (stgToCmmPlatform)+import GHC.StgToCmm.TagCheck (checkConArgsStatic, checkConArgsDyn)+import GHC.Utils.Outputable  --------------------------------------------------------------- --      Top-level constructors --------------------------------------------------------------- -cgTopRhsCon :: DynFlags+cgTopRhsCon :: StgToCmmConfig             -> Id               -- Name of thing bound to this RHS             -> DataCon          -- Id             -> ConstructorNumber             -> [NonVoid StgArg] -- Args             -> (CgIdInfo, FCode ())-cgTopRhsCon dflags id con mn args-  | Just static_info <- precomputedStaticConInfo_maybe dflags id con args+cgTopRhsCon cfg id con mn args+  | Just static_info <- precomputedStaticConInfo_maybe cfg id con args   , let static_code | isInternalName name = pure ()                     | otherwise           = gen_code   = -- There is a pre-allocated static closure available; use it@@ -82,7 +82,7 @@   = (id_Info, gen_code)    where-   platform      = targetPlatform dflags+   platform      = stgToCmmPlatform cfg    id_Info       = litIdInfo platform id (mkConLFInfo con) (CmmLabel closure_label)    name          = idName id    caffy         = idCafInfo id -- any stgArgHasCafRefs args@@ -93,9 +93,9 @@         ; this_mod <- getModuleName         ; when (platformOS platform == OSMinGW32) $               -- Windows DLLs have a problem with static cross-DLL refs.-              MASSERT( not (isDllConApp dflags this_mod con (map fromNonVoid args)) )-        ; ASSERT( args `lengthIs` countConRepArgs con ) return ()-+              massert (not (isDllConApp platform (stgToCmmExtDynRefs cfg) this_mod con (map fromNonVoid args)))+        ; assert (args `lengthIs` countConRepArgs con ) return ()+        ; checkConArgsStatic (text "TagCheck failed - Top level con") con (map fromNonVoid args)         -- LAY IT OUT         ; let             (tot_wds, --  #ptr_wds + #nonptr_wds@@ -167,18 +167,20 @@             -> FCode (CgIdInfo, FCode CmmAGraph)                -- Return details about how to find it and initialization code buildDynCon binder mn actually_bound cc con args-    = do dflags <- getDynFlags-         buildDynCon' dflags binder mn actually_bound cc con args+    = do cfg <- getStgToCmmConfig+         --   pprTrace "noCodeLocal:" (ppr (binder,con,args,cgInfo)) True+         case precomputedStaticConInfo_maybe cfg binder con args of+           Just cgInfo -> return (cgInfo, return mkNop)+           Nothing     -> buildDynCon' binder mn actually_bound cc con args  -buildDynCon' :: DynFlags-             -> Id -> ConstructorNumber+buildDynCon' :: Id+             -> ConstructorNumber              -> Bool              -> CostCentreStack              -> DataCon              -> [NonVoid StgArg]              -> FCode (CgIdInfo, FCode CmmAGraph)- {- We used to pass a boolean indicating whether all the args were of size zero, so we could use a static constructor; but I concluded that it just isn't worth it.@@ -189,14 +191,8 @@ the addr modes of the args is that we may be in a "knot", and premature looking at the args will cause the compiler to black-hole! -}--buildDynCon' dflags binder _ _ _cc con args-  | Just cgInfo <- precomputedStaticConInfo_maybe dflags binder con args-  -- , pprTrace "noCodeLocal:" (ppr (binder,con,args,cgInfo)) True-  = return (cgInfo, return mkNop)- -------- buildDynCon': the general case ------------buildDynCon' _ binder mn actually_bound ccs con args+buildDynCon' binder mn actually_bound ccs con args   = do  { (id_info, reg) <- rhsIdInfo binder lf_info         ; return (id_info, gen_code reg)         }@@ -205,8 +201,9 @@    gen_code reg     = do  { modu <- getModuleName-          ; profile <- getProfile-          ; let platform = profilePlatform profile+          ; cfg  <- getStgToCmmConfig+          ; let platform = stgToCmmPlatform cfg+                profile  = stgToCmmProfile  cfg                 (tot_wds, ptr_wds, args_w_offsets)                    = mkVirtConstrOffsets profile (addArgReps args)                 nonptr_wds = tot_wds - ptr_wds@@ -215,6 +212,8 @@           ; let ticky_name | actually_bound = Just binder                            | otherwise = Nothing +          ; checkConArgsDyn (hang (text "TagCheck failed on constructor application.") 4 $+                                   text "On binder:" <> ppr binder $$ text "Constructor:" <> ppr con) con (map fromNonVoid args)           ; hp_plus_n <- allocDynClosure ticky_name info_tbl lf_info                                           use_cc blame_cc args_w_offsets           ; return (mkRhsInit platform reg lf_info hp_plus_n) }@@ -225,13 +224,14 @@        blame_cc = use_cc -- cost-centre on which to blame the alloc (same) + {- Note [Precomputed static closures]    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  For Char/Int closures there are some value closures built into the RTS. This is the case for all values in the range mINT_INTLIKE .. mAX_INTLIKE (or CHARLIKE).-See Note [CHARLIKE and INTLIKE closures.] in the RTS code.+See Note [CHARLIKE and INTLIKE closures] in the RTS code.  Similarly zero-arity constructors have a closure in their defining Module we can use.@@ -318,36 +318,36 @@ because they don't support cross package data references well. -} --- (precomputedStaticConInfo_maybe dflags id con args)+-- (precomputedStaticConInfo_maybe cfg id con args) --     returns (Just cg_id_info) -- if there is a precomputed static closure for (con args). -- In that case, cg_id_info addresses it. -- See Note [Precomputed static closures]-precomputedStaticConInfo_maybe :: DynFlags -> Id -> DataCon -> [NonVoid StgArg] -> Maybe CgIdInfo-precomputedStaticConInfo_maybe dflags binder con []+precomputedStaticConInfo_maybe :: StgToCmmConfig -> Id -> DataCon -> [NonVoid StgArg] -> Maybe CgIdInfo+precomputedStaticConInfo_maybe cfg binder con [] -- Nullary constructors   | isNullaryRepDataCon con-  = Just $ litIdInfo (targetPlatform dflags) binder (mkConLFInfo con)+  = Just $ litIdInfo (stgToCmmPlatform cfg) binder (mkConLFInfo con)                 (CmmLabel (mkClosureLabel (dataConName con) NoCafRefs))-precomputedStaticConInfo_maybe dflags binder con [arg]+precomputedStaticConInfo_maybe cfg binder con [arg]   -- Int/Char values with existing closures in the RTS   | intClosure || charClosure-  , platformOS platform /= OSMinGW32 || not (positionIndependent dflags)+  , platformOS platform /= OSMinGW32 || not (stgToCmmPIE cfg || stgToCmmPIC cfg)   , Just val <- getClosurePayload arg   , inRange val   = let intlike_lbl   = mkCmmClosureLabel rtsUnitId (fsLit label)         val_int = fromIntegral val :: Int-        offsetW = (val_int - (fromIntegral min_static_range)) * (fixedHdrSizeW profile + 1)+        offsetW = (val_int - fromIntegral min_static_range) * (fixedHdrSizeW profile + 1)                 -- INTLIKE/CHARLIKE closures consist of a header and one word payload         static_amode = cmmLabelOffW platform intlike_lbl offsetW     in Just $ litIdInfo platform binder (mkConLFInfo con) static_amode   where-    profile = targetProfile dflags-    platform = profilePlatform profile-    intClosure = maybeIntLikeCon con+    profile     = stgToCmmProfile  cfg+    platform    = stgToCmmPlatform cfg+    intClosure  = maybeIntLikeCon  con     charClosure = maybeCharLikeCon con     getClosurePayload (NonVoid (StgLitArg (LitNumber LitNumInt val))) = Just val-    getClosurePayload (NonVoid (StgLitArg (LitChar val))) = Just $ (fromIntegral . ord $ val)+    getClosurePayload (NonVoid (StgLitArg (LitChar val))) = Just (fromIntegral . ord $ val)     getClosurePayload _ = Nothing     -- Avoid over/underflow by comparisons at type Integer!     inRange :: Integer -> Bool@@ -382,7 +382,7 @@ -- binders args, assuming that we have just returned from a 'case' which -- found a con bindConArgs (DataAlt con) base args-  = ASSERT(not (isUnboxedTupleDataCon con))+  = assert (not (isUnboxedTupleDataCon con)) $     do profile <- getProfile        platform <- getPlatform        let (_, _, args_w_offsets) = mkVirtConstrOffsets profile (addIdReps args)@@ -402,4 +402,4 @@        mapMaybeM bind_arg args_w_offsets  bindConArgs _other_con _base args-  = ASSERT( null args ) return []+  = assert (null args ) return []
compiler/GHC/StgToCmm/Env.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Stg to C-- code generation: the binding environment@@ -17,11 +17,9 @@          bindArgsToRegs, bindToReg, rebindToReg,         bindArgToReg, idToReg,-        getCgIdInfo,+        getCgIdInfo, getCgInfo_maybe,         maybeLetNoEscape,-    ) where--#include "GhclibHsVersions.h"+        ) where  import GHC.Prelude @@ -42,11 +40,11 @@ import GHC.Types.Unique.FM import GHC.Types.Var.Env -import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain -import GHC.Driver.Session+import GHC.Builtin.Names (getUnique)   -------------------------------------@@ -86,16 +84,16 @@  idInfoToAmode :: CgIdInfo -> CmmExpr -- Returns a CmmExpr for the *tagged* pointer-idInfoToAmode (CgIdInfo { cg_loc = CmmLoc e }) = e+idInfoToAmode CgIdInfo { cg_loc = CmmLoc e } = e idInfoToAmode cg_info   = pprPanic "idInfoToAmode" (ppr (cg_id cg_info))        -- LneLoc  -- | A tag adds a byte offset to the pointer addDynTag :: Platform -> CmmExpr -> DynTag -> CmmExpr-addDynTag platform expr tag = cmmOffsetB platform expr tag+addDynTag = cmmOffsetB  maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg])-maybeLetNoEscape (CgIdInfo { cg_loc = LneLoc blk_id args}) = Just (blk_id, args)+maybeLetNoEscape CgIdInfo { cg_loc = LneLoc blk_id args} = Just (blk_id, args) maybeLetNoEscape _other                                      = Nothing  @@ -120,12 +118,20 @@                                new_bindings         setBinds new_binds +-- Inside GHC the average module creates 385 external references+-- with noteable cgIdInfo (so not generated by mkLFArgument).+-- On average 200 of these are covered by True/False/[]+-- and nullary constructors make up ~80.+-- One would think it would be worthwhile to cache these.+-- Sadly it's not. See #16937+ getCgIdInfo :: Id -> FCode CgIdInfo getCgIdInfo id-  = do  { platform <- targetPlatform <$> getDynFlags+  = do  { platform <- getPlatform         ; local_binds <- getBinds -- Try local bindings first         ; case lookupVarEnv local_binds id of {-            Just info -> return info ;+            Just info -> -- pprTrace "getCgIdInfoLocal" (ppr id) $+              return info ;             Nothing   -> do {                  -- Should be imported; make up a CgIdInfo for it@@ -137,7 +143,7 @@                       | isUnliftedType (idType id)                           -- An unlifted external Id must refer to a top-level                           -- string literal. See Note [Bytes label] in "GHC.Cmm.CLabel".-                      = ASSERT( idType id `eqType` addrPrimTy )+                      = assert (idType id `eqType` addrPrimTy) $                         mkBytesLabel name                       | otherwise                       = pprPanic "GHC.StgToCmm.Env: label not found" (ppr id <+> dcolon <+> ppr (idType id))@@ -147,6 +153,12 @@               cgLookupPanic id -- Bug         }}} +-- | Retrieve cg info for a name if it already exists.+getCgInfo_maybe :: Name -> FCode (Maybe CgIdInfo)+getCgInfo_maybe name+  = do  { local_binds <- getBinds -- Try local bindings first+        ; return $ lookupVarEnv_Directly local_binds (getUnique name) }+ cgLookupPanic :: Id -> FCode a cgLookupPanic id   = do  local_binds <- getBinds@@ -181,7 +193,7 @@ bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id)  bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg]-bindArgsToRegs args = mapM bindArgToReg args+bindArgsToRegs = mapM bindArgToReg  idToReg :: Platform -> NonVoid Id -> LocalReg -- Make a register from an Id, typically a function argument,
compiler/GHC/StgToCmm/Expr.hs view
@@ -1,6 +1,7 @@-{-# LANGUAGE CPP, BangPatterns #-}- {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}  ----------------------------------------------------------------------------- --@@ -12,8 +13,6 @@  module GHC.StgToCmm.Expr ( cgExpr, cgLit ) where -#include "GhclibHsVersions.h"- import GHC.Prelude hiding ((<*>))  import {-# SOURCE #-} GHC.StgToCmm.Bind ( cgBind )@@ -27,6 +26,7 @@ import GHC.StgToCmm.Lit import GHC.StgToCmm.Prim import GHC.StgToCmm.Hpc+import GHC.StgToCmm.TagCheck import GHC.StgToCmm.Ticky import GHC.StgToCmm.Utils import GHC.StgToCmm.Closure@@ -38,6 +38,7 @@ import GHC.Cmm hiding ( succ ) import GHC.Cmm.Info import GHC.Cmm.Utils ( zeroExpr, cmmTagMask, mkWordCLit, mAX_PTR_TAG )+import GHC.Cmm.Ppr import GHC.Core import GHC.Core.DataCon import GHC.Types.ForeignCall@@ -45,7 +46,7 @@ import GHC.Builtin.PrimOps import GHC.Core.TyCon import GHC.Core.Type        ( isUnliftedType )-import GHC.Types.RepType    ( isVoidTy, countConRepArgs )+import GHC.Types.RepType    ( isZeroBitTy, countConRepArgs, mightBeFunTy ) import GHC.Types.CostCentre ( CostCentreStack, currentCCS ) import GHC.Types.Tickish import GHC.Data.Maybe@@ -53,10 +54,13 @@ import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain  import Control.Monad ( unless, void ) import Control.Arrow ( first ) import Data.List     ( partition )+import GHC.Stg.InferTags.TagSig (isTaggedSig)+import GHC.Platform.Profile (profileIsProfiling)  ------------------------------------------------------------------------ --              cgExpr: the main function@@ -72,7 +76,7 @@   cgIdApp a []  -- dataToTag# :: a -> Int#--- See Note [dataToTag# magic] in primops.txt.pp+-- See Note [dataToTag# magic] in GHC.Core.Opt.ConstantFold cgExpr (StgOpApp (StgPrimOp DataToTagOp) [StgVarArg a] _res_ty) = do   platform <- getPlatform   emitComment (mkFastString "dataToTag#")@@ -92,9 +96,10 @@   slow_path <- getCode $ do       tmp <- newTemp (bWord platform)       _ <- withSequel (AssignTo [tmp] False) (cgIdApp a [])-      ptr_opts <- getPtrOpts+      profile     <- getProfile+      align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig       emitAssign (CmmLocal result_reg)-        $ getConstrTag ptr_opts (cmmUntag platform (CmmReg (CmmLocal tmp)))+        $ getConstrTag profile align_check (cmmUntag platform (CmmReg (CmmLocal tmp)))    fast_path <- getCode $ do       -- Return the constructor index from the pointer tag@@ -103,9 +108,10 @@             $ cmmSubWord platform tag (CmmLit $ mkWordCLit platform 1)       -- Return the constructor index recorded in the info table       return_info_tag <- getCode $ do-          ptr_opts <- getPtrOpts+          profile     <- getProfile+          align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig           emitAssign (CmmLocal result_reg)-            $ getConstrTag ptr_opts (cmmUntag platform amode)+            $ getConstrTag profile align_check (cmmUntag platform amode)        emit =<< mkCmmIfThenElse' is_too_big_tag return_info_tag return_ptr_tag (Just False) @@ -211,7 +217,7 @@   = do platform <- getPlatform        return ( lneIdInfo platform bndr args, code )   where-   code = forkLneBody $ withNewTickyCounterLNE (idName bndr) args $ do+   code = forkLneBody $ withNewTickyCounterLNE bndr args $ do             { restoreCurrentCostCentre cc_slot             ; arg_regs <- bindArgsToRegs args             ; void $ noEscapeHeapCheck arg_regs (tickyEnterLNE >> cgExpr body) }@@ -290,7 +296,7 @@ entry to a function, when not many things are live.  After a bunch of single-branch cases, we may have lots of things live -Hence: two basic plans for+Hence: Two basic plans for          case e of r { alts } @@ -305,6 +311,13 @@         ...code for alts...         ...alts do their own heap checks +   When using GcInAlts the return point for heap checks and evaluating+   the scrutinee is shared. This does mean we might execute the actual+   branching code twice but it's rare enough to not matter.+   The huge advantage of this pattern is that we do not require multiple+   info tables for returning from gc as they can be shared between all+   cases. Reducing code size nicely.+ ------ Plan B: special case when ---------   (i)  e does not allocate or call GC   (ii) either upstream code performs allocation@@ -319,6 +332,80 @@          ...code for alts...         ...no heap check...++   There is a variant B.2 which we use if:++  (i)   e is already evaluated+tagged+  (ii)  We have multiple alternatives+  (iii) and there is no upstream allocation.++  Here we also place one heap check before the `case` which+  branches on `e`. Hopefully to be absorbed by an already existing+  heap check further up. However the big difference in this case is that+  there is no code for e. So we are not guaranteed that the heap+  checks of the alts will be combined with an heap check further up.++  Very common example: Casing on strict fields.++        ...heap check...+        ...assign bindings...++        ...code for alts...+        ...no heap check...++  -- Reasoning for Plan B.2:+   Since the scrutinee is already evaluated there is no evaluation+   call which would force a info table that we can use as a shared+   return point.+   This means currently if we were to do GcInAlts like in Plan A then+   we would end up with one info table per alternative.++   To avoid this we unconditionally do gc outside of the alts with all+   the pros and cons described in Note [Compiling case expressions].+   Rewriting the logic to generate a shared return point before the case+   expression while keeping the heap checks in the alternatives would be+   possible. But it's unclear to me that this would actually be an improvement.++   This means if we have code along these lines:++      g x y = case x of+         True -> Left $ (y + 1,y,y-1)+         False -> Right $! y - (2 :: Int)++   We get these potential heap check placements:++   f = ...+      !max(L,R)!; -- Might be absorbed upstream.+      case x of+         True  -> !L!; ...L...+         False -> !R!; ...R...++   And we place a heap check at !max(L,R)!++   The downsides of using !max(L,R)! are:++   * If f is recursive, and the hot loop wouldn't allocate, but the exit branch does then we do+   a redundant heap check.+   * We use one more instruction to de-allocate the unused heap in the branch using less heap. (Neglible)+   * A small risk of running gc slightly more often than needed especially if one branch allocates a lot.++   The upsides are:+   * May save a heap overflow test if there is an upstream check already.+   * If the heap check is absorbed upstream we can also eliminate its info table.+   * We generate at most one heap check (versus one per alt otherwise).+   * No need to save volatile vars etc across heap checks in !L!, !R!+   * We can use relative addressing from a single Hp to get at all the closures so allocated. (seems neglible)+   * It fits neatly in the logic we already have for handling A/B++   For containers:Data/Sequence/Internal/Sorting.o the difference is+   about 10% in terms of code size compared to using Plan A for this case.+   The main downside is we might put heap checks into loops, even if we+   could avoid it (See Note [Compiling case expressions]).++   Potential improvement: Investigate if heap checks in alts would be an+   improvement if we generate and use a shared return point that is placed+   in the common path for all alts.+ -}  @@ -373,7 +460,7 @@  cgCase (StgApp v []) _ (PrimAlt _) alts   | isVoidRep (idPrimRep v)  -- See Note [Scrutinising VoidRep]-  , [(DEFAULT, _, rhs)] <- alts+  , [GenStgAlt{alt_con=DEFAULT, alt_bndrs=_, alt_rhs=rhs}] <- alts   = cgExpr rhs  {- Note [Dodgy unsafeCoerce 1]@@ -460,6 +547,7 @@        ; up_hp_usg <- getVirtHp        -- Upstream heap usage        ; let ret_bndrs = chooseReturnBndrs bndr alt_type alts              alt_regs  = map (idToReg platform) ret_bndrs+        ; simple_scrut <- isSimpleScrut scrut alt_type        ; let do_gc  | is_cmp_op scrut  = False  -- See Note [GC for conditionals]                     | not simple_scrut = True@@ -481,6 +569,7 @@     is_cmp_op (StgOpApp (StgPrimOp op) _ _) = isComparisonPrimOp op     is_cmp_op _                             = False + {- Note [GC for conditionals] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For boolean conditionals it seems that we have always done NoGcInAlts.@@ -529,21 +618,28 @@ -- heap usage from alternatives into the stuff before the case -- NB: if you get this wrong, and claim that the expression doesn't allocate --     when it does, you'll deeply mess up allocation-isSimpleScrut (StgOpApp op args _) _       = isSimpleOp op args-isSimpleScrut (StgLit _)       _           = return True       -- case 1# of { 0# -> ..; ... }-isSimpleScrut (StgApp _ [])    (PrimAlt _) = return True       -- case x# of { 0# -> ..; ... }-isSimpleScrut _                _           = return False+isSimpleScrut (StgOpApp op args _) _         = isSimpleOp op args+isSimpleScrut (StgLit _)           _         = return True       -- case 1# of { 0# -> ..; ... }+isSimpleScrut (StgApp _ [])    (PrimAlt _)   = return True       -- case x# of { 0# -> ..; ... }+isSimpleScrut (StgApp f [])   _+  | Just sig <- idTagSig_maybe f+  , isTaggedSig sig  -- case !x of { ... }+  = if mightBeFunTy (idType f)+      -- See Note [Evaluating functions with profiling] in rts/Apply.cmm+      then not . profileIsProfiling <$> getProfile+      else pure True+isSimpleScrut _                    _         = return False  isSimpleOp :: StgOp -> [StgArg] -> FCode Bool -- True iff the op cannot block or allocate isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) _ = return $! not (playSafe safe)--- dataToTag# evaluates its argument, see Note [dataToTag#] in primops.txt.pp+-- dataToTag# evaluates its argument, see Note [dataToTag# magic] in GHC.Core.Opt.ConstantFold isSimpleOp (StgPrimOp DataToTagOp) _ = return False isSimpleOp (StgPrimOp op) stg_args                  = do     arg_exprs <- getNonVoidArgAmodes stg_args-    dflags <- getDynFlags+    cfg       <- getStgToCmmConfig     -- See Note [Inlining out-of-line primops and heap checks]-    return $! shouldInlinePrimOp dflags op arg_exprs+    return $! shouldInlinePrimOp cfg op arg_exprs isSimpleOp (StgPrimCallOp _) _                           = return False  -----------------@@ -554,9 +650,10 @@ chooseReturnBndrs bndr (PrimAlt _) _alts   = assertNonVoidIds [bndr] -chooseReturnBndrs _bndr (MultiValAlt n) [(_, ids, _)]-  = ASSERT2(ids `lengthIs` n, ppr n $$ ppr ids $$ ppr _bndr)+chooseReturnBndrs _bndr (MultiValAlt n) [alt]+  = assertPpr (ids `lengthIs` n) (ppr n $$ ppr ids $$ ppr _bndr) $     assertNonVoidIds ids     -- 'bndr' is not assigned!+    where ids = alt_bndrs alt  chooseReturnBndrs bndr (AlgAlt _) _alts   = assertNonVoidIds [bndr]  -- Only 'bndr' is assigned@@ -571,11 +668,11 @@ cgAlts :: (GcPlan,ReturnKind) -> NonVoid Id -> AltType -> [CgStgAlt]        -> FCode ReturnKind -- At this point the result of the case are in the binders-cgAlts gc_plan _bndr PolyAlt [(_, _, rhs)]-  = maybeAltHeapCheck gc_plan (cgExpr rhs)+cgAlts gc_plan _bndr PolyAlt [alt]+  = maybeAltHeapCheck gc_plan (cgExpr $ alt_rhs alt) -cgAlts gc_plan _bndr (MultiValAlt _) [(_, _, rhs)]-  = maybeAltHeapCheck gc_plan (cgExpr rhs)+cgAlts gc_plan _bndr (MultiValAlt _) [alt]+  = maybeAltHeapCheck gc_plan (cgExpr $ alt_rhs alt)         -- Here bndrs are *already* in scope, so don't rebind them  cgAlts gc_plan bndr (PrimAlt _) alts@@ -616,9 +713,10 @@            else -- No, the get exact tag from info table when mAX_PTR_TAG                 -- See Note [Double switching for big families]               do-                ptr_opts <- getPtrOpts+                profile     <- getProfile+                align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig                 let !untagged_ptr = cmmUntag platform (CmmReg bndr_reg)-                    !itag_expr = getConstrTag ptr_opts untagged_ptr+                    !itag_expr = getConstrTag profile align_check untagged_ptr                     !info0 = first pred <$> via_info                 if null via_ptr then                   emitSwitch itag_expr info0 mb_deflt 0 (fam_sz - 1)@@ -808,10 +906,10 @@ -- tricky part is that the default case needs (logical) duplication. -- To do this we emit an extra label for it and branch to that from -- the second switch. This avoids duplicated codegen. See Trac #14373.--- See note [Double switching for big families] for the mechanics+-- See Note [Double switching for big families] for the mechanics -- involved. ----- Also see note [Data constructor dynamic tags]+-- Also see Note [Data constructor dynamic tags] -- and the wiki https://gitlab.haskell.org/ghc/ghc/wikis/commentary/rts/haskell-execution/pointer-tagging -- @@ -843,7 +941,7 @@   let     base_reg = idToReg platform bndr     cg_alt :: CgStgAlt -> FCode (AltCon, CmmAGraphScoped)-    cg_alt (con, bndrs, rhs)+    cg_alt GenStgAlt{alt_con=con, alt_bndrs=bndrs, alt_rhs=rhs}       = getCodeScoped             $         maybeAltHeapCheck gc_plan $         do { _ <- bindConArgs con base_reg (assertNonVoidIds bndrs)@@ -872,7 +970,8 @@        ; emitReturn arg_exprs }    | otherwise   --  Boxed constructors; allocate and return-  = ASSERT2( stg_args `lengthIs` countConRepArgs con, ppr con <> parens (ppr (countConRepArgs con)) <+> ppr stg_args )+  = assertPpr (stg_args `lengthIs` countConRepArgs con)+              (ppr con <> parens (ppr (countConRepArgs con)) <+> ppr stg_args) $     do  { (idinfo, fcode_init) <- buildDynCon (dataConWorkId con) mn False                                      currentCCS con (assertNonVoidStgArgs stg_args)                                      -- con args are always non-void,@@ -887,24 +986,43 @@  cgIdApp :: Id -> [StgArg] -> FCode ReturnKind cgIdApp fun_id args = do+    platform       <- getPlatform     fun_info       <- getCgIdInfo fun_id-    self_loop_info <- getSelfLoop-    call_opts      <- getCallOpts-    profile        <- getProfile-    let fun_arg     = StgVarArg fun_id-        fun_name    = idName    fun_id-        fun         = idInfoToAmode fun_info-        lf_info     = cg_lf         fun_info-        n_args      = length args-        v_args      = length $ filter (isVoidTy . stgArgType) args-    case getCallMethod call_opts fun_name fun_id lf_info n_args v_args (cg_loc fun_info) self_loop_info of+    cfg            <- getStgToCmmConfig+    self_loop      <- getSelfLoop+    let profile        = stgToCmmProfile  cfg+        fun_arg        = StgVarArg fun_id+        fun_name       = idName    fun_id+        fun            = idInfoToAmode fun_info+        lf_info        = cg_lf         fun_info+        n_args         = length args+        v_args         = length $ filter (isZeroBitTy . stgArgType) args+    case getCallMethod cfg fun_name fun_id lf_info n_args v_args (cg_loc fun_info) self_loop of             -- A value in WHNF, so we can just return it.         ReturnIt-          | isVoidTy (idType fun_id) -> emitReturn []+          | isZeroBitTy (idType fun_id) -> emitReturn []           | otherwise                -> emitReturn [fun]-          -- ToDo: does ReturnIt guarantee tagged? -        EnterIt -> ASSERT( null args )  -- Discarding arguments+        -- A value infered to be in WHNF, so we can just return it.+        InferedReturnIt+          | isZeroBitTy (idType fun_id) -> trace >> emitReturn []+          | otherwise                   -> trace >> assertTag >>+                                                    emitReturn [fun]+            where+              trace = do+                tickyTagged+                use_id <- newUnique+                _lbl <- emitTickyCounterTag use_id (NonVoid fun_id)+                tickyTagSkip use_id fun_id++                -- pprTraceM "WHNF:" (ppr fun_id <+> ppr args )+              assertTag = whenCheckTags $ do+                  mod <- getModuleName+                  emitTagAssertion (showPprUnsafe+                      (text "TagCheck failed on entry in" <+> ppr mod <+> text "- value:" <> ppr fun_id <+> pprExpr platform fun))+                      fun++        EnterIt -> assert (null args) $  -- Discarding arguments                    emitEnter fun          SlowCall -> do      -- A slow function call via the RTS apply routines@@ -975,7 +1093,7 @@ -- Implementation is spread across a couple of places in the code: -- --   * FCode monad stores additional information in its reader environment---     (cgd_self_loop field). This information tells us which function can+--     (stgToCmmSelfLoop field). This information tells us which function can --     tail call itself in an optimized way (it is the function currently --     being compiled), what is the label of a loop header (L1 in example above) --     and information about local registers in which we should arguments@@ -1008,7 +1126,7 @@ --     command-line option. -- --   * Command line option to turn loopification on and off is implemented in---     DynFlags.+--     DynFlags, then passed to StgToCmmConfig for this phase. -- -- -- Note [Void arguments in self-recursive tail calls]@@ -1036,12 +1154,12 @@  emitEnter :: CmmExpr -> FCode ReturnKind emitEnter fun = do-  { ptr_opts <- getPtrOpts-  ; platform <- getPlatform-  ; profile <- getProfile+  { platform <- getPlatform+  ; profile  <- getProfile   ; adjustHpBackwards-  ; sequel <- getSequel-  ; updfr_off <- getUpdFrameOff+  ; sequel      <- getSequel+  ; updfr_off   <- getUpdFrameOff+  ; align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig   ; case sequel of       -- For a return, we have the option of generating a tag-test or       -- not.  If the value is tagged, we can return directly, which@@ -1052,7 +1170,9 @@       -- Right now, we do what the old codegen did, and omit the tag       -- test, just generating an enter.       Return -> do-        { let entry = entryCode platform $ closureInfoPtr ptr_opts $ CmmReg nodeReg+        { let entry = entryCode platform+                $ closureInfoPtr platform align_check+                $ CmmReg nodeReg         ; emit $ mkJump profile NativeNodeCall entry                         [cmmUntag platform fun] updfr_off         ; return AssignedDirectly@@ -1084,17 +1204,18 @@       -- code in the enclosing case expression.       --       AssignTo res_regs _ -> do-       { lret <- newBlockId-       ; let (off, _, copyin) = copyInOflow profile NativeReturn (Young lret) res_regs []+       { lret  <- newBlockId        ; lcall <- newBlockId-       ; updfr_off <- getUpdFrameOff+       ; updfr_off   <- getUpdFrameOff+       ; align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig+       ; let (off, _, copyin) = copyInOflow profile NativeReturn (Young lret) res_regs []        ; let area = Young lret        ; let (outArgs, regs, copyout) = copyOutOflow profile NativeNodeCall Call area                                           [fun] updfr_off []          -- refer to fun via nodeReg after the copyout, to avoid having          -- both live simultaneously; this sometimes enables fun to be          -- inlined in the RHS of the R1 assignment.-       ; let entry = entryCode platform (closureInfoPtr ptr_opts (CmmReg nodeReg))+       ; let entry = entryCode platform (closureInfoPtr platform align_check (CmmReg nodeReg))              the_call = toCall entry (Just lret) updfr_off off outArgs regs        ; tscope <- getTickScope        ; emit $
− compiler/GHC/StgToCmm/Expr.hs-boot 
@@ -1,7 +0,0 @@-module GHC.StgToCmm.Expr where--import GHC.Cmm.Expr-import GHC.StgToCmm.Monad-import GHC.Types.Literal--cgLit :: Literal -> FCode CmmExpr
compiler/GHC/StgToCmm/ExtCode.hs view
@@ -34,7 +34,7 @@         getCode, getCodeR, getCodeScoped,         emitOutOfLine,         withUpdFrameOff, getUpdFrameOff,-        getProfile, getPlatform, getPtrOpts+        getProfile, getPlatform, getContext )  where@@ -50,10 +50,8 @@ import GHC.Cmm import GHC.Cmm.CLabel import GHC.Cmm.Graph-import GHC.Cmm.Info  import GHC.Cmm.BlockId-import GHC.Driver.Session import GHC.Data.FastString import GHC.Unit.Module import GHC.Types.Unique.FM@@ -61,6 +59,7 @@ import GHC.Types.Unique.Supply  import Control.Monad (ap)+import GHC.Utils.Outputable (SDocContext)  -- | The environment contains variable definitions or blockids. data Named@@ -103,17 +102,14 @@     u <- getUniqueM     return (decls, u) -instance HasDynFlags CmmParse where-    getDynFlags = EC (\_ _ d -> (d,) <$> getDynFlags)- getProfile :: CmmParse Profile getProfile = EC (\_ _ d -> (d,) <$> F.getProfile)  getPlatform :: CmmParse Platform getPlatform = EC (\_ _ d -> (d,) <$> F.getPlatform) -getPtrOpts :: CmmParse PtrOpts-getPtrOpts = EC (\_ _ d -> (d,) <$> F.getPtrOpts)+getContext :: CmmParse SDocContext+getContext = EC (\_ _ d -> (d,) <$> F.getContext)  -- | Takes the variable declarations and imports from the monad --      and makes an environment, which is looped back into the computation.@@ -127,7 +123,6 @@         (_, a) <- F.fixC $ \ ~(decls, _) ->           fcode c (addListToUFM e decls) globalDecls         return (globalDecls, a)-  -- | Get the current environment from the monad. getEnv :: CmmParse Env
compiler/GHC/StgToCmm/Foreign.hs view
@@ -127,7 +127,7 @@          }  {- Note [safe foreign call convention]-+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The simple thing to do for a safe foreign call would be the same as an unsafe one: just @@ -174,7 +174,7 @@  L2:   ... r ... -And when the safe foreign call is lowered later (see Note [lower safe+And when the safe foreign call is lowered later (see Note [Lower safe foreign calls]) we get this:    suspendThread()@@ -601,9 +601,9 @@ -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- For certain types passed to foreign calls, we adjust the actual--- value passed to the call.  For ByteArray#, Array#, SmallArray#,--- and ArrayArray#, we pass the address of the array's payload, not--- the address of the heap object. For example, consider+-- value passed to the call.  For ByteArray#, Array# and SmallArray#,+-- we pass the address of the array's payload, not the address of+-- the heap object. For example, consider: --   foreign import "c_foo" foo :: ByteArray# -> Int# -> IO () -- At a Haskell call like `foo x y`, we'll generate a C call that -- is more like@@ -713,8 +713,6 @@ typeToStgFArgType typ   | tycon == arrayPrimTyCon = StgArrayType   | tycon == mutableArrayPrimTyCon = StgArrayType-  | tycon == arrayArrayPrimTyCon = StgArrayType-  | tycon == mutableArrayArrayPrimTyCon = StgArrayType   | tycon == smallArrayPrimTyCon = StgSmallArrayType   | tycon == smallMutableArrayPrimTyCon = StgSmallArrayType   | tycon == byteArrayPrimTyCon = StgByteArrayType
compiler/GHC/StgToCmm/Heap.hs view
@@ -44,7 +44,6 @@ import GHC.Types.Id.Info( CafInfo(..), mayHaveCafRefs ) import GHC.Types.Id ( Id ) import GHC.Unit-import GHC.Driver.Session import GHC.Platform import GHC.Platform.Profile import GHC.Data.FastString( mkFastString, fsLit )@@ -429,7 +428,7 @@ -- is more efficient), but cannot be optimized away in the non-allocating -- case because it may occur in a loop noEscapeHeapCheck :: [LocalReg] -> FCode a -> FCode a-noEscapeHeapCheck regs code = altOrNoEscapeHeapCheck True regs code+noEscapeHeapCheck = altOrNoEscapeHeapCheck True  cannedGCReturnsTo :: Bool -> Bool -> CmmExpr -> [LocalReg] -> Label -> ByteOff                   -> FCode a@@ -491,6 +490,7 @@       _otherwise -> Nothing  -- Note [stg_gc arguments]+-- ~~~~~~~~~~~~~~~~~~~~~~~ -- It might seem that we could avoid passing the arguments to the -- stg_gc function, because they are already in the right registers. -- While this is usually the case, it isn't always.  Sometimes the@@ -605,9 +605,9 @@           -> CmmAGraph        -- What to do on failure           -> FCode () do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do-  dflags <- getDynFlags-  platform <- getPlatform-  gc_id <- newBlockId+  omit_yields <- stgToCmmOmitYields <$> getStgToCmmConfig+  platform    <- getPlatform+  gc_id       <- newBlockId    let     Just alloc_lit = mb_alloc_lit@@ -644,13 +644,13 @@         | checkYield && isJust mb_stk_hwm -> emitLabel loop_header_id     _otherwise -> return () -  if (isJust mb_alloc_lit)+  if isJust mb_alloc_lit     then do      tickyHeapCheck      emitAssign hpReg bump_hp      emit =<< mkCmmIfThen' hp_oflo (alloc_n <*> mkBranch gc_id) (Just False)     else-      when (checkYield && not (gopt Opt_OmitYields dflags)) $ do+      when (checkYield && not omit_yields) $ do          -- Yielding if HpLim == 0          let yielding = CmmMachOp (mo_wordEq platform)                                   [CmmReg hpLimReg,@@ -670,7 +670,6 @@  -- Note [Self-recursive loop header] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- -- Self-recursive loop header is required by loopification optimization (See -- Note [Self-recursive tail calls] in GHC.StgToCmm.Expr). We emit it if: --
compiler/GHC/StgToCmm/Hpc.hs view
@@ -11,8 +11,6 @@ import GHC.Prelude import GHC.Platform -import GHC.Driver.Session- import GHC.StgToCmm.Monad import GHC.StgToCmm.Utils @@ -39,13 +37,13 @@  -- | Emit top-level tables for HPC and return code to initialise initHpc :: Module -> HpcInfo -> FCode ()-initHpc _ (NoHpcInfo {})+initHpc _ NoHpcInfo{}   = return () initHpc this_mod (HpcInfo tickCount _hashNo)-  = do dflags <- getDynFlags-       when (gopt Opt_Hpc dflags) $+  = do do_hpc <- stgToCmmOptHpc <$> getStgToCmmConfig+       when do_hpc $            emitDataLits (mkHpcTicksLabel this_mod)-                        [ (CmmInt 0 W64)+                        [ CmmInt 0 W64                         | _ <- take tickCount [0 :: Int ..]                         ]
compiler/GHC/StgToCmm/Layout.hs view
@@ -31,13 +31,8 @@   ) where  -#include "GhclibHsVersions.h"- import GHC.Prelude hiding ((<*>)) -import GHC.Driver.Session-import GHC.Driver.Ppr- import GHC.StgToCmm.Closure import GHC.StgToCmm.Env import GHC.StgToCmm.ArgRep -- notably: ( slowCallPattern )@@ -65,8 +60,12 @@ import Data.List (mapAccumL, partition) import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Utils.Constants (debugIsOn) import GHC.Data.FastString import Control.Monad+import GHC.StgToCmm.Config (stgToCmmPlatform)+import GHC.StgToCmm.Types  ------------------------------------------------------------------------ --                Call and return sequences@@ -196,9 +195,12 @@ slowCall :: CmmExpr -> [StgArg] -> FCode ReturnKind -- (slowCall fun args) applies fun to args, returning the results to Sequel slowCall fun stg_args-  = do  dflags <- getDynFlags-        profile <- getProfile-        let platform = profilePlatform profile+  = do  cfg <- getStgToCmmConfig+        let profile   = stgToCmmProfile      cfg+            platform  = stgToCmmPlatform     cfg+            ctx       = stgToCmmContext      cfg+            fast_pap  = stgToCmmFastPAPCalls cfg+            align_sat = stgToCmmAlignCheck   cfg         argsreps <- getArgRepsAmodes stg_args         let (rts_fun, arity) = slowCallPattern (map fst argsreps) @@ -206,18 +208,17 @@            r <- direct_call "slow_call" NativeNodeCall                  (mkRtsApFastLabel rts_fun) arity ((P,Just fun):argsreps)            emitComment $ mkFastString ("slow_call for " ++-                                      showSDoc dflags (pdoc platform fun) +++                                      renderWithContext ctx (pdoc platform fun) ++                                       " with pat " ++ unpackFS rts_fun)            return r -        -- Note [avoid intermediate PAPs]+        -- See Note [avoid intermediate PAPs]         let n_args = length stg_args-        if n_args > arity && optLevel dflags >= 2+        if n_args > arity && fast_pap            then do-             ptr_opts <- getPtrOpts              funv <- (CmmReg . CmmLocal) `fmap` assignTemp fun              fun_iptr <- (CmmReg . CmmLocal) `fmap`-                    assignTemp (closureInfoPtr ptr_opts (cmmUntag platform funv))+               assignTemp (closureInfoPtr platform align_sat (cmmUntag platform funv))               -- ToDo: we could do slightly better here by reusing the              -- continuation from the slow call, which we have in r.@@ -260,7 +261,7 @@   -- Note [avoid intermediate PAPs]---+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- A slow call which needs multiple generic apply patterns will be -- almost guaranteed to create one or more intermediate PAPs when -- applied to a function that takes the correct number of arguments.@@ -303,15 +304,14 @@   = emitCall (call_conv, NativeReturn) target (nonVArgs args)    | otherwise       -- Note [over-saturated calls]-  = do dflags <- getDynFlags+  = do do_scc_prof <- stgToCmmSCCProfiling <$> getStgToCmmConfig        emitCallWithExtraStack (call_conv, NativeReturn)                               target                               (nonVArgs fast_args)-                              (nonVArgs (stack_args dflags))+                              (nonVArgs (slowArgs rest_args do_scc_prof))   where     target = CmmLit (CmmLabel lbl)     (fast_args, rest_args) = splitAt real_arity args-    stack_args dflags = slowArgs dflags rest_args     real_arity = case call_conv of                    NativeNodeCall -> arity+1                    _              -> arity@@ -339,7 +339,7 @@  {- Note [over-saturated calls]-+~~~~~~~~~~~~~~~~~~~~~~~~~~~ The natural thing to do for an over-saturated call would be to call the function with the correct number of arguments, and then apply the remaining arguments to the value returned, e.g.@@ -375,12 +375,11 @@ -- | 'slowArgs' takes a list of function arguments and prepares them for -- pushing on the stack for "extra" arguments to a function which requires -- fewer arguments than we currently have.-slowArgs :: DynFlags -> [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)]-slowArgs _ [] = []-slowArgs dflags args -- careful: reps contains voids (V), but args does not-  | sccProfilingEnabled dflags-              = save_cccs ++ this_pat ++ slowArgs dflags rest_args-  | otherwise =              this_pat ++ slowArgs dflags rest_args+slowArgs :: [(ArgRep, Maybe CmmExpr)] -> DoSCCProfiling -> [(ArgRep, Maybe CmmExpr)]+slowArgs []   _                    = mempty+slowArgs args sccProfilingEnabled  -- careful: reps contains voids (V), but args does not+  | sccProfilingEnabled = save_cccs ++ this_pat ++ slowArgs rest_args sccProfilingEnabled+  | otherwise           =              this_pat ++ slowArgs rest_args sccProfilingEnabled   where     (arg_pat, n)            = slowCallPattern (map fst args)     (call_args, rest_args)  = splitAt n args@@ -438,7 +437,7 @@ -- than the unboxed things  mkVirtHeapOffsetsWithPadding profile header things =-    ASSERT(not (any (isVoidRep . fst . fromNonVoid) things))+    assert (not (any (isVoidRep . fst . fromNonVoid) things))     ( tot_wds     , bytesToWordsRoundUp platform bytes_of_ptrs     , concat (ptrs_w_offsets ++ non_ptrs_w_offsets) ++ final_pad@@ -541,7 +540,7 @@ -------------------------------------------------------------------------  -- bring in ARG_P, ARG_N, etc.-#include "rts/storage/FunTypes.h"+#include "FunTypes.h"  mkArgDescr :: Platform -> [Id] -> ArgDescr mkArgDescr platform args
compiler/GHC/StgToCmm/Lit.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, LambdaCase #-}+{-# LANGUAGE LambdaCase #-}  ----------------------------------------------------------------------------- --@@ -12,8 +12,6 @@     cgLit, mkSimpleLit,     newStringCLit, newByteStringCLit   ) where--#include "GhclibHsVersions.h"  import GHC.Prelude
compiler/GHC/StgToCmm/Monad.hs view
@@ -14,7 +14,7 @@ module GHC.StgToCmm.Monad (         FCode,        -- type -        initC, runC, fixC,+        initC, initFCodeState, runC, fixC,         newUnique,          emitLabel,@@ -28,7 +28,7 @@          getCmm, aGraphToGraph, getPlatform, getProfile,         getCodeR, getCode, getCodeScoped, getHeapUsage,-        getCallOpts, getPtrOpts,+        getContext,          mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto,         mkCmmIfThenElse', mkCmmIfThen', mkCmmIfGoto',@@ -45,7 +45,7 @@         setTickyCtrLabel, getTickyCtrLabel,         tickScope, getTickScope, -        withUpdFrameOff, getUpdFrameOff, initUpdFrameOff,+        withUpdFrameOff, getUpdFrameOff,          HeapUsage(..), VirtualHpOffset,        initHpUsage,         getHpUsage,  setHpUsage, heapHWM,@@ -54,13 +54,13 @@         getModuleName,          -- ideally we wouldn't export these, but some other modules access internal state-        getState, setState, getSelfLoop, withSelfLoop, getInfoDown, getDynFlags,+        getState, setState, getSelfLoop, withSelfLoop, getStgToCmmConfig,          -- more localised access to monad state         CgIdInfo(..),         getBinds, setBinds,         -- out of general friendliness, we also export ...-        CgInfoDownwards(..), CgState(..) -- non-abstract+        StgToCmmConfig(..), CgState(..) -- non-abstract     ) where  import GHC.Prelude hiding( sequence, succ )@@ -68,13 +68,13 @@ import GHC.Platform import GHC.Platform.Profile import GHC.Cmm+import GHC.StgToCmm.Config import GHC.StgToCmm.Closure-import GHC.Driver.Session+import GHC.StgToCmm.Sequel import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Graph as CmmGraph import GHC.Cmm.BlockId import GHC.Cmm.CLabel-import GHC.Cmm.Info import GHC.Runtime.Heap.Layout import GHC.Unit import GHC.Types.Id@@ -86,7 +86,7 @@ import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Misc+import GHC.Utils.Constants (debugIsOn) import GHC.Exts (oneShot)  import Control.Monad@@ -109,24 +109,30 @@ --    - the current heap usage --    - a UniqSupply -----  - A reader monad, for CgInfoDownwards, containing---    - DynFlags,+--  - A reader monad, for StgToCmmConfig, containing+--    - the profile, --    - the current Module+--    - the debug level+--    - a bunch of flags see StgToCmm.Config for full details++--  - A second reader monad with: --    - the update-frame offset --    - the ticky counter label --    - the Sequel (the continuation to return to) --    - the self-recursive tail call information+--    - The tick scope for new blocks and ticks+--  -------------------------------------------------------- -newtype FCode a = FCode' { doFCode :: CgInfoDownwards -> CgState -> (a, CgState) }+newtype FCode a = FCode' { doFCode :: StgToCmmConfig -> FCodeState -> CgState -> (a, CgState) }  -- Not derived because of #18202. -- See Note [The one-shot state monad trick] in GHC.Utils.Monad instance Functor FCode where   fmap f (FCode m) =-    FCode $ \info_down state ->-      case m info_down state of+    FCode $ \cfg fst state ->+      case m cfg fst state of         (x, state') -> (f x, state')  -- This pattern synonym makes the simplifier monad eta-expand,@@ -134,29 +140,31 @@ -- See #18202. -- See Note [The one-shot state monad trick] in GHC.Utils.Monad {-# COMPLETE FCode #-}-pattern FCode :: (CgInfoDownwards -> CgState -> (a, CgState))+pattern FCode :: (StgToCmmConfig -> FCodeState -> CgState -> (a, CgState))               -> FCode a pattern FCode m <- FCode' m   where-    FCode m = FCode' $ oneShot (\cgInfoDown -> oneShot (\state ->m cgInfoDown state))+    FCode m = FCode' $ oneShot (\cfg -> oneShot+                                 (\fstate -> oneShot+                                   (\state -> m cfg fstate state)))  instance Applicative FCode where-    pure val = FCode (\_info_down state -> (val, state))+    pure val = FCode (\_cfg _fstate state -> (val, state))     {-# INLINE pure #-}     (<*>) = ap  instance Monad FCode where     FCode m >>= k = FCode $-        \info_down state ->-            case m info_down state of+        \cfg fstate state ->+            case m cfg fstate state of               (m_result, new_state) ->                  case k m_result of-                   FCode kcode -> kcode info_down new_state+                   FCode kcode -> kcode cfg fstate new_state     {-# INLINE (>>=) #-}  instance MonadUnique FCode where   getUniqueSupplyM = cgs_uniqs <$> getState-  getUniqueM = FCode $ \_ st ->+  getUniqueM = FCode $ \_ _ st ->     let (u, us') = takeUniqFromSupply (cgs_uniqs st)     in (u, st { cgs_uniqs = us' }) @@ -164,36 +172,18 @@ initC  = do { uniqs <- mkSplitUniqSupply 'c'             ; return (initCgState uniqs) } -runC :: DynFlags -> Module -> CgState -> FCode a -> (a,CgState)-runC dflags mod st fcode = doFCode fcode (initCgInfoDown dflags mod) st+runC :: StgToCmmConfig -> FCodeState -> CgState -> FCode a -> (a, CgState)+runC cfg fst st fcode = doFCode fcode cfg fst st  fixC :: (a -> FCode a) -> FCode a fixC fcode = FCode $-    \info_down state -> let (v, s) = doFCode (fcode v) info_down state-                        in (v, s)+    \cfg fstate state ->+      let (v, s) = doFCode (fcode v) cfg fstate state+      in (v, s)  -------------------------------------------------------- --        The code generator environment ------------------------------------------------------------ This monadery has some information that it only passes--- *downwards*, as well as some ``state'' which is modified--- as we go along.--data CgInfoDownwards        -- information only passed *downwards* by the monad-  = MkCgInfoDown {-        cgd_dflags    :: DynFlags,-        cgd_mod       :: Module,            -- Module being compiled-        cgd_updfr_off :: UpdFrameOffset,    -- Size of current update frame-        cgd_ticky     :: CLabel,            -- Current destination for ticky counts-        cgd_sequel    :: Sequel,            -- What to do at end of basic block-        cgd_self_loop :: Maybe SelfLoopInfo,-- Which tail calls can be compiled-                                            -- as local jumps? See Note-                                            -- [Self-recursive tail calls] in-                                            -- GHC.StgToCmm.Expr-        cgd_tick_scope:: CmmTickScope       -- Tick scope for new blocks & ticks-  }- type CgBindings = IdEnv CgIdInfo  data CgIdInfo@@ -207,31 +197,13 @@   pdoc env (CgIdInfo { cg_id = id, cg_loc = loc })     = ppr id <+> text "-->" <+> pdoc env loc --- Sequel tells what to do with the result of this expression-data Sequel-  = Return              -- Return result(s) to continuation found on the stack.--  | AssignTo-        [LocalReg]      -- Put result(s) in these regs and fall through-                        -- NB: no void arguments here-                        ---        Bool            -- Should we adjust the heap pointer back to-                        -- recover space that's unused on this path?-                        -- We need to do this only if the expression-                        -- may allocate (e.g. it's a foreign call or-                        -- allocating primOp)--instance Outputable Sequel where-    ppr Return = text "Return"-    ppr (AssignTo regs b) = text "AssignTo" <+> ppr regs <+> ppr b- -- See Note [sharing continuations] below data ReturnKind   = AssignedDirectly   | ReturnedTo BlockId ByteOff  -- Note [sharing continuations]---+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- ReturnKind says how the expression being compiled returned its -- results: either by assigning directly to the registers specified -- by the Sequel, or by returning to a continuation that does the@@ -297,24 +269,6 @@ -- fall back to AssignedDirectly. -- --initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards-initCgInfoDown dflags mod-  = MkCgInfoDown { cgd_dflags    = dflags-                 , cgd_mod       = mod-                 , cgd_updfr_off = initUpdFrameOff (targetPlatform dflags)-                 , cgd_ticky     = mkTopTickyCtrLabel-                 , cgd_sequel    = initSequel-                 , cgd_self_loop = Nothing-                 , cgd_tick_scope= GlobalScope }--initSequel :: Sequel-initSequel = Return--initUpdFrameOff :: Platform -> UpdFrameOffset-initUpdFrameOff platform = platformWordSizeInBytes platform -- space for the RA-- -------------------------------------------------------- --        The code generator state --------------------------------------------------------@@ -337,6 +291,17 @@ -- the reason is the knot-tying in 'getHeapUsage'. This problem is tracked -- in #19245 +data FCodeState =+  MkFCodeState { fcs_upframeoffset :: UpdFrameOffset     -- ^ Size of current update frame UpdFrameOffset must be kept lazy or+                                                         -- else the RTS will deadlock _and_ also experience a severe+                                                         -- performance degredation+              , fcs_sequel        :: !Sequel             -- ^ What to do at end of basic block+              , fcs_selfloop      :: Maybe SelfLoopInfo  -- ^ Which tail calls can be compiled as local jumps?+                                                         --   See Note [Self-recursive tail calls] in GHC.StgToCmm.Expr+              , fcs_ticky         :: !CLabel             -- ^ Destination for ticky counts+              , fcs_tickscope     :: !CmmTickScope       -- ^ Tick scope for new blocks & ticks+              }+ data HeapUsage   -- See Note [Virtual and real heap pointers]   = HeapUsage {         virtHp :: VirtualHpOffset,       -- Virtual offset of highest-allocated word@@ -418,14 +383,14 @@ hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }  ----------------------------------------------------------- Operators for getting and setting the state and "info_down".+-- Operators for getting and setting the state and "stgToCmmConfig". --------------------------------------------------------  getState :: FCode CgState-getState = FCode $ \_info_down state -> (state, state)+getState = FCode $ \_cfg _fstate state -> (state, state)  setState :: CgState -> FCode ()-setState state = FCode $ \_info_down _ -> ((), state)+setState state = FCode $ \_cfg _fstate _ -> ((), state)  getHpUsage :: FCode HeapUsage getHpUsage = do@@ -462,9 +427,9 @@         state <- getState         setState $ state {cgs_binds = new_binds} -withState :: FCode a -> CgState -> FCode (a,CgState)-withState (FCode fcode) newstate = FCode $ \info_down state ->-  case fcode info_down newstate of+withCgState :: FCode a -> CgState -> FCode (a,CgState)+withCgState (FCode fcode) newstate = FCode $ \cfg fstate state ->+  case fcode cfg fstate newstate of     (retval, state2) -> ((retval,state2), state)  newUniqSupply :: FCode UniqSupply@@ -486,68 +451,41 @@                  ; return (LocalReg uniq rep) }  -------------------getInfoDown :: FCode CgInfoDownwards-getInfoDown = FCode $ \info_down state -> (info_down,state)+initFCodeState :: Platform -> FCodeState+initFCodeState p =+  MkFCodeState { fcs_upframeoffset = platformWordSizeInBytes p+               , fcs_sequel        = Return+               , fcs_selfloop      = Nothing+               , fcs_ticky         = mkTopTickyCtrLabel+               , fcs_tickscope     = GlobalScope+               } +getFCodeState :: FCode FCodeState+getFCodeState = FCode $ \_ fstate state -> (fstate,state)++-- basically local for the reader monad+withFCodeState :: FCode a -> FCodeState -> FCode a+withFCodeState (FCode fcode) fst = FCode $ \cfg _ state -> fcode cfg fst state+ getSelfLoop :: FCode (Maybe SelfLoopInfo)-getSelfLoop = do-        info_down <- getInfoDown-        return $ cgd_self_loop info_down+getSelfLoop = fcs_selfloop <$> getFCodeState  withSelfLoop :: SelfLoopInfo -> FCode a -> FCode a withSelfLoop self_loop code = do-        info_down <- getInfoDown-        withInfoDown code (info_down {cgd_self_loop = Just self_loop})--instance HasDynFlags FCode where-    getDynFlags = liftM cgd_dflags getInfoDown--getProfile :: FCode Profile-getProfile = targetProfile <$> getDynFlags--getPlatform :: FCode Platform-getPlatform = profilePlatform <$> getProfile--getCallOpts :: FCode CallOpts-getCallOpts = do-   dflags <- getDynFlags-   profile <- getProfile-   pure $ CallOpts-    { co_profile       = profile-    , co_loopification = gopt Opt_Loopification dflags-    , co_ticky         = gopt Opt_Ticky dflags-    }--getPtrOpts :: FCode PtrOpts-getPtrOpts = do-   dflags <- getDynFlags-   profile <- getProfile-   pure $ PtrOpts-      { po_profile     = profile-      , po_align_check = gopt Opt_AlignmentSanitisation dflags-      }---withInfoDown :: FCode a -> CgInfoDownwards -> FCode a-withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state---- ------------------------------------------------------------------------------- Get the current module name--getModuleName :: FCode Module-getModuleName = do { info <- getInfoDown; return (cgd_mod info) }+        fstate <- getFCodeState+        withFCodeState code (fstate {fcs_selfloop = Just self_loop})  -- ---------------------------------------------------------------------------- -- Get/set the end-of-block info  withSequel :: Sequel -> FCode a -> FCode a withSequel sequel code-  = do  { info  <- getInfoDown-        ; withInfoDown code (info {cgd_sequel = sequel, cgd_self_loop = Nothing }) }+  = do  { fstate <- getFCodeState+        ; withFCodeState code (fstate { fcs_sequel = sequel+                                      , fcs_selfloop = Nothing }) }  getSequel :: FCode Sequel-getSequel = do  { info <- getInfoDown-                ; return (cgd_sequel info) }+getSequel = fcs_sequel <$> getFCodeState  -- ---------------------------------------------------------------------------- -- Get/set the size of the update frame@@ -561,35 +499,29 @@  withUpdFrameOff :: UpdFrameOffset -> FCode a -> FCode a withUpdFrameOff size code-  = do  { info  <- getInfoDown-        ; withInfoDown code (info {cgd_updfr_off = size }) }+  = do  { fstate <- getFCodeState+        ; withFCodeState code (fstate {fcs_upframeoffset = size }) }  getUpdFrameOff :: FCode UpdFrameOffset-getUpdFrameOff-  = do  { info  <- getInfoDown-        ; return $ cgd_updfr_off info }+getUpdFrameOff = fcs_upframeoffset <$> getFCodeState  -- ---------------------------------------------------------------------------- -- Get/set the current ticky counter label  getTickyCtrLabel :: FCode CLabel-getTickyCtrLabel = do-        info <- getInfoDown-        return (cgd_ticky info)+getTickyCtrLabel = fcs_ticky <$> getFCodeState  setTickyCtrLabel :: CLabel -> FCode a -> FCode a setTickyCtrLabel ticky code = do-        info <- getInfoDown-        withInfoDown code (info {cgd_ticky = ticky})+        fstate <- getFCodeState+        withFCodeState code (fstate {fcs_ticky = ticky})  -- ---------------------------------------------------------------------------- -- Manage tick scopes  -- | The current tick scope. We will assign this to generated blocks. getTickScope :: FCode CmmTickScope-getTickScope = do-        info <- getInfoDown-        return (cgd_tick_scope info)+getTickScope = fcs_tickscope <$> getFCodeState  -- | Places blocks generated by the given code into a fresh -- (sub-)scope. This will make sure that Cmm annotations in our scope@@ -597,13 +529,35 @@ -- way around. tickScope :: FCode a -> FCode a tickScope code = do-        info <- getInfoDown-        if debugLevel (cgd_dflags info) == 0 then code else do+        cfg <- getStgToCmmConfig+        fstate <- getFCodeState+        if stgToCmmDebugLevel cfg == 0 then code else do           u <- newUnique-          let scope' = SubScope u (cgd_tick_scope info)-          withInfoDown code info{ cgd_tick_scope = scope' }+          let scope' = SubScope u (fcs_tickscope fstate)+          withFCodeState code fstate{ fcs_tickscope = scope' } +-- ----------------------------------------------------------------------------+-- Config related helpers +getStgToCmmConfig :: FCode StgToCmmConfig+getStgToCmmConfig = FCode $ \cfg _ state -> (cfg,state)++getProfile :: FCode Profile+getProfile = stgToCmmProfile <$> getStgToCmmConfig++getPlatform :: FCode Platform+getPlatform = profilePlatform <$> getProfile++getContext :: FCode SDocContext+getContext = stgToCmmContext <$> getStgToCmmConfig++-- ----------------------------------------------------------------------------+-- Get the current module name++getModuleName :: FCode Module+getModuleName = stgToCmmThisModule <$> getStgToCmmConfig++ -------------------------------------------------------- --                 Forking --------------------------------------------------------@@ -618,14 +572,16 @@  forkClosureBody body_code   = do  { platform <- getPlatform-        ; info   <- getInfoDown-        ; us     <- newUniqSupply-        ; state  <- getState-        ; let body_info_down = info { cgd_sequel    = initSequel-                                    , cgd_updfr_off = initUpdFrameOff platform-                                    , cgd_self_loop = Nothing }+        ; cfg      <- getStgToCmmConfig+        ; fstate   <- getFCodeState+        ; us       <- newUniqSupply+        ; state    <- getState+        ; let fcs = fstate { fcs_sequel        = Return+                           , fcs_upframeoffset = platformWordSizeInBytes platform+                           , fcs_selfloop      = Nothing+                           }               fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }-              ((),fork_state_out) = doFCode body_code body_info_down fork_state_in+              ((),fork_state_out) = doFCode body_code cfg fcs fork_state_in         ; setState $ state `addCodeBlocksFrom` fork_state_out }  forkLneBody :: FCode a -> FCode a@@ -636,11 +592,12 @@ -- the successor.  In particular, any heap usage from the enclosed -- code is discarded; it should deal with its own heap consumption. forkLneBody body_code-  = do  { info_down <- getInfoDown-        ; us        <- newUniqSupply-        ; state     <- getState+  = do  { cfg   <- getStgToCmmConfig+        ; us    <- newUniqSupply+        ; state <- getState+        ; fstate <- getFCodeState         ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }-              (result, fork_state_out) = doFCode body_code info_down fork_state_in+              (result, fork_state_out) = doFCode body_code cfg fstate fork_state_in         ; setState $ state `addCodeBlocksFrom` fork_state_out         ; return result } @@ -649,12 +606,13 @@ -- Do not affect anything else in the outer state -- Used in almost-circular code to prevent false loop dependencies codeOnly body_code-  = do  { info_down <- getInfoDown-        ; us        <- newUniqSupply-        ; state     <- getState+  = do  { cfg   <- getStgToCmmConfig+        ; us    <- newUniqSupply+        ; state <- getState+        ; fstate <- getFCodeState         ; let   fork_state_in = (initCgState us) { cgs_binds   = cgs_binds state                                                  , cgs_hp_usg  = cgs_hp_usg state }-                ((), fork_state_out) = doFCode body_code info_down fork_state_in+                ((), fork_state_out) = doFCode body_code cfg fstate fork_state_in         ; setState $ state `addCodeBlocksFrom` fork_state_out }  forkAlts :: [FCode a] -> FCode [a]@@ -664,11 +622,12 @@ -- that the virtual Hp is moved on to the worst virtual Hp for the branches  forkAlts branch_fcodes-  = do  { info_down <- getInfoDown-        ; us <- newUniqSupply+  = do  { cfg   <- getStgToCmmConfig+        ; us    <- newUniqSupply         ; state <- getState+        ; fstate <- getFCodeState         ; let compile us branch-                = (us2, doFCode branch info_down branch_state)+                = (us2, doFCode branch cfg fstate branch_state)                 where                   (us1,us2) = splitUniqSupply us                   branch_state = (initCgState us1) {@@ -693,7 +652,7 @@ getCodeR :: FCode a -> FCode (a, CmmAGraph) getCodeR fcode   = do  { state1 <- getState-        ; (a, state2) <- withState fcode (state1 { cgs_stmts = mkNop })+        ; (a, state2) <- withCgState fcode (state1 { cgs_stmts = mkNop })         ; setState $ state2 { cgs_stmts = cgs_stmts state1  }         ; return (a, cgs_stmts state2) } @@ -706,7 +665,7 @@   = do  { state1 <- getState         ; ((a, tscope), state2) <-             tickScope $-            flip withState state1 { cgs_stmts = mkNop } $+            flip withCgState state1 { cgs_stmts = mkNop } $             do { a   <- fcode                ; scp <- getTickScope                ; return (a, scp) }@@ -725,10 +684,11 @@  getHeapUsage :: (VirtualHpOffset -> FCode a) -> FCode a getHeapUsage fcode-  = do  { info_down <- getInfoDown+  = do  { cfg <- getStgToCmmConfig         ; state <- getState+        ; fcstate <- getFCodeState         ; let   fstate_in = state { cgs_hp_usg  = initHpUsage }-                (r, fstate_out) = doFCode (fcode hp_hw) info_down fstate_in+                (r, fstate_out) = doFCode (fcode hp_hw) cfg fcstate fstate_in                 hp_hw = heapHWM (cgs_hp_usg fstate_out)        -- Loop here!          ; setState $ fstate_out { cgs_hp_usg = cgs_hp_usg state }@@ -757,8 +717,8 @@  emitUnwind :: [(GlobalReg, Maybe CmmExpr)] -> FCode () emitUnwind regs = do-  dflags <- getDynFlags-  when (debugLevel dflags > 0) $+  debug_level <- stgToCmmDebugLevel <$> getStgToCmmConfig+  when (debug_level > 0) $      emitCgStmt $ CgStmt $ CmmUnwind regs  emitAssign :: CmmReg  -> CmmExpr -> FCode ()@@ -842,7 +802,7 @@ -- object splitting (at a later stage) getCmm code   = do  { state1 <- getState-        ; (a, state2) <- withState code (state1 { cgs_tops  = nilOL })+        ; (a, state2) <- withCgState code (state1 { cgs_tops  = nilOL })         ; setState $ state2 { cgs_tops = cgs_tops state1 }         ; return (a, fromOL (cgs_tops state2)) }
compiler/GHC/StgToCmm/Prim.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}@@ -16,14 +15,12 @@    shouldInlinePrimOp  ) where -#include "GhclibHsVersions.h"-#include "MachDeps.h"- import GHC.Prelude hiding ((<*>))  import GHC.Platform import GHC.Platform.Profile +import GHC.StgToCmm.Config import GHC.StgToCmm.Layout import GHC.StgToCmm.Foreign import GHC.StgToCmm.Monad@@ -32,26 +29,27 @@ import GHC.StgToCmm.Heap import GHC.StgToCmm.Prof ( costCentreFrom ) -import GHC.Driver.Session-import GHC.Driver.Backend import GHC.Types.Basic import GHC.Cmm.BlockId import GHC.Cmm.Graph import GHC.Stg.Syntax import GHC.Cmm import GHC.Unit         ( rtsUnit )-import GHC.Core.Type    ( Type, tyConAppTyCon )+import GHC.Core.Type    ( Type, tyConAppTyCon_maybe ) import GHC.Core.TyCon import GHC.Cmm.CLabel+import GHC.Cmm.Info     ( closureInfoPtr ) import GHC.Cmm.Utils import GHC.Builtin.PrimOps import GHC.Runtime.Heap.Layout import GHC.Data.FastString import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import Data.Maybe  import Control.Monad (liftM, when, unless)+import GHC.Utils.Outputable  ------------------------------------------------------------------------ --      Primitive operations and foreign calls@@ -76,21 +74,21 @@ -- Foreign calls cgOpApp (StgFCallOp fcall ty) stg_args res_ty   = cgForeignCall fcall ty stg_args res_ty-      -- Note [Foreign call results]+      -- See Note [Foreign call results]  cgOpApp (StgPrimOp primop) args res_ty = do-    dflags <- getDynFlags+    cfg <- getStgToCmmConfig     cmm_args <- getNonVoidArgAmodes args-    cmmPrimOpApp dflags primop cmm_args (Just res_ty)+    cmmPrimOpApp cfg primop cmm_args (Just res_ty)  cgOpApp (StgPrimCallOp primcall) args _res_ty   = do  { cmm_args <- getNonVoidArgAmodes args         ; let fun = CmmLit (CmmLabel (mkPrimCallLabel primcall))         ; emitCall (NativeNodeCall, NativeReturn) fun cmm_args } -cmmPrimOpApp :: DynFlags -> PrimOp -> [CmmExpr] -> Maybe Type -> FCode ReturnKind-cmmPrimOpApp dflags primop cmm_args mres_ty =-  case emitPrimOp dflags primop cmm_args of+cmmPrimOpApp :: StgToCmmConfig -> PrimOp -> [CmmExpr] -> Maybe Type -> FCode ReturnKind+cmmPrimOpApp cfg primop cmm_args mres_ty =+  case emitPrimOp cfg primop cmm_args of     PrimopCmmEmit_Internal f ->       let          -- if the result type isn't explicitly given, we directly use the@@ -121,8 +119,8 @@ --      Emitting code for a primop ------------------------------------------------------------------------ -shouldInlinePrimOp :: DynFlags -> PrimOp -> [CmmExpr] -> Bool-shouldInlinePrimOp dflags op args = case emitPrimOp dflags op args of+shouldInlinePrimOp :: StgToCmmConfig -> PrimOp -> [CmmExpr] -> Bool+shouldInlinePrimOp cfg op args = case emitPrimOp cfg op args of   PrimopCmmEmit_External -> False   PrimopCmmEmit_Internal _ -> True @@ -145,20 +143,22 @@ -- might happen e.g. if there's enough static information, such as statically -- know arguments. emitPrimOp-  :: DynFlags+  :: StgToCmmConfig   -> PrimOp            -- ^ The primop   -> [CmmExpr]         -- ^ The primop arguments   -> PrimopCmmEmit-emitPrimOp dflags primop = case primop of+emitPrimOp cfg primop =+  let max_inl_alloc_size = fromIntegral (stgToCmmMaxInlAllocSize cfg)+  in case primop of   NewByteArrayOp_Char -> \case     [(CmmLit (CmmInt n w))]-      | asUnsigned w n <= fromIntegral (maxInlineAllocSize dflags)+      | asUnsigned w n <= max_inl_alloc_size       -> opIntoRegs  $ \ [res] -> doNewByteArrayOp res (fromInteger n)     _ -> PrimopCmmEmit_External    NewArrayOp -> \case     [(CmmLit (CmmInt n w)), init]-      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size       -> opIntoRegs $ \[res] -> doNewArrayOp res (arrPtrsRep platform (fromInteger n)) mkMAP_DIRTY_infoLabel         [ (mkIntExpr platform (fromInteger n),            fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform))@@ -178,43 +178,33 @@       opIntoRegs $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n)     _ -> PrimopCmmEmit_External -  CopyArrayArrayOp -> \case-    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->-      opIntoRegs $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n)-    _ -> PrimopCmmEmit_External--  CopyMutableArrayArrayOp -> \case-    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->-      opIntoRegs $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n)-    _ -> PrimopCmmEmit_External-   CloneArrayOp -> \case     [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size       -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)     _ -> PrimopCmmEmit_External    CloneMutableArrayOp -> \case     [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size       -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)     _ -> PrimopCmmEmit_External    FreezeArrayOp -> \case     [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size       -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)     _ -> PrimopCmmEmit_External    ThawArrayOp -> \case     [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size       -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)     _ -> PrimopCmmEmit_External    NewSmallArrayOp -> \case     [(CmmLit (CmmInt n w)), init]-      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size       -> opIntoRegs $ \ [res] ->         doNewArrayOp res (smallArrPtrsRep (fromInteger n)) mkSMAP_DIRTY_infoLabel         [ (mkIntExpr platform (fromInteger n),@@ -235,25 +225,25 @@    CloneSmallArrayOp -> \case     [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size       -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)     _ -> PrimopCmmEmit_External    CloneSmallMutableArrayOp -> \case     [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size       -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)     _ -> PrimopCmmEmit_External    FreezeSmallArrayOp -> \case     [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size       -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)     _ -> PrimopCmmEmit_External    ThawSmallArrayOp -> \case     [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size       -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)     _ -> PrimopCmmEmit_External @@ -306,11 +296,17 @@     -- MutVar's value.     emitPrimCall res MO_WriteBarrier []     emitStore (cmmOffsetW platform mutv (fixedHdrSizeW profile)) var-    emitCCall-            [{-no results-}]-            (CmmLit (CmmLabel mkDirty_MUT_VAR_Label))-            [(baseExpr, AddrHint), (mutv, AddrHint), (CmmReg old_val, AddrHint)] +    platform <- getPlatform+    mkdirtyMutVarCCall <- getCode $! emitCCall+      [{-no results-}]+      (CmmLit (CmmLabel mkDirty_MUT_VAR_Label))+      [(baseExpr, AddrHint), (mutv, AddrHint), (CmmReg old_val, AddrHint)]+    emit =<< mkCmmIfThen+      (cmmEqWord platform (mkLblExpr mkMUT_VAR_CLEAN_infoLabel)+       (closureInfoPtr platform (stgToCmmAlignCheck cfg) mutv))+      mkdirtyMutVarCCall+ --  #define sizzeofByteArrayzh(r,a) \ --     r = ((StgArrBytes *)(a))->bytes   SizeofByteArrayOp -> \[arg] -> opIntoRegs $ \[res] ->@@ -318,7 +314,7 @@  --  #define sizzeofMutableByteArrayzh(r,a) \ --      r = ((StgArrBytes *)(a))->bytes-  SizeofMutableByteArrayOp -> emitPrimOp dflags SizeofByteArrayOp+  SizeofMutableByteArrayOp -> emitPrimOp cfg SizeofByteArrayOp  --  #define getSizzeofMutableByteArrayzh(r,a) \ --      r = ((StgArrBytes *)(a))->bytes@@ -342,6 +338,8 @@   StableNameToIntOp -> \[arg] -> opIntoRegs $ \[res] ->     emitAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile) (bWord platform)) +  EqStablePtrOp -> \args -> opTranslate args (mo_wordEq platform)+   ReallyUnsafePtrEqualityOp -> \[arg1, arg2] -> opIntoRegs $ \[res] ->     emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq platform) [arg1,arg2]) @@ -367,10 +365,6 @@     emit $ catAGraphs       [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)),         mkAssign (CmmLocal res) arg ]-  UnsafeFreezeArrayArrayOp -> \[arg] -> opIntoRegs $ \[res] ->-    emit $ catAGraphs-      [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)),-        mkAssign (CmmLocal res) arg ]   UnsafeFreezeSmallArrayOp -> \[arg] -> opIntoRegs $ \[res] ->     emit $ catAGraphs       [ setInfo arg (CmmLit (CmmLabel mkSMAP_FROZEN_DIRTY_infoLabel)),@@ -389,27 +383,6 @@   WriteArrayOp -> \[obj, ix, v] -> opIntoRegs $ \[] ->     doWritePtrArrayOp obj ix v -  IndexArrayArrayOp_ByteArray -> \[obj, ix] -> opIntoRegs $ \[res] ->-    doReadPtrArrayOp res obj ix-  IndexArrayArrayOp_ArrayArray -> \[obj, ix] -> opIntoRegs $ \[res] ->-    doReadPtrArrayOp res obj ix-  ReadArrayArrayOp_ByteArray -> \[obj, ix] -> opIntoRegs $ \[res] ->-    doReadPtrArrayOp res obj ix-  ReadArrayArrayOp_MutableByteArray -> \[obj, ix] -> opIntoRegs $ \[res] ->-    doReadPtrArrayOp res obj ix-  ReadArrayArrayOp_ArrayArray -> \[obj, ix] -> opIntoRegs $ \[res] ->-    doReadPtrArrayOp res obj ix-  ReadArrayArrayOp_MutableArrayArray -> \[obj, ix] -> opIntoRegs $ \[res] ->-    doReadPtrArrayOp res obj ix-  WriteArrayArrayOp_ByteArray -> \[obj,ix,v] -> opIntoRegs $ \[] ->-    doWritePtrArrayOp obj ix v-  WriteArrayArrayOp_MutableByteArray -> \[obj,ix,v] -> opIntoRegs $ \[] ->-    doWritePtrArrayOp obj ix v-  WriteArrayArrayOp_ArrayArray -> \[obj,ix,v] -> opIntoRegs $ \[] ->-    doWritePtrArrayOp obj ix v-  WriteArrayArrayOp_MutableArrayArray -> \[obj,ix,v] -> opIntoRegs $ \[] ->-    doWritePtrArrayOp obj ix v-   ReadSmallArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] ->     doReadSmallPtrArrayOp res obj ix   IndexSmallArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] ->@@ -423,17 +396,15 @@     emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg       (fixedHdrSizeW profile + bytesToWordsRoundUp platform (pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform)))         (bWord platform))-  SizeofMutableArrayOp -> emitPrimOp dflags SizeofArrayOp-  SizeofArrayArrayOp -> emitPrimOp dflags SizeofArrayOp-  SizeofMutableArrayArrayOp -> emitPrimOp dflags SizeofArrayOp+  SizeofMutableArrayOp      -> emitPrimOp cfg SizeofArrayOp   SizeofSmallArrayOp -> \[arg] -> opIntoRegs $ \[res] ->     emit $ mkAssign (CmmLocal res)      (cmmLoadIndexW platform arg      (fixedHdrSizeW profile + bytesToWordsRoundUp platform (pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform)))         (bWord platform)) -  SizeofSmallMutableArrayOp -> emitPrimOp dflags SizeofSmallArrayOp-  GetSizeofSmallMutableArrayOp -> emitPrimOp dflags SizeofSmallArrayOp+  SizeofSmallMutableArrayOp    -> emitPrimOp cfg SizeofSmallArrayOp+  GetSizeofSmallMutableArrayOp -> emitPrimOp cfg SizeofSmallArrayOp  -- IndexXXXoffAddr @@ -870,10 +841,18 @@     emitPrimCall [res] (MO_Cmpxchg (wordWidth platform)) [dst, expected, new]   CasAddrOp_Word -> \[dst, expected, new] -> opIntoRegs $ \[res] ->     emitPrimCall [res] (MO_Cmpxchg (wordWidth platform)) [dst, expected, new]+  CasAddrOp_Word8 -> \[dst, expected, new] -> opIntoRegs $ \[res] ->+    emitPrimCall [res] (MO_Cmpxchg W8) [dst, expected, new]+  CasAddrOp_Word16 -> \[dst, expected, new] -> opIntoRegs $ \[res] ->+    emitPrimCall [res] (MO_Cmpxchg W16) [dst, expected, new]+  CasAddrOp_Word32 -> \[dst, expected, new] -> opIntoRegs $ \[res] ->+    emitPrimCall [res] (MO_Cmpxchg W32) [dst, expected, new]+  CasAddrOp_Word64 -> \[dst, expected, new] -> opIntoRegs $ \[res] ->+    emitPrimCall [res] (MO_Cmpxchg W64) [dst, expected, new]  -- SIMD primops   (VecBroadcastOp vcat n w) -> \[e] -> opIntoRegs $ \[res] -> do-    checkVecCompatibility dflags vcat n w+    checkVecCompatibility cfg vcat n w     doVecPackOp (vecElemInjectCast platform vcat w) ty zeros (replicate n e) res    where     zeros :: CmmExpr@@ -889,7 +868,7 @@     ty = vecVmmType vcat n w    (VecPackOp vcat n w) -> \es -> opIntoRegs $ \[res] -> do-    checkVecCompatibility dflags vcat n w+    checkVecCompatibility cfg vcat n w     when (es `lengthIsNot` n) $         panic "emitPrimOp: VecPackOp has wrong number of arguments"     doVecPackOp (vecElemInjectCast platform vcat w) ty zeros es res@@ -907,7 +886,7 @@     ty = vecVmmType vcat n w    (VecUnpackOp vcat n w) -> \[arg] -> opIntoRegs $ \res -> do-    checkVecCompatibility dflags vcat n w+    checkVecCompatibility cfg vcat n w     when (res `lengthIsNot` n) $         panic "emitPrimOp: VecUnpackOp has wrong number of results"     doVecUnpackOp (vecElemProjectCast platform vcat w) ty arg res@@ -916,56 +895,56 @@     ty = vecVmmType vcat n w    (VecInsertOp vcat n w) -> \[v,e,i] -> opIntoRegs $ \[res] -> do-    checkVecCompatibility dflags vcat n w+    checkVecCompatibility cfg vcat n w     doVecInsertOp (vecElemInjectCast platform vcat w) ty v e i res    where     ty :: CmmType     ty = vecVmmType vcat n w    (VecIndexByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility dflags vcat n w+    checkVecCompatibility cfg vcat n w     doIndexByteArrayOp Nothing ty res0 args    where     ty :: CmmType     ty = vecVmmType vcat n w    (VecReadByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility dflags vcat n w+    checkVecCompatibility cfg vcat n w     doIndexByteArrayOp Nothing ty res0 args    where     ty :: CmmType     ty = vecVmmType vcat n w    (VecWriteByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility dflags vcat n w+    checkVecCompatibility cfg vcat n w     doWriteByteArrayOp Nothing ty res0 args    where     ty :: CmmType     ty = vecVmmType vcat n w    (VecIndexOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility dflags vcat n w+    checkVecCompatibility cfg vcat n w     doIndexOffAddrOp Nothing ty res0 args    where     ty :: CmmType     ty = vecVmmType vcat n w    (VecReadOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility dflags vcat n w+    checkVecCompatibility cfg vcat n w     doIndexOffAddrOp Nothing ty res0 args    where     ty :: CmmType     ty = vecVmmType vcat n w    (VecWriteOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility dflags vcat n w+    checkVecCompatibility cfg vcat n w     doWriteOffAddrOp Nothing ty res0 args    where     ty :: CmmType     ty = vecVmmType vcat n w    (VecIndexScalarByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility dflags vcat n w+    checkVecCompatibility cfg vcat n w     doIndexByteArrayOpAs Nothing vecty ty res0 args    where     vecty :: CmmType@@ -975,7 +954,7 @@     ty = vecCmmCat vcat w    (VecReadScalarByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility dflags vcat n w+    checkVecCompatibility cfg vcat n w     doIndexByteArrayOpAs Nothing vecty ty res0 args    where     vecty :: CmmType@@ -985,14 +964,14 @@     ty = vecCmmCat vcat w    (VecWriteScalarByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility dflags vcat n w+    checkVecCompatibility cfg vcat n w     doWriteByteArrayOp Nothing ty res0 args    where     ty :: CmmType     ty = vecCmmCat vcat w    (VecIndexScalarOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility dflags vcat n w+    checkVecCompatibility cfg vcat n w     doIndexOffAddrOpAs Nothing vecty ty res0 args    where     vecty :: CmmType@@ -1002,7 +981,7 @@     ty = vecCmmCat vcat w    (VecReadScalarOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility dflags vcat n w+    checkVecCompatibility cfg vcat n w     doIndexOffAddrOpAs Nothing vecty ty res0 args    where     vecty :: CmmType@@ -1012,7 +991,7 @@     ty = vecCmmCat vcat w    (VecWriteScalarOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility dflags vcat n w+    checkVecCompatibility cfg vcat n w     doWriteOffAddrOp Nothing ty res0 args    where     ty :: CmmType@@ -1073,6 +1052,14 @@     doAtomicWriteByteArray mba ix (bWord platform) val   CasByteArrayOp_Int -> \[mba, ix, old, new] -> opIntoRegs $ \[res] ->     doCasByteArray res mba ix (bWord platform) old new+  CasByteArrayOp_Int8 -> \[mba, ix, old, new] -> opIntoRegs $ \[res] ->+    doCasByteArray res mba ix b8 old new+  CasByteArrayOp_Int16 -> \[mba, ix, old, new] -> opIntoRegs $ \[res] ->+    doCasByteArray res mba ix b16 old new+  CasByteArrayOp_Int32 -> \[mba, ix, old, new] -> opIntoRegs $ \[res] ->+    doCasByteArray res mba ix b32 old new+  CasByteArrayOp_Int64 -> \[mba, ix, old, new] -> opIntoRegs $ \[res] ->+    doCasByteArray res mba ix b64 old new  -- The rest just translate straightforwardly @@ -1082,10 +1069,8 @@   Word16ToInt16Op -> \args -> opNop args   Int32ToWord32Op -> \args -> opNop args   Word32ToInt32Op -> \args -> opNop args-#if WORD_SIZE_IN_BITS < 64   Int64ToWord64Op -> \args -> opNop args   Word64ToInt64Op -> \args -> opNop args-#endif   IntToWordOp     -> \args -> opNop args   WordToIntOp     -> \args -> opNop args   IntToAddrOp     -> \args -> opNop args@@ -1338,7 +1323,6 @@   Word32LtOp     -> \args -> opTranslate args (MO_U_Lt W32)   Word32NeOp     -> \args -> opTranslate args (MO_Ne W32) -#if WORD_SIZE_IN_BITS < 64 -- Int64# signed ops    Int64ToIntOp   -> \args -> opTranslate64 args (\w -> MO_SS_Conv w (wordWidth platform)) MO_I64_ToI@@ -1384,7 +1368,6 @@   Word64LeOp     -> \args -> opTranslate64 args MO_U_Le   MO_W64_Le   Word64LtOp     -> \args -> opTranslate64 args MO_U_Lt   MO_W64_Lt   Word64NeOp     -> \args -> opTranslate64 args MO_Ne     MO_x64_Ne-#endif  -- Char# ops @@ -1462,107 +1445,93 @@   FloatToDoubleOp -> \args -> opTranslate args (MO_FF_Conv W32 W64)   DoubleToFloatOp -> \args -> opTranslate args (MO_FF_Conv W64 W32) --- Word comparisons masquerading as more exotic things.--  SameMutVarOp            -> \args -> opTranslate args (mo_wordEq platform)-  SameMVarOp              -> \args -> opTranslate args (mo_wordEq platform)-  SameIOPortOp            -> \args -> opTranslate args (mo_wordEq platform)-  SameMutableArrayOp      -> \args -> opTranslate args (mo_wordEq platform)-  SameMutableByteArrayOp  -> \args -> opTranslate args (mo_wordEq platform)-  SameMutableArrayArrayOp -> \args -> opTranslate args (mo_wordEq platform)-  SameSmallMutableArrayOp -> \args -> opTranslate args (mo_wordEq platform)-  SameTVarOp              -> \args -> opTranslate args (mo_wordEq platform)-  EqStablePtrOp           -> \args -> opTranslate args (mo_wordEq platform)--- See Note [Comparing stable names]-  EqStableNameOp          -> \args -> opTranslate args (mo_wordEq platform)-   IntQuotRemOp -> \args -> opCallishHandledLater args $-    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)+    if allowQuotRem && not (quotRemCanBeOptimized args)     then Left (MO_S_QuotRem  (wordWidth platform))     else Right (genericIntQuotRemOp (wordWidth platform))    Int8QuotRemOp -> \args -> opCallishHandledLater args $-    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)+    if allowQuotRem && not (quotRemCanBeOptimized args)     then Left (MO_S_QuotRem W8)     else Right (genericIntQuotRemOp W8)    Int16QuotRemOp -> \args -> opCallishHandledLater args $-    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)+    if allowQuotRem && not (quotRemCanBeOptimized args)     then Left (MO_S_QuotRem W16)     else Right (genericIntQuotRemOp W16)    Int32QuotRemOp -> \args -> opCallishHandledLater args $-    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)+    if allowQuotRem && not (quotRemCanBeOptimized args)     then Left (MO_S_QuotRem W32)     else Right (genericIntQuotRemOp W32)    WordQuotRemOp -> \args -> opCallishHandledLater args $-    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)+    if allowQuotRem && not (quotRemCanBeOptimized args)     then Left (MO_U_QuotRem  (wordWidth platform))     else Right (genericWordQuotRemOp (wordWidth platform))    WordQuotRem2Op -> \args -> opCallishHandledLater args $-    if (ncg && (x86ish || ppc)) || llvm+    if allowQuotRem2     then Left (MO_U_QuotRem2 (wordWidth platform))     else Right (genericWordQuotRem2Op platform)    Word8QuotRemOp -> \args -> opCallishHandledLater args $-    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)+    if allowQuotRem && not (quotRemCanBeOptimized args)     then Left (MO_U_QuotRem W8)     else Right (genericWordQuotRemOp W8)    Word16QuotRemOp -> \args -> opCallishHandledLater args $-    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)+    if allowQuotRem && not (quotRemCanBeOptimized args)     then Left (MO_U_QuotRem W16)     else Right (genericWordQuotRemOp W16)    Word32QuotRemOp -> \args -> opCallishHandledLater args $-    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)+    if allowQuotRem && not (quotRemCanBeOptimized args)     then Left (MO_U_QuotRem W32)     else Right (genericWordQuotRemOp W32)    WordAdd2Op -> \args -> opCallishHandledLater args $-    if (ncg && (x86ish || ppc)) || llvm+    if allowExtAdd     then Left (MO_Add2       (wordWidth platform))     else Right genericWordAdd2Op    WordAddCOp -> \args -> opCallishHandledLater args $-    if (ncg && (x86ish || ppc)) || llvm+    if allowExtAdd     then Left (MO_AddWordC   (wordWidth platform))     else Right genericWordAddCOp    WordSubCOp -> \args -> opCallishHandledLater args $-    if (ncg && (x86ish || ppc)) || llvm+    if allowExtAdd     then Left (MO_SubWordC   (wordWidth platform))     else Right genericWordSubCOp    IntAddCOp -> \args -> opCallishHandledLater args $-    if (ncg && (x86ish || ppc)) || llvm+    if allowExtAdd     then Left (MO_AddIntC    (wordWidth platform))     else Right genericIntAddCOp    IntSubCOp -> \args -> opCallishHandledLater args $-    if (ncg && (x86ish || ppc)) || llvm+    if allowExtAdd     then Left (MO_SubIntC    (wordWidth platform))     else Right genericIntSubCOp    WordMul2Op -> \args -> opCallishHandledLater args $-    if ncg && (x86ish || ppc) || llvm+    if allowExtAdd     then Left (MO_U_Mul2     (wordWidth platform))     else Right genericWordMul2Op    IntMul2Op  -> \args -> opCallishHandledLater args $-    if ncg && x86ish || llvm+    if allowInt2Mul     then Left (MO_S_Mul2     (wordWidth platform))     else Right genericIntMul2Op    FloatFabsOp -> \args -> opCallishHandledLater args $-    if (ncg && (x86ish || ppc || aarch64)) || llvm+    if allowFab     then Left MO_F32_Fabs     else Right $ genericFabsOp W32    DoubleFabsOp -> \args -> opCallishHandledLater args $-    if (ncg && (x86ish || ppc || aarch64)) || llvm+    if allowFab     then Left MO_F64_Fabs     else Right $ genericFabsOp W64 @@ -1574,8 +1543,8 @@     -- you used tagToEnum# in a non-monomorphic setting, e.g.,     --         intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x#     -- That won't work.-    let tycon = tyConAppTyCon res_ty-    MASSERT(isEnumerationTyCon tycon)+    let tycon = fromMaybe (pprPanic "tagToEnum#: Applied to non-concrete type" (ppr res_ty)) (tyConAppTyCon_maybe res_ty)+    massert (isEnumerationTyCon tycon)     platform <- getPlatform     pure [tagToClosure platform tycon amode] @@ -1596,7 +1565,6 @@   ShrinkMutableByteArrayOp_Char -> alwaysExternal   ResizeMutableByteArrayOp_Char -> alwaysExternal   ShrinkSmallMutableArrayOp_Char -> alwaysExternal-  NewArrayArrayOp -> alwaysExternal   NewMutVarOp -> alwaysExternal   AtomicModifyMutVar2Op -> alwaysExternal   AtomicModifyMutVar_Op -> alwaysExternal@@ -1624,7 +1592,7 @@   ReadMVarOp -> alwaysExternal   TryReadMVarOp -> alwaysExternal   IsEmptyMVarOp -> alwaysExternal-  NewIOPortrOp -> alwaysExternal+  NewIOPortOp -> alwaysExternal   ReadIOPortOp -> alwaysExternal   WriteIOPortOp -> alwaysExternal   DelayOp -> alwaysExternal@@ -1675,8 +1643,8 @@   KeepAliveOp -> alwaysExternal   where-  profile = targetProfile dflags-  platform = profilePlatform profile+  profile  = stgToCmmProfile  cfg+  platform = stgToCmmPlatform cfg   result_info = getPrimOpResultInfo primop    opNop :: [CmmExpr] -> PrimopCmmEmit@@ -1691,7 +1659,7 @@     CmmMachOp (mop rep (wordWidth platform)) [CmmMachOp (mop (wordWidth platform) rep) [arg]]     where [arg] = args -  -- | These primops are implemented by CallishMachOps, because they sometimes+  -- These primops are implemented by CallishMachOps, because they sometimes   -- turn into foreign calls depending on the backend.   opCallish :: [CmmExpr] -> CallishMachOp -> PrimopCmmEmit   opCallish args prim = opIntoRegs $ \[res] -> emitPrimCall [res] prim args@@ -1701,7 +1669,6 @@     let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args)     emit stmt -#if WORD_SIZE_IN_BITS < 64   opTranslate64     :: [CmmExpr]     -> (Width -> MachOp)@@ -1710,12 +1677,11 @@   opTranslate64 args mkMop callish =     case platformWordSize platform of       -- LLVM and C `can handle larger than native size arithmetic natively.-      _ | not ncg -> opTranslate args $ mkMop W64+      _ | stgToCmmAllowBigArith cfg -> opTranslate args $ mkMop W64       PW4 -> opCallish args callish       PW8 -> opTranslate args $ mkMop W64-#endif -  -- | Basically a "manual" case, rather than one of the common repetitive forms+  -- Basically a "manual" case, rather than one of the common repetitive forms   -- above. The results are a parameter to the returned function so we know the   -- choice of variant never depends on them.   opCallishHandledLater@@ -1748,7 +1714,6 @@   alwaysExternal = \_ -> PrimopCmmEmit_External   -- Note [QuotRem optimization]   -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~-  --   -- `quot` and `rem` with constant divisor can be implemented with fast bit-ops   -- (shift, .&.).   --@@ -1765,17 +1730,11 @@     [_, CmmLit (CmmInt n _) ] -> isJust (exactLog2 n)     _                         -> False -  ncg  = backend dflags == NCG-  llvm = backend dflags == LLVM-  x86ish = case platformArch platform of-             ArchX86    -> True-             ArchX86_64 -> True-             _          -> False-  ppc = case platformArch platform of-          ArchPPC      -> True-          ArchPPC_64 _ -> True-          _            -> False-  aarch64 = platformArch platform == ArchAArch64+  allowQuotRem  = stgToCmmAllowQuotRemInstr         cfg+  allowQuotRem2 = stgToCmmAllowQuotRem2             cfg+  allowExtAdd   = stgToCmmAllowExtendedAddSubInstrs cfg+  allowInt2Mul  = stgToCmmAllowIntMul2Instr         cfg+  allowFab      = stgToCmmAllowFabsInstrs           cfg  data PrimopCmmEmit   -- | Out of line fake primop that's actually just a foreign call to other@@ -2042,14 +2001,14 @@  genericIntMul2Op :: GenericOp genericIntMul2Op [res_c, res_h, res_l] both_args@[arg_x, arg_y]- = do dflags <- getDynFlags-      platform <- getPlatform+ = do cfg <- getStgToCmmConfig       -- Implement algorithm from Hacker's Delight, 2nd edition, p.174-      let t = cmmExprType platform arg_x+      let t        = cmmExprType platform arg_x+          platform = stgToCmmPlatform cfg       p   <- newTemp t       -- 1) compute the multiplication as if numbers were unsigned       _ <- withSequel (AssignTo [p, res_l] False) $-             cmmPrimOpApp dflags WordMul2Op both_args Nothing+             cmmPrimOpApp cfg WordMul2Op both_args Nothing       -- 2) correct the high bits of the unsigned result       let carryFill x = CmmMachOp (MO_S_Shr ww) [x, wwm1]           sub x y     = CmmMachOp (MO_Sub   ww) [x, y]@@ -2093,17 +2052,6 @@  genericFabsOp _ _ _ = panic "genericFabsOp" --- Note [Comparing stable names]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ A StableName# is actually a pointer to a stable name object (SNO)--- containing an index into the stable name table (SNT). We--- used to compare StableName#s by following the pointers to the--- SNOs and checking whether they held the same SNT indices. However,--- this is not necessary: there is a one-to-one correspondence--- between SNOs and entries in the SNT, so simple pointer equality--- does the trick.- ------------------------------------------------------------------------------ -- Helpers for translating various minor variants of array indexing. @@ -2355,14 +2303,13 @@ --    it may very well be a design perspective that helps guide improving the NCG.  -checkVecCompatibility :: DynFlags -> PrimOpVecCat -> Length -> Width -> FCode ()-checkVecCompatibility dflags vcat l w = do-    when (backend dflags /= LLVM) $-        sorry $ unlines ["SIMD vector instructions require the LLVM back-end."-                         ,"Please use -fllvm."]-    check vecWidth vcat l w+checkVecCompatibility :: StgToCmmConfig -> PrimOpVecCat -> Length -> Width -> FCode ()+checkVecCompatibility cfg vcat l w =+  case stgToCmmVecInstrsErr cfg of+    Nothing  -> check vecWidth vcat l w  -- We are in a compatible backend+    Just err -> sorry err                -- incompatible backend, do panic   where-    platform = targetPlatform dflags+    platform = stgToCmmPlatform cfg     check :: Width -> PrimOpVecCat -> Length -> Width -> FCode ()     check W128 FloatVec 4 W32 | not (isSseEnabled platform) =         sorry $ "128-bit wide single-precision floating point " ++@@ -2370,13 +2317,13 @@     check W128 _ _ _ | not (isSse2Enabled platform) =         sorry $ "128-bit wide integer and double precision " ++                 "SIMD vector instructions require at least -msse2."-    check W256 FloatVec _ _ | not (isAvxEnabled dflags) =+    check W256 FloatVec _ _ | not (stgToCmmAvx cfg) =         sorry $ "256-bit wide floating point " ++                 "SIMD vector instructions require at least -mavx."-    check W256 _ _ _ | not (isAvx2Enabled dflags) =+    check W256 _ _ _ | not (stgToCmmAvx2 cfg) =         sorry $ "256-bit wide integer " ++                 "SIMD vector instructions require at least -mavx2."-    check W512 _ _ _ | not (isAvx512fEnabled dflags) =+    check W512 _ _ _ | not (stgToCmmAvx512f cfg) =         sorry $ "512-bit wide " ++                 "SIMD vector instructions require -mavx512f."     check _ _ _ _ = return ()@@ -3294,9 +3241,9 @@               -> CmmExpr  -- ^ array size (in elements)               -> FCode () doBoundsCheck idx sz = do-    dflags <- getDynFlags-    platform <- getPlatform-    when (gopt Opt_DoBoundsChecking dflags) (doCheck platform)+    do_bounds_check <- stgToCmmDoBoundsCheck <$> getStgToCmmConfig+    platform        <- getPlatform+    when do_bounds_check (doCheck platform)   where     doCheck platform = do         boundsCheckFailed <- getCode $ emitCCall [] (mkLblExpr mkOutOfBoundsAccessLabel) []
compiler/GHC/StgToCmm/Prof.hs view
@@ -28,12 +28,10 @@  import GHC.Prelude -import GHC.Driver.Session-import GHC.Driver.Ppr- import GHC.Platform import GHC.Platform.Profile import GHC.StgToCmm.Closure+import GHC.StgToCmm.Config import GHC.StgToCmm.Utils import GHC.StgToCmm.Monad import GHC.StgToCmm.Lit@@ -56,7 +54,9 @@ import GHC.Utils.Encoding  import Control.Monad-import Data.Char (ord)+import Data.Char       (ord)+import Data.Bifunctor  (first)+import GHC.Utils.Monad (whenM)  ----------------------------------------------------------------------------- --@@ -72,7 +72,7 @@ ccType = bWord  storeCurCCS :: CmmExpr -> CmmAGraph-storeCurCCS e = mkAssign cccsReg e+storeCurCCS = mkAssign cccsReg  mkCCostCentre :: CostCentre -> CmmLit mkCCostCentre cc = CmmLabel (mkCCLabel cc)@@ -139,9 +139,9 @@ saveCurrentCostCentre :: FCode (Maybe LocalReg)         -- Returns Nothing if profiling is off saveCurrentCostCentre-  = do dflags <- getDynFlags-       platform <- getPlatform-       if not (sccProfilingEnabled dflags)+  = do sccProfilingEnabled <- stgToCmmSCCProfiling <$> getStgToCmmConfig+       platform            <- getPlatform+       if not sccProfilingEnabled            then return Nothing            else do local_cc <- newTemp (ccType platform)                    emitAssign (CmmLocal local_cc) cccsExpr@@ -163,7 +163,7 @@ profDynAlloc :: SMRep -> CmmExpr -> FCode () profDynAlloc rep ccs   = ifProfiling $-    do profile <- targetProfile <$> getDynFlags+    do profile <- getProfile        let platform = profilePlatform profile        profAlloc (mkIntExpr platform (heapClosureSizeW profile rep)) ccs @@ -173,12 +173,12 @@ profAlloc :: CmmExpr -> CmmExpr -> FCode () profAlloc words ccs   = ifProfiling $-        do profile <- targetProfile <$> getDynFlags+        do profile <- getProfile            let platform = profilePlatform profile            let alloc_rep = rEP_CostCentreStack_mem_alloc platform            emit $ addToMemE alloc_rep                        (cmmOffsetB platform ccs (pc_OFFSET_CostCentreStack_mem_alloc (platformConstants platform)))-                       (CmmMachOp (MO_UU_Conv (wordWidth platform) (typeWidth alloc_rep)) $+                       (CmmMachOp (MO_UU_Conv (wordWidth platform) (typeWidth alloc_rep))                            -- subtract the "profiling overhead", which is the                            -- profiling header in a closure.                            [CmmMachOp (mo_wordSub platform) [ words, mkIntExpr platform (profHdrSize profile)]]@@ -194,21 +194,18 @@       emit $ storeCurCCS (costCentreFrom platform closure)  enterCostCentreFun :: CostCentreStack -> CmmExpr -> FCode ()-enterCostCentreFun ccs closure =-  ifProfiling $-    if isCurrentCCS ccs-       then do platform <- getPlatform-               emitRtsCall rtsUnitId (fsLit "enterFunCCS")-                   [(baseExpr, AddrHint),-                    (costCentreFrom platform closure, AddrHint)] False-       else return () -- top-level function, nothing to do+enterCostCentreFun ccs closure = ifProfiling $+    when (isCurrentCCS ccs) $+    do platform <- getPlatform+       emitRtsCall+         rtsUnitId+         (fsLit "enterFunCCS")+         [(baseExpr, AddrHint), (costCentreFrom platform closure, AddrHint)]+         False+       -- otherwise we have a top-level function, nothing to do  ifProfiling :: FCode () -> FCode ()-ifProfiling code-  = do profile <- targetProfile <$> getDynFlags-       if profileIsProfiling profile-           then code-           else return ()+ifProfiling = whenM (stgToCmmSCCProfiling <$> getStgToCmmConfig)  --------------------------------------------------------------- --        Initialising Cost Centres & CCSs@@ -224,7 +221,7 @@  emitCostCentreDecl :: CostCentre -> FCode () emitCostCentreDecl cc = do-  { dflags <- getDynFlags+  { ctx      <- stgToCmmContext <$> getStgToCmmConfig   ; platform <- getPlatform   ; let is_caf | isCafCC cc = mkIntCLit platform (ord 'c') -- 'c' == is a CAF                | otherwise  = zero platform@@ -234,7 +231,7 @@                                         $ moduleName                                         $ cc_mod cc)   ; loc <- newByteStringCLit $ utf8EncodeString $-                   showPpr dflags (costCentreSrcSpan cc)+                   renderWithContext ctx (ppr $! costCentreSrcSpan cc)   ; let      lits = [ zero platform,  -- StgInt ccID,               label,          -- char *label,@@ -278,37 +275,39 @@    (ws,ms) = pc_SIZEOF_CostCentreStack (platformConstants platform) `divMod` platformWordSizeInBytes platform  -initInfoTableProv ::  [CmmInfoTable] -> InfoTableProvMap -> Module -> FCode CStub+initInfoTableProv ::  [CmmInfoTable] -> InfoTableProvMap -> FCode CStub -- Emit the declarations-initInfoTableProv infos itmap this_mod+initInfoTableProv infos itmap   = do-       dflags <- getDynFlags-       let ents = convertInfoProvMap dflags infos this_mod itmap-       --pprTraceM "UsedInfo" (ppr (length infos))-       --pprTraceM "initInfoTable" (ppr (length ents))+       cfg <- getStgToCmmConfig+       let ents       = convertInfoProvMap infos this_mod itmap+           info_table = stgToCmmInfoTableMap cfg+           platform   = stgToCmmPlatform     cfg+           this_mod   = stgToCmmThisModule   cfg        -- Output the actual IPE data        mapM_ emitInfoTableProv ents-       -- Create the C stub which initialises the IPE_LIST-       return (ipInitCode dflags this_mod ents)+       -- Create the C stub which initialises the IPE map+       return (ipInitCode info_table platform this_mod ents)  --- Info Table Prov stuff emitInfoTableProv :: InfoProvEnt  -> FCode () emitInfoTableProv ip = do-  { dflags <- getDynFlags-  ; let mod = infoProvModule ip-  ; let (src, label) = maybe ("", "") (\(s, l) -> (showPpr dflags s, l)) (infoTableProv ip)-  ; platform <- getPlatform-  ; let mk_string = newByteStringCLit . utf8EncodeString+  { cfg <- getStgToCmmConfig+  ; let mod      = infoProvModule ip+        ctx      = stgToCmmContext  cfg+        platform = stgToCmmPlatform cfg+  ; let (src, label) = maybe ("", "") (first (renderWithContext ctx . ppr)) (infoTableProv ip)+        mk_string    = newByteStringCLit . utf8EncodeString   ; label <- mk_string label   ; modl  <- newByteStringCLit (bytesFS $ moduleNameFS-                                        $ moduleName-                                        $ mod)+                                        $ moduleName mod)    ; ty_string  <- mk_string (infoTableType ip)-  ; loc <- mk_string src-  ; table_name <- mk_string (showPpr dflags (pprCLabel platform CStyle (infoTablePtr ip)))-  ; closure_type <- mk_string-                      (showPpr dflags (text $ show $ infoProvEntClosureType ip))+  ; loc        <- mk_string src+  ; table_name <- mk_string (renderWithContext ctx+                             (pprCLabel platform CStyle (infoTablePtr ip)))+  ; closure_type <- mk_string (renderWithContext ctx+                               (text $ show $ infoProvEntClosureType ip))   ; let      lits = [ CmmLabel (infoTablePtr ip), -- Info table pointer               table_name,     -- char *table_name@@ -325,15 +324,12 @@ -- Set the current cost centre stack  emitSetCCC :: CostCentre -> Bool -> Bool -> FCode ()-emitSetCCC cc tick push- = do profile <- targetProfile <$> getDynFlags-      let platform = profilePlatform profile-      if not (profileIsProfiling profile)-          then return ()-          else do tmp <- newTemp (ccsType platform)-                  pushCostCentre tmp cccsExpr cc-                  when tick $ emit (bumpSccCount platform (CmmReg (CmmLocal tmp)))-                  when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp)))+emitSetCCC cc tick push = ifProfiling $+  do platform <- getPlatform+     tmp      <- newTemp (ccsType platform)+     pushCostCentre tmp cccsExpr cc+     when tick $ emit (bumpSccCount platform (CmmReg (CmmLocal tmp)))+     when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp)))  pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode () pushCostCentre result ccs cc
+ compiler/GHC/StgToCmm/Sequel.hs view
@@ -0,0 +1,46 @@+-----------------------------------------------------------------------------+--+-- Sequel type for Stg to C-- code generation+--+-- (c) The University of Glasgow 2004-2006+--+-- This module is just a bucket of types used in StgToCmm.Monad and+-- StgToCmm.Closure. Its sole purpose is to break a cyclic dependency between+-- StgToCmm.Monad and StgToCmm.Closure which derives from coupling around+-- the BlockId and LocalReg types+-----------------------------------------------------------------------------++module GHC.StgToCmm.Sequel+  ( Sequel(..)+  , SelfLoopInfo+  ) where++import GHC.Cmm.BlockId+import GHC.Cmm+import GHC.Cmm.Ppr()++import GHC.Types.Id+import GHC.Utils.Outputable++import GHC.Prelude++--------------------------------------------------------------------------------+-- | A Sequel tells what to do with the result of this expression+data Sequel+  = Return              -- ^ Return result(s) to continuation found on the stack.++  | AssignTo+        [LocalReg]      -- ^ Put result(s) in these regs and fall through+                        -- NB: no void arguments here+                        --+        Bool            -- ^ Should we adjust the heap pointer back to recover+                        -- space that's unused on this path? We need to do this+                        -- only if the expression may allocate (e.g. it's a+                        -- foreign call or allocating primOp)++instance Outputable Sequel where+    ppr Return = text "Return"+    ppr (AssignTo regs b) = text "AssignTo" <+> ppr regs <+> ppr b++type SelfLoopInfo = (Id, BlockId, [LocalReg])+--------------------------------------------------------------------------------
+ compiler/GHC/StgToCmm/TagCheck.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+--+-- Code generator utilities; mostly monadic+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module GHC.StgToCmm.TagCheck+  ( emitTagAssertion, emitArgTagCheck, checkArg, whenCheckTags,+    checkArgStatic, checkFunctionArgTags,checkConArgsStatic,checkConArgsDyn) where++#include "ClosureTypes.h"++import GHC.Prelude++import GHC.StgToCmm.Env+import GHC.StgToCmm.Monad+import GHC.StgToCmm.Utils+import GHC.Cmm+import GHC.Cmm.BlockId+import GHC.Cmm.Graph as CmmGraph++import GHC.Core.Type+import GHC.Types.Id+import GHC.Utils.Misc+import GHC.Utils.Outputable++import GHC.Core.DataCon+import Control.Monad+import GHC.StgToCmm.Types+import GHC.Utils.Panic (pprPanic)+import GHC.Utils.Panic.Plain (panic)+import GHC.Stg.Syntax+import GHC.StgToCmm.Closure+import GHC.Cmm.Switch (mkSwitchTargets)+import GHC.Cmm.Info (cmmGetClosureType)+import GHC.Types.RepType (dataConRuntimeRepStrictness)+import GHC.Types.Basic+import GHC.Data.FastString (mkFastString)++import qualified Data.Map as M++-- | Check all arguments marked as already tagged for a function+-- are tagged by inserting runtime checks.+checkFunctionArgTags :: SDoc -> Id -> [Id] -> FCode ()+checkFunctionArgTags msg f args = whenCheckTags $ do+  onJust (return ()) (idCbvMarks_maybe f) $ \marks -> do+    -- Only check args marked as strict, and only lifted ones.+    let cbv_args = filter (isLiftedRuntimeRep . idType) $ filterByList (map isMarkedCbv marks) args+    -- Get their (cmm) address+    arg_infos <- mapM getCgIdInfo cbv_args+    let arg_cmms = map idInfoToAmode arg_infos+    mapM_ (emitTagAssertion (showPprUnsafe msg))  (arg_cmms)++-- | Check all required-tagged arguments of a constructor are tagged *at compile time*.+checkConArgsStatic :: SDoc -> DataCon -> [StgArg] -> FCode ()+checkConArgsStatic msg con args = whenCheckTags $ do+  let marks = dataConRuntimeRepStrictness con+  zipWithM_ (checkArgStatic msg) marks args++-- Check all required arguments of a constructor are tagged.+-- Possible by emitting checks at runtime.+checkConArgsDyn :: SDoc -> DataCon -> [StgArg] -> FCode ()+checkConArgsDyn msg con args = whenCheckTags $ do+  let marks = dataConRuntimeRepStrictness con+  zipWithM_ (checkArg msg) (map cbvFromStrictMark marks) args++whenCheckTags :: FCode () -> FCode ()+whenCheckTags act = do+  check_tags <- stgToCmmDoTagCheck <$> getStgToCmmConfig+  when check_tags act++-- | Call barf if we failed to predict a tag correctly.+-- This is immensly useful when debugging issues in tag inference+-- as it will result in a program abort when we encounter an invalid+-- call/heap object, rather than leaving it be and segfaulting arbitrary+-- or producing invalid results.+-- We check if either:+-- * A tag is present+-- * Or the object is a PAP (for which zero is the proper tag)+emitTagAssertion :: String -> CmmExpr -> FCode ()+emitTagAssertion onWhat fun = do+  { platform <- getPlatform+  ; lret <- newBlockId+  ; lno_tag <- newBlockId+  ; lbarf <- newBlockId+  -- Check for presence of any tag.+  ; emit $ mkCbranch (cmmIsTagged platform fun)+                     lret lno_tag (Just True)+  -- If there is no tag check if we are dealing with a PAP+  ; emitLabel lno_tag+  ; emitComment (mkFastString "closereTypeCheck")+  ; needsArgTag fun lbarf lret++  ; emitLabel lbarf+  ; emitBarf ("Tag inference failed on:" ++ onWhat)+  ; emitLabel lret+  }++-- | Jump to the first block if the argument closure is subject+--   to tagging requirements. Otherwise jump to the 2nd one.+needsArgTag :: CmmExpr -> BlockId -> BlockId -> FCode ()+needsArgTag closure fail lpass = do+  profile <- getProfile+  align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig+  let clo_ty_e = cmmGetClosureType profile align_check closure+  -- The ENTER macro doesn't evaluate FUN/PAP/BCO objects. So we+  -- have to accept them not being tagged. See #21193+  -- See Note [TagInfo of functions]+  let targets = mkSwitchTargets+        False+        (INVALID_OBJECT, N_CLOSURE_TYPES)+        (Just fail)+        (M.fromList [(PAP,lpass)+                    ,(BCO,lpass)+                    ,(FUN,lpass)+                    ,(FUN_1_0,lpass)+                    ,(FUN_0_1,lpass)+                    ,(FUN_2_0,lpass)+                    ,(FUN_1_1,lpass)+                    ,(FUN_0_2,lpass)+                    ,(FUN_STATIC,lpass)+                    ])++  emit $ mkSwitch clo_ty_e targets++  emit $ mkBranch lpass+++emitArgTagCheck :: SDoc -> [CbvMark] -> [Id] -> FCode ()+emitArgTagCheck info marks args = whenCheckTags $ do+  mod <- getModuleName+  let cbv_args = filter (isLiftedRuntimeRep . idType) $ filterByList (map isMarkedCbv marks) args+  arg_infos <- mapM getCgIdInfo cbv_args+  let arg_cmms = map idInfoToAmode arg_infos+      mk_msg arg = showPprUnsafe (text "Untagged arg:" <> (ppr mod) <> char ':' <> info <+> ppr arg)+  zipWithM_ emitTagAssertion (map mk_msg args) (arg_cmms)++taggedCgInfo :: CgIdInfo -> Bool+taggedCgInfo cg_info+  = case lf of+      LFCon {} -> True+      LFReEntrant {} -> True+      LFUnlifted {} -> True+      LFThunk {} -> False+      LFUnknown {} -> False+      LFLetNoEscape -> panic "Let no escape binding passed to top level con"+  where+    lf = cg_lf cg_info++-- Check that one argument is properly tagged.+checkArg :: SDoc -> CbvMark -> StgArg -> FCode ()+checkArg _ NotMarkedCbv _ = return ()+checkArg msg MarkedCbv arg = whenCheckTags $+  case arg of+    StgLitArg _ -> return ()+    StgVarArg v -> do+      info <- getCgIdInfo v+      if taggedCgInfo info+          then return ()+          else case (cg_loc info) of+            CmmLoc loc -> emitTagAssertion (showPprUnsafe $ msg <+> text "arg:" <> ppr arg) loc+            LneLoc {} -> panic "LNE-arg"++-- Check that argument is properly tagged.+checkArgStatic :: SDoc -> StrictnessMark  -> StgArg -> FCode ()+checkArgStatic _   NotMarkedStrict _ = return ()+checkArgStatic msg MarkedStrict arg = whenCheckTags $+  case arg of+    StgLitArg _ -> return ()+    StgVarArg v -> do+      info <- getCgIdInfo v+      if taggedCgInfo info+          then return ()+          else pprPanic "Arg not tagged as expectd" (ppr msg <+> ppr arg)++
compiler/GHC/StgToCmm/Ticky.hs view
@@ -29,12 +29,12 @@   * GHC.Cmm.Parser expands some macros using generators defined in     this module -  * includes/stg/Ticky.h declares all of the global counters+  * rts/include/stg/Ticky.h declares all of the global counters -  * includes/rts/Ticky.h declares the C data type for an+  * rts/include/rts/Ticky.h declares the C data type for an     STG-declaration's counters -  * some macros defined in includes/Cmm.h (and used within the RTS's+  * some macros defined in rts/include/Cmm.h (and used within the RTS's     CMM code) update the global ticky counters    * at the end of execution rts/Ticky.c generates the final report@@ -64,6 +64,15 @@    * someone else might know how to repair it! ++Note [Ticky counters are static]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Currently GHC only supports static ticky events. That is -ticky emits+code containing labels containing counters which then get bumped at runtime.++There are currently only *static* ticky counters. Either we bump one of the+static counters included in the RTS. Or we emit StgEntCounter structures in+the object code and bump these. -}  module GHC.StgToCmm.Ticky (@@ -72,6 +81,7 @@   withNewTickyCounterThunk,   withNewTickyCounterStdThunk,   withNewTickyCounterCon,+  emitTickyCounterTag,    tickyDynAlloc,   tickyAllocHeap,@@ -97,7 +107,10 @@   tickyUnboxedTupleReturn,   tickyReturnOldCon, tickyReturnNewCon, -  tickySlowCall+  tickyKnownCallTooFewArgs, tickyKnownCallExact, tickyKnownCallExtraArgs,+  tickySlowCall, tickySlowCallPat,++  tickyTagged, tickyUntagged, tickyTagSkip   ) where  import GHC.Prelude@@ -107,10 +120,11 @@  import GHC.StgToCmm.ArgRep    ( slowCallPattern , toArgRep , argRepString ) import GHC.StgToCmm.Closure-import GHC.StgToCmm.Utils-import GHC.StgToCmm.Monad+import GHC.StgToCmm.Config import {-# SOURCE #-} GHC.StgToCmm.Foreign   ( emitPrimCall ) import GHC.StgToCmm.Lit       ( newStringCLit )+import GHC.StgToCmm.Monad+import GHC.StgToCmm.Utils  import GHC.Stg.Syntax import GHC.Cmm.Expr@@ -119,6 +133,7 @@ import GHC.Cmm.CLabel import GHC.Runtime.Heap.Layout + import GHC.Types.Name import GHC.Types.Id import GHC.Types.Basic@@ -126,9 +141,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc--import GHC.Driver.Session-import GHC.Driver.Ppr+import GHC.Utils.Monad (whenM)  -- Turgid imports for showTypeCategory import GHC.Builtin.Names@@ -139,7 +152,12 @@  import Data.Maybe import qualified Data.Char-import Control.Monad ( when )+import Control.Monad ( when, unless )+import GHC.Types.Id.Info+import GHC.Utils.Trace+import GHC.StgToCmm.Env (getCgInfo_maybe)+import Data.Coerce (coerce)+import GHC.Utils.Json  ----------------------------------------------------------------------------- --@@ -147,122 +165,290 @@ -- ----------------------------------------------------------------------------- +-- | Number of arguments for a ticky counter.+--+-- Ticky currently treats args to constructor allocations differently than those for functions/LNE bindings.+tickyArgArity :: TickyClosureType -> Int+tickyArgArity (TickyFun _ _fvs args) = length args+tickyArgArity (TickyLNE args) = length args+tickyArgArity (TickyCon{}) = 0+tickyArgArity (TickyThunk{}) = 0++tickyArgDesc :: TickyClosureType -> String+tickyArgDesc arg_info =+  case arg_info of+    TickyFun _ _fvs args -> map (showTypeCategory . idType . fromNonVoid) args+    TickyLNE args -> map (showTypeCategory . idType . fromNonVoid) args+    TickyThunk{} -> ""+    TickyCon{} -> ""++tickyFvDesc :: TickyClosureType -> String+tickyFvDesc arg_info =+  case arg_info of+    TickyFun _ fvs _args -> map (showTypeCategory . idType . fromNonVoid) fvs+    TickyLNE{} -> ""+    TickyThunk _ _ fvs -> map (showTypeCategory . stgArgType) fvs+    TickyCon{} -> ""++instance ToJson TickyClosureType where+    json info = case info of+      (TickyFun {})   -> mkInfo (tickyFvDesc info) (tickyArgDesc info) "fun"+      (TickyLNE {})   -> mkInfo []                 (tickyArgDesc info) "lne"+      (TickyThunk uf _ _) -> mkInfo (tickyFvDesc info) []              ("thk" ++ if uf then "_u" else "")+      (TickyCon{})    -> mkInfo []                 []                  "con"+      where+        mkInfo :: String -> String -> String -> JsonDoc+        mkInfo fvs args ty =+          JSObject+              [("type", json "entCntr")+              ,("subTy", json ty)+              ,("fvs_c", json (length fvs))+              ,("fvs" , json fvs)+              ,("args", json args)+              ]++tickyEntryDescJson :: (SDocContext -> TickyClosureType -> String)+tickyEntryDescJson ctxt = renderWithContext ctxt . renderJSON . json+ data TickyClosureType     = TickyFun         Bool -- True <-> single entry+        [NonVoid Id] -- ^ FVs+        [NonVoid Id] -- ^ Args     | TickyCon         DataCon -- the allocated constructor+        ConstructorNumber     | TickyThunk         Bool -- True <-> updateable         Bool -- True <-> standard thunk (AP or selector), has no entry counter+        [StgArg] -- ^ FVS, StgArg because for thunks these can also be literals.     | TickyLNE+        [NonVoid Id] -- ^ Args -withNewTickyCounterFun :: Bool -> Name  -> [NonVoid Id] -> FCode a -> FCode a-withNewTickyCounterFun single_entry = withNewTickyCounter (TickyFun single_entry)+withNewTickyCounterFun :: Bool -> Id -> [NonVoid Id] -> [NonVoid Id] -> FCode a -> FCode a+withNewTickyCounterFun single_entry f fvs args = withNewTickyCounter (TickyFun single_entry fvs args) f -withNewTickyCounterLNE :: Name  -> [NonVoid Id] -> FCode a -> FCode a+withNewTickyCounterLNE :: Id  ->  [NonVoid Id] -> FCode a -> FCode a withNewTickyCounterLNE nm args code = do-  b <- tickyLNEIsOn-  if not b then code else withNewTickyCounter TickyLNE nm args code+  b <- isEnabled stgToCmmTickyLNE+  if not b then code else withNewTickyCounter (TickyLNE args) nm code  thunkHasCounter :: Bool -> FCode Bool-thunkHasCounter isStatic = do-  b <- tickyDynThunkIsOn-  pure (not isStatic && b)+thunkHasCounter isStatic = (not isStatic &&) <$> isEnabled stgToCmmTickyDynThunk  withNewTickyCounterThunk   :: Bool -- ^ static   -> Bool -- ^ updateable-  -> Name+  -> Id+  -> [NonVoid Id] -- ^ Free vars   -> FCode a   -> FCode a-withNewTickyCounterThunk isStatic isUpdatable name code = do+withNewTickyCounterThunk isStatic isUpdatable name fvs code = do     has_ctr <- thunkHasCounter isStatic     if not has_ctr       then code-      else withNewTickyCounter (TickyThunk isUpdatable False) name [] code+      else withNewTickyCounter (TickyThunk isUpdatable False (map StgVarArg $ coerce fvs)) name code  withNewTickyCounterStdThunk   :: Bool -- ^ updateable-  -> Name+  -> Id+  -> [StgArg] -- ^ Free vars + function   -> FCode a   -> FCode a-withNewTickyCounterStdThunk isUpdatable name code = do+withNewTickyCounterStdThunk isUpdatable name fvs code = do     has_ctr <- thunkHasCounter False     if not has_ctr       then code-      else withNewTickyCounter (TickyThunk isUpdatable True) name [] code+      else withNewTickyCounter (TickyThunk isUpdatable True fvs) name code  withNewTickyCounterCon-  :: Name+  :: Id   -> DataCon+  -> ConstructorNumber   -> FCode a   -> FCode a-withNewTickyCounterCon name datacon code = do+withNewTickyCounterCon name datacon info code = do     has_ctr <- thunkHasCounter False     if not has_ctr       then code-      else withNewTickyCounter (TickyCon datacon) name [] code+      else withNewTickyCounter (TickyCon datacon info) name code  -- args does not include the void arguments-withNewTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode a -> FCode a-withNewTickyCounter cloType name args m = do-  lbl <- emitTickyCounter cloType name args+withNewTickyCounter :: TickyClosureType -> Id -> FCode a -> FCode a+withNewTickyCounter cloType name m = do+  lbl <- emitTickyCounter cloType name   setTickyCtrLabel lbl m -emitTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode CLabel-emitTickyCounter cloType name args-  = let ctr_lbl = mkRednCountsLabel name in+emitTickyData :: Platform+              -> CLabel -- ^ lbl for the counter+              -> Arity -- ^ arity+              -> CmmLit -- ^ fun desc+              -> CmmLit -- ^ arg desc+              -> CmmLit -- ^ json desc+              -> CmmLit -- ^ info table lbl+              -> FCode ()+emitTickyData platform ctr_lbl arity fun_desc arg_desc json_desc info_tbl =+  emitDataLits ctr_lbl+    -- Must match layout of rts/include/rts/Ticky.h's StgEntCounter+    --+    -- krc: note that all the fields are I32 now; some were I16+    -- before, but the code generator wasn't handling that+    -- properly and it led to chaos, panic and disorder.+        [ zeroCLit platform,               -- registered?+          mkIntCLit platform arity,   -- Arity+          zeroCLit platform,               -- Heap allocated for this thing+          fun_desc,+          arg_desc,+          json_desc,+          info_tbl,+          zeroCLit platform,          -- Entries into this thing+          zeroCLit platform,          -- Heap allocated by this thing+          zeroCLit platform           -- Link to next StgEntCounter+        ]+++emitTickyCounter :: TickyClosureType -> Id -> FCode CLabel+emitTickyCounter cloType tickee+  = let name = idName tickee in+    let ctr_lbl = mkRednCountsLabel name in     (>> return ctr_lbl) $     ifTicky $ do-        { dflags <- getDynFlags-        ; platform <- getPlatform+        { cfg    <- getStgToCmmConfig         ; parent <- getTickyCtrLabel         ; mod_name <- getModuleName            -- When printing the name of a thing in a ticky file, we           -- want to give the module name even for *local* things.  We           -- print just "x (M)" rather that "M.x" to distinguish them-          -- from the global kind.-        ; let ppr_for_ticky_name :: SDoc+          -- from the global kind by calling to @pprTickyName@+        ; let platform = stgToCmmPlatform cfg+              ppr_for_ticky_name :: SDoc               ppr_for_ticky_name =-                let n = ppr name-                    ext = case cloType of-                              TickyFun single_entry -> parens $ hcat $ punctuate comma $+                let ext = case cloType of+                              TickyFun single_entry _ _-> parens $ hcat $ punctuate comma $                                   [text "fun"] ++ [text "se"|single_entry]-                              TickyCon datacon -> parens (text "con:" <+> ppr (dataConName datacon))-                              TickyThunk upd std -> parens $ hcat $ punctuate comma $+                              TickyCon datacon _cn -> parens (text "con:" <+> ppr (dataConName datacon))+                              TickyThunk upd std _-> parens $ hcat $ punctuate comma $                                   [text "thk"] ++ [text "se"|not upd] ++ [text "std"|std]-                              TickyLNE | isInternalName name -> parens (text "LNE")-                                       | otherwise -> panic "emitTickyCounter: how is this an external LNE?"+                              TickyLNE _ | isInternalName name -> parens (text "LNE")+                                         | otherwise -> panic "emitTickyCounter: how is this an external LNE?"                     p = case hasHaskellName parent of                             -- NB the default "top" ticky ctr does not                             -- have a Haskell name                           Just pname -> text "in" <+> ppr (nameUnique pname)                           _ -> empty+                in pprTickyName mod_name name <+> ext <+> p+        ; this_mod <- getModuleName+        ; let t = case cloType of+                    TickyCon {} -> "C"+                    TickyFun {} -> "F"+                    TickyThunk {} -> "T"+                    TickyLNE {} -> "L"+        ; info_lbl <- case cloType of+                            TickyCon dc mn -> case mn of+                                               NoNumber -> return $! CmmLabel $ mkConInfoTableLabel (dataConName dc) DefinitionSite+                                               (Numbered n) -> return $! CmmLabel $ mkConInfoTableLabel (dataConName dc) (UsageSite this_mod n)+                            TickyFun {} ->+                              return $! CmmLabel $ mkInfoTableLabel name NoCafRefs++                            TickyThunk _ std_thunk _fvs+                              | not std_thunk+                              -> return $! CmmLabel $ mkInfoTableLabel name NoCafRefs+                              -- IPE Maps have no entry for std thunks.+                              | otherwise+                              -> do+                                    lf_info <- getCgInfo_maybe name+                                    profile <- getProfile+                                    case lf_info of+                                      Just (CgIdInfo { cg_lf = cg_lf })+                                          | isLFThunk cg_lf+                                          -> return $! CmmLabel $ mkClosureInfoTableLabel (profilePlatform profile) tickee cg_lf+                                      _   -> pprTraceDebug "tickyThunkUnknown" (text t <> colon <> ppr name <+> ppr (mkInfoTableLabel name NoCafRefs))+                                            return $! zeroCLit platform++                            TickyLNE {} -> return $! zeroCLit platform++        ; let ctx = defaultSDocContext {sdocPprDebug = True}+        ; fun_descr_lit <- newStringCLit $ renderWithContext ctx ppr_for_ticky_name+        ; arg_descr_lit <- newStringCLit $ tickyArgDesc cloType+        ; json_descr_lit <- newStringCLit $ tickyEntryDescJson ctx cloType+        ; emitTickyData platform ctr_lbl (tickyArgArity cloType) fun_descr_lit arg_descr_lit json_descr_lit info_lbl+        }++{- Note [TagSkip ticky counters]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+These counters keep track how often we execute code where we+would have performed a tag check if we hadn't run tag inference.++If we have some code of the form:+    case v[tagged] of ...+and we want to record how often we avoid a tag check on v+through tag inference we have to emit a new StgEntCounter for+each such case statement in order to record how often it's executed.++In theory we could emit one per *binding*. But then we+would have to either keep track of the bindings which+already have a StgEntCounter associated with them in the+code gen state or preallocate such a structure for each binding+in the code unconditionally (since ticky-code can call non-ticky code)++The first makes the compiler slower, even when ticky is not+used (a big no no). The later is fairly complex but increases code size+unconditionally. See also Note [Ticky counters are static].++So instead we emit a new StgEntCounter for each use site of a binding+where we infered a tag to be present. And increment the counter whenever+this use site is executed.++We use the fields as follows:++entry_count: Entries avoided.+str:       : Name of the id.++We use emitTickyCounterTag to emit the counter.++Unlike the closure counters each *use* site of v has it's own+counter. So there is no need to keep track of the closure/case we are+in.++We also have to pass a unique for the counter. An Id might be+scrutinized in more than one place, so the ID alone isn't enough+to distinguish between use sites.+-}++emitTickyCounterTag :: Unique -> NonVoid Id -> FCode CLabel+emitTickyCounterTag unique (NonVoid id) =+  let name = idName id+      ctr_lbl = mkTagHitLabel name unique in+    (>> return ctr_lbl) $+    ifTickyTag $ do+        { platform <- getPlatform+        ; parent <- getTickyCtrLabel+        ; mod_name <- getModuleName++          -- When printing the name of a thing in a ticky file, we+          -- want to give the module name even for *local* things.  We+          -- print just "x (M)" rather that "M.x" to distinguish them+          -- from the global kind.+        ; let ppr_for_ticky_name :: SDoc+              ppr_for_ticky_name =+                let n = ppr name+                    ext = empty -- parens (text "tagged")+                    p = case hasHaskellName parent of+                            -- NB the default "top" ticky ctr does not+                            -- have a Haskell name+                          Just pname -> text "at" <+> ppr (nameSrcLoc pname) <+>+                                          text "in" <+> pprNameUnqualified name+                          _ -> empty                 in if isInternalName name                    then n <+> parens (ppr mod_name) <+> ext <+> p                    else n <+> ext <+> p--        ; fun_descr_lit <- newStringCLit $ showSDocDebug dflags ppr_for_ticky_name-        ; arg_descr_lit <- newStringCLit $ map (showTypeCategory . idType . fromNonVoid) args-        ; emitDataLits ctr_lbl-        -- Must match layout of includes/rts/Ticky.h's StgEntCounter-        ---        -- krc: note that all the fields are I32 now; some were I16-        -- before, but the code generator wasn't handling that-        -- properly and it led to chaos, panic and disorder.-            [ mkIntCLit platform 0,               -- registered?-              mkIntCLit platform (length args),   -- Arity-              mkIntCLit platform 0,               -- Heap allocated for this thing-              fun_descr_lit,-              arg_descr_lit,-              zeroCLit platform,          -- Entries into this thing-              zeroCLit platform,          -- Heap allocated by this thing-              zeroCLit platform           -- Link to next StgEntCounter-            ]+        ; sdoc_context <- stgToCmmContext <$> getStgToCmmConfig+        ; fun_descr_lit <- newStringCLit $ renderWithContext sdoc_context ppr_for_ticky_name+        ; arg_descr_lit <- newStringCLit $ "infer"+        ; json_descr_lit <- newStringCLit $ "infer"+        ; emitTickyData platform ctr_lbl 0 fun_descr_lit arg_descr_lit json_descr_lit (zeroCLit platform)         }- -- ----------------------------------------------------------------------------- -- Ticky stack frames @@ -336,8 +522,8 @@ -- since the counter was registered already upon being alloc'd registerTickyCtrAtEntryDyn :: CLabel -> FCode () registerTickyCtrAtEntryDyn ctr_lbl = do-  already_registered <- tickyAllocdIsOn-  when (not already_registered) $ registerTickyCtr ctr_lbl+  already_registered <- isEnabled stgToCmmTickyAllocd+  unless already_registered $ registerTickyCtr ctr_lbl  -- | Register a ticky counter. --@@ -563,35 +749,55 @@ tickyStackCheck = ifTicky $ bumpTickyCounter (fsLit "STK_CHK_ctr")  -- -----------------------------------------------------------------------------+-- Ticky for tag inference characterisation++-- | Predicted a pointer would be tagged correctly (GHC will crash if not so no miss case)+tickyTagged :: FCode ()+tickyTagged         = ifTickyTag $ bumpTickyCounter (fsLit "TAG_TAGGED_pred")++-- | Pass a boolean expr indicating if tag was present.+tickyUntagged :: CmmExpr -> FCode ()+tickyUntagged e     = do+    ifTickyTag $ bumpTickyCounter (fsLit "TAG_UNTAGGED_pred")+    ifTickyTag $ bumpTickyCounterByE (fsLit "TAG_UNTAGGED_miss") e++-- | Called when for `case v of ...` we can avoid entering v based on+-- tag inference information.+tickyTagSkip :: Unique -> Id -> FCode ()+tickyTagSkip unique id = ifTickyTag $ do+  let ctr_lbl = mkTagHitLabel (idName id) unique+  registerTickyCtr ctr_lbl+  bumpTickyTagSkip ctr_lbl++-- ----------------------------------------------------------------------------- -- Ticky utils -ifTicky :: FCode () -> FCode ()-ifTicky code =-  getDynFlags >>= \dflags -> when (gopt Opt_Ticky dflags) code+isEnabled :: (StgToCmmConfig -> Bool) -> FCode Bool+isEnabled = flip fmap getStgToCmmConfig -tickyAllocdIsOn :: FCode Bool-tickyAllocdIsOn = gopt Opt_Ticky_Allocd `fmap` getDynFlags+runIfFlag :: (StgToCmmConfig -> Bool) -> FCode () -> FCode ()+runIfFlag f = whenM (f <$> getStgToCmmConfig) -tickyLNEIsOn :: FCode Bool-tickyLNEIsOn = gopt Opt_Ticky_LNE `fmap` getDynFlags+ifTicky :: FCode () -> FCode ()+ifTicky = runIfFlag stgToCmmDoTicky -tickyDynThunkIsOn :: FCode Bool-tickyDynThunkIsOn = gopt Opt_Ticky_Dyn_Thunk `fmap` getDynFlags+ifTickyTag :: FCode () -> FCode ()+ifTickyTag = runIfFlag stgToCmmTickyTag  ifTickyAllocd :: FCode () -> FCode ()-ifTickyAllocd code = tickyAllocdIsOn >>= \b -> when b code+ifTickyAllocd = runIfFlag stgToCmmTickyAllocd  ifTickyLNE :: FCode () -> FCode ()-ifTickyLNE code = tickyLNEIsOn >>= \b -> when b code+ifTickyLNE = runIfFlag stgToCmmTickyLNE  ifTickyDynThunk :: FCode () -> FCode ()-ifTickyDynThunk code = tickyDynThunkIsOn >>= \b -> when b code+ifTickyDynThunk = runIfFlag stgToCmmTickyDynThunk  bumpTickyCounter :: FastString -> FCode ()-bumpTickyCounter lbl = bumpTickyLbl (mkRtsCmmDataLabel lbl)+bumpTickyCounter = bumpTickyLbl . mkRtsCmmDataLabel  bumpTickyCounterBy :: FastString -> Int -> FCode ()-bumpTickyCounterBy lbl = bumpTickyLblBy (mkRtsCmmDataLabel lbl)+bumpTickyCounterBy = bumpTickyLblBy . mkRtsCmmDataLabel  bumpTickyCounterByE :: FastString -> CmmExpr -> FCode () bumpTickyCounterByE lbl = bumpTickyLblByE (mkRtsCmmDataLabel lbl)@@ -604,8 +810,13 @@ bumpTickyAllocd :: CLabel -> Int -> FCode () bumpTickyAllocd lbl bytes = do   platform <- getPlatform-  bumpTickyLitBy (cmmLabelOffB lbl (pc_OFFSET_StgEntCounter_allocd (platformConstants platform))) bytes+  bumpTickyLitBy (cmmLabelOffB lbl (pc_OFFSET_StgEntCounter_entry_count (platformConstants platform))) bytes +bumpTickyTagSkip :: CLabel -> FCode ()+bumpTickyTagSkip lbl = do+  platform <- getPlatform+  bumpTickyLitBy (cmmLabelOffB lbl (pc_OFFSET_StgEntCounter_entry_count (platformConstants platform))) 1+ bumpTickyLbl :: CLabel -> FCode () bumpTickyLbl lhs = bumpTickyLitBy (cmmLabelOffB lhs 0) 1 @@ -674,20 +885,21 @@   | otherwise = case tcSplitTyConApp_maybe ty of   Nothing -> '.'   Just (tycon, _) ->-    (if isUnliftedTyCon tycon then Data.Char.toLower else id) $     let anyOf us = getUnique tycon `elem` us in     case () of       _ | anyOf [funTyConKey] -> '>'-        | anyOf [charPrimTyConKey, charTyConKey] -> 'C'-        | anyOf [doublePrimTyConKey, doubleTyConKey] -> 'D'-        | anyOf [floatPrimTyConKey, floatTyConKey] -> 'F'-        | anyOf [intPrimTyConKey, int32PrimTyConKey, int64PrimTyConKey,-                 intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey-                ] -> 'I'-        | anyOf [wordPrimTyConKey, word32PrimTyConKey, word64PrimTyConKey, wordTyConKey,-                 word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey-                ] -> 'W'+        | anyOf [charTyConKey] -> 'C'+        | anyOf [charPrimTyConKey] -> 'c'+        | anyOf [doubleTyConKey] -> 'D'+        | anyOf [doublePrimTyConKey] -> 'd'+        | anyOf [floatTyConKey] -> 'F'+        | anyOf [floatPrimTyConKey] -> 'f'+        | anyOf [intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey] -> 'I'+        | anyOf [intPrimTyConKey, int8PrimTyConKey, int16PrimTyConKey, int32PrimTyConKey, int64PrimTyConKey] -> 'i'+        | anyOf [wordTyConKey, word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey] -> 'W'+        | anyOf [wordPrimTyConKey, word8PrimTyConKey, word16PrimTyConKey, word32PrimTyConKey, word64PrimTyConKey] -> 'w'         | anyOf [listTyConKey] -> 'L'+        | isUnboxedTupleTyCon tycon -> 't'         | isTupleTyCon tycon       -> 'T'         | isPrimTyCon tycon        -> 'P'         | isEnumerationTyCon tycon -> 'E'
compiler/GHC/StgToCmm/Utils.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Code generator utilities; mostly monadic@@ -12,7 +12,8 @@         emitDataLits, emitRODataLits,         emitDataCon,         emitRtsCall, emitRtsCallWithResult, emitRtsCallGen,-        assignTemp,+        emitBarf,+        assignTemp, newTemp,          newUnboxedTupleRegs, @@ -45,14 +46,12 @@         convertInfoProvMap, cmmInfoTableToInfoProvEnt   ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Platform import GHC.StgToCmm.Monad import GHC.StgToCmm.Closure-import GHC.StgToCmm.Lit (mkSimpleLit)+import GHC.StgToCmm.Lit (mkSimpleLit, newStringCLit) import GHC.Cmm import GHC.Cmm.BlockId import GHC.Cmm.Graph as CmmGraph@@ -72,10 +71,10 @@ import GHC.Data.Graph.Directed import GHC.Utils.Misc import GHC.Types.Unique-import GHC.Driver.Session import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Types.RepType import GHC.Types.CostCentre import GHC.Types.IPE@@ -85,12 +84,12 @@ import Data.Ord import GHC.Types.Unique.Map import Data.Maybe-import GHC.Driver.Ppr import qualified Data.List.NonEmpty as NE import GHC.Core.DataCon import GHC.Types.Unique.FM import GHC.Data.Maybe import Control.Monad+import qualified Data.Map.Strict as Map  -------------------------------------------------------------------------- --@@ -99,7 +98,7 @@ --------------------------------------------------------------------------  addToMemLbl :: CmmType -> CLabel -> Int -> CmmAGraph-addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n+addToMemLbl rep lbl = addToMem rep (CmmLit (CmmLabel lbl))  addToMemLblE :: CmmType -> CLabel -> CmmExpr -> CmmAGraph addToMemLblE rep lbl = addToMemE rep (CmmLit (CmmLabel lbl))@@ -159,13 +158,17 @@ -- ------------------------------------------------------------------------- +emitBarf :: String -> FCode ()+emitBarf msg = do+  strLbl <- newStringCLit msg+  emitRtsCall rtsUnitId (fsLit "barf") [(CmmLit strLbl,AddrHint)] False+ emitRtsCall :: UnitId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()-emitRtsCall pkg fun args safe = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) args safe+emitRtsCall pkg fun = emitRtsCallGen [] (mkCmmCodeLabel pkg fun)  emitRtsCallWithResult :: LocalReg -> ForeignHint -> UnitId -> FastString         -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()-emitRtsCallWithResult res hint pkg fun args safe-   = emitRtsCallGen [(res,hint)] (mkCmmCodeLabel pkg fun) args safe+emitRtsCallWithResult res hint pkg = emitRtsCallGen [(res,hint)] . mkCmmCodeLabel pkg  -- Make a call to an RTS C procedure emitRtsCallGen@@ -175,7 +178,7 @@    -> Bool -- True <=> CmmSafe call    -> FCode () emitRtsCallGen res lbl args safe-  = do { platform <- targetPlatform <$> getDynFlags+  = do { platform <- getPlatform        ; updfr_off <- getUpdFrameOff        ; let (caller_save, caller_load) = callerSaveVolatileRegs platform        ; emit caller_save@@ -202,7 +205,7 @@ -- Here we generate the sequence of saves/restores required around a -- foreign call instruction. --- TODO: reconcile with includes/Regs.h+-- TODO: reconcile with rts/include/Regs.h --  * Regs.h claims that BaseReg should be saved last and loaded first --    * This might not have been tickled before since BaseReg is callee save --  * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim@@ -210,7 +213,7 @@ -- This code isn't actually used right now, because callerSaves -- only ever returns true in the current universe for registers NOT in -- system_regs (just do a grep for CALLER_SAVES in--- includes/stg/MachRegs.h).  It's all one giant no-op, and for+-- rts/include/stg/MachRegs.h).  It's all one giant no-op, and for -- good reason: having to save system registers on every foreign call -- would be very expensive, so we avoid assigning them to those -- registers when we add support for an architecture.@@ -291,19 +294,17 @@ -- the Sequel.  If the Sequel is a join point, using the -- regs it wants will save later assignments. newUnboxedTupleRegs res_ty-  = ASSERT( isUnboxedTupleType res_ty )+  = assert (isUnboxedTupleType res_ty) $     do  { platform <- getPlatform         ; sequel <- getSequel         ; regs <- choose_regs platform sequel-        ; ASSERT( regs `equalLength` reps )-          return (regs, map primRepForeignHint reps) }+        ; massert (regs `equalLength` reps)+        ; return (regs, map primRepForeignHint reps) }   where     reps = typePrimRep res_ty     choose_regs _ (AssignTo regs _) = return regs     choose_regs platform _          = mapM (newTemp . primRepCmmType platform) reps -- ------------------------------------------------------------------------- --      emitMultiAssign -------------------------------------------------------------------------@@ -327,7 +328,7 @@ emitMultiAssign [reg] [rhs] = emitAssign (CmmLocal reg) rhs emitMultiAssign regs rhss   = do   platform <- getPlatform-  ASSERT2( equalLength regs rhss, ppr regs $$ pdoc platform rhss )+  assertPpr (equalLength regs rhss) (ppr regs $$ pdoc platform rhss) $     unscramble platform ([1..] `zip` (regs `zip` rhss))  unscramble :: Platform -> [Vrtx] -> FCode ()@@ -415,7 +416,7 @@ -- SINGLETON TAG RANGE: no case analysis to do mk_discrete_switch _ _tag_expr [(tag, lbl)] _ (lo_tag, hi_tag)   | lo_tag == hi_tag-  = ASSERT( tag == lo_tag )+  = assert (tag == lo_tag) $     mkBranch lbl  -- SINGLETON BRANCH, NO DEFAULT: no case analysis to do@@ -459,12 +460,19 @@         rep = typeWidth cmm_ty      -- We find the necessary type information in the literals in the branches-    let signed = case head branches of-                    (LitNumber nt _, _) -> litNumIsSigned nt-                    _ -> False--    let range | signed    = (platformMinInt platform, platformMaxInt platform)-              | otherwise = (0, platformMaxWord platform)+    let (signed,range) = case head branches of+          (LitNumber nt _, _) -> (signed,range)+            where+              signed = litNumIsSigned nt+              range  = case litNumRange platform nt of+                        (Just mi, Just ma) -> (mi,ma)+                                              -- unbounded literals (Natural and+                                              -- Integer) must have been+                                              -- lowered at this point+                        partial_bounds     -> pprPanic "Unexpected unbounded literal range"+                                                       (ppr partial_bounds)+               -- assuming native word range+          _ -> (False, (0, platformMaxWord platform))      if isFloatType cmm_ty     then emit =<< mk_float_switch rep scrut' deflt_lbl noBound branches_lbls@@ -597,14 +605,14 @@  -- | Convert source information collected about identifiers in 'GHC.STG.Debug' -- to entries suitable for placing into the info table provenenance table.-convertInfoProvMap :: DynFlags -> [CmmInfoTable] -> Module -> InfoTableProvMap -> [InfoProvEnt]-convertInfoProvMap dflags defns this_mod (InfoTableProvMap (UniqMap dcenv) denv) =+convertInfoProvMap :: [CmmInfoTable] -> Module -> InfoTableProvMap -> [InfoProvEnt]+convertInfoProvMap defns this_mod (InfoTableProvMap (UniqMap dcenv) denv infoTableToSourceLocationMap) =   map (\cmit ->     let cl = cit_lbl cmit         cn  = rtsClosureType (cit_rep cmit)          tyString :: Outputable a => a -> String-        tyString t = showPpr dflags t+        tyString = renderWithContext defaultSDocContext . ppr          lookupClosureMap :: Maybe InfoProvEnt         lookupClosureMap = case hasHaskellName cl >>= lookupUniqMap denv of@@ -614,12 +622,20 @@         lookupDataConMap = do             UsageSite _ n <- hasIdLabelInfo cl >>= getConInfoTableLocation             -- This is a bit grimy, relies on the DataCon and Name having the same Unique, which they do-            (dc, ns) <- (hasHaskellName cl >>= lookupUFM_Directly dcenv . getUnique)+            (dc, ns) <- hasHaskellName cl >>= lookupUFM_Directly dcenv . getUnique             -- Lookup is linear but lists will be small (< 100)             return $ InfoProvEnt cl cn (tyString (dataConTyCon dc)) this_mod (join $ lookup n (NE.toList ns)) +        lookupInfoTableToSourceLocation = do+            sourceNote <- Map.lookup (cit_lbl cmit) infoTableToSourceLocationMap+            return $ InfoProvEnt cl cn "" this_mod sourceNote+         -- This catches things like prim closure types and anything else which doesn't have a         -- source location         simpleFallback = cmmInfoTableToInfoProvEnt this_mod cmit -    in fromMaybe simpleFallback (lookupDataConMap `firstJust` lookupClosureMap)) defns+  in+    if (isStackRep . cit_rep) cmit then+      fromMaybe simpleFallback lookupInfoTableToSourceLocation+    else+      fromMaybe simpleFallback (lookupDataConMap `firstJust` lookupClosureMap)) defns
compiler/GHC/SysTools.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE ScopedTypeVariables #-}  {-@@ -20,7 +20,9 @@         module GHC.SysTools.Tasks,         module GHC.SysTools.Info, -        copy,+        -- * Fast file copy+        copyFile,+        copyHandle,         copyWithHeader,          -- * General utilities@@ -28,27 +30,26 @@         expandTopDir,  ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Settings.Utils -import GHC.Utils.Error import GHC.Utils.Panic-import GHC.Utils.Logger import GHC.Driver.Session -import Control.Monad.Trans.Except (runExceptT)-import System.FilePath-import System.IO-import System.IO.Unsafe (unsafeInterleaveIO) import GHC.Linker.ExtraObj import GHC.SysTools.Info import GHC.SysTools.Tasks import GHC.SysTools.BaseDir import GHC.Settings.IO +import Control.Monad.Trans.Except (runExceptT)+import System.FilePath+import System.IO+import System.IO.Unsafe (unsafeInterleaveIO)+import Foreign.Marshal.Alloc (allocaBytes)+import System.Directory (copyFile)+ {- Note [How GHC finds toolchain utilities] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -155,8 +156,8 @@     Left (SettingsError_MissingData msg) -> pgmError msg     Left (SettingsError_BadData msg) -> pgmError msg -{- Note [Windows stack usage]-+{- Note [Windows stack allocations]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ See: #8870 (and #8834 for related info) and #12186  On Windows, occasionally we need to grow the stack. In order to do@@ -186,26 +187,25 @@  -} -copy :: Logger -> DynFlags -> String -> FilePath -> FilePath -> IO ()-copy logger dflags purpose from to = copyWithHeader logger dflags purpose Nothing from to--copyWithHeader :: Logger -> DynFlags -> String -> Maybe String -> FilePath -> FilePath-               -> IO ()-copyWithHeader logger dflags purpose maybe_header from to = do-  showPass logger dflags purpose+-- | Copy remaining bytes from the first Handle to the second one+copyHandle :: Handle -> Handle -> IO ()+copyHandle hin hout = do+  let buf_size = 8192+  allocaBytes buf_size $ \ptr -> do+    let go = do+          c <- hGetBuf hin ptr buf_size+          hPutBuf hout ptr c+          if c == 0 then return () else go+    go -  hout <- openBinaryFile to   WriteMode-  hin  <- openBinaryFile from ReadMode-  ls <- hGetContents hin -- inefficient, but it'll do for now. ToDo: speed up-  maybe (return ()) (header hout) maybe_header-  hPutStr hout ls-  hClose hout-  hClose hin- where-  -- write the header string in UTF-8.  The header is something like-  --   {-# LINE "foo.hs" #-}-  -- and we want to make sure a Unicode filename isn't mangled.-  header h str = do-   hSetEncoding h utf8-   hPutStr h str-   hSetBinaryMode h True+-- | Copy file after printing the given header+copyWithHeader :: String -> FilePath -> FilePath -> IO ()+copyWithHeader header from to =+  withBinaryFile to WriteMode $ \hout -> do+    -- write the header string in UTF-8.  The header is something like+    --   {-# LINE "foo.hs" #-}+    -- and we want to make sure a Unicode filename isn't mangled.+    hSetEncoding hout utf8+    hPutStr hout header+    withBinaryFile from ReadMode $ \hin ->+      copyHandle hin hout
compiler/GHC/SysTools/Ar.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, CPP #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-} {- Note: [The need for Ar.hs] Building `-staticlib` required the presence of libtool, and was a such restricted to mach-o only. As libtool on macOS and gnu libtool are very
compiler/GHC/SysTools/Elf.hs view
@@ -18,7 +18,6 @@  import GHC.Utils.Asm import GHC.Utils.Exception-import GHC.Driver.Session import GHC.Platform import GHC.Utils.Error import GHC.Data.Maybe       (MaybeT(..),runMaybeT)@@ -142,9 +141,9 @@   -- | Read the ELF header-readElfHeader :: Logger -> DynFlags -> ByteString -> IO (Maybe ElfHeader)-readElfHeader logger dflags bs = runGetOrThrow getHeader bs `catchIO` \_ -> do-    debugTraceMsg logger dflags 3 $+readElfHeader :: Logger -> ByteString -> IO (Maybe ElfHeader)+readElfHeader logger bs = runGetOrThrow getHeader bs `catchIO` \_ -> do+    debugTraceMsg logger 3 $       text ("Unable to read ELF header")     return Nothing   where@@ -196,13 +195,12 @@  -- | Read the ELF section table readElfSectionTable :: Logger-                    -> DynFlags                     -> ElfHeader                     -> ByteString                     -> IO (Maybe SectionTable) -readElfSectionTable logger dflags hdr bs = action `catchIO` \_ -> do-    debugTraceMsg logger dflags 3 $+readElfSectionTable logger hdr bs = action `catchIO` \_ -> do+    debugTraceMsg logger 3 $       text ("Unable to read ELF section table")     return Nothing   where@@ -248,15 +246,14 @@  -- | Read a ELF section readElfSectionByIndex :: Logger-                      -> DynFlags                       -> ElfHeader                       -> SectionTable                       -> Word64                       -> ByteString                       -> IO (Maybe Section) -readElfSectionByIndex logger dflags hdr secTable i bs = action `catchIO` \_ -> do-    debugTraceMsg logger dflags 3 $+readElfSectionByIndex logger hdr secTable i bs = action `catchIO` \_ -> do+    debugTraceMsg logger 3 $       text ("Unable to read ELF section")     return Nothing   where@@ -293,13 +290,12 @@ -- -- We do not perform any check on the section type. findSectionFromName :: Logger-                    -> DynFlags                     -> ElfHeader                     -> SectionTable                     -> String                     -> ByteString                     -> IO (Maybe ByteString)-findSectionFromName logger dflags hdr secTable name bs =+findSectionFromName logger hdr secTable name bs =     rec [0..sectionEntryCount secTable - 1]   where     -- convert the required section name into a ByteString to perform@@ -310,7 +306,7 @@     -- the matching one, if any     rec []     = return Nothing     rec (x:xs) = do-      me <- readElfSectionByIndex logger dflags hdr secTable x bs+      me <- readElfSectionByIndex logger hdr secTable x bs       case me of         Just e | entryName e == name' -> return (Just (entryBS e))         _                             -> rec xs@@ -321,20 +317,19 @@ -- If the section isn't found or if there is any parsing error, we return -- Nothing readElfSectionByName :: Logger-                     -> DynFlags                      -> ByteString                      -> String                      -> IO (Maybe LBS.ByteString) -readElfSectionByName logger dflags bs name = action `catchIO` \_ -> do-    debugTraceMsg logger dflags 3 $+readElfSectionByName logger bs name = action `catchIO` \_ -> do+    debugTraceMsg logger 3 $       text ("Unable to read ELF section \"" ++ name ++ "\"")     return Nothing   where     action = runMaybeT $ do-      hdr      <- MaybeT $ readElfHeader logger dflags bs-      secTable <- MaybeT $ readElfSectionTable logger dflags hdr bs-      MaybeT $ findSectionFromName logger dflags hdr secTable name bs+      hdr      <- MaybeT $ readElfHeader logger bs+      secTable <- MaybeT $ readElfSectionTable logger hdr bs+      MaybeT $ findSectionFromName logger hdr secTable name bs  ------------------ -- NOTE SECTIONS@@ -345,14 +340,13 @@ -- If you try to read a note from a section which does not support the Note -- format, the parsing is likely to fail and Nothing will be returned readElfNoteBS :: Logger-              -> DynFlags               -> ByteString               -> String               -> String               -> IO (Maybe LBS.ByteString) -readElfNoteBS logger dflags bs sectionName noteId = action `catchIO`  \_ -> do-    debugTraceMsg logger dflags 3 $+readElfNoteBS logger bs sectionName noteId = action `catchIO`  \_ -> do+    debugTraceMsg logger 3 $          text ("Unable to read ELF note \"" ++ noteId ++                "\" in section \"" ++ sectionName ++ "\"")     return Nothing@@ -386,8 +380,8 @@       action = runMaybeT $ do-      hdr  <- MaybeT $ readElfHeader logger dflags bs-      sec  <- MaybeT $ readElfSectionByName logger dflags bs sectionName+      hdr  <- MaybeT $ readElfHeader logger bs+      sec  <- MaybeT $ readElfSectionByName logger bs sectionName       MaybeT $ runGetOrThrow (findNote hdr) sec  -- | read a Note as a String@@ -395,21 +389,20 @@ -- If you try to read a note from a section which does not support the Note -- format, the parsing is likely to fail and Nothing will be returned readElfNoteAsString :: Logger-                    -> DynFlags                     -> FilePath                     -> String                     -> String                     -> IO (Maybe String) -readElfNoteAsString logger dflags path sectionName noteId = action `catchIO`  \_ -> do-    debugTraceMsg logger dflags 3 $+readElfNoteAsString logger path sectionName noteId = action `catchIO`  \_ -> do+    debugTraceMsg logger 3 $          text ("Unable to read ELF note \"" ++ noteId ++                "\" in section \"" ++ sectionName ++ "\"")     return Nothing   where     action = do       bs   <- LBS.readFile path-      note <- readElfNoteBS logger dflags bs sectionName noteId+      note <- readElfNoteBS logger bs sectionName noteId       return (fmap B8.unpack note)
compiler/GHC/SysTools/Info.hs view
@@ -26,14 +26,12 @@ import GHC.SysTools.Process  {- Note [Run-time linker info]-+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~ See also: #5240, #6063, #10110  Before 'runLink', we need to be sure to get the relevant information about the linker we're using at runtime to see if we need any extra-options. For example, GNU ld requires '--reduce-memory-overheads' and-'--hash-size=31' in order to use reasonable amounts of memory (see-trac #5240.) But this isn't supported in GNU gold.+options.  Generally, the linker changing from what was detected at ./configure time has always been possible using -pgml, but on Linux it can happen@@ -57,7 +55,7 @@ -}  {- Note [ELF needed shared libs]-+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Some distributions change the link editor's default handling of ELF DT_NEEDED tags to include only those shared objects that are needed to resolve undefined symbols. For Template Haskell we need@@ -70,30 +68,6 @@  -} -{- Note [Windows static libGCC]--The GCC versions being upgraded to in #10726 are configured with-dynamic linking of libgcc supported. This results in libgcc being-linked dynamically when a shared library is created.--This introduces thus an extra dependency on GCC dll that was not-needed before by shared libraries created with GHC. This is a particular-issue on Windows because you get a non-obvious error due to this missing-dependency. This dependent dll is also not commonly on your path.--For this reason using the static libgcc is preferred as it preserves-the same behaviour that existed before. There are however some very good-reasons to have the shared version as well as described on page 181 of-https://gcc.gnu.org/onlinedocs/gcc-5.2.0/gcc.pdf :--"There are several situations in which an application should use the- shared ‘libgcc’ instead of the static version. The most common of these- is when the application wishes to throw and catch exceptions across different- shared libraries. In that case, each of the libraries as well as the application- itself should use the shared ‘libgcc’. "---}- neededLinkArgs :: LinkerInfo -> [Option] neededLinkArgs (GnuLD o)     = o neededLinkArgs (GnuGold o)   = o@@ -127,13 +101,8 @@       -- Try to grab the info from the process output.       parseLinkerInfo stdo _stde _exitc         | any ("GNU ld" `isPrefixOf`) stdo =-          -- GNU ld specifically needs to use less memory. This especially-          -- hurts on small object files. #5240.           -- Set DT_NEEDED for all shared libraries. #10110.-          -- TODO: Investigate if these help or hurt when using split sections.-          return (GnuLD $ map Option ["-Wl,--hash-size=31",-                                      "-Wl,--reduce-memory-overheads",-                                      -- ELF specific flag+          return (GnuLD $ map Option [-- ELF specific flag                                       -- see Note [ELF needed shared libs]                                       "-Wl,--no-as-needed"]) @@ -173,15 +142,10 @@         -- Process creation is also fairly expensive on win32, so         -- we short-circuit here.         return $ GnuLD $ map Option-          [ -- Reduce ld memory usage-            "-Wl,--hash-size=31"-          , "-Wl,--reduce-memory-overheads"-            -- Emit gcc stack checks-            -- Note [Windows stack usage]-          , "-fstack-check"-            -- Force static linking of libGCC-            -- Note [Windows static libGCC]-          , "-static-libgcc" ]+          [ -- Emit stack checks+            -- See Note [Windows stack allocations]+           "-fstack-check"+          ]       _ -> do         -- In practice, we use the compiler as the linker here. Pass         -- -Wl,--version to get linker version info.@@ -195,32 +159,44 @@         parseLinkerInfo (lines stdo) (lines stde) exitc     )     (\err -> do-        debugTraceMsg logger dflags 2+        debugTraceMsg logger 2             (text "Error (figuring out linker information):" <+>              text (show err))-        errorMsg logger dflags $ hang (text "Warning:") 9 $+        errorMsg logger $ hang (text "Warning:") 9 $           text "Couldn't figure out linker information!" $$           text "Make sure you're using GNU ld, GNU gold" <+>           text "or the built in OS X linker, etc."         return UnknownLD     ) --- Grab compiler info and cache it in DynFlags.+-- | Grab compiler info and cache it in DynFlags. getCompilerInfo :: Logger -> DynFlags -> IO CompilerInfo getCompilerInfo logger dflags = do   info <- readIORef (rtccInfo dflags)   case info of     Just v  -> return v     Nothing -> do-      v <- getCompilerInfo' logger dflags+      let pgm = pgm_c dflags+      v <- getCompilerInfo' logger pgm       writeIORef (rtccInfo dflags) (Just v)       return v +-- | Grab assembler info and cache it in DynFlags.+getAssemblerInfo :: Logger -> DynFlags -> IO CompilerInfo+getAssemblerInfo logger dflags = do+  info <- readIORef (rtasmInfo dflags)+  case info of+    Just v  -> return v+    Nothing -> do+      let (pgm, _) = pgm_a dflags+      v <- getCompilerInfo' logger pgm+      writeIORef (rtasmInfo dflags) (Just v)+      return v+ -- See Note [Run-time linker info].-getCompilerInfo' :: Logger -> DynFlags -> IO CompilerInfo-getCompilerInfo' logger dflags = do-  let pgm = pgm_c dflags-      -- Try to grab the info from the process output.+getCompilerInfo' :: Logger -> String -> IO CompilerInfo+getCompilerInfo' logger pgm = do+  let -- Try to grab the info from the process output.       parseCompilerInfo _stdo stde _exitc         -- Regular GCC         | any ("gcc version" `isInfixOf`) stde =@@ -240,8 +216,8 @@         -- Xcode 4.1 clang         | any ("Apple clang version" `isPrefixOf`) stde =           return AppleClang-         -- Unknown linker.-        | otherwise = fail $ "invalid -v output, or compiler is unsupported: " ++ unlines stde+         -- Unknown compiler.+        | otherwise = fail $ "invalid -v output, or compiler is unsupported (" ++ pgm ++ "): " ++ unlines stde    -- Process the executable call   catchIO (do@@ -252,10 +228,10 @@       parseCompilerInfo (lines stdo) (lines stde) exitc       )       (\err -> do-          debugTraceMsg logger dflags 2+          debugTraceMsg logger 2               (text "Error (figuring out C compiler information):" <+>                text (show err))-          errorMsg logger dflags $ hang (text "Warning:") 9 $+          errorMsg logger $ hang (text "Warning:") 9 $             text "Couldn't figure out C compiler information!" $$             text "Make sure you're using GNU gcc, or clang"           return UnknownCC
compiler/GHC/SysTools/Process.hs view
@@ -8,8 +8,6 @@ ----------------------------------------------------------------------------- module GHC.SysTools.Process where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Driver.Session@@ -133,7 +131,6 @@ -- Running an external program  runSomething :: Logger-             -> DynFlags              -> String          -- For -v message              -> String          -- Command name (possibly a full path)                                 --      assumed already dos-ified@@ -141,8 +138,8 @@                                 --      runSomething will dos-ify them              -> IO () -runSomething logger dflags phase_name pgm args =-  runSomethingFiltered logger dflags id phase_name pgm args Nothing Nothing+runSomething logger phase_name pgm args =+  runSomethingFiltered logger id phase_name pgm args Nothing Nothing  -- | Run a command, placing the arguments in an external response file. --@@ -164,14 +161,14 @@   -> Maybe [(String,String)]   -> IO () runSomethingResponseFile logger tmpfs dflags filter_fn phase_name pgm args mb_env =-    runSomethingWith logger dflags phase_name pgm args $ \real_args -> do+    runSomethingWith logger phase_name pgm args $ \real_args -> do         fp <- getResponseFile real_args         let args = ['@':fp]-        r <- builderMainLoop logger dflags filter_fn pgm args Nothing mb_env+        r <- builderMainLoop logger filter_fn pgm args Nothing mb_env         return (r,())   where     getResponseFile args = do-      fp <- newTempName logger tmpfs dflags TFL_CurrentModule "rsp"+      fp <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "rsp"       withFile fp WriteMode $ \h -> do #if defined(mingw32_HOST_OS)           hSetEncoding h latin1@@ -207,23 +204,23 @@         ]  runSomethingFiltered-  :: Logger -> DynFlags -> (String->String) -> String -> String -> [Option]+  :: Logger -> (String->String) -> String -> String -> [Option]   -> Maybe FilePath -> Maybe [(String,String)] -> IO () -runSomethingFiltered logger dflags filter_fn phase_name pgm args mb_cwd mb_env =-    runSomethingWith logger dflags phase_name pgm args $ \real_args -> do-        r <- builderMainLoop logger dflags filter_fn pgm real_args mb_cwd mb_env+runSomethingFiltered logger filter_fn phase_name pgm args mb_cwd mb_env =+    runSomethingWith logger phase_name pgm args $ \real_args -> do+        r <- builderMainLoop logger filter_fn pgm real_args mb_cwd mb_env         return (r,())  runSomethingWith-  :: Logger -> DynFlags -> String -> String -> [Option]+  :: Logger -> String -> String -> [Option]   -> ([String] -> IO (ExitCode, a))   -> IO a -runSomethingWith logger dflags phase_name pgm args io = do+runSomethingWith logger phase_name pgm args io = do   let real_args = filter notNull (map showOpt args)       cmdLine = showCommandForUser pgm real_args-  traceCmd logger dflags phase_name cmdLine $ handleProc pgm phase_name $ io real_args+  traceCmd logger phase_name cmdLine $ handleProc pgm phase_name $ io real_args  handleProc :: String -> String -> IO (ExitCode, r) -> IO r handleProc pgm phase_name proc = do@@ -243,10 +240,10 @@     does_not_exist = throwGhcExceptionIO (InstallationError ("could not execute: " ++ pgm))  -builderMainLoop :: Logger -> DynFlags -> (String -> String) -> FilePath+builderMainLoop :: Logger -> (String -> String) -> FilePath                 -> [String] -> Maybe FilePath -> Maybe [(String, String)]                 -> IO ExitCode-builderMainLoop logger dflags filter_fn pgm real_args mb_cwd mb_env = do+builderMainLoop logger filter_fn pgm real_args mb_cwd mb_env = do   chan <- newChan    -- We use a mask here rather than a bracket because we want@@ -307,10 +304,10 @@       msg <- readChan chan       case msg of         BuildMsg msg -> do-          logInfo logger dflags $ withPprStyle defaultUserStyle msg+          logInfo logger $ withPprStyle defaultUserStyle msg           log_loop chan t         BuildError loc msg -> do-          putLogMsg logger dflags NoReason SevError (mkSrcSpan loc loc)+          logMsg logger errorDiagnostic (mkSrcSpan loc loc)               $ withPprStyle defaultUserStyle msg           log_loop chan t         EOF ->
compiler/GHC/SysTools/Tasks.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE CPP #-}+ ----------------------------------------------------------------------------- -- -- Tasks running external programs for SysTools@@ -12,8 +12,10 @@ import GHC.Prelude import GHC.Platform import GHC.ForeignSrcLang+import GHC.IO (catchException) -import GHC.CmmToLlvm.Base (LlvmVersion, llvmVersionStr, supportedLlvmVersionLowerBound, supportedLlvmVersionUpperBound, llvmVersionStr, parseLlvmVersion)+import GHC.CmmToLlvm.Base   (llvmVersionStr, supportedLlvmVersionUpperBound, parseLlvmVersion, supportedLlvmVersionLowerBound)+import GHC.CmmToLlvm.Config (LlvmVersion)  import GHC.SysTools.Process import GHC.SysTools.Info@@ -26,8 +28,11 @@ import GHC.Utils.Misc import GHC.Utils.Logger import GHC.Utils.TmpFs+import GHC.Utils.Constants (isWindowsHost)+import GHC.Utils.Panic  import Data.List (tails, isPrefixOf)+import Data.Maybe (fromMaybe) import System.IO import System.Process @@ -40,38 +45,49 @@ -}  runUnlit :: Logger -> DynFlags -> [Option] -> IO ()-runUnlit logger dflags args = traceToolCommand logger dflags "unlit" $ do+runUnlit logger dflags args = traceToolCommand logger "unlit" $ do   let prog = pgm_L dflags       opts = getOpts dflags opt_L-  runSomething logger dflags "Literate pre-processor" prog+  runSomething logger "Literate pre-processor" prog                (map Option opts ++ args) +-- | Prepend the working directory to the search path.+-- Note [Filepaths and Multiple Home Units]+augmentImports :: DynFlags  -> [FilePath] -> [FilePath]+augmentImports dflags fps | Nothing <- workingDirectory dflags  = fps+augmentImports _ [] = []+augmentImports _ [x] = [x]+augmentImports dflags ("-include":fp:fps) = "-include" : augmentByWorkingDirectory dflags fp  : augmentImports dflags fps+augmentImports dflags (fp1: fp2: fps) = fp1 : augmentImports dflags (fp2:fps)+ runCpp :: Logger -> DynFlags -> [Option] -> IO ()-runCpp logger dflags args = traceToolCommand logger dflags "cpp" $ do+runCpp logger dflags args = traceToolCommand logger "cpp" $ do+  let opts = getOpts dflags opt_P+      modified_imports = augmentImports dflags opts   let (p,args0) = pgm_P dflags-      args1 = map Option (getOpts dflags opt_P)+      args1 = map Option modified_imports       args2 = [Option "-Werror" | gopt Opt_WarnIsError dflags]                 ++ [Option "-Wundef" | wopt Opt_WarnCPPUndef dflags]   mb_env <- getGccEnv args2-  runSomethingFiltered logger dflags id  "C pre-processor" p+  runSomethingFiltered logger id  "C pre-processor" p                        (args0 ++ args1 ++ args2 ++ args) Nothing mb_env  runPp :: Logger -> DynFlags -> [Option] -> IO ()-runPp logger dflags args = traceToolCommand logger dflags "pp" $ do+runPp logger dflags args = traceToolCommand logger "pp" $ do   let prog = pgm_F dflags       opts = map Option (getOpts dflags opt_F)-  runSomething logger dflags "Haskell pre-processor" prog (args ++ opts)+  runSomething logger "Haskell pre-processor" prog (args ++ opts)  -- | Run compiler of C-like languages and raw objects (such as gcc or clang). runCc :: Maybe ForeignSrcLang -> Logger -> TmpFs -> DynFlags -> [Option] -> IO ()-runCc mLanguage logger tmpfs dflags args = traceToolCommand logger dflags "cc" $ do-  let p = pgm_c dflags-      args1 = map Option userOpts+runCc mLanguage logger tmpfs dflags args = traceToolCommand logger "cc" $ do+  let args1 = map Option userOpts       args2 = languageOptions ++ args ++ args1       -- We take care to pass -optc flags in args1 last to ensure that the       -- user can override flags passed by GHC. See #14452.   mb_env <- getGccEnv args2-  runSomethingResponseFile logger tmpfs dflags cc_filter "C Compiler" p args2 mb_env+  runSomethingResponseFile logger tmpfs dflags cc_filter dbgstring prog args2+                           mb_env  where   -- discard some harmless warnings from gcc that we can't turn off   cc_filter = unlines . doFilter . lines@@ -127,17 +143,23 @@   -- compiling .hc files, by adding the -x c option.   -- Also useful for plain .c files, just in case GHC saw a   -- -x c option.-  (languageOptions, userOpts) = case mLanguage of-    Nothing -> ([], userOpts_c)-    Just language -> ([Option "-x", Option languageName], opts)+  (languageOptions, userOpts, prog, dbgstring) = case mLanguage of+    Nothing -> ([], userOpts_c, pgm_c dflags, "C Compiler")+    Just language -> ([Option "-x", Option languageName], opts, prog, dbgstr)       where-        (languageName, opts) = case language of-          LangC      -> ("c",             userOpts_c)-          LangCxx    -> ("c++",           userOpts_cxx)-          LangObjc   -> ("objective-c",   userOpts_c)-          LangObjcxx -> ("objective-c++", userOpts_cxx)-          LangAsm    -> ("assembler",     [])-          RawObject  -> ("c",             []) -- claim C for lack of a better idea+        (languageName, opts, prog, dbgstr) = case language of+          LangC      -> ("c",             userOpts_c+                        ,pgm_c dflags,    "C Compiler")+          LangCxx    -> ("c++",           userOpts_cxx+                        ,pgm_cxx dflags , "C++ Compiler")+          LangObjc   -> ("objective-c",   userOpts_c+                        ,pgm_c dflags   , "Objective C Compiler")+          LangObjcxx -> ("objective-c++", userOpts_cxx+                        ,pgm_cxx dflags,  "Objective C++ Compiler")+          LangAsm    -> ("assembler",     []+                        ,pgm_c dflags,    "Asm Compiler")+          RawObject  -> ("c",             []+                        ,pgm_c dflags,    "C Compiler") -- claim C for lack of a better idea   userOpts_c   = getOpts dflags opt_c   userOpts_cxx = getOpts dflags opt_cxx @@ -146,43 +168,43 @@  -- | Run the linker with some arguments and return the output askLd :: Logger -> DynFlags -> [Option] -> IO String-askLd logger dflags args = traceToolCommand logger dflags "linker" $ do+askLd logger dflags args = traceToolCommand logger "linker" $ do   let (p,args0) = pgm_l dflags       args1     = map Option (getOpts dflags opt_l)       args2     = args0 ++ args1 ++ args   mb_env <- getGccEnv args2-  runSomethingWith logger dflags "gcc" p args2 $ \real_args ->+  runSomethingWith logger "gcc" p args2 $ \real_args ->     readCreateProcessWithExitCode' (proc p real_args){ env = mb_env }  runAs :: Logger -> DynFlags -> [Option] -> IO ()-runAs logger dflags args = traceToolCommand logger dflags "as" $ do+runAs logger dflags args = traceToolCommand logger "as" $ do   let (p,args0) = pgm_a dflags       args1 = map Option (getOpts dflags opt_a)       args2 = args0 ++ args1 ++ args   mb_env <- getGccEnv args2-  runSomethingFiltered logger dflags id "Assembler" p args2 Nothing mb_env+  runSomethingFiltered logger id "Assembler" p args2 Nothing mb_env  -- | Run the LLVM Optimiser runLlvmOpt :: Logger -> DynFlags -> [Option] -> IO ()-runLlvmOpt logger dflags args = traceToolCommand logger dflags "opt" $ do+runLlvmOpt logger dflags args = traceToolCommand logger "opt" $ do   let (p,args0) = pgm_lo dflags       args1 = map Option (getOpts dflags opt_lo)       -- We take care to pass -optlo flags (e.g. args0) last to ensure that the       -- user can override flags passed by GHC. See #14821.-  runSomething logger dflags "LLVM Optimiser" p (args1 ++ args ++ args0)+  runSomething logger "LLVM Optimiser" p (args1 ++ args ++ args0)  -- | Run the LLVM Compiler runLlvmLlc :: Logger -> DynFlags -> [Option] -> IO ()-runLlvmLlc logger dflags args = traceToolCommand logger dflags "llc" $ do+runLlvmLlc logger dflags args = traceToolCommand logger "llc" $ do   let (p,args0) = pgm_lc dflags       args1 = map Option (getOpts dflags opt_lc)-  runSomething logger dflags "LLVM Compiler" p (args0 ++ args1 ++ args)+  runSomething logger "LLVM Compiler" p (args0 ++ args1 ++ args)  -- | Run the clang compiler (used as an assembler for the LLVM -- backend on OS X as LLVM doesn't support the OS X system -- assembler) runClang :: Logger -> DynFlags -> [Option] -> IO ()-runClang logger dflags args = traceToolCommand logger dflags "clang" $ do+runClang logger dflags args = traceToolCommand logger "clang" $ do   let (clang,_) = pgm_lcc dflags       -- be careful what options we call clang with       -- see #5903 and #7617 for bugs caused by this.@@ -190,10 +212,10 @@       args1 = map Option (getOpts dflags opt_a)       args2 = args0 ++ args1 ++ args   mb_env <- getGccEnv args2-  catch-    (runSomethingFiltered logger dflags id "Clang (Assembler)" clang args2 Nothing mb_env)+  catchException+    (runSomethingFiltered logger id "Clang (Assembler)" clang args2 Nothing mb_env)     (\(err :: SomeException) -> do-        errorMsg logger dflags $+        errorMsg logger $             text ("Error running clang! you need clang installed to use the" ++                   " LLVM backend") $+$             text "(or GHC tried to execute clang incorrectly)"@@ -202,7 +224,7 @@  -- | Figure out which version of LLVM we are running this session figureLlvmVersion :: Logger -> DynFlags -> IO (Maybe LlvmVersion)-figureLlvmVersion logger dflags = traceToolCommand logger dflags "llc" $ do+figureLlvmVersion logger dflags = traceToolCommand logger "llc" $ do   let (pgm,opts) = pgm_lc dflags       args = filter notNull (map showOpt opts)       -- we grab the args even though they should be useless just in@@ -229,10 +251,10 @@               return mb_ver             )             (\err -> do-                debugTraceMsg logger dflags 2+                debugTraceMsg logger 2                     (text "Error (figuring out LLVM version):" <+>                       text (show err))-                errorMsg logger dflags $ vcat+                errorMsg logger $ vcat                     [ text "Warning:", nest 9 $                           text "Couldn't figure out LLVM version!" $$                           text ("Make sure you have installed LLVM between ["@@ -245,7 +267,7 @@   runLink :: Logger -> TmpFs -> DynFlags -> [Option] -> IO ()-runLink logger tmpfs dflags args = traceToolCommand logger dflags "linker" $ do+runLink logger tmpfs dflags args = traceToolCommand logger "linker" $ do   -- See Note [Run-time linker info]   --   -- `-optl` args come at the end, so that later `-l` options@@ -309,80 +331,64 @@  -- See Note [Merging object files for GHCi] in GHC.Driver.Pipeline. runMergeObjects :: Logger -> TmpFs -> DynFlags -> [Option] -> IO ()-#if defined(mingw32_HOST_OS)-runMergeObjects logger tmpfs  dflags args =-#else-runMergeObjects logger _tmpfs dflags args =-#endif-  traceToolCommand logger dflags "merge-objects" $ do-    let (p,args0) = pgm_lm dflags+runMergeObjects logger tmpfs dflags args =+  traceToolCommand logger "merge-objects" $ do+    let (p,args0) = fromMaybe err (pgm_lm dflags)+        err = throwGhcException $ UsageError $ unwords+            [ "Attempted to merge object files but the configured linker"+            , "does not support object merging." ]         optl_args = map Option (getOpts dflags opt_lm)         args2     = args0 ++ args ++ optl_args     -- N.B. Darwin's ld64 doesn't support response files. Consequently we only     -- use them on Windows where they are truly necessary.-#if defined(mingw32_HOST_OS)-    mb_env <- getGccEnv args2-    runSomethingResponseFile logger tmpfs dflags id "Merge objects" p args2 mb_env-#else-    runSomething logger dflags "Merge objects" p args2-#endif+    if isWindowsHost+      then do+        mb_env <- getGccEnv args2+        runSomethingResponseFile logger tmpfs dflags id "Merge objects" p args2 mb_env+      else do+        runSomething logger "Merge objects" p args2  runLibtool :: Logger -> DynFlags -> [Option] -> IO ()-runLibtool logger dflags args = traceToolCommand logger dflags "libtool" $ do+runLibtool logger dflags args = traceToolCommand logger "libtool" $ do   linkargs <- neededLinkArgs `fmap` getLinkerInfo logger dflags   let args1      = map Option (getOpts dflags opt_l)       args2      = [Option "-static"] ++ args1 ++ args ++ linkargs       libtool    = pgm_libtool dflags   mb_env <- getGccEnv args2-  runSomethingFiltered logger dflags id "Libtool" libtool args2 Nothing mb_env+  runSomethingFiltered logger id "Libtool" libtool args2 Nothing mb_env  runAr :: Logger -> DynFlags -> Maybe FilePath -> [Option] -> IO ()-runAr logger dflags cwd args = traceToolCommand logger dflags "ar" $ do+runAr logger dflags cwd args = traceToolCommand logger "ar" $ do   let ar = pgm_ar dflags-  runSomethingFiltered logger dflags id "Ar" ar args cwd Nothing+  runSomethingFiltered logger id "Ar" ar args cwd Nothing  askOtool :: Logger -> DynFlags -> Maybe FilePath -> [Option] -> IO String askOtool logger dflags mb_cwd args = do   let otool = pgm_otool dflags-  runSomethingWith logger dflags "otool" otool args $ \real_args ->+  runSomethingWith logger "otool" otool args $ \real_args ->     readCreateProcessWithExitCode' (proc otool real_args){ cwd = mb_cwd }  runInstallNameTool :: Logger -> DynFlags -> [Option] -> IO () runInstallNameTool logger dflags args = do   let tool = pgm_install_name_tool dflags-  runSomethingFiltered logger dflags id "Install Name Tool" tool args Nothing Nothing+  runSomethingFiltered logger id "Install Name Tool" tool args Nothing Nothing  runRanlib :: Logger -> DynFlags -> [Option] -> IO ()-runRanlib logger dflags args = traceToolCommand logger dflags "ranlib" $ do+runRanlib logger dflags args = traceToolCommand logger "ranlib" $ do   let ranlib = pgm_ranlib dflags-  runSomethingFiltered logger dflags id "Ranlib" ranlib args Nothing Nothing+  runSomethingFiltered logger id "Ranlib" ranlib args Nothing Nothing  runWindres :: Logger -> DynFlags -> [Option] -> IO ()-runWindres logger dflags args = traceToolCommand logger dflags "windres" $ do-  let cc = pgm_c dflags-      cc_args = map Option (sOpt_c (settings dflags))+runWindres logger dflags args = traceToolCommand logger "windres" $ do+  let cc_args = map Option (sOpt_c (settings dflags))       windres = pgm_windres dflags       opts = map Option (getOpts dflags opt_windres)-      quote x = "\"" ++ x ++ "\""-      args' = -- If windres.exe and gcc.exe are in a directory containing-              -- spaces then windres fails to run gcc. We therefore need-              -- to tell it what command to use...-              Option ("--preprocessor=" ++-                      unwords (map quote (cc :-                                          map showOpt opts ++-                                          ["-E", "-xc", "-DRC_INVOKED"])))-              -- ...but if we do that then if windres calls popen then-              -- it can't understand the quoting, so we have to use-              -- --use-temp-file so that it interprets it correctly.-              -- See #1828.-            : Option "--use-temp-file"-            : args   mb_env <- getGccEnv cc_args-  runSomethingFiltered logger dflags id "Windres" windres args' Nothing mb_env+  runSomethingFiltered logger id "Windres" windres (opts ++ args) Nothing mb_env  touch :: Logger -> DynFlags -> String -> String -> IO ()-touch logger dflags purpose arg = traceToolCommand logger dflags "touch" $-  runSomething logger dflags purpose (pgm_T dflags) [FileOption "" arg]+touch logger dflags purpose arg = traceToolCommand logger "touch" $+  runSomething logger purpose (pgm_T dflags) [FileOption "" arg]  -- * Tracing utility @@ -393,6 +399,5 @@ -- --   For those events to show up in the eventlog, you need --   to run GHC with @-v2@ or @-ddump-timings@.-traceToolCommand :: Logger -> DynFlags -> String -> IO a -> IO a-traceToolCommand logger dflags tool = withTiming logger-  dflags (text $ "systool:" ++ tool) (const ())+traceToolCommand :: Logger -> String -> IO a -> IO a+traceToolCommand logger tool = withTiming logger (text "systool:" <> text tool) (const ())
compiler/GHC/Tc/Deriv.hs view
@@ -4,7 +4,8 @@  -} -{-# LANGUAGE CPP #-}++{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TypeFamilies #-} @@ -13,17 +14,15 @@ -- | Handles @deriving@ clauses on @data@ declarations. module GHC.Tc.Deriv ( tcDeriving, DerivInfo(..) ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Hs import GHC.Driver.Session +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Instance.Family import GHC.Tc.Types.Origin-import GHC.Core.Predicate import GHC.Tc.Deriv.Infer import GHC.Tc.Deriv.Utils import GHC.Tc.TyCl.Class( instDeclCtxt3, tcATDefault )@@ -61,8 +60,8 @@ import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Logger-import GHC.Data.FastString import GHC.Data.Bag import GHC.Utils.FV as FV (fvVarList, unionFV, mkFVs) import qualified GHC.LanguageExtensions as LangExt@@ -89,7 +88,7 @@ 3.  Add the derived bindings, generating InstInfos -} -data EarlyDerivSpec = InferTheta (DerivSpec [ThetaOrigin])+data EarlyDerivSpec = InferTheta (DerivSpec ThetaSpec)                     | GivenTheta (DerivSpec ThetaType)         -- InferTheta ds => the context for the instance should be inferred         --      In this case ds_theta is the list of all the sets of@@ -103,7 +102,7 @@         -- See Note [Inferring the instance context] in GHC.Tc.Deriv.Infer  splitEarlyDerivSpec :: [EarlyDerivSpec]-                    -> ([DerivSpec [ThetaOrigin]], [DerivSpec ThetaType])+                    -> ([DerivSpec ThetaSpec], [DerivSpec ThetaType]) splitEarlyDerivSpec [] = ([],[]) splitEarlyDerivSpec (InferTheta spec : specs) =     case splitEarlyDerivSpec specs of (is, gs) -> (spec : is, gs)@@ -171,6 +170,8 @@                              -- or the *representation* tycon for data families                            , di_scoped_tvs :: ![(Name,TyVar)]                              -- ^ Variables that scope over the deriving clause.+                             -- See @Note [Scoped tyvars in a TcTyCon]@ in+                             -- "GHC.Core.TyCon".                            , di_clauses :: [LHsDerivingClause GhcRn]                            , di_ctxt    :: SDoc -- ^ error context                            }@@ -196,71 +197,66 @@         ; traceTc "tcDeriving" (ppr early_specs)          ; let (infer_specs, given_specs) = splitEarlyDerivSpec early_specs-        ; insts1 <- mapM genInst given_specs-        ; insts2 <- mapM genInst infer_specs+        ; famInsts1 <- concatMapM genFamInsts given_specs+        ; famInsts2 <- concatMapM genFamInsts infer_specs+        ; let famInsts = famInsts1 ++ famInsts2          ; dflags <- getDynFlags         ; logger <- getLogger -        ; let (_, deriv_stuff, fvs) = unzip3 (insts1 ++ insts2)-        ; loc <- getSrcSpanM-        ; let (binds, famInsts) = genAuxBinds dflags loc-                                    (unionManyBags deriv_stuff)--        ; let mk_inst_infos1 = map fstOf3 insts1-        ; inst_infos1 <- apply_inst_infos mk_inst_infos1 given_specs-           -- We must put all the derived type family instances (from both           -- infer_specs and given_specs) in the local instance environment           -- before proceeding, or else simplifyInstanceContexts might           -- get stuck if it has to reason about any of those family instances.           -- See Note [Staging of tcDeriving]-        ; tcExtendLocalFamInstEnv (bagToList famInsts) $+        ; tcExtendLocalFamInstEnv famInsts $           -- NB: only call tcExtendLocalFamInstEnv once, as it performs           -- validity checking for all of the family instances you give it.           -- If the family instances have errors, calling it twice will result           -- in duplicate error messages! -     do {-        -- the stand-alone derived instances (@inst_infos1@) are used when+     do { given_inst_binds <- mapM genInstBinds given_specs++        ; let given_inst_infos = map fstOf3 given_inst_binds++        -- the stand-alone derived instances (@given_inst_infos@) are used when         -- inferring the contexts for "deriving" clauses' instances         -- (@infer_specs@)-        ; final_specs <- extendLocalInstEnv (map iSpec inst_infos1) $-                         simplifyInstanceContexts infer_specs+        ; final_infer_specs <-+            extendLocalInstEnv (map iSpec given_inst_infos) $+            simplifyInstanceContexts infer_specs+        ; infer_inst_binds <- mapM genInstBinds final_infer_specs -        ; let mk_inst_infos2 = map fstOf3 insts2-        ; inst_infos2 <- apply_inst_infos mk_inst_infos2 final_specs-        ; let inst_infos = inst_infos1 ++ inst_infos2+        ; let (_, aux_specs, fvs) = unzip3 (given_inst_binds ++ infer_inst_binds)+        ; loc <- getSrcSpanM+        ; let aux_binds = genAuxBinds dflags loc (unionManyBags aux_specs) -        ; (inst_info, rn_binds, rn_dus) <- renameDeriv inst_infos binds+        ; let infer_inst_infos = map fstOf3 infer_inst_binds+        ; let inst_infos = given_inst_infos ++ infer_inst_infos +        ; (inst_info, rn_aux_binds, rn_dus) <- renameDeriv inst_infos aux_binds+         ; unless (isEmptyBag inst_info) $-             liftIO (dumpIfSet_dyn logger dflags Opt_D_dump_deriv "Derived instances"+             liftIO (putDumpFileMaybe logger Opt_D_dump_deriv "Derived instances"                         FormatHaskell-                        (ddump_deriving inst_info rn_binds famInsts))+                        (ddump_deriving inst_info rn_aux_binds famInsts))          ; gbl_env <- tcExtendLocalInstEnv (map iSpec (bagToList inst_info))                                           getGblEnv         ; let all_dus = rn_dus `plusDU` usesOnly (NameSet.mkFVs $ concat fvs)-        ; return (addTcgDUs gbl_env all_dus, inst_info, rn_binds) } }+        ; return (addTcgDUs gbl_env all_dus, inst_info, rn_aux_binds) } }   where     ddump_deriving :: Bag (InstInfo GhcRn) -> HsValBinds GhcRn-                   -> Bag FamInst             -- ^ Rep type family instances+                   -> [FamInst]               -- Associated type family instances                    -> SDoc-    ddump_deriving inst_infos extra_binds repFamInsts+    ddump_deriving inst_infos extra_binds famInsts       =    hang (text "Derived class instances:")               2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") (bagToList inst_infos))                  $$ ppr extra_binds)-        $$ hangP "Derived type family instances:"-             (vcat (map pprRepTy (bagToList repFamInsts)))--    hangP s x = text "" $$ hang (ptext (sLit s)) 2 x+        $$ hangP (text "Derived type family instances:")+             (vcat (map pprRepTy famInsts)) -    -- Apply the suspended computations given by genInst calls.-    -- See Note [Staging of tcDeriving]-    apply_inst_infos :: [ThetaType -> TcM (InstInfo GhcPs)]-                     -> [DerivSpec ThetaType] -> TcM [InstInfo GhcPs]-    apply_inst_infos = zipWithM (\f ds -> f (ds_theta ds))+    hangP s x = text "" $$ hang s 2 x  -- Prints the representable type family instance pprRepTy :: FamInst -> SDoc@@ -358,32 +354,18 @@ it needed in the environment in order to properly simplify instance like the C N instance above. -To avoid this scenario, we carefully structure the order of events in-tcDeriving. We first call genInst on the standalone derived instance specs and-the instance specs obtained from deriving clauses. Note that the return type of-genInst is a triple:--    TcM (ThetaType -> TcM (InstInfo RdrName), BagDerivStuff, Maybe Name)--The type family instances are in the BagDerivStuff. The first field of the-triple is a suspended computation which, given an instance context, produces-the rest of the instance. The fact that it is suspended is important, because-right now, we don't have ThetaTypes for the instances that use deriving clauses-(only the standalone-derived ones).--Now we can collect the type family instances and extend the local instance-environment. At this point, it is safe to run simplifyInstanceContexts on the-deriving-clause instance specs, which gives us the ThetaTypes for the-deriving-clause instances. Now we can feed all the ThetaTypes to the-suspended computations and obtain our InstInfos, at which point-tcDeriving is done.+To avoid this scenario, we generate things in tcDeriving in a specific order: -An alternative design would be to split up genInst so that the-family instances are generated separately from the InstInfos. But this would-require carving up a lot of the GHC deriving internals to accommodate the-change. On the other hand, we can keep all of the InstInfo and type family-instance logic together in genInst simply by converting genInst to-continuation-returning style, so we opt for that route.+1. First, we generate all of the associated type family instances for derived+   instances (using `genFamInsts`).+2. Next, we extend the local instance environment with these type family+   instances.+3. Then, we generate the instance bindings for derived instances+   (using `genInstBinds`).+4. Finally, for instances generated with `deriving` clauses, we infer the+   instance contexts (using `simplifyInstanceContexts`). At this point, we+   already have the necessary type family instances in scope (from step (2)),+   so this is safe to do.  Note [Why we don't pass rep_tc into deriveTyData] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -438,6 +420,7 @@                -> TcM [EarlyDerivSpec] makeDerivSpecs deriv_infos deriv_decls   = do  { eqns1 <- sequenceA+                      -- MP: scoped_tvs here magically converts TyVar into TcTyVar                      [ deriveClause rep_tc scoped_tvs dcs (deriv_clause_preds dct) err_ctxt                      | DerivInfo { di_rep_tc = rep_tc                                  , di_scoped_tvs = scoped_tvs@@ -511,7 +494,7 @@       , text "via_tvs"         <+> ppr via_tvs ]     (cls_tvs, cls, cls_tys, cls_arg_kinds) <- tcHsDeriv deriv_pred     when (cls_arg_kinds `lengthIsNot` 1) $-      failWithTc (nonUnaryErr deriv_pred)+      failWithTc (TcRnNonUnaryTypeclassConstraint deriv_pred)     let [cls_arg_kind] = cls_arg_kinds         mb_deriv_strat = fmap unLoc mb_lderiv_strat     if (className cls == typeableClassName)@@ -632,6 +615,8 @@        ; traceTc "Deriving strategy (standalone deriving)" $            vcat [ppr mb_lderiv_strat, ppr deriv_ty]        ; (mb_lderiv_strat, via_tvs) <- tcDerivStrategy mb_lderiv_strat+       ; traceTc "Deriving strategy (standalone deriving) 2" $+           vcat [ppr mb_lderiv_strat, ppr via_tvs]        ; (cls_tvs, deriv_ctxt, cls, inst_tys)            <- tcExtendTyVarEnv via_tvs $               tcStandaloneDerivInstType ctxt deriv_ty@@ -656,8 +641,8 @@                    mb_match     = tcUnifyTy inst_ty_kind via_kind                 checkTc (isJust mb_match)-                       (derivingViaKindErr cls inst_ty_kind-                                           via_ty via_kind)+                       (TcRnCannotDeriveInstance cls mempty Nothing NoGeneralizedNewtypeDeriving $+                          DerivErrDerivingViaWrongKind inst_ty_kind via_ty via_kind)                 let Just kind_subst = mb_match                    ki_subst_range  = getTCvSubstRangeFVs kind_subst@@ -737,11 +722,7 @@        pure (tvs, SupplyContext theta, cls, inst_tys)  warnUselessTypeable :: TcM ()-warnUselessTypeable-  = do { warn <- woptM Opt_WarnDerivingTypeable-       ; when warn $ addWarnTc (Reason Opt_WarnDerivingTypeable)-                   $ text "Deriving" <+> quotes (ppr typeableClassName) <+>-                     text "has no effect: all types now auto-derive Typeable" }+warnUselessTypeable = addDiagnosticTc TcRnUselessTypeable  ------------------------------------------------------------------ deriveTyData :: TyCon -> [Type] -- LHS of data or data instance@@ -777,7 +758,8 @@          -- Check that the result really is well-kinded         ; checkTc (enough_args && isJust mb_match)-                  (derivingKindErr tc cls cls_tys cls_arg_kind enough_args)+                  (TcRnCannotDeriveInstance cls cls_tys Nothing NoGeneralizedNewtypeDeriving $+                     DerivErrNotWellKinded tc cls_arg_kind n_args_to_keep)          ; let -- Returns a singleton-element list if using ViaStrategy and an               -- empty list otherwise. Useful for free-variable calculations.@@ -822,7 +804,8 @@                     via_match = tcUnifyTy inst_ty_kind via_kind                  checkTc (isJust via_match)-                        (derivingViaKindErr cls inst_ty_kind via_ty via_kind)+                        (TcRnCannotDeriveInstance cls mempty Nothing NoGeneralizedNewtypeDeriving $+                           DerivErrDerivingViaWrongKind inst_ty_kind via_ty via_kind)                  let Just via_subst = via_match                 pure $ propagate_subst via_subst tkvs' cls_tys'@@ -843,7 +826,8 @@         ; let final_tc_app   = mkTyConApp tc final_tc_args               final_cls_args = final_cls_tys ++ [final_tc_app]         ; checkTc (allDistinctTyVars (mkVarSet final_tkvs) args_to_drop) -- (a, b, c)-                  (derivingEtaErr cls final_cls_tys final_tc_app)+                  (TcRnCannotDeriveInstance cls final_cls_tys Nothing NoGeneralizedNewtypeDeriving $+                     DerivErrNoEtaReduce final_tc_app)                 -- Check that                 --  (a) The args to drop are all type variables; eg reject:                 --              data instance T a Int = .... deriving( Monad )@@ -1152,19 +1136,44 @@  mkEqnHelp overlap_mode tvs cls cls_args deriv_ctxt deriv_strat = do   is_boot <- tcIsHsBootOrSig-  when is_boot $-       bale_out (text "Cannot derive instances in hs-boot files"-             $+$ text "Write an instance declaration instead")+  when is_boot $ bale_out DerivErrBootFileFound++  let pred = mkClassPred cls cls_args+  skol_info <- mkSkolemInfo (DerivSkol pred)+  (tvs', cls_args', deriv_strat') <-+    skolemise_when_inferring_context skol_info deriv_ctxt+  let deriv_env = DerivEnv+                    { denv_overlap_mode = overlap_mode+                    , denv_tvs          = tvs'+                    , denv_cls          = cls+                    , denv_inst_tys     = cls_args'+                    , denv_ctxt         = deriv_ctxt+                    , denv_skol_info    = skol_info+                    , denv_strat        = deriv_strat' }   runReaderT mk_eqn deriv_env   where-    deriv_env = DerivEnv { denv_overlap_mode = overlap_mode-                         , denv_tvs          = tvs-                         , denv_cls          = cls-                         , denv_inst_tys     = cls_args-                         , denv_ctxt         = deriv_ctxt-                         , denv_strat        = deriv_strat }+    skolemise_when_inferring_context ::+         SkolemInfo -> DerivContext+      -> TcM ([TcTyVar], [TcType], Maybe (DerivStrategy GhcTc))+    skolemise_when_inferring_context skol_info deriv_ctxt =+      case deriv_ctxt of+        -- In order to infer an instance context, we must later make use of+        -- the constraint solving machinery, which expects TcTyVars rather+        -- than TyVars. We skolemise the type variables with non-overlappable+        -- (vanilla) skolems.+        -- See Note [Overlap and deriving] in GHC.Tc.Deriv.Infer.+        InferContext{} -> do+          (skol_subst, tvs') <- tcInstSkolTyVars skol_info tvs+          let cls_args'    = substTys skol_subst cls_args+              deriv_strat' = fmap (mapDerivStrategy (substTy skol_subst))+                                  deriv_strat+          pure (tvs', cls_args', deriv_strat')+        -- If the instance context is supplied, we don't need to skolemise+        -- at all.+        SupplyContext{} -> pure (tvs, cls_args, deriv_strat) -    bale_out msg = failWithTc $ derivingThingErr False cls cls_args deriv_strat msg+    bale_out =+      failWithTc . TcRnCannotDeriveInstance cls cls_args deriv_strat NoGeneralizedNewtypeDeriving      mk_eqn :: DerivM EarlyDerivSpec     mk_eqn = do@@ -1186,7 +1195,7 @@           (cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args           dit                <- expectAlgTyConApp cls_tys inst_ty           unless (isNewTyCon (dit_rep_tc dit)) $-            derivingThingFailWith False gndNonNewtypeErr+            derivingThingFailWith NoGeneralizedNewtypeDeriving DerivErrGNDUsedOnData           mkNewTypeEqn True dit          Nothing -> mk_eqn_no_strategy@@ -1198,7 +1207,7 @@ -- property is important. expectNonNullaryClsArgs :: [Type] -> DerivM ([Type], Type) expectNonNullaryClsArgs inst_tys =-  maybe (derivingThingFailWith False derivingNullaryErr) pure $+  maybe (derivingThingFailWith NoGeneralizedNewtypeDeriving DerivErrNullaryClasses) pure $   snocView inst_tys  -- @expectAlgTyConApp cls_tys inst_ty@ checks if @inst_ty@ is an application@@ -1215,9 +1224,7 @@ expectAlgTyConApp cls_tys inst_ty = do   fam_envs <- lift tcGetFamInstEnvs   case mk_deriv_inst_tys_maybe fam_envs cls_tys inst_ty of-    Nothing -> derivingThingFailWith False $-                   text "The last argument of the instance must be a"-               <+> text "data or newtype application"+    Nothing -> derivingThingFailWith NoGeneralizedNewtypeDeriving DerivErrLastArgMustBeApp     Just dit -> do expectNonDataFamTyCon dit                    pure dit @@ -1232,8 +1239,8 @@                                     , dit_rep_tc  = rep_tc }) =   -- If it's still a data family, the lookup failed; i.e no instance exists   when (isDataFamilyTyCon rep_tc) $-    derivingThingFailWith False $-    text "No family instance for" <+> quotes (pprTypeApp tc tc_args)+    derivingThingFailWith NoGeneralizedNewtypeDeriving $+      DerivErrNoFamilyInstance tc tc_args  mk_deriv_inst_tys_maybe :: FamInstEnvs                         -> [Type] -> Type -> Maybe DerivInstTys@@ -1245,11 +1252,13 @@       -- Find the instance of a data family       -- Note [Looking up family instances for deriving]       let (rep_tc, rep_tc_args, _co) = tcLookupDataFamInst fam_envs tc tc_args-      in DerivInstTys { dit_cls_tys     = cls_tys-                      , dit_tc          = tc-                      , dit_tc_args     = tc_args-                      , dit_rep_tc      = rep_tc-                      , dit_rep_tc_args = rep_tc_args }+          dc_inst_arg_env = buildDataConInstArgEnv rep_tc rep_tc_args+      in DerivInstTys { dit_cls_tys         = cls_tys+                      , dit_tc              = tc+                      , dit_tc_args         = tc_args+                      , dit_rep_tc          = rep_tc+                      , dit_rep_tc_args     = rep_tc_args+                      , dit_dc_inst_arg_env = dc_inst_arg_env }  {- Note [Looking up family instances for deriving]@@ -1325,22 +1334,26 @@                 , denv_tvs          = tvs                 , denv_cls          = cls                 , denv_inst_tys     = inst_tys-                , denv_ctxt         = deriv_ctxt } <- ask+                , denv_ctxt         = deriv_ctxt+                , denv_skol_info    = skol_info } <- ask+       user_ctxt <- askDerivUserTypeCtxt        doDerivInstErrorChecks1 mechanism        loc       <- lift getSrcSpanM        dfun_name <- lift $ newDFunName cls inst_tys loc        case deriv_ctxt of         InferContext wildcard ->-          do { (inferred_constraints, tvs', inst_tys')+          do { (inferred_constraints, tvs', inst_tys', mechanism')                  <- inferConstraints mechanism              ; return $ InferTheta $ DS                    { ds_loc = loc                    , ds_name = dfun_name, ds_tvs = tvs'                    , ds_cls = cls, ds_tys = inst_tys'                    , ds_theta = inferred_constraints+                   , ds_skol_info = skol_info+                   , ds_user_ctxt = user_ctxt                    , ds_overlap = overlap_mode                    , ds_standalone_wildcard = wildcard-                   , ds_mechanism = mechanism } }+                   , ds_mechanism = mechanism' } }          SupplyContext theta ->             return $ GivenTheta $ DS@@ -1348,32 +1361,40 @@                    , ds_name = dfun_name, ds_tvs = tvs                    , ds_cls = cls, ds_tys = inst_tys                    , ds_theta = theta+                   , ds_skol_info = skol_info+                   , ds_user_ctxt = user_ctxt                    , ds_overlap = overlap_mode                    , ds_standalone_wildcard = Nothing                    , ds_mechanism = mechanism }  mk_eqn_stock :: DerivInstTys -- Information about the arguments to the class              -> DerivM EarlyDerivSpec-mk_eqn_stock dit@(DerivInstTys { dit_cls_tys = cls_tys-                               , dit_tc      = tc-                               , dit_rep_tc  = rep_tc })-  = do DerivEnv { denv_cls  = cls-                , denv_ctxt = deriv_ctxt } <- ask-       dflags <- getDynFlags-       case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys-                                           tc rep_tc of-         CanDeriveStock gen_fn -> mk_eqn_from_mechanism $-                                  DerivSpecStock { dsm_stock_dit    = dit-                                                 , dsm_stock_gen_fn = gen_fn }-         StockClassError msg   -> derivingThingFailWith False msg-         _                     -> derivingThingFailWith False (nonStdErr cls)+mk_eqn_stock dit+  = do dflags <- getDynFlags+       let isDeriveAnyClassEnabled =+             deriveAnyClassEnabled (xopt LangExt.DeriveAnyClass dflags)+       checkOriginativeSideConditions dit >>= \case+         CanDeriveStock gen_fns -> mk_eqn_from_mechanism $+                                   DerivSpecStock { dsm_stock_dit     = dit+                                                  , dsm_stock_gen_fns = gen_fns }+         StockClassError why    -> derivingThingFailWith NoGeneralizedNewtypeDeriving why+         CanDeriveAnyClass      -> derivingThingFailWith NoGeneralizedNewtypeDeriving+                                     (DerivErrNotStockDeriveable isDeriveAnyClassEnabled)+         -- In the 'NonDerivableClass' case we can't derive with either stock or anyclass+         -- so we /don't want/ to suggest the user to enabled 'DeriveAnyClass', that's+         -- why we pass 'YesDeriveAnyClassEnabled', so that GHC won't attempt to suggest it.+         NonDerivableClass      -> derivingThingFailWith NoGeneralizedNewtypeDeriving+                                     (DerivErrNotStockDeriveable YesDeriveAnyClassEnabled)  mk_eqn_anyclass :: DerivM EarlyDerivSpec mk_eqn_anyclass   = do dflags <- getDynFlags-       case canDeriveAnyClass dflags of-         IsValid      -> mk_eqn_from_mechanism DerivSpecAnyClass-         NotValid msg -> derivingThingFailWith False msg+       let isDeriveAnyClassEnabled =+             deriveAnyClassEnabled (xopt LangExt.DeriveAnyClass dflags)+       case xopt LangExt.DeriveAnyClass dflags of+         True  -> mk_eqn_from_mechanism DerivSpecAnyClass+         False -> derivingThingFailWith NoGeneralizedNewtypeDeriving+                                        (DerivErrNotDeriveable isDeriveAnyClassEnabled)  mk_eqn_newtype :: DerivInstTys -- Information about the arguments to the class                -> Type         -- The newtype's representation type@@ -1424,30 +1445,26 @@     -- Use heuristics (checkOriginativeSideConditions) to determine whether     -- stock or anyclass deriving should be used.     mk_eqn_originative :: DerivInstTys -> DerivM EarlyDerivSpec-    mk_eqn_originative dit@(DerivInstTys { dit_cls_tys = cls_tys-                                         , dit_tc      = tc-                                         , dit_rep_tc  = rep_tc }) = do-      DerivEnv { denv_cls  = cls-               , denv_ctxt = deriv_ctxt } <- ask+    mk_eqn_originative dit@(DerivInstTys { dit_tc     = tc+                                         , dit_rep_tc = rep_tc }) = do       dflags <- getDynFlags+      let isDeriveAnyClassEnabled =+            deriveAnyClassEnabled (xopt LangExt.DeriveAnyClass dflags)        -- See Note [Deriving instances for classes themselves]-      let dac_error msg+      let dac_error             | isClassTyCon rep_tc-            = quotes (ppr tc) <+> text "is a type class,"-                              <+> text "and can only have a derived instance"-                              $+$ text "if DeriveAnyClass is enabled"+            = DerivErrOnlyAnyClassDeriveable tc isDeriveAnyClassEnabled             | otherwise-            = nonStdErr cls $$ msg+            = DerivErrNotStockDeriveable isDeriveAnyClassEnabled -      case checkOriginativeSideConditions dflags deriv_ctxt cls-             cls_tys tc rep_tc of-        NonDerivableClass   msg -> derivingThingFailWith False (dac_error msg)-        StockClassError msg     -> derivingThingFailWith False msg-        CanDeriveStock gen_fn   -> mk_eqn_from_mechanism $-                                   DerivSpecStock { dsm_stock_dit    = dit-                                                  , dsm_stock_gen_fn = gen_fn }-        CanDeriveAnyClass       -> mk_eqn_from_mechanism DerivSpecAnyClass+      checkOriginativeSideConditions dit >>= \case+        NonDerivableClass      -> derivingThingFailWith NoGeneralizedNewtypeDeriving dac_error+        StockClassError why    -> derivingThingFailWith NoGeneralizedNewtypeDeriving why+        CanDeriveStock gen_fns -> mk_eqn_from_mechanism $+                                  DerivSpecStock { dsm_stock_dit     = dit+                                                 , dsm_stock_gen_fns = gen_fns }+        CanDeriveAnyClass      -> mk_eqn_from_mechanism DerivSpecAnyClass  {- ************************************************************************@@ -1469,22 +1486,16 @@                      -- deriving strategy?              -> DerivInstTys -> DerivM EarlyDerivSpec mkNewTypeEqn newtype_strat dit@(DerivInstTys { dit_cls_tys     = cls_tys-                                             , dit_tc          = tycon                                              , dit_rep_tc      = rep_tycon                                              , dit_rep_tc_args = rep_tc_args }) -- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ...-  = do DerivEnv { denv_cls   = cls-                , denv_ctxt  = deriv_ctxt } <- ask+  = do DerivEnv{denv_cls = cls} <- ask        dflags <- getDynFlags         let newtype_deriving  = xopt LangExt.GeneralizedNewtypeDeriving dflags            deriveAnyClass    = xopt LangExt.DeriveAnyClass             dflags -           bale_out = derivingThingFailWith newtype_deriving--           non_std     = nonStdErr cls-           suggest_gnd = text "Try GeneralizedNewtypeDeriving for GHC's"-                     <+> text "newtype-deriving extension"+           bale_out = derivingThingFailWith (usingGeneralizedNewtypeDeriving newtype_deriving)             -- Here is the plan for newtype derivings.  We see            --        newtype T a1...an = MkT (t ak+1...an)@@ -1553,10 +1564,7 @@              --     And the [a] must not mention 'b'.  That's all handled              --     by nt_eta_rity. -           cant_derive_err = ppUnless eta_ok  eta_msg-           eta_msg = text "cannot eta-reduce the representation type enough"--       MASSERT( cls_tys `lengthIs` (classArity cls - 1) )+       massert (cls_tys `lengthIs` (classArity cls - 1))        if newtype_strat        then            -- Since the user explicitly asked for GeneralizedNewtypeDeriving,@@ -1567,16 +1575,14 @@            -- See Note [Determining whether newtype-deriving is appropriate]            if eta_ok && newtype_deriving              then mk_eqn_newtype dit rep_inst_ty-             else bale_out (cant_derive_err $$-                            if newtype_deriving then empty else suggest_gnd)+             else bale_out (DerivErrCannotEtaReduceEnough eta_ok)        else          if might_be_newtype_derivable              && ((newtype_deriving && not deriveAnyClass)                   || std_class_via_coercible cls)          then mk_eqn_newtype dit rep_inst_ty-         else case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys-                                                 tycon rep_tycon of-               StockClassError msg+         else checkOriginativeSideConditions dit >>= \case+               StockClassError why                  -- There's a particular corner case where                  --                  -- 1. -XGeneralizedNewtypeDeriving and -XDeriveAnyClass are@@ -1590,18 +1596,18 @@                 -> mk_eqn_newtype dit rep_inst_ty                  -- Otherwise, throw an error for a stock class                  | might_be_newtype_derivable && not newtype_deriving-                -> bale_out (msg $$ suggest_gnd)+                -> bale_out why                  | otherwise-                -> bale_out msg+                -> bale_out why                 -- Must use newtype deriving or DeriveAnyClass-               NonDerivableClass _msg+               NonDerivableClass                  -- Too hard, even with newtype deriving-                 | newtype_deriving           -> bale_out cant_derive_err+                 | newtype_deriving           -> bale_out (DerivErrCannotEtaReduceEnough eta_ok)                  -- Try newtype deriving!                  -- Here we suggest GeneralizedNewtypeDeriving even in cases                  -- where it may not be applicable. See #9600.-                 | otherwise                  -> bale_out (non_std $$ suggest_gnd)+                 | otherwise                  -> bale_out DerivErrNewtypeNonDeriveableClass                 -- DeriveAnyClass                CanDeriveAnyClass -> do@@ -1610,20 +1616,13 @@                  -- DeriveAnyClass, but emitting a warning about the choice.                  -- See Note [Deriving strategies]                  when (newtype_deriving && deriveAnyClass) $-                   lift $ whenWOptM Opt_WarnDerivingDefaults $-                     addWarnTc (Reason Opt_WarnDerivingDefaults) $ sep-                     [ text "Both DeriveAnyClass and"-                       <+> text "GeneralizedNewtypeDeriving are enabled"-                     , text "Defaulting to the DeriveAnyClass strategy"-                       <+> text "for instantiating" <+> ppr cls-                     , text "Use DerivingStrategies to pick"-                       <+> text "a different strategy"-                      ]+                   lift $ addDiagnosticTc+                        $ TcRnDerivingDefaults cls                  mk_eqn_from_mechanism DerivSpecAnyClass                -- CanDeriveStock-               CanDeriveStock gen_fn -> mk_eqn_from_mechanism $-                                        DerivSpecStock { dsm_stock_dit    = dit-                                                       , dsm_stock_gen_fn = gen_fn }+               CanDeriveStock gen_fns -> mk_eqn_from_mechanism $+                                         DerivSpecStock { dsm_stock_dit     = dit+                                                        , dsm_stock_gen_fns = gen_fns }  {- Note [Recursive newtypes]@@ -1830,32 +1829,31 @@ \end{itemize} -} --- Generate the InstInfo for the required instance--- plus any auxiliary bindings required-genInst :: DerivSpec theta-        -> TcM (ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])--- We must use continuation-returning style here to get the order in which we--- typecheck family instances and derived instances right.--- See Note [Staging of tcDeriving]-genInst spec@(DS { ds_tvs = tvs, ds_mechanism = mechanism-                 , ds_tys = tys, ds_cls = clas, ds_loc = loc-                 , ds_standalone_wildcard = wildcard })-  = do (meth_binds, meth_sigs, deriv_stuff, unusedNames)-         <- set_span_and_ctxt $-            genDerivStuff mechanism loc clas tys tvs-       let mk_inst_info theta = set_span_and_ctxt $ do-             inst_spec <- newDerivClsInst theta spec-             doDerivInstErrorChecks2 clas inst_spec theta wildcard mechanism-             traceTc "newder" (ppr inst_spec)-             return $ InstInfo-                       { iSpec   = inst_spec-                       , iBinds  = InstBindings-                                     { ib_binds = meth_binds-                                     , ib_tyvars = map Var.varName tvs-                                     , ib_pragmas = meth_sigs-                                     , ib_extensions = extensions-                                     , ib_derived = True } }-       return (mk_inst_info, deriv_stuff, unusedNames)+-- | Generate the 'InstInfo' for the required instance,+-- plus any auxiliary bindings required (see @Note [Auxiliary binders]@ in+-- "GHC.Tc.Deriv.Generate") and any additional free variables+-- that should be marked (see @Note [Deriving and unused record selectors]@+-- in "GHC.Tc.Deriv.Utils").+genInstBinds :: DerivSpec ThetaType+             -> TcM (InstInfo GhcPs, Bag AuxBindSpec, [Name])+genInstBinds spec@(DS { ds_tvs = tyvars, ds_mechanism = mechanism+                      , ds_tys = inst_tys, ds_theta = theta, ds_cls = clas+                      , ds_loc = loc, ds_standalone_wildcard = wildcard })+  = set_spec_span_and_ctxt spec $+    do (meth_binds, meth_sigs, aux_specs, unusedNames) <- gen_inst_binds+       inst_spec <- newDerivClsInst spec+       doDerivInstErrorChecks2 clas inst_spec theta wildcard mechanism+       traceTc "newder" (ppr inst_spec)+       let inst_info =+             InstInfo+               { iSpec   = inst_spec+               , iBinds  = InstBindings+                             { ib_binds = meth_binds+                             , ib_tyvars = map Var.varName tyvars+                             , ib_pragmas = meth_sigs+                             , ib_extensions = extensions+                             , ib_derived = True } }+       return (inst_info, aux_specs, unusedNames)   where     extensions :: [LangExt.Extension]     extensions@@ -1867,13 +1865,83 @@           -- that bring type variables into scope.           -- See Note [Newtype-deriving instances] in GHC.Tc.Deriv.Generate         , LangExt.InstanceSigs+          -- Skip unboxed tuples checking for derived instances when imported+          -- in a different module, see #20524+        , LangExt.UnboxedTuples         ]       | otherwise       = [] -    set_span_and_ctxt :: TcM a -> TcM a-    set_span_and_ctxt = setSrcSpan loc . addErrCtxt (instDeclCtxt3 clas tys)+    gen_inst_binds :: TcM (LHsBinds GhcPs, [LSig GhcPs], Bag AuxBindSpec, [Name])+    gen_inst_binds+      = case mechanism of+          -- See Note [Bindings for Generalised Newtype Deriving]+          DerivSpecNewtype { dsm_newtype_rep_ty = rhs_ty}+            -> gen_newtype_or_via rhs_ty +          -- Try a stock deriver+          DerivSpecStock { dsm_stock_dit = dit+                         , dsm_stock_gen_fns =+                             StockGenFns { stock_gen_binds = gen_fn } }+            -> gen_fn loc dit++          -- Try DeriveAnyClass+          DerivSpecAnyClass+            -> return (emptyBag, [], emptyBag, [])+               -- No method bindings, signatures, auxiliary bindings or free+               -- variable names are needed. The only interesting work happens when+               -- defaulting associated type family instances (see the+               -- DeriveSpecAnyClass case in genFamInsts below).++          -- Try DerivingVia+          DerivSpecVia{dsm_via_ty = via_ty}+            -> gen_newtype_or_via via_ty++    gen_newtype_or_via ty = do+      let (binds, sigs) = gen_Newtype_binds loc clas tyvars inst_tys ty+      return (binds, sigs, emptyBag, [])++-- | Generate the associated type family instances for a derived instance.+genFamInsts :: DerivSpec theta -> TcM [FamInst]+genFamInsts spec@(DS { ds_tvs = tyvars, ds_mechanism = mechanism+                     , ds_tys = inst_tys, ds_cls = clas, ds_loc = loc })+  = set_spec_span_and_ctxt spec $+    case mechanism of+      -- See Note [GND and associated type families]+      DerivSpecNewtype { dsm_newtype_rep_ty = rhs_ty}+        -> gen_newtype_or_via rhs_ty++      -- Try a stock deriver+      DerivSpecStock { dsm_stock_dit = dit+                     , dsm_stock_gen_fns =+                         StockGenFns { stock_gen_fam_insts = gen_fn } }+        -> gen_fn loc dit++      -- See Note [DeriveAnyClass and default family instances]+      DerivSpecAnyClass -> do+        let mini_env   = mkVarEnv (classTyVars clas `zip` inst_tys)+            mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env+        dflags <- getDynFlags+        tyfam_insts <-+          -- canDeriveAnyClass should ensure that this code can't be reached+          -- unless -XDeriveAnyClass is enabled.+          assertPpr (xopt LangExt.DeriveAnyClass dflags)+                    (ppr "genFamInsts: bad derived class" <+> ppr clas) $+          mapM (tcATDefault loc mini_subst emptyNameSet)+               (classATItems clas)+        pure $ concat tyfam_insts++      -- Try DerivingVia+      DerivSpecVia{dsm_via_ty = via_ty}+        -> gen_newtype_or_via via_ty+  where+    gen_newtype_or_via ty = gen_Newtype_fam_insts loc clas tyvars inst_tys ty++-- Set the SrcSpan and error context for an action that uses a DerivSpec.+set_spec_span_and_ctxt :: DerivSpec theta -> TcM a -> TcM a+set_spec_span_and_ctxt (DS{ ds_loc = loc, ds_cls = clas, ds_tys = tys }) =+  setSrcSpan loc . addErrCtxt (instDeclCtxt3 clas tys)+ -- Checks: -- -- * All of the data constructors for a data type are in scope for a@@ -1927,7 +1995,7 @@         lift $ addUsedDataCons rdr_env rep_tc          unless (not hidden_data_cons) $-          bale_out $ derivingHiddenErr tc+          bale_out $ DerivErrDataConsNotAllInScope tc      -- Ensure that a class's associated type variables are suitable for     -- GeneralizedNewtypeDeriving or DerivingVia. Unsurprisingly, this check is@@ -1963,27 +2031,15 @@           at_last_cls_tv_in_kind kind             = last_cls_tv `elemVarSet` exactTyCoVarsOfType kind           at_tcs = classATs cls-          last_cls_tv = ASSERT( notNull cls_tyvars )+          last_cls_tv = assert (notNull cls_tyvars )                         last cls_tyvars -          cant_derive_err-             = vcat [ ppUnless no_adfs adfs_msg-                    , maybe empty at_without_last_cls_tv_msg-                            at_without_last_cls_tv-                    , maybe empty at_last_cls_tv_in_kinds_msg-                            at_last_cls_tv_in_kinds-                    ]-          adfs_msg  = text "the class has associated data types"-          at_without_last_cls_tv_msg at_tc = hang-            (text "the associated type" <+> quotes (ppr at_tc)-             <+> text "is not parameterized over the last type variable")-            2 (text "of the class" <+> quotes (ppr cls))-          at_last_cls_tv_in_kinds_msg at_tc = hang-            (text "the associated type" <+> quotes (ppr at_tc)-             <+> text "contains the last type variable")-           2 (text "of the class" <+> quotes (ppr cls)-             <+> text "in a kind, which is not (yet) allowed")-      unless ats_look_sensible $ bale_out cant_derive_err+      unless ats_look_sensible $+        bale_out (DerivErrHasAssociatedDatatypes+                   (hasAssociatedDataFamInsts (not no_adfs))+                   (associatedTyLastVarInKind at_last_cls_tv_in_kinds)+                   (associatedTyNotParamOverLastTyVar at_without_last_cls_tv)+                 )  doDerivInstErrorChecks2 :: Class -> ClsInst -> ThetaType -> Maybe SrcSpan                         -> DerivSpecMechanism -> TcM ()@@ -2000,82 +2056,33 @@        ; case wildcard of            Nothing -> pure ()            Just span -> setSrcSpan span $ do-             checkTc xpartial_sigs (hang partial_sig_msg 2 pts_suggestion)-             warnTc (Reason Opt_WarnPartialTypeSignatures)-                    wpartial_sigs partial_sig_msg+             let suggParSigs = suggestPartialTypeSignatures xpartial_sigs+             let dia = TcRnPartialTypeSignatures suggParSigs theta+             checkTc xpartial_sigs dia+             diagnosticTc wpartial_sigs dia           -- Check for Generic instances that are derived with an exotic          -- deriving strategy like DAC          -- See Note [Deriving strategies]        ; when (exotic_mechanism && className clas `elem` genericClassNames) $-         do { failIfTc (safeLanguageOn dflags) gen_inst_err-            ; when (safeInferOn dflags) (recordUnsafeInfer emptyBag) } }+         do { failIfTc (safeLanguageOn dflags)+                       (TcRnCannotDeriveInstance clas mempty Nothing NoGeneralizedNewtypeDeriving $+                          DerivErrSafeHaskellGenericInst)+            ; when (safeInferOn dflags) (recordUnsafeInfer emptyMessages) } }   where     exotic_mechanism = not $ isDerivSpecStock mechanism -    partial_sig_msg = text "Found type wildcard" <+> quotes (char '_')-                  <+> text "standing for" <+> quotes (pprTheta theta)--    pts_suggestion-      = text "To use the inferred type, enable PartialTypeSignatures"--    gen_inst_err = text "Generic instances can only be derived in"-               <+> text "Safe Haskell using the stock strategy."--derivingThingFailWith :: Bool -- If True, add a snippet about how not even-                              -- GeneralizedNewtypeDeriving would make this-                              -- declaration work. This only kicks in when-                              -- an explicit deriving strategy is not given.-                      -> SDoc -- The error message+derivingThingFailWith :: UsingGeneralizedNewtypeDeriving+                         -- ^ If 'YesGeneralizedNewtypeDeriving', add a snippet about+                         -- how not even GeneralizedNewtypeDeriving would make this+                         -- declaration work. This only kicks in when+                         -- an explicit deriving strategy is not given.+                      -> DeriveInstanceErrReason -- The reason the derivation failed                       -> DerivM a derivingThingFailWith newtype_deriving msg = do   err <- derivingThingErrM newtype_deriving msg   lift $ failWithTc err -genDerivStuff :: DerivSpecMechanism -> SrcSpan -> Class-              -> [Type] -> [TyVar]-              -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name])-genDerivStuff mechanism loc clas inst_tys tyvars-  = case mechanism of-      -- See Note [Bindings for Generalised Newtype Deriving]-      DerivSpecNewtype { dsm_newtype_rep_ty = rhs_ty}-        -> gen_newtype_or_via rhs_ty--      -- Try a stock deriver-      DerivSpecStock { dsm_stock_dit    = DerivInstTys-                        { dit_rep_tc = rep_tc-                        , dit_rep_tc_args = rep_tc_args-                        }-                     , dsm_stock_gen_fn = gen_fn }-        -> gen_fn loc rep_tc rep_tc_args inst_tys--      -- Try DeriveAnyClass-      DerivSpecAnyClass -> do-        let mini_env   = mkVarEnv (classTyVars clas `zip` inst_tys)-            mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env-        dflags <- getDynFlags-        tyfam_insts <--          -- canDeriveAnyClass should ensure that this code can't be reached-          -- unless -XDeriveAnyClass is enabled.-          ASSERT2( isValid (canDeriveAnyClass dflags)-                 , ppr "genDerivStuff: bad derived class" <+> ppr clas )-          mapM (tcATDefault loc mini_subst emptyNameSet)-               (classATItems clas)-        return ( emptyBag, [] -- No method bindings are needed...-               , listToBag (map DerivFamInst (concat tyfam_insts))-               -- ...but we may need to generate binding for associated type-               -- family default instances.-               -- See Note [DeriveAnyClass and default family instances]-               , [] )--      -- Try DerivingVia-      DerivSpecVia{dsm_via_ty = via_ty}-        -> gen_newtype_or_via via_ty-  where-    gen_newtype_or_via ty = do-      (binds, sigs, faminsts) <- gen_Newtype_binds loc clas tyvars inst_tys ty-      return (binds, sigs, faminsts, [])- {- Note [Bindings for Generalised Newtype Deriving] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2089,7 +2096,7 @@   instance (C [a], Eq a) => C (N a) where      f = coerce (f :: [a] -> [a]) -This generates a cast for each method, but allows the superclasse to+This generates a cast for each method, but allows the superclasses to be worked out in the usual way.  In this case the superclass (Eq (N a)) will be solved by the explicit Eq (N a) instance.  We do *not* create the superclasses by casting the superclass dictionaries for the@@ -2208,95 +2215,26 @@ ************************************************************************ -} -nonUnaryErr :: LHsSigType GhcRn -> SDoc-nonUnaryErr ct = quotes (ppr ct)-  <+> text "is not a unary constraint, as expected by a deriving clause"--nonStdErr :: Class -> SDoc-nonStdErr cls =-      quotes (ppr cls)-  <+> text "is not a stock derivable class (Eq, Show, etc.)"--gndNonNewtypeErr :: SDoc-gndNonNewtypeErr =-  text "GeneralizedNewtypeDeriving cannot be used on non-newtypes"--derivingNullaryErr :: SDoc-derivingNullaryErr = text "Cannot derive instances for nullary classes"--derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> Bool -> SDoc-derivingKindErr tc cls cls_tys cls_kind enough_args-  = sep [ hang (text "Cannot derive well-kinded instance of form"-                      <+> quotes (pprClassPred cls cls_tys-                                    <+> parens (ppr tc <+> text "...")))-               2 gen1_suggestion-        , nest 2 (text "Class" <+> quotes (ppr cls)-                      <+> text "expects an argument of kind"-                      <+> quotes (pprKind cls_kind))-        ]-  where-    gen1_suggestion | cls `hasKey` gen1ClassKey && enough_args-                    = text "(Perhaps you intended to use PolyKinds)"-                    | otherwise = Outputable.empty--derivingViaKindErr :: Class -> Kind -> Type -> Kind -> SDoc-derivingViaKindErr cls cls_kind via_ty via_kind-  = hang (text "Cannot derive instance via" <+> quotes (pprType via_ty))-       2 (text "Class" <+> quotes (ppr cls)-               <+> text "expects an argument of kind"-               <+> quotes (pprKind cls_kind) <> char ','-      $+$ text "but" <+> quotes (pprType via_ty)-               <+> text "has kind" <+> quotes (pprKind via_kind))--derivingEtaErr :: Class -> [Type] -> Type -> SDoc-derivingEtaErr cls cls_tys inst_ty-  = sep [text "Cannot eta-reduce to an instance of form",-         nest 2 (text "instance (...) =>"-                <+> pprClassPred cls (cls_tys ++ [inst_ty]))]--derivingThingErr :: Bool -> Class -> [Type]-                 -> Maybe (DerivStrategy GhcTc) -> SDoc -> SDoc-derivingThingErr newtype_deriving cls cls_args mb_strat why-  = derivingThingErr' newtype_deriving cls cls_args mb_strat-                      (maybe empty derivStrategyName mb_strat) why--derivingThingErrM :: Bool -> SDoc -> DerivM SDoc+derivingThingErrM :: UsingGeneralizedNewtypeDeriving+                  -> DeriveInstanceErrReason+                  -> DerivM TcRnMessage derivingThingErrM newtype_deriving why   = do DerivEnv { denv_cls      = cls                 , denv_inst_tys = cls_args                 , denv_strat    = mb_strat } <- ask-       pure $ derivingThingErr newtype_deriving cls cls_args mb_strat why+       pure $ TcRnCannotDeriveInstance cls cls_args mb_strat newtype_deriving why -derivingThingErrMechanism :: DerivSpecMechanism -> SDoc -> DerivM SDoc+derivingThingErrMechanism :: DerivSpecMechanism -> DeriveInstanceErrReason -> DerivM TcRnMessage derivingThingErrMechanism mechanism why   = do DerivEnv { denv_cls      = cls                 , denv_inst_tys = cls_args                 , denv_strat    = mb_strat } <- ask-       pure $ derivingThingErr' (isDerivSpecNewtype mechanism) cls cls_args mb_strat-                (derivStrategyName $ derivSpecMechanismToStrategy mechanism) why--derivingThingErr' :: Bool -> Class -> [Type]-                  -> Maybe (DerivStrategy GhcTc) -> SDoc -> SDoc -> SDoc-derivingThingErr' newtype_deriving cls cls_args mb_strat strat_msg why-  = sep [(hang (text "Can't make a derived instance of")-             2 (quotes (ppr pred) <+> via_mechanism)-          $$ nest 2 extra) <> colon,-         nest 2 why]+       pure $ TcRnCannotDeriveInstance cls cls_args mb_strat newtype_deriving why   where-    strat_used = isJust mb_strat-    extra | not strat_used, newtype_deriving-          = text "(even with cunning GeneralizedNewtypeDeriving)"-          | otherwise = empty-    pred = mkClassPred cls cls_args-    via_mechanism | strat_used-                  = text "with the" <+> strat_msg <+> text "strategy"-                  | otherwise-                  = empty--derivingHiddenErr :: TyCon -> SDoc-derivingHiddenErr tc-  = hang (text "The data constructors of" <+> quotes (ppr tc) <+> ptext (sLit "are not all in scope"))-       2 (text "so you cannot derive an instance for it")+    newtype_deriving :: UsingGeneralizedNewtypeDeriving+    newtype_deriving+      = if isDerivSpecNewtype mechanism then YesGeneralizedNewtypeDeriving+                                        else NoGeneralizedNewtypeDeriving  standaloneCtxt :: LHsSigWcType GhcRn -> SDoc standaloneCtxt ty = hang (text "In the stand-alone deriving instance for")
compiler/GHC/Tc/Deriv/Functor.hs view
@@ -3,7 +3,7 @@  -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-}@@ -22,8 +22,6 @@    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Data.Bag@@ -34,7 +32,7 @@ import GHC.Builtin.Names import GHC.Types.Name.Reader import GHC.Types.SrcLoc-import GHC.Utils.Monad.State+import GHC.Utils.Monad.State.Strict import GHC.Tc.Deriv.Generate import GHC.Tc.Utils.TcType import GHC.Core.TyCon@@ -151,10 +149,10 @@   $(coreplace 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(coreplace 'a' 'tc' (x $(replace 'a 'tb y))) -} -gen_Functor_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)+gen_Functor_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec) -- When the argument is phantom, we can use  fmap _ = coerce -- See Note [Phantom types with Functor, Foldable, and Traversable]-gen_Functor_binds loc tycon _+gen_Functor_binds loc (DerivInstTys{dit_rep_tc = tycon})   | Phantom <- last (tyConRoles tycon)   = (unitBag fmap_bind, emptyBag)   where@@ -165,7 +163,8 @@                                coerce_Expr]     fmap_match_ctxt = mkPrefixFunRhs fmap_name -gen_Functor_binds loc tycon tycon_args+gen_Functor_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon+                                       , dit_rep_tc_args = tycon_args })   = (listToBag [fmap_bind, replace_bind], emptyBag)   where     data_cons = getPossibleDataCons tycon tycon_args@@ -178,7 +177,7 @@     fmap_eqn con = flip evalState bs_RDRs $                      match_for_con fmap_match_ctxt [f_Pat] con parts       where-        parts = foldDataConArgs ft_fmap con+        parts = foldDataConArgs ft_fmap con dit      fmap_eqns = map fmap_eqn data_cons @@ -217,7 +216,7 @@     replace_eqn con = flip evalState bs_RDRs $         match_for_con replace_match_ctxt [z_Pat] con parts       where-        parts = foldDataConArgs ft_replace con+        parts = foldDataConArgs ft_replace con dit      replace_eqns = map replace_eqn data_cons @@ -554,10 +553,10 @@             , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyCoVarsOfType) xs })  -foldDataConArgs :: FFoldType a -> DataCon -> [a]+foldDataConArgs :: FFoldType a -> DataCon -> DerivInstTys -> [a] -- Fold over the arguments of the datacon-foldDataConArgs ft con-  = map foldArg (map scaledThing $ dataConOrigArgTys con)+foldDataConArgs ft con dit+  = map foldArg (derivDataConInstArgTys con dit)   where     foldArg       = case getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) of@@ -785,10 +784,10 @@ think it's okay to do it for now. -} -gen_Foldable_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)+gen_Foldable_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec) -- When the parameter is phantom, we can use foldMap _ _ = mempty -- See Note [Phantom types with Functor, Foldable, and Traversable]-gen_Foldable_binds loc tycon _+gen_Foldable_binds loc (DerivInstTys{dit_rep_tc = tycon})   | Phantom <- last (tyConRoles tycon)   = (unitBag foldMap_bind, emptyBag)   where@@ -799,7 +798,8 @@                                   mempty_Expr]     foldMap_match_ctxt = mkPrefixFunRhs foldMap_name -gen_Foldable_binds loc tycon tycon_args+gen_Foldable_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon+                                        , dit_rep_tc_args = tycon_args })   | null data_cons  -- There's no real point producing anything but                     -- foldMap for a type with no constructors.   = (unitBag foldMap_bind, emptyBag)@@ -809,12 +809,15 @@   where     data_cons = getPossibleDataCons tycon tycon_args +    foldr_name = L (noAnnSrcSpan loc) foldable_foldr_RDR+     foldr_bind = mkRdrFunBind (L (noAnnSrcSpan loc) foldable_foldr_RDR) eqns     eqns = map foldr_eqn data_cons     foldr_eqn con       = evalState (match_foldr z_Expr [f_Pat,z_Pat] con =<< parts) bs_RDRs       where-        parts = sequence $ foldDataConArgs ft_foldr con+        parts = sequence $ foldDataConArgs ft_foldr con dit+    foldr_match_ctxt = mkPrefixFunRhs foldr_name      foldMap_name = L (noAnnSrcSpan loc) foldMap_RDR @@ -827,7 +830,8 @@     foldMap_eqn con       = evalState (match_foldMap [f_Pat] con =<< parts) bs_RDRs       where-        parts = sequence $ foldDataConArgs ft_foldMap con+        parts = sequence $ foldDataConArgs ft_foldMap con dit+    foldMap_match_ctxt = mkPrefixFunRhs foldMap_name      -- Given a list of NullM results, produce Nothing if any of     -- them is NotNull, and otherwise produce a list of Maybes@@ -845,7 +849,7 @@     null_eqns = map null_eqn data_cons     null_eqn con       = flip evalState bs_RDRs $ do-          parts <- sequence $ foldDataConArgs ft_null con+          parts <- sequence $ foldDataConArgs ft_null con dit           case convert parts of             Nothing -> return $               mkMatch null_match_ctxt [nlParPat (nlWildConPat con)]@@ -883,7 +887,7 @@                 -> DataCon                 -> [Maybe (LHsExpr GhcPs)]                 -> m (LMatch GhcPs (LHsExpr GhcPs))-    match_foldr z = mkSimpleConMatch2 LambdaExpr $ \_ xs -> return (mkFoldr xs)+    match_foldr z = mkSimpleConMatch2 foldr_match_ctxt $ \_ xs -> return (mkFoldr xs)       where         -- g1 v1 (g2 v2 (.. z))         mkFoldr :: [LHsExpr GhcPs] -> LHsExpr GhcPs@@ -913,7 +917,7 @@                   -> DataCon                   -> [Maybe (LHsExpr GhcPs)]                   -> m (LMatch GhcPs (LHsExpr GhcPs))-    match_foldMap = mkSimpleConMatch2 CaseAlt $ \_ xs -> return (mkFoldMap xs)+    match_foldMap = mkSimpleConMatch2 foldMap_match_ctxt $ \_ xs -> return (mkFoldMap xs)       where         -- mappend v1 (mappend v2 ..)         mkFoldMap :: [LHsExpr GhcPs] -> LHsExpr GhcPs@@ -1014,10 +1018,10 @@ See Note [Generated code for DeriveFoldable and DeriveTraversable]. -} -gen_Traversable_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)+gen_Traversable_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec) -- When the argument is phantom, we can use traverse = pure . coerce -- See Note [Phantom types with Functor, Foldable, and Traversable]-gen_Traversable_binds loc tycon _+gen_Traversable_binds loc (DerivInstTys{dit_rep_tc = tycon})   | Phantom <- last (tyConRoles tycon)   = (unitBag traverse_bind, emptyBag)   where@@ -1029,7 +1033,8 @@                        (nlHsApps pure_RDR [nlHsApp coerce_Expr z_Expr])]     traverse_match_ctxt = mkPrefixFunRhs traverse_name -gen_Traversable_binds loc tycon tycon_args+gen_Traversable_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon+                                           , dit_rep_tc_args = tycon_args })   = (unitBag traverse_bind, emptyBag)   where     data_cons = getPossibleDataCons tycon tycon_args@@ -1043,7 +1048,8 @@     traverse_eqn con       = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs       where-        parts = sequence $ foldDataConArgs ft_trav con+        parts = sequence $ foldDataConArgs ft_trav con dit+    traverse_match_ctxt = mkPrefixFunRhs traverse_name      -- Yields 'Just' an expression if we're folding over a type that mentions     -- the last type parameter of the datatype. Otherwise, yields 'Nothing'.@@ -1074,7 +1080,7 @@                   -> DataCon                   -> [Maybe (LHsExpr GhcPs)]                   -> m (LMatch GhcPs (LHsExpr GhcPs))-    match_for_con = mkSimpleConMatch2 CaseAlt $+    match_for_con = mkSimpleConMatch2 traverse_match_ctxt $                                              \con xs -> return (mkApCon con xs)       where         -- liftA2 (\b1 b2 ... -> Con b1 b2 ...) x1 x2 <*> ..
compiler/GHC/Tc/Deriv/Generate.hs view
@@ -5,7 +5,7 @@  -} -{-# LANGUAGE CPP, ScopedTypeVariables #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-}@@ -19,7 +19,7 @@ -- -- This is where we do all the grimy bindings' generation. module GHC.Tc.Deriv.Generate (-        BagDerivStuff, DerivStuff(..),+        AuxBindSpec(..),          gen_Eq_binds,         gen_Ord_binds,@@ -31,16 +31,17 @@         gen_Data_binds,         gen_Lift_binds,         gen_Newtype_binds,+        gen_Newtype_fam_insts,         mkCoerceClassMethEqn,         genAuxBinds,         ordOpTbl, boxConTbl, litConTbl,         mkRdrFunBind, mkRdrFunBindEC, mkRdrFunBindSE, error_Expr, -        getPossibleDataCons, tyConInstArgTys+        getPossibleDataCons,+        DerivInstTys(..), buildDataConInstArgEnv,+        derivDataConInstArgTys, substDerivInstTys, zonkDerivInstTys     ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Tc.Utils.Monad@@ -53,38 +54,40 @@ import GHC.Types.SourceText  import GHC.Driver.Session-import GHC.Builtin.Utils import GHC.Tc.Instance.Family import GHC.Core.FamInstEnv import GHC.Builtin.Names import GHC.Builtin.Names.TH import GHC.Types.Id.Make ( coerceId ) import GHC.Builtin.PrimOps+import GHC.Builtin.PrimOps.Ids (primOpId) import GHC.Types.SrcLoc import GHC.Core.TyCon import GHC.Tc.Utils.Env import GHC.Tc.Utils.TcType+import GHC.Tc.Utils.Zonk import GHC.Tc.Validity ( checkValidCoAxBranch ) import GHC.Core.Coercion.Axiom ( coAxiomSingleBranch ) import GHC.Builtin.Types.Prim import GHC.Builtin.Types import GHC.Core.Type-import GHC.Core.Multiplicity import GHC.Core.Class+import GHC.Types.Unique.FM ( lookupUFM, listToUFM ) import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Utils.Misc import GHC.Types.Var import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Lexeme import GHC.Data.FastString import GHC.Data.Pair import GHC.Data.Bag  import Data.List  ( find, partition, intersperse )--type BagDerivStuff = Bag DerivStuff+import GHC.Data.Maybe ( expectJust )+import GHC.Unit.Module  -- | A declarative description of an auxiliary binding that should be -- generated. See @Note [Auxiliary binders]@ for a more detailed description@@ -135,23 +138,6 @@ auxBindSpecRdrName (DerivDataDataType _ dataT_RDR _) = dataT_RDR auxBindSpecRdrName (DerivDataConstr   _ dataC_RDR _) = dataC_RDR -data DerivStuff     -- Please add this auxiliary stuff-  = DerivAuxBind AuxBindSpec-    -- ^ A new, top-level auxiliary binding. Used for deriving 'Eq', 'Ord',-    --   'Enum', 'Ix', and 'Data'. See Note [Auxiliary binders].--  -- Generics and DeriveAnyClass-  | DerivFamInst FamInst               -- New type family instances-    -- ^ A new type family instance. Used for:-    ---    -- * @DeriveGeneric@, which generates instances of @Rep(1)@-    ---    -- * @DeriveAnyClass@, which can fill in associated type family defaults-    ---    -- * @GeneralizedNewtypeDeriving@, which generates instances of associated-    --   type families for newtypes-- {- ************************************************************************ *                                                                      *@@ -167,6 +153,12 @@    data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ... +* We first attempt to compare the constructor tags. If tags don't+  match - we immediately bail out. Otherwise, we then generate one+  branch per constructor comparing only the fields as we already+  know that the tags match. Note that it only makes sense to check+  the tag if there is more than one data constructor.+ * For the ordinary constructors (if any), we emit clauses to do The   Usual Thing, e.g.,: @@ -179,23 +171,29 @@        case (a1 `eqFloat#` a2) of r -> r   for that particular test. -* For nullary constructors, we emit a-  catch-all clause of the form:+* For nullary constructors, we emit a catch-all clause that always+  returns True since we already know that the tags match. -      (==) a b  = case (dataToTag# a) of { a# ->-                  case (dataToTag# b) of { b# ->-                  case (a# ==# b#)     of {-                    r -> r }}}+* So, given this data type: +    data T = A | B Int | C Char++  We roughly get:++    (==) a b =+      case dataToTag# a /= dataToTag# b of+        True -> False+        False -> case a of       -- Here we already know that tags match+            B a1 -> case b of+                B b1 -> a1 == b1 -- Only one branch+            C a1 -> case b of+                C b1 -> a1 == b1 -- Only one branch+            _ -> True            -- catch-all to match all nullary ctors+   An older approach preferred regular pattern matches in some cases   but with dataToTag# forcing it's argument, and work on improving   join points, this seems no longer necessary. -* If there aren't any nullary constructors, we emit a simpler-  catch-all:--     (==) a b  = False- * For the @(/=)@ method, we normally just use the default method.   If the type is an enumeration type, we could/may/should? generate   special code that calls @dataToTag#@, much like for @(==)@ shown@@ -211,64 +209,75 @@ produced don't get through the typechecker. -} -gen_Eq_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)-gen_Eq_binds loc tycon tycon_args = do+gen_Eq_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec)+gen_Eq_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon+                                  , dit_rep_tc_args = tycon_args }) = do     return (method_binds, emptyBag)   where     all_cons = getPossibleDataCons tycon tycon_args-    (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon all_cons--    -- For nullary constructors, use the getTag stuff.-    (tag_match_cons, pat_match_cons) = (nullary_cons, non_nullary_cons)-    no_tag_match_cons = null tag_match_cons--    -- (LHS patterns, result)-    fall_through_eqn :: [([LPat (GhcPass 'Parsed)] , LHsExpr GhcPs)]-    fall_through_eqn-      | no_tag_match_cons   -- All constructors have arguments-      = case pat_match_cons of-          []  -> []   -- No constructors; no fall-though case-          [_] -> []   -- One constructor; no fall-though case-          _   ->      -- Two or more constructors; add fall-through of-                      --       (==) _ _ = False-                 [([nlWildPat, nlWildPat], false_Expr)]+    non_nullary_cons = filter (not . isNullarySrcDataCon) all_cons -      | otherwise -- One or more tag_match cons; add fall-through of-                  -- extract tags compare for equality,-                  -- The case `(C1 x) == (C1 y)` can no longer happen-                  -- at this point as it's matched earlier.-      = [([a_Pat, b_Pat],-         untag_Expr [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]-                    (genPrimOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]+    -- Generate tag check. See #17240+    eq_expr_with_tag_check = nlHsCase+      (nlHsPar (untag_Expr [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]+                    (nlHsOpApp (nlHsVar ah_RDR) neInt_RDR (nlHsVar bh_RDR))))+      [ mkHsCaseAlt (nlLitPat (HsIntPrim NoSourceText 1)) false_Expr+      , mkHsCaseAlt nlWildPat (+          nlHsCase+            (nlHsVar a_RDR)+            -- Only one branch to match all nullary constructors+            -- as we already know the tags match but do not emit+            -- the branch if there are no nullary constructors+            (let non_nullary_pats = map pats_etc non_nullary_cons+             in if null non_nullary_cons+                then non_nullary_pats+                else non_nullary_pats ++ [mkHsCaseAlt nlWildPat true_Expr]))+      ]      method_binds = unitBag eq_bind-    eq_bind-      = mkFunBindEC 2 loc eq_RDR (const true_Expr)-                    (map pats_etc pat_match_cons-                      ++ fall_through_eqn)+    eq_bind = mkFunBindEC 2 loc eq_RDR (const true_Expr) binds+      where+        binds+          | null all_cons = []+          -- Tag checking is redundant when there is only one data constructor+          | [data_con] <- all_cons+          , (as_needed, bs_needed, tys_needed) <- gen_con_fields_and_tys data_con+          , data_con_RDR <- getRdrName data_con+          , con1_pat <- nlParPat $ nlConVarPat data_con_RDR as_needed+          , con2_pat <- nlParPat $ nlConVarPat data_con_RDR bs_needed+          , eq_expr <- nested_eq_expr tys_needed as_needed bs_needed+          = [([con1_pat, con2_pat], eq_expr)]+          -- This is an enum (all constructors are nullary) - just do a simple tag check+          | all isNullarySrcDataCon all_cons+          = [([a_Pat, b_Pat], untag_Expr [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]+                    (genPrimOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]+          | otherwise+          = [([a_Pat, b_Pat], eq_expr_with_tag_check)]      -------------------------------------------------------------------    pats_etc data_con-      = let-            con1_pat = nlParPat $ nlConVarPat data_con_RDR as_needed-            con2_pat = nlParPat $ nlConVarPat data_con_RDR bs_needed--            data_con_RDR = getRdrName data_con-            con_arity   = length tys_needed-            as_needed   = take con_arity as_RDRs-            bs_needed   = take con_arity bs_RDRs-            tys_needed  = dataConOrigArgTys data_con-        in-        ([con1_pat, con2_pat], nested_eq_expr (map scaledThing tys_needed) as_needed bs_needed)+    nested_eq_expr []  [] [] = true_Expr+    nested_eq_expr tys as bs+      = foldr1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)+      -- Using 'foldr1' here ensures that the derived code is correctly+      -- associated. See #10859.       where-        nested_eq_expr []  [] [] = true_Expr-        nested_eq_expr tys as bs-          = foldr1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)-          -- Using 'foldr1' here ensures that the derived code is correctly-          -- associated. See #10859.-          where-            nested_eq ty a b = nlHsPar (eq_Expr ty (nlHsVar a) (nlHsVar b))+        nested_eq ty a b = nlHsPar (eq_Expr ty (nlHsVar a) (nlHsVar b)) +    gen_con_fields_and_tys data_con+      | tys_needed <- derivDataConInstArgTys data_con dit+      , con_arity <- length tys_needed+      , as_needed <- take con_arity as_RDRs+      , bs_needed <- take con_arity bs_RDRs+      = (as_needed, bs_needed, tys_needed)++    pats_etc data_con+      | (as_needed, bs_needed, tys_needed) <- gen_con_fields_and_tys data_con+      , data_con_RDR <- getRdrName data_con+      , con1_pat <- nlParPat $ nlConVarPat data_con_RDR as_needed+      , con2_pat <- nlParPat $ nlConVarPat data_con_RDR bs_needed+      , fields_eq_expr <- nested_eq_expr tys_needed as_needed bs_needed+      = mkHsCaseAlt con1_pat (nlHsCase (nlHsVar b_RDR) [mkHsCaseAlt con2_pat fields_eq_expr])+ {- ************************************************************************ *                                                                      *@@ -387,8 +396,9 @@ gtResult OrdGT      = true_Expr  -------------gen_Ord_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)-gen_Ord_binds loc tycon tycon_args = do+gen_Ord_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec)+gen_Ord_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon+                                   , dit_rep_tc_args = tycon_args }) = do     return $ if null tycon_data_cons -- No data-cons => invoke bale-out case       then ( unitBag $ mkFunBindEC 2 loc compare_RDR (const eqTag_Expr) []            , emptyBag)@@ -506,7 +516,7 @@     -- Returns a case alternative  Ki b1 b2 ... bv -> compare (a1,a2,...) with (b1,b2,...)     mkInnerEqAlt op data_con       = mkHsCaseAlt (nlConVarPat data_con_RDR bs_needed) $-        mkCompareFields op (map scaledThing $ dataConOrigArgTys data_con)+        mkCompareFields op (derivDataConInstArgTys data_con dit)       where         data_con_RDR = getRdrName data_con         bs_needed    = take (dataConSourceArity data_con) bs_RDRs@@ -580,7 +590,7 @@   where     ascribeBool e = noLocA $ ExprWithTySig noAnn e                            $ mkHsWildCardBndrs $ noLocA $ mkHsImplicitSigType-                           $ nlHsTyVar boolTyCon_RDR+                           $ nlHsTyVar NotPromoted boolTyCon_RDR  nlConWildPat :: DataCon -> LPat GhcPs -- The pattern (K {})@@ -635,8 +645,8 @@ For @enumFromTo@ and @enumFromThenTo@, we use the default methods. -} -gen_Enum_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)-gen_Enum_binds loc tycon _ = do+gen_Enum_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec)+gen_Enum_binds loc (DerivInstTys{dit_rep_tc = tycon}) = do     -- See Note [Auxiliary binders]     tag2con_RDR <- new_tag2con_rdr_name loc tycon     maxtag_RDR  <- new_maxtag_rdr_name  loc tycon@@ -652,7 +662,7 @@       , enum_from_then tag2con_RDR maxtag_RDR -- [0, 1 ..]       , from_enum       ]-    aux_binds tag2con_RDR maxtag_RDR = listToBag $ map DerivAuxBind+    aux_binds tag2con_RDR maxtag_RDR = listToBag       [ DerivTag2Con tycon tag2con_RDR       , DerivMaxTag  tycon maxtag_RDR       ]@@ -725,12 +735,12 @@ ************************************************************************ -} -gen_Bounded_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)-gen_Bounded_binds loc tycon _+gen_Bounded_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec)+gen_Bounded_binds loc (DerivInstTys{dit_rep_tc = tycon})   | isEnumerationTyCon tycon   = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag)   | otherwise-  = ASSERT(isSingleton data_cons)+  = assert (isSingleton data_cons)     (listToBag [ min_bound_1con, max_bound_1con ], emptyBag)   where     data_cons = tyConDataCons tycon@@ -812,14 +822,14 @@ (p.~147). -} -gen_Ix_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)+gen_Ix_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec) -gen_Ix_binds loc tycon _ = do+gen_Ix_binds loc (DerivInstTys{dit_rep_tc = tycon}) = do     -- See Note [Auxiliary binders]     tag2con_RDR <- new_tag2con_rdr_name loc tycon      return $ if isEnumerationTyCon tycon-      then (enum_ixes tag2con_RDR, listToBag $ map DerivAuxBind+      then (enum_ixes tag2con_RDR, listToBag                    [ DerivTag2Con tycon tag2con_RDR                    ])       else (single_con_ixes, emptyBag)@@ -1014,10 +1024,10 @@ we want to be able to parse (Left 3) just fine. -} -gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> [Type]-               -> (LHsBinds GhcPs, BagDerivStuff)+gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> DerivInstTys+               -> (LHsBinds GhcPs, Bag AuxBindSpec) -gen_Read_binds get_fixity loc tycon _+gen_Read_binds get_fixity loc dit@(DerivInstTys{dit_rep_tc = tycon})   = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag)   where     -----------------------------------------------------------------------@@ -1106,7 +1116,7 @@         is_infix     = dataConIsInfix data_con         is_record    = labels `lengthExceeds` 0         as_needed    = take con_arity as_RDRs-        read_args    = zipWithEqual "gen_Read_binds" read_arg as_needed (map scaledThing $ dataConOrigArgTys data_con)+        read_args    = zipWithEqual "gen_Read_binds" read_arg as_needed (derivDataConInstArgTys data_con dit)         (read_a1:read_a2:_) = read_args          prefix_prec = appPrecedence@@ -1137,7 +1147,7 @@      data_con_str con = occNameString (getOccName con) -    read_arg a ty = ASSERT( not (isUnliftedType ty) )+    read_arg a ty = assert (not (isUnliftedType ty)) $                     noLocA (mkPsBindStmt noAnn (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))      -- When reading field labels we might encounter@@ -1198,10 +1208,11 @@                     -- the most tightly-binding operator -} -gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> [Type]-               -> (LHsBinds GhcPs, BagDerivStuff)+gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> DerivInstTys+               -> (LHsBinds GhcPs, Bag AuxBindSpec) -gen_Show_binds get_fixity loc tycon tycon_args+gen_Show_binds get_fixity loc dit@(DerivInstTys{ dit_rep_tc = tycon+                                               , dit_rep_tc_args = tycon_args })   = (unitBag shows_prec, emptyBag)   where     data_cons = getPossibleDataCons tycon tycon_args@@ -1210,7 +1221,7 @@      pats_etc data_con       | nullary_con =  -- skip the showParen junk...-         ASSERT(null bs_needed)+         assert (null bs_needed)          ([nlWildPat, con_pat], mk_showString_app op_con_str)       | otherwise   =          ([a_Pat, con_pat],@@ -1221,7 +1232,7 @@              data_con_RDR  = getRdrName data_con              con_arity     = dataConSourceArity data_con              bs_needed     = take con_arity bs_RDRs-             arg_tys       = dataConOrigArgTys data_con         -- Correspond 1-1 with bs_needed+             arg_tys       = derivDataConInstArgTys data_con dit -- Correspond 1-1 with bs_needed              con_pat       = nlConVarPat data_con_RDR bs_needed              nullary_con   = con_arity == 0              labels        = map flLabel $ dataConFieldLabels data_con@@ -1249,7 +1260,7 @@                  where                    nm       = wrapOpParens (unpackFS l) -             show_args               = zipWithEqual "gen_Show_binds" show_arg bs_needed (map scaledThing arg_tys)+             show_args               = zipWithEqual "gen_Show_binds" show_arg bs_needed arg_tys              (show_arg1:show_arg2:_) = show_args              show_prefix_args        = intersperse (nlHsVar showSpace_RDR) show_args @@ -1369,12 +1380,10 @@ -}  gen_Data_binds :: SrcSpan-               -> TyCon                 -- For data families, this is the-                                        --  *representation* TyCon-               -> [Type]+               -> DerivInstTys                -> TcM (LHsBinds GhcPs,  -- The method bindings-                       BagDerivStuff)   -- Auxiliary bindings-gen_Data_binds loc rep_tc _+                       Bag AuxBindSpec) -- Auxiliary bindings+gen_Data_binds loc (DerivInstTys{dit_rep_tc = rep_tc})   = do { -- See Note [Auxiliary binders]          dataT_RDR  <- new_dataT_rdr_name loc rep_tc        ; dataC_RDRs <- traverse (new_dataC_rdr_name loc) data_cons@@ -1383,7 +1392,7 @@                           , toCon_bind dataC_RDRs, dataTypeOf_bind dataT_RDR ]                 `unionBags` gcast_binds                           -- Auxiliary definitions: the data type and constructors-              , listToBag $ map DerivAuxBind+              , listToBag                   ( DerivDataDataType rep_tc dataT_RDR dataC_RDRs                   : zipWith (\data_con dataC_RDR ->                                DerivDataConstr data_con dataC_RDR dataT_RDR)@@ -1487,7 +1496,7 @@     dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR,     constr_RDR, dataType_RDR,     eqChar_RDR  , ltChar_RDR  , geChar_RDR  , gtChar_RDR  , leChar_RDR  ,-    eqInt_RDR   , ltInt_RDR   , geInt_RDR   , gtInt_RDR   , leInt_RDR   ,+    eqInt_RDR   , ltInt_RDR   , geInt_RDR   , gtInt_RDR   , leInt_RDR   , neInt_RDR ,     eqInt8_RDR  , ltInt8_RDR  , geInt8_RDR  , gtInt8_RDR  , leInt8_RDR  ,     eqInt16_RDR , ltInt16_RDR , geInt16_RDR , gtInt16_RDR , leInt16_RDR ,     eqInt32_RDR , ltInt32_RDR , geInt32_RDR , gtInt32_RDR , leInt32_RDR ,@@ -1527,6 +1536,7 @@ geChar_RDR     = varQual_RDR  gHC_PRIM (fsLit "geChar#")  eqInt_RDR      = varQual_RDR  gHC_PRIM (fsLit "==#")+neInt_RDR      = varQual_RDR  gHC_PRIM (fsLit "/=#") ltInt_RDR      = varQual_RDR  gHC_PRIM (fsLit "<#" ) leInt_RDR      = varQual_RDR  gHC_PRIM (fsLit "<=#") gtInt_RDR      = varQual_RDR  gHC_PRIM (fsLit ">#" )@@ -1613,7 +1623,6 @@ word32ToWord_RDR = varQual_RDR  gHC_PRIM (fsLit "word32ToWord#") int32ToInt_RDR   = varQual_RDR  gHC_PRIM (fsLit "int32ToInt#") - {- ************************************************************************ *                                                                      *@@ -1639,16 +1648,18 @@ -}  -gen_Lift_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)-gen_Lift_binds loc tycon tycon_args = (listToBag [lift_bind, liftTyped_bind], emptyBag)+gen_Lift_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec)+gen_Lift_binds loc (DerivInstTys{ dit_rep_tc = tycon+                                , dit_rep_tc_args = tycon_args }) =+  (listToBag [lift_bind, liftTyped_bind], emptyBag)   where     lift_bind      = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr)-                                 (map (pats_etc mk_exp mk_usplice liftName) data_cons)+                                 (map (pats_etc mk_untyped_bracket mk_usplice liftName) data_cons)     liftTyped_bind = mkFunBindEC 1 loc liftTyped_RDR (nlHsApp unsafeCodeCoerce_Expr . nlHsApp pure_Expr)-                                 (map (pats_etc mk_texp mk_tsplice liftTypedName) data_cons)+                                 (map (pats_etc mk_typed_bracket mk_tsplice liftTypedName) data_cons) -    mk_exp = ExpBr noExtField-    mk_texp = TExpBr noExtField+    mk_untyped_bracket = HsUntypedBracket noAnn . ExpBr noExtField+    mk_typed_bracket = HsTypedBracket noAnn      mk_usplice = HsUntypedSplice EpAnnNotUsed DollarSplice     mk_tsplice = HsTypedSplice EpAnnNotUsed DollarSplice@@ -1661,7 +1672,7 @@             data_con_RDR = getRdrName data_con             con_arity    = dataConSourceArity data_con             as_needed    = take con_arity as_RDRs-            lift_Expr    = noLocA (HsBracket noAnn (mk_bracket br_body))+            lift_Expr    = noLocA (mk_bracket br_body)             br_body      = nlHsApps (Exact (dataConName data_con))                                     (map lift_var as_needed) @@ -1966,17 +1977,18 @@                              -- newtype itself)                   -> [Type]  -- instance head parameters (incl. newtype)                   -> Type    -- the representation type-                  -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff)+                  -> (LHsBinds GhcPs, [LSig GhcPs]) -- See Note [Newtype-deriving instances] gen_Newtype_binds loc' cls inst_tvs inst_tys rhs_ty-  = do let ats = classATs cls-           (binds, sigs) = mapAndUnzip mk_bind_and_sig (classMethods cls)-       atf_insts <- ASSERT( all (not . isDataFamilyTyCon) ats )-                    mapM mk_atf_inst ats-       return ( listToBag binds-              , sigs-              , listToBag $ map DerivFamInst atf_insts )+  = (listToBag binds, sigs)   where+    (binds, sigs) = mapAndUnzip mk_bind_and_sig (classMethods cls)++    -- Same as inst_tys, but with the last argument type replaced by the+    -- representation type.+    underlying_inst_tys :: [Type]+    underlying_inst_tys = changeLast inst_tys rhs_ty+     locn = noAnnSrcSpan loc'     loca = noAnnSrcSpan loc'     -- For each class method, generate its derived binding and instance@@ -2046,6 +2058,33 @@                      -- Filter out any inferred arguments, since they can't be                      -- applied with visible type application. +gen_Newtype_fam_insts :: SrcSpan+                      -> Class   -- the class being derived+                      -> [TyVar] -- the tvs in the instance head (this includes+                                 -- the tvs from both the class types and the+                                 -- newtype itself)+                      -> [Type]  -- instance head parameters (incl. newtype)+                      -> Type    -- the representation type+                      -> TcM [FamInst]+-- See Note [GND and associated type families] in GHC.Tc.Deriv+gen_Newtype_fam_insts loc' cls inst_tvs inst_tys rhs_ty+  = assert (all (not . isDataFamilyTyCon) ats) $+    mapM mk_atf_inst ats+  where+    -- Same as inst_tys, but with the last argument type replaced by the+    -- representation type.+    underlying_inst_tys :: [Type]+    underlying_inst_tys = changeLast inst_tys rhs_ty++    ats       = classATs cls+    locn      = noAnnSrcSpan loc'+    cls_tvs   = classTyVars cls+    in_scope  = mkInScopeSet $ mkVarSet inst_tvs+    lhs_env   = zipTyEnv cls_tvs inst_tys+    lhs_subst = mkTvSubst in_scope lhs_env+    rhs_env   = zipTyEnv cls_tvs underlying_inst_tys+    rhs_subst = mkTvSubst in_scope rhs_env+     mk_atf_inst :: TyCon -> TcM FamInst     mk_atf_inst fam_tc = do         rep_tc_name <- newFamInstTyConName (L locn (tyConName fam_tc))@@ -2056,12 +2095,6 @@         checkValidCoAxBranch fam_tc (coAxiomSingleBranch axiom)         newFamInst SynFamilyInst axiom       where-        cls_tvs     = classTyVars cls-        in_scope    = mkInScopeSet $ mkVarSet inst_tvs-        lhs_env     = zipTyEnv cls_tvs inst_tys-        lhs_subst   = mkTvSubst in_scope lhs_env-        rhs_env     = zipTyEnv cls_tvs underlying_inst_tys-        rhs_subst   = mkTvSubst in_scope rhs_env         fam_tvs     = tyConTyVars fam_tc         rep_lhs_tys = substTyVars lhs_subst fam_tvs         rep_rhs_tys = substTyVars rhs_subst fam_tvs@@ -2071,11 +2104,6 @@         rep_tvs'    = scopedSort rep_tvs         rep_cvs'    = scopedSort rep_cvs -    -- Same as inst_tys, but with the last argument type replaced by the-    -- representation type.-    underlying_inst_tys :: [Type]-    underlying_inst_tys = changeLast inst_tys rhs_ty- nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs nlHsAppType e s = noLocA (HsAppType noSrcSpan e hs_ty)   where@@ -2153,9 +2181,12 @@     gen_bind (DerivDataDataType tycon dataT_RDR dataC_RDRs)       = mkHsVarBind loc dataT_RDR rhs       where+        tc_name = tyConName tycon+        tc_name_string = occNameString (getOccName tc_name)+        definition_mod_name = moduleNameString (moduleName (expectJust "gen_bind DerivDataDataType" $ nameModule_maybe tc_name))         ctx = initDefaultSDocContext dflags         rhs = nlHsVar mkDataType_RDR-              `nlHsApp` nlHsLit (mkHsString (showSDocOneLine ctx (ppr tycon)))+              `nlHsApp` nlHsLit (mkHsString (showSDocOneLine ctx (text definition_mod_name <> dot <> text tc_name_string)))               `nlHsApp` nlList (map nlHsVar dataC_RDRs)      gen_bind (DerivDataConstr dc dataC_RDR dataT_RDR)@@ -2202,31 +2233,19 @@   DerivMaxTag _ _     -> mk_sig (L (noAnnSrcSpan loc) (XHsType intTy))   DerivDataDataType _ _ _-    -> mk_sig (nlHsTyVar dataType_RDR)+    -> mk_sig (nlHsTyVar NotPromoted dataType_RDR)   DerivDataConstr _ _ _-    -> mk_sig (nlHsTyVar constr_RDR)+    -> mk_sig (nlHsTyVar NotPromoted constr_RDR)   where     mk_sig = mkHsWildCardBndrs . L (noAnnSrcSpan loc) . mkHsImplicitSigType -type SeparateBagsDerivStuff =-  -- DerivAuxBinds-  ( Bag (LHsBind GhcPs, LSig GhcPs)--  -- Extra family instances (used by DeriveGeneric, DeriveAnyClass, and-  -- GeneralizedNewtypeDeriving)-  , Bag FamInst )---- | Take a 'BagDerivStuff' and partition it into 'SeparateBagsDerivStuff'.--- Also generate the code for auxiliary bindings based on the declarative--- descriptions in the supplied 'AuxBindSpec's. See @Note [Auxiliary binders]@.-genAuxBinds :: DynFlags -> SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff-genAuxBinds dflags loc b = (gen_aux_bind_specs b1, b2) where-  (b1,b2) = partitionBagWith splitDerivAuxBind b-  splitDerivAuxBind (DerivAuxBind x) = Left x-  splitDerivAuxBind (DerivFamInst t) = Right t--  gen_aux_bind_specs = snd . foldr gen_aux_bind_spec (emptyOccEnv, emptyBag)-+-- | Take a 'Bag' of 'AuxBindSpec's and generate the code for auxiliary+-- bindings based on the declarative descriptions in the supplied+-- 'AuxBindSpec's. See @Note [Auxiliary binders]@.+genAuxBinds :: DynFlags -> SrcSpan -> Bag AuxBindSpec+            -> Bag (LHsBind GhcPs, LSig GhcPs)+genAuxBinds dflags loc = snd . foldr gen_aux_bind_spec (emptyOccEnv, emptyBag)+ where   -- Perform a CSE-like pass over the generated auxiliary bindings to avoid   -- code duplication, as described in   -- Note [Auxiliary binders] (Wrinkle: Reducing code duplication).@@ -2651,33 +2670,134 @@ getPossibleDataCons :: TyCon -> [Type] -> [DataCon] getPossibleDataCons tycon tycon_args = filter isPossible $ tyConDataCons tycon   where-    isPossible = not . dataConCannotMatch (tyConInstArgTys tycon tycon_args)+    isPossible dc = not $ dataConCannotMatch (dataConInstUnivs dc tycon_args) dc --- | Given a type constructor @tycon@ of arity /n/ and a list of argument types--- @tycon_args@ of length /m/,+-- | Information about the arguments to the class in a stock- or+-- newtype-derived instance. For a @deriving@-generated instance declaration+-- such as this one: -- -- @--- tyConInstArgTys tycon tycon_args+-- instance Ctx => Cls cls_ty_1 ... cls_ty_m (TC tc_arg_1 ... tc_arg_n) where ... -- @ ----- returns+-- * 'dit_cls_tys' corresponds to @cls_ty_1 ... cls_ty_m@. ----- @--- [tycon_arg_{1}, tycon_arg_{2}, ..., tycon_arg_{m}, extra_arg_{m+1}, ..., extra_arg_{n}]--- @+-- * 'dit_tc' corresponds to @TC@. ----- where @extra_args@ are distinct type variables.+-- * 'dit_tc_args' corresponds to @tc_arg_1 ... tc_arg_n@. ----- Examples:+-- See @Note [DerivEnv and DerivSpecMechanism]@ in "GHC.Tc.Deriv.Utils" for a+-- more in-depth explanation, including the relationship between+-- 'dit_tc'/'dit_rep_tc' and 'dit_tc_args'/'dit_rep_tc_args'. ----- * Given @tycon: Foo a b@ and @tycon_args: [Int, Bool]@, return @[Int, Bool]@.+-- A 'DerivInstTys' value can be seen as a more structured representation of+-- the 'denv_inst_tys' in a 'DerivEnv', as the 'denv_inst_tys' is equal to+-- @dit_cls_tys ++ ['mkTyConApp' dit_tc dit_tc_args]@. Other parts of the+-- instance declaration can be found in the 'DerivEnv'. For example, the @Cls@+-- in the example above corresponds to the 'denv_cls' field of 'DerivEnv'. ----- * Given @tycon: Foo a b@ and @tycon_args: [Int]@, return @[Int, b]@.-tyConInstArgTys :: TyCon -> [Type] -> [Type]-tyConInstArgTys tycon tycon_args = chkAppend tycon_args $ map mkTyVarTy tycon_args_suffix+-- Similarly, the type variables that appear in a 'DerivInstTys' value are the+-- same type variables as the 'denv_tvs' in the parent 'DerivEnv'. Accordingly,+-- if we are inferring an instance context, the type variables will be 'TcTyVar'+-- skolems. Otherwise, they will be ordinary 'TyVar's.+-- See @Note [Overlap and deriving]@ in "GHC.Tc.Deriv.Infer".+data DerivInstTys = DerivInstTys+  { dit_cls_tys     :: [Type]+    -- ^ Other arguments to the class except the last+  , dit_tc          :: TyCon+    -- ^ Type constructor for which the instance is requested+    --   (last arguments to the type class)+  , dit_tc_args     :: [Type]+    -- ^ Arguments to the type constructor+  , dit_rep_tc      :: TyCon+    -- ^ The representation tycon for 'dit_tc'+    --   (for data family instances). Otherwise the same as 'dit_tc'.+  , dit_rep_tc_args :: [Type]+    -- ^ The representation types for 'dit_tc_args'+    --   (for data family instances). Otherwise the same as 'dit_tc_args'.+  , dit_dc_inst_arg_env :: DataConEnv [Type]+    -- ^ The cached results of instantiating each data constructor's field+    --   types using @'dataConInstUnivs' data_con 'dit_rep_tc_args'@.+    --   See @Note [Instantiating field types in stock deriving]@.+    --+    --   This field is only used for stock-derived instances and goes unused+    --   for newtype-derived instances. It is put here mainly for the sake of+    --   convenience.+  }++instance Outputable DerivInstTys where+  ppr (DerivInstTys { dit_cls_tys = cls_tys, dit_tc = tc, dit_tc_args = tc_args+                    , dit_rep_tc = rep_tc, dit_rep_tc_args = rep_tc_args+                    , dit_dc_inst_arg_env = dc_inst_arg_env })+    = hang (text "DerivInstTys")+         2 (vcat [ text "dit_cls_tys"         <+> ppr cls_tys+                 , text "dit_tc"              <+> ppr tc+                 , text "dit_tc_args"         <+> ppr tc_args+                 , text "dit_rep_tc"          <+> ppr rep_tc+                 , text "dit_rep_tc_args"     <+> ppr rep_tc_args+                 , text "dit_dc_inst_arg_env" <+> ppr dc_inst_arg_env ])++-- | Look up a data constructor's instantiated field types in a 'DerivInstTys'.+-- See @Note [Instantiating field types in stock deriving]@.+derivDataConInstArgTys :: DataCon -> DerivInstTys -> [Type]+derivDataConInstArgTys dc dit =+  case lookupUFM (dit_dc_inst_arg_env dit) dc of+    Just inst_arg_tys -> inst_arg_tys+    Nothing           -> pprPanic "derivDataConInstArgTys" (ppr dc)++-- | @'buildDataConInstArgEnv' tycon arg_tys@ constructs a cache that maps+-- each of @tycon@'s data constructors to their field types, with are to be+-- instantiated with @arg_tys@.+-- See @Note [Instantiating field types in stock deriving]@.+buildDataConInstArgEnv :: TyCon -> [Type] -> DataConEnv [Type]+buildDataConInstArgEnv rep_tc rep_tc_args =+  listToUFM [ (dc, inst_arg_tys)+            | dc <- tyConDataCons rep_tc+            , let (_, _, inst_arg_tys) =+                    dataConInstSig dc $ dataConInstUnivs dc rep_tc_args+            ]++-- | Apply a substitution to all of the 'Type's contained in a 'DerivInstTys'.+-- See @Note [Instantiating field types in stock deriving]@ for why we need to+-- substitute into a 'DerivInstTys' in the first place.+substDerivInstTys :: TCvSubst -> DerivInstTys -> DerivInstTys+substDerivInstTys subst+  dit@(DerivInstTys { dit_cls_tys = cls_tys, dit_tc_args = tc_args+                    , dit_rep_tc = rep_tc, dit_rep_tc_args = rep_tc_args })++  | isEmptyTCvSubst subst+  = dit+  | otherwise+  = dit{ dit_cls_tys         = cls_tys'+       , dit_tc_args         = tc_args'+       , dit_rep_tc_args     = rep_tc_args'+       , dit_dc_inst_arg_env = buildDataConInstArgEnv rep_tc rep_tc_args'+       }   where-    tycon_args_suffix = drop (length tycon_args) $ tyConTyVars tycon+    cls_tys'     = substTys subst cls_tys+    tc_args'     = substTys subst tc_args+    rep_tc_args' = substTys subst rep_tc_args +-- | Zonk the 'TcTyVar's in a 'DerivInstTys' value to 'TyVar's.+-- See @Note [What is zonking?]@ in "GHC.Tc.Utils.TcMType".+--+-- This is only used in the final zonking step when inferring+-- the context for a derived instance.+-- See @Note [Overlap and deriving]@ in "GHC.Tc.Deriv.Infer".+zonkDerivInstTys :: ZonkEnv -> DerivInstTys -> TcM DerivInstTys+zonkDerivInstTys ze dit@(DerivInstTys { dit_cls_tys = cls_tys+                                      , dit_tc_args = tc_args+                                      , dit_rep_tc = rep_tc+                                      , dit_rep_tc_args = rep_tc_args }) = do+  cls_tys'     <- zonkTcTypesToTypesX ze cls_tys+  tc_args'     <- zonkTcTypesToTypesX ze tc_args+  rep_tc_args' <- zonkTcTypesToTypesX ze rep_tc_args+  pure dit{ dit_cls_tys         = cls_tys'+          , dit_tc_args         = tc_args'+          , dit_rep_tc_args     = rep_tc_args'+          , dit_dc_inst_arg_env = buildDataConInstArgEnv rep_tc rep_tc_args'+          }+ {- Note [Auxiliary binders] ~~~~~~~~~~~~~~~~~~~~~~~~@@ -2947,4 +3067,82 @@ there is a valid use-case and we have requirements for how they should work.  See #16341 and the T16341.hs test case.++Note [Instantiating field types in stock deriving]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Figuring out what the types of data constructor fields are in `deriving` can+be surprisingly tricky. Here are some examples (adapted from #20375) to set+the scene:++  data Ta = MkTa Int#+  data Tb (x :: TYPE IntRep) = MkTb x++  deriving instance Eq Ta        -- 1.+  deriving instance Eq (Tb a)    -- 2.+  deriving instance Eq (Tb Int#) -- 3.++Example (1) is accepted, as `deriving Eq` has a special case for fields of type+Int#. Example (2) is rejected, however, as the special case for Int# does not+extend to all types of kind (TYPE IntRep).++Example (3) ought to typecheck. If you instantiate the field of type `x` in+MkTb to be Int#, then `deriving Eq` is capable of handling that. We must be+careful, however. If we naïvely use, say, `dataConOrigArgTys` to retrieve the+field types, then we would get `b`, which `deriving Eq` would reject. In+order to handle `deriving Eq` (and, more generally, any stock deriving+strategy) correctly, we /must/ instantiate the field types as needed.+Not doing so led to #20375 and #20387.++In fact, we end up needing to instantiate the field types in quite a few+places:++* When performing validity checks for stock deriving strategies (e.g., in+  GHC.Tc.Deriv.Utils.cond_stdOK)++* When inferring the instance context in+  GHC.Tc.Deriv.Infer.inferConstraintStock++* When generating code for stock-derived instances in+  GHC.Tc.Deriv.{Functor,Generate,Generics}++Repeatedly performing these instantiations in multiple places would be+wasteful, so we build a cache of data constructor field instantiations in+the `dit_dc_inst_arg_env` field of DerivInstTys. Specifically:++1. When beginning to generate code for a stock-derived instance+   `T arg_1 ... arg_n`, the `dit_dc_inst_arg_env` field is created by taking+   each data constructor `dc`, instantiating its field types with+   `dataConInstUnivs dc [arg_1, ..., arg_n]`, and mapping `dc` to the+   instantiated field types in the cache. The `buildDataConInstArgEnv` function+   is responsible for orchestrating this.++2. When a part of the code in GHC.Tc.Deriv.* needs to look up the field+   types, we deliberately avoid using `dataConOrigArgTys`. Instead, we use+   `derivDataConInstArgTys`, which looks up a DataCon's instantiated field+   types in the cache.++StandaloneDeriving is one way for the field types to become instantiated.+Another way is by deriving Functor and related classes, as chronicled in+Note [Inferring the instance context] in GHC.Tc.Deriv.Infer. Here is one such+example:++  newtype Compose (f :: k -> Type) (g :: j -> k) (a :: j) = Compose (f (g a))+    deriving Generic1++This ultimately generates the following instance:++  instance forall (f :: Type -> Type) (g :: j -> Type).+    Functor f => Generic1 (Compose f g) where ...++Note that because of the inferred `Functor f` constraint, `k` was instantiated+to be `Type`. GHC's deriving machinery doesn't realize this until it performs+constraint inference (in GHC.Tc.Deriv.Infer.inferConstraintsStock), however,+which is *after* the initial DerivInstTys has been created. As a result, the+`dit_dc_inst_arg_env` field might need to be updated after constraint inference,+as the inferred constraints might instantiate the field types further.++This is accomplished by way of `substDerivInstTys`, which substitutes all of+the fields in a `DerivInstTys`, including the `dit_dc_inst_arg_env`.+It is important to do this in inferConstraintsStock, as the+deriving/should_compile/T20387 test case will not compile otherwise. -}
compiler/GHC/Tc/Deriv/Generics.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies        #-}@@ -12,10 +12,11 @@  -- | The deriving code for the Generic class module GHC.Tc.Deriv.Generics-   (canDoGenerics+   ( canDoGenerics    , canDoGenerics1    , GenericKind(..)    , gen_Generic_binds+   , gen_Generic_fam_inst    , get_gen1_constrained_tys    ) where@@ -27,17 +28,16 @@ import GHC.Tc.Utils.TcType import GHC.Tc.Deriv.Generate import GHC.Tc.Deriv.Functor+import GHC.Tc.Errors.Types import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Core.FamInstEnv ( FamInst, FamFlavor(..), mkSingleCoAxiom )-import GHC.Core.Multiplicity import GHC.Tc.Instance.Family import GHC.Unit.Module ( moduleName, moduleNameFS                         , moduleUnit, unitFS, getModule ) import GHC.Iface.Env    ( newGlobalBinder ) import GHC.Types.Name hiding ( varName ) import GHC.Types.Name.Reader-import GHC.Types.Fixity.Env import GHC.Types.SourceText import GHC.Types.Fixity import GHC.Types.Basic@@ -47,13 +47,14 @@ import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad import GHC.Driver.Session-import GHC.Utils.Error( Validity(..), andValid )+import GHC.Utils.Error( Validity'(..), andValid ) import GHC.Types.SrcLoc import GHC.Data.Bag import GHC.Types.Var.Env import GHC.Types.Var.Set (elemVarSet) import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Data.FastString import GHC.Utils.Misc @@ -61,8 +62,6 @@ import Data.List (zip4, partition) import Data.Maybe (isJust) -#include "GhclibHsVersions.h"- {- ************************************************************************ *                                                                      *@@ -78,13 +77,11 @@ \end{itemize} -} -gen_Generic_binds :: GenericKind -> TyCon -> [Type]-                 -> TcM (LHsBinds GhcPs, [LSig GhcPs], FamInst)-gen_Generic_binds gk tc inst_tys = do+gen_Generic_binds :: GenericKind -> SrcSpan -> DerivInstTys+                  -> TcM (LHsBinds GhcPs, [LSig GhcPs])+gen_Generic_binds gk loc dit = do   dflags <- getDynFlags-  repTyInsts <- tc_mkRepFamInsts gk tc inst_tys-  let (binds, sigs) = mkBindsRep dflags gk tc-  return (binds, sigs, repTyInsts)+  return $ mkBindsRep dflags gk loc dit  {- ************************************************************************@@ -119,6 +116,7 @@       alpha-renaming).    (b) D cannot have a "stupid context".+      See Note [The stupid context] in GHC.Core.DataCon.    (c) The right-hand side of D cannot include existential types, universally       quantified types, or "exotic" unlifted types. An exotic unlifted type@@ -147,7 +145,7 @@  -} -canDoGenerics :: TyCon -> Validity+canDoGenerics :: DerivInstTys -> Validity' [DeriveGenericsErrReason] -- canDoGenerics determines if Generic/Rep can be derived. -- -- Check (a) from Note [Requirements for deriving Generic and Rep] is taken@@ -155,18 +153,18 @@ -- -- It returns IsValid if deriving is possible. It returns (NotValid reason) -- if not.-canDoGenerics tc+canDoGenerics dit@(DerivInstTys{dit_rep_tc = tc})   = mergeErrors (           -- Check (b) from Note [Requirements for deriving Generic and Rep].               (if (not (null (tyConStupidTheta tc)))-                then (NotValid (tc_name <+> text "must not have a datatype context"))+                then (NotValid $ DerivErrGenericsMustNotHaveDatatypeContext tc_name)                 else IsValid)           -- See comment below             : (map bad_con (tyConDataCons tc)))   where     -- The tc can be a representation tycon. When we want to display it to the     -- user (in an error message) we should print its parent-    tc_name = ppr $ case tyConFamInst_maybe tc of+    tc_name = case tyConFamInst_maybe tc of         Just (ptc, _) -> ptc         _             -> tc @@ -176,16 +174,16 @@         -- then we can't build the embedding-projection pair, because         -- it relies on instantiating *polymorphic* sum and product types         -- at the argument types of the constructors-    bad_con dc = if (any bad_arg_type (map scaledThing $ dataConOrigArgTys dc))-                  then (NotValid (ppr dc <+> text-                    "must not have exotic unlifted or polymorphic arguments"))-                  else (if (not (isVanillaDataCon dc))-                          then (NotValid (ppr dc <+> text "must be a vanilla data constructor"))-                          else IsValid)+    bad_con :: DataCon -> Validity' DeriveGenericsErrReason+    bad_con dc = if any bad_arg_type (derivDataConInstArgTys dc dit)+                  then NotValid $ DerivErrGenericsMustNotHaveExoticArgs dc+                  else if not (isVanillaDataCon dc)+                          then NotValid $ DerivErrGenericsMustBeVanillaDataCon dc+                          else IsValid          -- Nor can we do the job if it's an existential data constructor,         -- Nor if the args are polymorphic types (I don't think)-    bad_arg_type ty = (isUnliftedType ty && not (allowedUnliftedTy ty))+    bad_arg_type ty = (mightBeUnliftedType ty && not (allowedUnliftedTy ty))                       || not (isTauTy ty)  -- Returns True the Type argument is an unlifted type which has a@@ -195,19 +193,20 @@ allowedUnliftedTy :: Type -> Bool allowedUnliftedTy = isJust . unboxedRepRDRs -mergeErrors :: [Validity] -> Validity+mergeErrors :: [Validity' a] -> Validity' [a] mergeErrors []             = IsValid mergeErrors (NotValid s:t) = case mergeErrors t of-  IsValid     -> NotValid s-  NotValid s' -> NotValid (s <> text ", and" $$ s')+  IsValid     -> NotValid [s]+  NotValid s' -> NotValid (s : s') mergeErrors (IsValid : t) = mergeErrors t+  -- NotValid s' -> NotValid (s <> text ", and" $$ s')  -- A datatype used only inside of canDoGenerics1. It's the result of analysing -- a type term. data Check_for_CanDoGenerics1 = CCDG1   { _ccdg1_hasParam :: Bool       -- does the parameter of interest occurs in                                   -- this type?-  , _ccdg1_errors   :: Validity   -- errors generated by this type+  , _ccdg1_errors   :: Validity' DeriveGenericsErrReason -- errors generated by this type   }  {-@@ -242,32 +241,28 @@ -- -- It returns IsValid if deriving is possible. It returns (NotValid reason) -- if not.-canDoGenerics1 :: TyCon -> Validity-canDoGenerics1 rep_tc =-  canDoGenerics rep_tc `andValid` additionalChecks+canDoGenerics1 :: DerivInstTys -> Validity' [DeriveGenericsErrReason]+canDoGenerics1 dit@(DerivInstTys{dit_rep_tc = rep_tc}) =+  canDoGenerics dit `andValid` additionalChecks   where     additionalChecks         -- check (d) from Note [Requirements for deriving Generic and Rep]-      | null (tyConTyVars rep_tc) = NotValid $-          text "Data type" <+> quotes (ppr rep_tc)-      <+> text "must have some type parameters"+      | null (tyConTyVars rep_tc) = NotValid [+          DerivErrGenericsMustHaveSomeTypeParams rep_tc]        | otherwise = mergeErrors $ concatMap check_con data_cons      data_cons = tyConDataCons rep_tc     check_con con = case check_vanilla con of       j@(NotValid {}) -> [j]-      IsValid -> _ccdg1_errors `map` foldDataConArgs (ft_check con) con--    bad :: DataCon -> SDoc -> SDoc-    bad con msg = text "Constructor" <+> quotes (ppr con) <+> msg+      IsValid -> _ccdg1_errors `map` foldDataConArgs (ft_check con) con dit -    check_vanilla :: DataCon -> Validity+    check_vanilla :: DataCon -> Validity' DeriveGenericsErrReason     check_vanilla con | isVanillaDataCon con = IsValid-                      | otherwise            = NotValid (bad con existential)+                      | otherwise            = NotValid $ DerivErrGenericsMustNotHaveExistentials con -    bmzero      = CCDG1 False IsValid-    bmbad con s = CCDG1 True $ NotValid $ bad con s+    bmzero    = CCDG1 False IsValid+    bmbad con = CCDG1 True $ NotValid (DerivErrGenericsWrongArgKind con)     bmplus (CCDG1 b1 m1) (CCDG1 b2 m2) = CCDG1 (b1 || b2) (m1 `andValid` m2)      -- check (e) from Note [Requirements for deriving Generic and Rep]@@ -280,30 +275,25 @@        -- (component_0,component_1,...,component_n)       , ft_tup = \_ components -> if any _ccdg1_hasParam (init components)-                                  then bmbad con wrong_arg+                                  then bmbad con                                   else foldr bmplus bmzero components        -- (dom -> rng), where the head of ty is not a tuple tycon       , ft_fun = \dom rng -> -- cf #8516           if _ccdg1_hasParam dom-          then bmbad con wrong_arg+          then bmbad con           else bmplus dom rng        -- (ty arg), where head of ty is neither (->) nor a tuple constructor and       -- the parameter of interest does not occur in ty       , ft_ty_app = \_ _ arg -> arg -      , ft_bad_app = bmbad con wrong_arg+      , ft_bad_app = bmbad con       , ft_forall  = \_ body -> body -- polytypes are handled elsewhere       }       where         caseVar = CCDG1 True IsValid --    existential = text "must not have existential arguments"-    wrong_arg   = text "applies a type to an argument involving the last parameter"-               $$ text "but the applied type is not of kind * -> *"- {- ************************************************************************ *                                                                      *@@ -319,26 +309,30 @@ -- Generic1 (Gen1). data GenericKind = Gen0 | Gen1 --- as above, but with a payload of the TyCon's name for "the" parameter-data GenericKind_ = Gen0_ | Gen1_ TyVar---- as above, but using a single datacon's name for "the" parameter+-- Like 'GenericKind', but with a payload of a datacon's last universally+-- quantified 'TyVar' in the 'Generic1' case.+--+-- Note that for GADTs, the last TyVar's Name will be different in each data+-- constructor, so it is not correct to simply use the last TyVar in+-- 'tyConTyVars' in 'Gen1_DC'. (See #21185 for an example of what would happen+-- if you tried.) data GenericKind_DC = Gen0_DC | Gen1_DC TyVar -forgetArgVar :: GenericKind_DC -> GenericKind-forgetArgVar Gen0_DC   = Gen0-forgetArgVar Gen1_DC{} = Gen1---- When working only within a single datacon, "the" parameter's name should--- match that datacon's name for it.-gk2gkDC :: GenericKind_ -> DataCon -> GenericKind_DC-gk2gkDC Gen0_   _ = Gen0_DC-gk2gkDC Gen1_{} d = Gen1_DC $ last $ dataConUnivTyVars d+-- Construct a 'GenericKind_DC', retrieving the last universally quantified+-- type variable of a 'DataCon' in the 'Generic1' case.+gk2gkDC :: GenericKind -> DataCon -> [Type] -> GenericKind_DC+gk2gkDC Gen0 _  _       = Gen0_DC+gk2gkDC Gen1 dc tc_args = Gen1_DC $ assert (isTyVarTy last_dc_inst_univ)+                                  $ getTyVar "gk2gkDC" last_dc_inst_univ+  where+    dc_inst_univs = dataConInstUnivs dc tc_args+    last_dc_inst_univ = assert (not (null dc_inst_univs)) $+                        last dc_inst_univs   -- Bindings for the Generic instance-mkBindsRep :: DynFlags -> GenericKind -> TyCon -> (LHsBinds GhcPs, [LSig GhcPs])-mkBindsRep dflags gk tycon = (binds, sigs)+mkBindsRep :: DynFlags -> GenericKind -> SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, [LSig GhcPs])+mkBindsRep dflags gk loc dit@(DerivInstTys{dit_rep_tc = tycon}) = (binds, sigs)       where         binds = unitBag (mkRdrFunBind (L loc' from01_RDR) [from_eqn])               `unionBags`@@ -374,7 +368,6 @@          from_matches  = [mkHsCaseAlt pat rhs | (pat,rhs) <- from_alts]         to_matches    = [mkHsCaseAlt pat rhs | (pat,rhs) <- to_alts  ]-        loc           = srcLocSpan (getSrcLoc tycon)         loc'          = noAnnSrcSpan loc         loc''         = noAnnSrcSpan loc         datacons      = tyConDataCons tycon@@ -385,12 +378,7 @@          -- Recurse over the sum first         from_alts, to_alts :: [Alt]-        (from_alts, to_alts) = mkSum gk_ (1 :: US) datacons-          where gk_ = case gk of-                  Gen0 -> Gen0_-                  Gen1 -> ASSERT(tyvars `lengthAtLeast` 1)-                          Gen1_ (last tyvars)-                    where tyvars = tyConTyVars tycon+        (from_alts, to_alts) = mkSum gk (1 :: US) dit datacons  -------------------------------------------------------------------------------- -- The type synonym instance and synonym@@ -398,12 +386,17 @@ --       type Rep_D a b = ...representation type for D ... -------------------------------------------------------------------------------- -tc_mkRepFamInsts :: GenericKind   -- Gen0 or Gen1-                 -> TyCon         -- The type to generate representation for-                 -> [Type]        -- The type(s) to which Generic(1) is applied-                                  -- in the generated instance-                 -> TcM FamInst   -- Generated representation0 coercion-tc_mkRepFamInsts gk tycon inst_tys =+gen_Generic_fam_inst :: GenericKind      -- Gen0 or Gen1+                     -> (Name -> Fixity) -- Get the Fixity for a data constructor Name+                     -> SrcSpan          -- The current source location+                     -> DerivInstTys     -- Information about the type(s) to which+                                         -- Generic(1) is applied in the generated+                                         -- instance, including the data type's TyCon+                     -> TcM FamInst      -- Generated representation0 coercion+gen_Generic_fam_inst gk get_fixity loc+       dit@(DerivInstTys{ dit_cls_tys = cls_tys+                        , dit_tc = tc, dit_tc_args = tc_args+                        , dit_rep_tc = tycon }) =        -- Consider the example input tycon `D`, where data D a b = D_ a        -- Also consider `R:DInt`, where { data family D x y :: * -> *        --                               ; data instance D Int a b = D_ a }@@ -412,8 +405,6 @@          Gen0 -> tcLookupTyCon repTyConName          Gen1 -> tcLookupTyCon rep1TyConName -     ; fam_envs <- tcGetFamInstEnvs-      ; let -- If the derived instance is            --   instance Generic (Foo x)            -- then:@@ -423,58 +414,28 @@            --   instance Generic1 (Bar x :: k -> *)            -- then:            --   `arg_k` = k, `inst_ty` = Bar x :: k -> *-           (arg_ki, inst_ty) = case (gk, inst_tys) of-             (Gen0, [inst_t])        -> (liftedTypeKind, inst_t)-             (Gen1, [arg_k, inst_t]) -> (arg_k,          inst_t)-             _ -> pprPanic "tc_mkRepFamInsts" (ppr inst_tys)--     ; let mbFamInst         = tyConFamInst_maybe tycon-           -- If we're examining a data family instance, we grab the parent-           -- TyCon (ptc) and use it to determine the type arguments-           -- (inst_args) for the data family *instance*'s type variables.-           ptc               = maybe tycon fst mbFamInst-           (_, inst_args, _) = tcLookupDataFamInst fam_envs ptc $ snd-                                 $ tcSplitTyConApp inst_ty--     ; let -- `tyvars` = [a,b]-           (tyvars, gk_) = case gk of-             Gen0 -> (all_tyvars, Gen0_)-             Gen1 -> ASSERT(not $ null all_tyvars)-                     (init all_tyvars, Gen1_ $ last all_tyvars)-             where all_tyvars = tyConTyVars tycon+           arg_ki = case (gk, cls_tys) of+             (Gen0, [])      -> liftedTypeKind+             (Gen1, [arg_k]) -> arg_k+             _ -> pprPanic "gen_Generic_fam_insts" (ppr cls_tys)+           inst_ty = mkTyConApp tc tc_args+           inst_tys = cls_tys ++ [inst_ty]         -- `repTy` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> *-     ; repTy <- tc_mkRepTy gk_ tycon arg_ki+     ; repTy <- tc_mkRepTy gk get_fixity dit arg_ki         -- `rep_name` is a name we generate for the synonym      ; mod <- getModule-     ; loc <- getSrcSpanM      ; let tc_occ  = nameOccName (tyConName tycon)            rep_occ = case gk of Gen0 -> mkGenR tc_occ; Gen1 -> mkGen1R tc_occ      ; rep_name <- newGlobalBinder mod rep_occ loc -       -- We make sure to substitute the tyvars with their user-supplied-       -- type arguments before generating the Rep/Rep1 instance, since some-       -- of the tyvars might have been instantiated when deriving.-       -- See Note [Generating a correctly typed Rep instance].-     ; let (env_tyvars, env_inst_args)-             = case gk_ of-                 Gen0_ -> (tyvars, inst_args)-                 Gen1_ last_tv-                          -- See the "wrinkle" in-                          -- Note [Generating a correctly typed Rep instance]-                       -> ( last_tv : tyvars-                          , anyTypeOfKind (tyVarKind last_tv) : inst_args )-           env        = zipTyEnv env_tyvars env_inst_args-           in_scope   = mkInScopeSet (tyCoVarsOfTypes inst_tys)-           subst      = mkTvSubst in_scope env-           repTy'     = substTyUnchecked  subst repTy-           tcv'       = tyCoVarsOfTypeList inst_ty-           (tv', cv') = partition isTyVar tcv'-           tvs'       = scopedSort tv'-           cvs'       = scopedSort cv'-           axiom      = mkSingleCoAxiom Nominal rep_name tvs' [] cvs'-                                        fam_tc inst_tys repTy'+     ; let tcv      = tyCoVarsOfTypeList inst_ty+           (tv, cv) = partition isTyVar tcv+           tvs      = scopedSort tv+           cvs      = scopedSort cv+           axiom    = mkSingleCoAxiom Nominal rep_name tvs [] cvs+                                      fam_tc inst_tys repTy       ; newFamInst SynFamilyInst axiom  } @@ -547,16 +508,19 @@             else mkComp phi `fmap` go beta -- It must be a composition.  -tc_mkRepTy ::  -- Gen0_ or Gen1_, for Rep or Rep1-               GenericKind_-              -- The type to generate representation for-            -> TyCon-              -- The kind of the representation type's argument-              -- See Note [Handling kinds in a Rep instance]+tc_mkRepTy ::  -- Gen0 or Gen1, for Rep or Rep1+               GenericKind+               -- Get the Fixity for a data constructor Name+            -> (Name -> Fixity)+               -- Information about the last type argument to Generic(1)+            -> DerivInstTys+               -- The kind of the representation type's argument+               -- See Note [Handling kinds in a Rep instance]             -> Kind                -- Generated representation0 type             -> TcM Type-tc_mkRepTy gk_ tycon k =+tc_mkRepTy gk get_fixity dit@(DerivInstTys{ dit_rep_tc = tycon+                                          , dit_rep_tc_args = tycon_args }) k =   do     d1      <- tcLookupTyCon d1TyConName     c1      <- tcLookupTyCon c1TyConName@@ -596,8 +560,6 @@     pDStr      <- tcLookupPromDataCon decidedStrictDataConName     pDUpk      <- tcLookupPromDataCon decidedUnpackDataConName -    fix_env <- getFixityEnv-     let mkSum' a b = mkTyConApp plus  [k,a,b]         mkProd a b = mkTyConApp times [k,a,b]         mkRec0 a   = mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 k a@@ -606,8 +568,8 @@         mkD    a   = mkTyConApp d1 [ k, metaDataTy, sumP (tyConDataCons a) ]         mkC      a = mkTyConApp c1 [ k                                    , metaConsTy a-                                   , prod (map scaledThing . dataConInstOrigArgTys a-                                            . mkTyVarTys . tyConTyVars $ tycon)+                                   , prod (gk2gkDC gk a tycon_args)+                                          (derivDataConInstArgTys a dit)                                           (dataConSrcBangs    a)                                           (dataConImplBangs   a)                                           (dataConFieldLabels a)]@@ -616,28 +578,38 @@         -- Sums and products are done in the same way for both Rep and Rep1         sumP l = foldBal mkSum' (mkTyConApp v1 [k]) . map mkC $ l         -- The Bool is True if this constructor has labelled fields-        prod :: [Type] -> [HsSrcBang] -> [HsImplBang] -> [FieldLabel] -> Type-        prod l sb ib fl = foldBal mkProd (mkTyConApp u1 [k])-                                  [ ASSERT(null fl || lengthExceeds fl j)-                                    arg t sb' ib' (if null fl-                                                      then Nothing-                                                      else Just (fl !! j))+        prod :: GenericKind_DC -> [Type] -> [HsSrcBang] -> [HsImplBang] -> [FieldLabel] -> Type+        prod gk_ l sb ib fl = foldBal mkProd (mkTyConApp u1 [k])+                                  [ assert (null fl || lengthExceeds fl j) $+                                    arg gk_ t sb' ib' (if null fl+                                                       then Nothing+                                                       else Just (fl !! j))                                   | (t,sb',ib',j) <- zip4 l sb ib [0..] ] -        arg :: Type -> HsSrcBang -> HsImplBang -> Maybe FieldLabel -> Type-        arg t (HsSrcBang _ su ss) ib fl = mkS fl su ss ib $ case gk_ of+        arg :: GenericKind_DC -> Type -> HsSrcBang -> HsImplBang -> Maybe FieldLabel -> Type+        arg gk_ t (HsSrcBang _ su ss) ib fl = mkS fl su ss ib $ case gk_ of             -- Here we previously used Par0 if t was a type variable, but we             -- realized that we can't always guarantee that we are wrapping-up             -- all type variables in Par0. So we decided to stop using Par0             -- altogether, and use Rec0 all the time.-                      Gen0_        -> mkRec0 t-                      Gen1_ argVar -> argPar argVar t+                      Gen0_DC        -> mkRec0 t+                      Gen1_DC argVar -> argPar argVar t           where             -- Builds argument representation for Rep1 (more complicated due to             -- the presence of composition).-            argPar argVar = argTyFold argVar $ ArgTyAlg+            argPar argVar =+              let -- If deriving Generic1, make sure to substitute the last+                  -- type variable with Any in the generated Rep1 instance.+                  -- This avoids issues like what is documented in the+                  -- "wrinkle" section of+                  -- Note [Generating a correctly typed Rep instance].+                  env      = zipTyEnv [argVar] [anyTypeOfKind (tyVarKind argVar)]+                  in_scope = mkInScopeSet (tyCoVarsOfTypes tycon_args)+                  subst    = mkTvSubst in_scope env in++              substTy subst . argTyFold argVar (ArgTyAlg               {ata_rec0 = mkRec0, ata_par1 = mkPar1,-               ata_rec1 = mkRec1, ata_comp = mkComp comp k}+               ata_rec1 = mkRec1, ata_comp = mkComp comp k})          tyConName_user = case tyConFamInst_maybe tycon of                            Just (ptycon, _) -> tyConName ptycon@@ -655,7 +627,7 @@         ctName = mkStrLitTy . occNameFS . nameOccName . dataConName         ctFix c             | dataConIsInfix c-            = case lookupFixity fix_env (dataConName c) of+            = case get_fixity (dataConName c) of                    Fixity _ n InfixL -> buildFix n pLA                    Fixity _ n InfixR -> buildFix n pRA                    Fixity _ n InfixN -> buildFix n pNA@@ -737,42 +709,45 @@ -- Dealing with sums -------------------------------------------------------------------------------- -mkSum :: GenericKind_ -- Generic or Generic1?-      -> US          -- Base for generating unique names-      -> [DataCon]   -- The data constructors-      -> ([Alt],     -- Alternatives for the T->Trep "from" function-          [Alt])     -- Alternatives for the Trep->T "to" function+mkSum :: GenericKind  -- Generic or Generic1?+      -> US           -- Base for generating unique names+      -> DerivInstTys -- Information about the last type argument to Generic(1)+      -> [DataCon]    -- The data constructors+      -> ([Alt],      -- Alternatives for the T->Trep "from" function+          [Alt])      -- Alternatives for the Trep->T "to" function  -- Datatype without any constructors-mkSum _ _ [] = ([from_alt], [to_alt])+mkSum _ _ _ [] = ([from_alt], [to_alt])   where     from_alt = (x_Pat, nlHsCase x_Expr [])     to_alt   = (x_Pat, nlHsCase x_Expr [])                -- These M1s are meta-information for the datatype  -- Datatype with at least one constructor-mkSum gk_ us datacons =+mkSum gk us dit datacons =   -- switch the payload of gk_ to be datacon-centric instead of tycon-centric- unzip [ mk1Sum (gk2gkDC gk_ d) us i (length datacons) d+ unzip [ mk1Sum gk us i (length datacons) dit d            | (d,i) <- zip datacons [1..] ]  -- Build the sum for a particular constructor-mk1Sum :: GenericKind_DC -- Generic or Generic1?-       -> US        -- Base for generating unique names-       -> Int       -- The index of this constructor-       -> Int       -- Total number of constructors-       -> DataCon   -- The data constructor-       -> (Alt,     -- Alternative for the T->Trep "from" function-           Alt)     -- Alternative for the Trep->T "to" function-mk1Sum gk_ us i n datacon = (from_alt, to_alt)+mk1Sum :: GenericKind  -- Generic or Generic1?+       -> US           -- Base for generating unique names+       -> Int          -- The index of this constructor+       -> Int          -- Total number of constructors+       -> DerivInstTys -- Information about the last type argument to Generic(1)+       -> DataCon      -- The data constructor+       -> (Alt,        -- Alternative for the T->Trep "from" function+           Alt)        -- Alternative for the Trep->T "to" function+mk1Sum gk us i n dit@(DerivInstTys{dit_rep_tc_args = tc_args}) datacon+  = (from_alt, to_alt)   where-    gk = forgetArgVar gk_+    gk_ = gk2gkDC gk datacon tc_args      -- Existentials already excluded-    argTys = dataConOrigArgTys datacon+    argTys = derivDataConInstArgTys datacon dit     n_args = dataConSourceArity datacon -    datacon_varTys = zip (map mkGenericLocal [us .. us+n_args-1]) (map scaledThing argTys)+    datacon_varTys = zip (map mkGenericLocal [us .. us+n_args-1]) argTys     datacon_vars = map fst datacon_varTys      datacon_rdr  = getRdrName datacon@@ -930,59 +905,55 @@ Note [Generating a correctly typed Rep instance] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ tc_mkRepTy derives the RHS of the Rep(1) type family instance when deriving-Generic(1). That is, it derives the ellipsis in the following:--    instance Generic Foo where-      type Rep Foo = ...+Generic(1). For example, given the following data declaration: -However, tc_mkRepTy only has knowledge of the *TyCon* of the type for which-a Generic(1) instance is being derived, not the fully instantiated type. As a-result, tc_mkRepTy builds the most generalized Rep(1) instance possible using-the type variables it learns from the TyCon (i.e., it uses tyConTyVars). This-can cause problems when the instance has instantiated type variables-(see #11732). As an example:+    data Foo a = MkFoo a+      deriving stock Generic -    data T a = MkT a-    deriving instance Generic (T Int)-    ==>-    instance Generic (T Int) where-      type Rep (T Int) = (... (Rec0 a)) -- wrong!+tc_mkRepTy would generate the `Rec0 a` portion of this instance: --XStandaloneDeriving is one way for the type variables to become instantiated.-Another way is when Generic1 is being derived for a datatype with a visible-kind binder, e.g.,+    instance Generic (Foo a) where+      type Rep (Foo a) = Rec0 a+      ... -   data P k (a :: k) = MkP k deriving Generic1-   ==>-   instance Generic1 (P *) where-     type Rep1 (P *) = (... (Rec0 k)) -- wrong!+(The full `Rep` instance is more complicated than this, but we have simplified+it for presentation purposes.) -See Note [Unify kinds in deriving] in GHC.Tc.Deriv.+`tc_mkRepTy` figures out the field types to use in the RHS by inspecting a+DerivInstTys, which contains the instantiated field types for each data+constructor. (See Note [Instantiating field types in stock deriving] for a+description of how this works.) As a result, `tc_mkRepTy` "just works" even+when dealing with StandaloneDeriving, such as in this example: -In any such scenario, we must prevent a discrepancy between the LHS and RHS of-a Rep(1) instance. To do so, we create a type variable substitution that maps-the tyConTyVars of the TyCon to their counterparts in the fully instantiated-type. (For example, using T above as example, you'd map a :-> Int.) We then-apply the substitution to the RHS before generating the instance.+    deriving stock instance Generic (Foo Int)+      ===>+    instance Generic (Foo Int) where+      type Rep (Foo Int) = Rec0 Int -- The `a` has been instantiated here -A wrinkle in all of this: when forming the type variable substitution for-Generic1 instances, we map the last type variable of the tycon to Any. Why?-It's because of wily data types like this one (#15012):+A wrinkle in all of this: what happens when deriving a Generic1 instance where+the last type variable appears in a type synonym that discards it? That is,+what should happen in this example (taken from #15012)? -   data T a = MkT (FakeOut a)-   type FakeOut a = Int+    type FakeOut a = Int+    data T a = MkT (FakeOut a)+      deriving Generic1 -If we ignore a, then we'll produce the following Rep1 instance:+MkT is a particularly wily data constructor. Although the last type variable+`a` technically appears in `FakeOut a`, it's just a smokescreen, as `FakeOut a`+simply expands to `Int`. As a result, `MkT` doesn't really *use* the last type+variable. Therefore, T's `Rep` instance would use Rec0 to represent MkT's+field. But we must be careful not to produce code like this:     instance Generic1 T where-     type Rep1 T = ... (Rec0 (FakeOut a))+     type Rep1 T = Rec0 (FakeOut a)      ... -Oh no! Now we have `a` on the RHS, but it's completely unbound. Instead, we-ensure that `a` is mapped to Any:+Oh no! Now we have `a` on the RHS, but it's completely unbound. This can cause+issues like what was observed in #15012. To avoid this, we ensure that `a` is+instantiated to Any:     instance Generic1 T where-     type Rep1 T = ... (Rec0 (FakeOut Any))+     type Rep1 T = Rec0 (FakeOut Any)      ...  And now all is good.
compiler/GHC/Tc/Deriv/Infer.hs view
@@ -4,7 +4,7 @@  -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE MultiWayIf #-}  -- | Functions for inferring (and simplifying) the context for derived instances.@@ -14,8 +14,6 @@    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Data.Bag@@ -23,9 +21,9 @@ import GHC.Core.Class import GHC.Core.DataCon import GHC.Utils.Error-import GHC.Tc.Utils.Instantiate import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Data.Pair import GHC.Builtin.Names import GHC.Tc.Deriv.Utils@@ -43,8 +41,9 @@ import GHC.Core.TyCo.Ppr (pprTyVars) import GHC.Core.Type import GHC.Tc.Solver+import GHC.Tc.Solver.Monad ( runTcS ) import GHC.Tc.Validity (validDerivPred)-import GHC.Tc.Utils.Unify (buildImplicationFor, checkConstraints)+import GHC.Tc.Utils.Unify (buildImplicationFor) import GHC.Builtin.Types (typeToTypeKind) import GHC.Core.Unify (tcUnifyTy) import GHC.Utils.Misc@@ -60,7 +59,7 @@ ----------------------  inferConstraints :: DerivSpecMechanism-                 -> DerivM ([ThetaOrigin], [TyVar], [TcType])+                 -> DerivM (ThetaSpec, [TyVar], [TcType], DerivSpecMechanism) -- inferConstraints figures out the constraints needed for the -- instance declaration generated by a 'deriving' clause on a -- data type declaration. It also returns the new in-scope type@@ -81,11 +80,13 @@                   , denv_cls      = main_cls                   , denv_inst_tys = inst_tys } <- ask        ; wildcard <- isStandaloneWildcardDeriv-       ; let infer_constraints :: DerivM ([ThetaOrigin], [TyVar], [TcType])+       ; let infer_constraints :: DerivM (ThetaSpec, [TyVar], [TcType], DerivSpecMechanism)              infer_constraints =                case mechanism of                  DerivSpecStock{dsm_stock_dit = dit}-                   -> inferConstraintsStock dit+                   -> do (thetas, tvs, inst_tys, dit') <- inferConstraintsStock dit+                         pure ( thetas, tvs, inst_tys+                              , mechanism{dsm_stock_dit = dit'} )                  DerivSpecAnyClass                    -> infer_constraints_simple inferConstraintsAnyclass                  DerivSpecNewtype { dsm_newtype_dit =@@ -104,30 +105,31 @@              -- this rule is stock deriving. See              -- Note [Inferring the instance context].              infer_constraints_simple-               :: DerivM [ThetaOrigin]-               -> DerivM ([ThetaOrigin], [TyVar], [TcType])+               :: DerivM ThetaSpec+               -> DerivM (ThetaSpec, [TyVar], [TcType], DerivSpecMechanism)              infer_constraints_simple infer_thetas = do                thetas <- infer_thetas-               pure (thetas, tvs, inst_tys)+               pure (thetas, tvs, inst_tys, mechanism)               -- Constraints arising from superclasses              -- See Note [Superclasses of derived instance]              cls_tvs  = classTyVars main_cls-             sc_constraints = ASSERT2( equalLength cls_tvs inst_tys-                                     , ppr main_cls <+> ppr inst_tys )-                              [ mkThetaOrigin (mkDerivOrigin wildcard)-                                              TypeLevel [] [] [] $-                                substTheta cls_subst (classSCTheta main_cls) ]-             cls_subst = ASSERT( equalLength cls_tvs inst_tys )+             sc_constraints = assertPpr (equalLength cls_tvs inst_tys)+                                        (ppr main_cls <+> ppr inst_tys) $+                              mkDirectThetaSpec+                                (mkDerivOrigin wildcard) TypeLevel+                                (substTheta cls_subst (classSCTheta main_cls))+             cls_subst = assert (equalLength cls_tvs inst_tys) $                          zipTvSubst cls_tvs inst_tys -       ; (inferred_constraints, tvs', inst_tys') <- infer_constraints+       ; (inferred_constraints, tvs', inst_tys', mechanism')+           <- infer_constraints        ; lift $ traceTc "inferConstraints" $ vcat               [ ppr main_cls <+> ppr inst_tys'               , ppr inferred_constraints               ]        ; return ( sc_constraints ++ inferred_constraints-                , tvs', inst_tys' ) }+                , tvs', inst_tys', mechanism' ) }  -- | Like 'inferConstraints', but used only in the case of the @stock@ deriving -- strategy. The constraints are inferred by inspecting the fields of each data@@ -135,7 +137,7 @@ -- -- > data Foo = MkFoo Int Char deriving Show ----- We would infer the following constraints ('ThetaOrigin's):+-- We would infer the following constraints ('ThetaSpec's): -- -- > (Show Int, Show Char) --@@ -153,12 +155,12 @@ -- 'TyVar's/'TcType's, /not/ @[k]@/@[k, f, g]@. -- See Note [Inferring the instance context]. inferConstraintsStock :: DerivInstTys-                      -> DerivM ([ThetaOrigin], [TyVar], [TcType])-inferConstraintsStock (DerivInstTys { dit_cls_tys     = cls_tys-                                    , dit_tc          = tc-                                    , dit_tc_args     = tc_args-                                    , dit_rep_tc      = rep_tc-                                    , dit_rep_tc_args = rep_tc_args })+                      -> DerivM (ThetaSpec, [TyVar], [TcType], DerivInstTys)+inferConstraintsStock dit@(DerivInstTys { dit_cls_tys     = cls_tys+                                        , dit_tc          = tc+                                        , dit_tc_args     = tc_args+                                        , dit_rep_tc      = rep_tc+                                        , dit_rep_tc_args = rep_tc_args })   = do DerivEnv { denv_tvs      = tvs                 , denv_cls      = main_cls                 , denv_inst_tys = inst_tys } <- ask@@ -176,22 +178,36 @@            con_arg_constraints              :: (CtOrigin -> TypeOrKind                           -> Type-                          -> [([PredOrigin], Maybe TCvSubst)])-             -> ([ThetaOrigin], [TyVar], [TcType])+                          -> [(ThetaSpec, Maybe TCvSubst)])+             -> (ThetaSpec, [TyVar], [TcType], DerivInstTys)            con_arg_constraints get_arg_constraints-             = let (predss, mbSubsts) = unzip+             = let -- Constraints from the fields of each data constructor.+                   (predss, mbSubsts) = unzip                      [ preds_and_mbSubst                      | data_con <- tyConDataCons rep_tc                      , (arg_n, arg_t_or_k, arg_ty)                          <- zip3 [1..] t_or_ks $-                            dataConInstOrigArgTys data_con all_rep_tc_args+                            derivDataConInstArgTys data_con dit                        -- No constraints for unlifted types                        -- See Note [Deriving and unboxed types]-                     , not (isUnliftedType (irrelevantMult arg_ty))+                     , not (isUnliftedType arg_ty)                      , let orig = DerivOriginDC data_con arg_n wildcard                      , preds_and_mbSubst-                         <- get_arg_constraints orig arg_t_or_k (irrelevantMult arg_ty)+                         <- get_arg_constraints orig arg_t_or_k arg_ty                      ]+                   -- Stupid constraints from DatatypeContexts. Note that we+                   -- must gather these constraints from the data constructors,+                   -- not from the parent type constructor, as the latter could+                   -- lead to redundant constraints due to thinning.+                   -- See Note [The stupid context] in GHC.Core.DataCon.+                   stupid_theta =+                     [ substTyWith (dataConUnivTyVars data_con)+                                   (dataConInstUnivs data_con rep_tc_args)+                                   stupid_pred+                     | data_con <- tyConDataCons rep_tc+                     , stupid_pred <- dataConStupidTheta data_con+                     ]+                    preds = concat predss                    -- If the constraints require a subtype to be of kind                    -- (* -> *) (which is the case for functor-like@@ -203,10 +219,15 @@                    unmapped_tvs = filter (\v -> v `notElemTCvSubst` subst                                              && not (v `isInScope` subst)) tvs                    (subst', _)  = substTyVarBndrs subst unmapped_tvs-                   preds'       = map (substPredOrigin subst') preds+                   stupid_theta_origin = mkDirectThetaSpec+                                           deriv_origin TypeLevel+                                           (substTheta subst' stupid_theta)+                   preds'       = map (substPredSpec subst') preds                    inst_tys'    = substTys subst' inst_tys+                   dit'         = substDerivInstTys subst' dit                    tvs'         = tyCoVarsOfTypesWellScoped inst_tys'-               in ([mkThetaOriginFromPreds preds'], tvs', inst_tys')+               in ( stupid_theta_origin ++ preds'+                  , tvs', inst_tys', dit' )             is_generic  = main_cls `hasKey` genClassKey            is_generic1 = main_cls `hasKey` gen1ClassKey@@ -215,13 +236,13 @@                           || is_generic1             get_gen1_constraints :: Class -> CtOrigin -> TypeOrKind -> Type-                                -> [([PredOrigin], Maybe TCvSubst)]+                                -> [(ThetaSpec, Maybe TCvSubst)]            get_gen1_constraints functor_cls orig t_or_k ty               = mk_functor_like_constraints orig t_or_k functor_cls $                 get_gen1_constrained_tys last_tv ty             get_std_constrained_tys :: CtOrigin -> TypeOrKind -> Type-                                   -> [([PredOrigin], Maybe TCvSubst)]+                                   -> [(ThetaSpec, Maybe TCvSubst)]            get_std_constrained_tys orig t_or_k ty                | is_functor_like                = mk_functor_like_constraints orig t_or_k main_cls $@@ -232,7 +253,7 @@             mk_functor_like_constraints :: CtOrigin -> TypeOrKind                                        -> Class -> [Type]-                                       -> [([PredOrigin], Maybe TCvSubst)]+                                       -> [(ThetaSpec, Maybe TCvSubst)]            -- 'cls' is usually main_cls (Functor or Traversable etc), but if            -- main_cls = Generic1, then 'cls' can be Functor; see            -- get_gen1_constraints@@ -247,31 +268,18 @@            mk_functor_like_constraints orig t_or_k cls               = map $ \ty -> let ki = tcTypeKind ty in                              ( [ mk_cls_pred orig t_or_k cls ty-                               , mkPredOrigin orig KindLevel-                                   (mkPrimEqPred ki typeToTypeKind) ]+                               , SimplePredSpec+                                   { sps_pred = mkPrimEqPred ki typeToTypeKind+                                   , sps_origin = orig+                                   , sps_type_or_kind = KindLevel+                                   }+                               ]                              , tcUnifyTy ki typeToTypeKind                              )             rep_tc_tvs      = tyConTyVars rep_tc            last_tv         = last rep_tc_tvs-           -- When we first gather up the constraints to solve, most of them-           -- contain rep_tc_tvs, i.e., the type variables from the derived-           -- datatype's type constructor. We don't want these type variables-           -- to appear in the final instance declaration, so we must-           -- substitute each type variable with its counterpart in the derived-           -- instance. rep_tc_args lists each of these counterpart types in-           -- the same order as the type variables.-           all_rep_tc_args = tyConInstArgTys rep_tc rep_tc_args -               -- Stupid constraints-           stupid_constraints-             = [ mkThetaOrigin deriv_origin TypeLevel [] [] [] $-                 substTheta tc_subst (tyConStupidTheta rep_tc) ]-           tc_subst = -- See the comment with all_rep_tc_args for an-                      -- explanation of this assertion-                      ASSERT( equalLength rep_tc_tvs all_rep_tc_args )-                      zipTvSubst rep_tc_tvs all_rep_tc_args-            -- Extra Data constraints            -- The Data class (only) requires that for            --    instance (...) => Data (T t1 t2)@@ -280,9 +288,7 @@            -- Reason: when the IF holds, we generate a method            --             dataCast2 f = gcast2 f            --         and we need the Data constraints to typecheck the method-           extra_constraints = [mkThetaOriginFromPreds constrs]-             where-               constrs+           extra_constraints                  | main_cls `hasKey` dataClassKey                  , all (isLiftedTypeKind . tcTypeKind) rep_tc_args                  = [ mk_cls_pred deriv_origin t_or_k main_cls ty@@ -292,7 +298,11 @@             mk_cls_pred orig t_or_k cls ty                 -- Don't forget to apply to cls_tys' too-              = mkPredOrigin orig t_or_k (mkClassPred cls (cls_tys' ++ [ty]))+              = SimplePredSpec+                  { sps_pred = mkClassPred cls (cls_tys' ++ [ty])+                  , sps_origin = orig+                  , sps_type_or_kind = t_or_k+                  }            cls_tys' | is_generic1 = []                       -- In the awkward Generic1 case, cls_tys' should be                       -- empty, since we are applying the class Functor.@@ -303,34 +313,28 @@         if    -- Generic constraints are easy           |  is_generic-           -> return ([], tvs, inst_tys)+           -> return ([], tvs, inst_tys, dit)               -- Generic1 needs Functor              -- See Note [Getting base classes]           |  is_generic1-           -> ASSERT( rep_tc_tvs `lengthExceeds` 0 )+           -> assert (rep_tc_tvs `lengthExceeds` 0) $               -- Generic1 has a single kind variable-              ASSERT( cls_tys `lengthIs` 1 )+              assert (cls_tys `lengthIs` 1) $               do { functorClass <- lift $ tcLookupClass functorClassName                  ; pure $ con_arg_constraints                         $ get_gen1_constraints functorClass }               -- The others are a bit more complicated           |  otherwise-           -> -- See the comment with all_rep_tc_args for an explanation of-              -- this assertion-              ASSERT2( equalLength rep_tc_tvs all_rep_tc_args-                     , ppr main_cls <+> ppr rep_tc-                       $$ ppr rep_tc_tvs $$ ppr all_rep_tc_args )-                do { let (arg_constraints, tvs', inst_tys')-                           = con_arg_constraints get_std_constrained_tys-                   ; lift $ traceTc "inferConstraintsStock" $ vcat-                          [ ppr main_cls <+> ppr inst_tys'-                          , ppr arg_constraints-                          ]-                   ; return ( stupid_constraints ++ extra_constraints-                                                 ++ arg_constraints-                            , tvs', inst_tys') }+           -> do { let (arg_constraints, tvs', inst_tys', dit')+                         = con_arg_constraints get_std_constrained_tys+                 ; lift $ traceTc "inferConstraintsStock" $ vcat+                        [ ppr main_cls <+> ppr inst_tys'+                        , ppr arg_constraints+                        ]+                 ; return ( extra_constraints ++ arg_constraints+                          , tvs', inst_tys', dit' ) }  -- | Like 'inferConstraints', but used only in the case of @DeriveAnyClass@, -- which gathers its constraints based on the type signatures of the class's@@ -339,36 +343,32 @@ -- See Note [Gathering and simplifying constraints for DeriveAnyClass] -- for an explanation of how these constraints are used to determine the -- derived instance context.-inferConstraintsAnyclass :: DerivM [ThetaOrigin]+inferConstraintsAnyclass :: DerivM ThetaSpec inferConstraintsAnyclass-  = do { DerivEnv { denv_cls      = cls-                  , denv_inst_tys = inst_tys } <- ask-       ; wildcard <- isStandaloneWildcardDeriv-+  = do { DerivEnv { denv_cls       = cls+                  , denv_inst_tys  = inst_tys } <- ask        ; let gen_dms = [ (sel_id, dm_ty)                        | (sel_id, Just (_, GenericDM dm_ty)) <- classOpItems cls ]--             cls_tvs = classTyVars cls+       ; wildcard <- isStandaloneWildcardDeriv -             do_one_meth :: (Id, Type) -> TcM ThetaOrigin+       ; let meth_pred :: (Id, Type) -> PredSpec                -- (Id,Type) are the selector Id and the generic default method type                -- NB: the latter is /not/ quantified over the class variables                -- See Note [Gathering and simplifying constraints for DeriveAnyClass]-             do_one_meth (sel_id, gen_dm_ty)-               = do { let (sel_tvs, _cls_pred, meth_ty)-                                   = tcSplitMethodTy (varType sel_id)-                          meth_ty' = substTyWith sel_tvs inst_tys meth_ty-                          (meth_tvs, meth_theta, meth_tau)-                                   = tcSplitNestedSigmaTys meth_ty'--                          gen_dm_ty' = substTyWith cls_tvs inst_tys gen_dm_ty-                          (dm_tvs, dm_theta, dm_tau)-                                     = tcSplitNestedSigmaTys gen_dm_ty'-                          tau_eq     = mkPrimEqPred meth_tau dm_tau-                    ; return (mkThetaOrigin (mkDerivOrigin wildcard) TypeLevel-                                meth_tvs dm_tvs meth_theta (tau_eq:dm_theta)) }+             meth_pred (sel_id, gen_dm_ty)+               = let (sel_tvs, _cls_pred, meth_ty) = tcSplitMethodTy (varType sel_id)+                     meth_ty'   = substTyWith sel_tvs inst_tys meth_ty+                     gen_dm_ty' = substTyWith sel_tvs inst_tys gen_dm_ty in+                 -- This is the only place where a SubTypePredSpec is+                 -- constructed instead of a SimplePredSpec. See+                 -- Note [Gathering and simplifying constraints for DeriveAnyClass]+                 -- for a more in-depth explanation.+                 SubTypePredSpec { stps_ty_actual = gen_dm_ty'+                                 , stps_ty_expected = meth_ty'+                                 , stps_origin = mkDerivOrigin wildcard+                                 } -       ; lift $ mapM do_one_meth gen_dms }+       ; pure $ map meth_pred gen_dms }  -- Like 'inferConstraints', but used only for @GeneralizedNewtypeDeriving@ and -- @DerivingVia@. Since both strategies generate code involving 'coerce', the@@ -377,11 +377,11 @@ -- -- > newtype Age = MkAge Int deriving newtype Num ----- We would infer the following constraints ('ThetaOrigin's):+-- We would infer the following constraints ('ThetaSpec'): -- -- > (Num Int, Coercible Age Int) inferConstraintsCoerceBased :: [Type] -> Type-                            -> DerivM [ThetaOrigin]+                            -> DerivM ThetaSpec inferConstraintsCoerceBased cls_tys rep_ty = do   DerivEnv { denv_tvs      = tvs            , denv_cls      = cls@@ -393,7 +393,10 @@       -- (for DerivingVia).       rep_tys ty  = cls_tys ++ [ty]       rep_pred ty = mkClassPred cls (rep_tys ty)-      rep_pred_o ty = mkPredOrigin deriv_origin TypeLevel (rep_pred ty)+      rep_pred_o ty = SimplePredSpec { sps_pred = rep_pred ty+                                     , sps_origin = deriv_origin+                                     , sps_type_or_kind = TypeLevel+                                     }               -- rep_pred is the representation dictionary, from where               -- we are going to get all the methods for the final               -- dictionary@@ -403,23 +406,23 @@       -- If there are no methods, we don't need any constraints       -- Otherwise we need (C rep_ty), for the representation methods,       -- and constraints to coerce each individual method-      meth_preds :: Type -> [PredOrigin]+      meth_preds :: Type -> ThetaSpec       meth_preds ty         | null meths = [] -- No methods => no constraints                           -- (#12814)         | otherwise = rep_pred_o ty : coercible_constraints ty       meths = classMethods cls       coercible_constraints ty-        = [ mkPredOrigin (DerivOriginCoerce meth t1 t2 sa_wildcard)-                         TypeLevel (mkReprPrimEqPred t1 t2)+        = [ SimplePredSpec+              { sps_pred = mkReprPrimEqPred t1 t2+              , sps_origin = DerivOriginCoerce meth t1 t2 sa_wildcard+              , sps_type_or_kind = TypeLevel+              }           | meth <- meths           , let (Pair t1 t2) = mkCoerceClassMethEqn cls tvs                                        inst_tys ty meth ] -      all_thetas :: Type -> [ThetaOrigin]-      all_thetas ty = [mkThetaOriginFromPreds $ meth_preds ty]--  pure (all_thetas rep_ty)+  pure (meth_preds rep_ty)  {- Note [Inferring the instance context] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -633,7 +636,7 @@ -}  -simplifyInstanceContexts :: [DerivSpec [ThetaOrigin]]+simplifyInstanceContexts :: [DerivSpec ThetaSpec]                          -> TcM [DerivSpec ThetaType] -- Used only for deriving clauses or standalone deriving with an -- extra-constraints wildcard (InferContext)@@ -643,7 +646,10 @@  simplifyInstanceContexts infer_specs   = do  { traceTc "simplifyInstanceContexts" $ vcat (map pprDerivSpec infer_specs)-        ; iterate_deriv 1 initial_solutions }+        ; final_specs <- iterate_deriv 1 initial_solutions+          -- After simplification finishes, zonk the TcTyVars as described+          -- in Note [Overlap and deriving].+        ; traverse zonkDerivSpec final_specs }   where     ------------------------------------------------------------------         -- The initial solutions for the equations claim that each@@ -667,13 +673,14 @@       | otherwise       = do {      -- Extend the inst info from the explicit instance decls                   -- with the current set of solutions, and simplify each RHS-             inst_specs <- zipWithM newDerivClsInst current_solns infer_specs+             inst_specs <- zipWithM (\soln -> newDerivClsInst . setDerivSpecTheta soln)+                                    current_solns infer_specs            ; new_solns <- checkNoErrs $                           extendLocalInstEnv inst_specs $                           mapM gen_soln infer_specs             ; if (current_solns `eqSolution` new_solns) then-                return [ spec { ds_theta = soln }+                return [ setDerivSpecTheta soln spec                        | (spec, soln) <- zip infer_specs current_solns ]              else                 iterate_deriv (n+1) new_solns }@@ -683,12 +690,13 @@        -- See Note [Deterministic simplifyInstanceContexts]     canSolution = map (sortBy nonDetCmpType)     -------------------------------------------------------------------    gen_soln :: DerivSpec [ThetaOrigin] -> TcM ThetaType+    gen_soln :: DerivSpec ThetaSpec -> TcM ThetaType     gen_soln (DS { ds_loc = loc, ds_tvs = tyvars-                 , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs })+                 , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs+                 , ds_skol_info = skol_info, ds_user_ctxt = user_ctxt })       = setSrcSpan loc  $         addErrCtxt (derivInstCtxt the_pred) $-        do { theta <- simplifyDeriv the_pred tyvars deriv_rhs+        do { theta <- simplifyDeriv skol_info user_ctxt tyvars deriv_rhs                 -- checkValidInstance tyvars theta clas inst_tys                 -- Not necessary; see Note [Exotic derived instance contexts] @@ -714,87 +722,35 @@  -- | Given @instance (wanted) => C inst_ty@, simplify 'wanted' as much -- as possible. Fail if not possible.-simplifyDeriv :: PredType -- ^ @C inst_ty@, head of the instance we are-                          -- deriving.  Only used for SkolemInfo.-              -> [TyVar]  -- ^ The tyvars bound by @inst_ty@.-              -> [ThetaOrigin] -- ^ Given and wanted constraints+simplifyDeriv :: SkolemInfo -- ^ The 'SkolemInfo' used to skolemise the+                            -- 'TcTyVar' arguments+              -> UserTypeCtxt -- ^ Used to inform error messages as to whether+                              -- we are in a @deriving@ clause or a standalone+                              -- @deriving@ declaration+              -> [TcTyVar]  -- ^ The tyvars bound by @inst_ty@.+              -> ThetaSpec -- ^ The constraints to solve and simplify               -> TcM ThetaType -- ^ Needed constraints (after simplification),                                -- i.e. @['PredType']@.-simplifyDeriv pred tvs thetas-  = do { (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize-                -- The constraint solving machinery-                -- expects *TcTyVars* not TyVars.-                -- We use *non-overlappable* (vanilla) skolems-                -- See Note [Overlap and deriving]--       ; let skol_set  = mkVarSet tvs_skols-             skol_info = DerivSkol pred-             doc = text "deriving" <+> parens (ppr pred)--             mk_given_ev :: PredType -> TcM EvVar-             mk_given_ev given =-               let given_pred = substTy skol_subst given-               in newEvVar given_pred--             emit_wanted_constraints :: [TyVar] -> [PredOrigin] -> TcM ()-             emit_wanted_constraints metas_to_be preds-               = do { -- We instantiate metas_to_be with fresh meta type-                      -- variables. Currently, these can only be type variables-                      -- quantified in generic default type signatures.-                      -- See Note [Gathering and simplifying constraints for-                      -- DeriveAnyClass]-                      (meta_subst, _meta_tvs) <- newMetaTyVars metas_to_be--                    -- Now make a constraint for each of the instantiated predicates-                    ; let wanted_subst = skol_subst `unionTCvSubst` meta_subst-                          mk_wanted_ct (PredOrigin wanted orig t_or_k)-                            = do { ev <- newWanted orig (Just t_or_k) $-                                         substTyUnchecked wanted_subst wanted-                                 ; return (mkNonCanonical ev) }-                    ; cts <- mapM mk_wanted_ct preds--                    -- And emit them into the monad-                    ; emitSimples (listToCts cts) }--             -- Create the implications we need to solve. For stock and newtype-             -- deriving, these implication constraints will be simple class-             -- constraints like (C a, Ord b).-             -- But with DeriveAnyClass, we make an implication constraint.-             -- See Note [Gathering and simplifying constraints for DeriveAnyClass]-             mk_wanteds :: ThetaOrigin -> TcM WantedConstraints-             mk_wanteds (ThetaOrigin { to_anyclass_skols  = ac_skols-                                     , to_anyclass_metas  = ac_metas-                                     , to_anyclass_givens = ac_givens-                                     , to_wanted_origins  = preds })-               = do { ac_given_evs <- mapM mk_given_ev ac_givens-                    ; (_, wanteds)-                        <- captureConstraints $-                           checkConstraints skol_info ac_skols ac_given_evs $-                              -- The checkConstraints bumps the TcLevel, and-                              -- wraps the wanted constraints in an implication,-                              -- when (but only when) necessary-                           emit_wanted_constraints ac_metas preds-                    ; pure wanteds }+simplifyDeriv skol_info user_ctxt tvs theta+  = do { let skol_set = mkVarSet tvs         -- See [STEP DAC BUILD]        -- Generate the implication constraints, one for each method, to solve        -- with the skolemized variables.  Start "one level down" because-       -- we are going to wrap the result in an implication with tvs_skols,+       -- we are going to wrap the result in an implication with tvs,        -- in step [DAC RESIDUAL]-       ; (tc_lvl, wanteds) <- pushTcLevelM $-                              mapM mk_wanteds thetas+       ; (tc_lvl, wanteds) <- captureThetaSpecConstraints user_ctxt theta         ; traceTc "simplifyDeriv inputs" $-         vcat [ pprTyVars tvs $$ ppr thetas $$ ppr wanteds, doc ]+         vcat [ pprTyVars tvs $$ ppr theta $$ ppr wanteds, ppr skol_info ]         -- See [STEP DAC SOLVE]        -- Simplify the constraints, starting at the same level at which        -- they are generated (c.f. the call to runTcSWithEvBinds in        -- simplifyInfer)-       ; solved_wanteds <- setTcLevel tc_lvl   $-                           runTcSDeriveds      $-                           solveWantedsAndDrop $-                           unionsWC wanteds+       ; (solved_wanteds, _) <- setTcLevel tc_lvl $+                                runTcS            $+                                solveWanteds wanteds         -- It's not yet zonked!  Obviously zonk it before peering at it        ; solved_wanteds <- zonkWC solved_wanteds@@ -812,19 +768,13 @@              -- constitutes an exotic constraint.              get_good :: Ct -> Maybe PredType              get_good ct | validDerivPred skol_set p-                         , isWantedCt ct                          = Just p-                          -- TODO: This is wrong-                          -- NB re 'isWantedCt': residual_wanted may contain-                          -- unsolved CtDerived and we stick them into the-                          -- bad set so that reportUnsolved may decide what-                          -- to do with them                          | otherwise                          = Nothing-                           where p = ctPred ct+               where p = ctPred ct         ; traceTc "simplifyDeriv outputs" $-         vcat [ ppr tvs_skols, ppr residual_simple, ppr good ]+         vcat [ ppr tvs, ppr residual_simple, ppr good ]         -- Return the good unsolved constraints (unskolemizing on the way out.)        ; let min_theta = mkMinimalBySCs id (bagToList good)@@ -834,8 +784,6 @@              -- constraints.              -- See Note [Gathering and simplifying constraints for              --           DeriveAnyClass]-             subst_skol = zipTvSubst tvs_skols $ mkTyVarTys tvs-                          -- The reverse substitution (sigh)         -- See [STEP DAC RESIDUAL]        -- Ensure that min_theta is enough to solve /all/ the constraints in@@ -844,7 +792,7 @@        --    forall tvs. min_theta => solved_wanteds        ; min_theta_vars <- mapM newEvVar min_theta        ; (leftover_implic, _)-           <- buildImplicationFor tc_lvl skol_info tvs_skols+           <- buildImplicationFor tc_lvl (getSkolemInfo skol_info) tvs                                   min_theta_vars solved_wanteds        -- This call to simplifyTop is purely for error reporting        -- See Note [Error reporting for deriving clauses]@@ -852,7 +800,7 @@        -- in this line of code.        ; simplifyTopImplic leftover_implic -       ; return (substTheta subst_skol min_theta) }+       ; return min_theta }  {- Note [Overlap and deriving]@@ -876,10 +824,21 @@ and we want to infer    f :: Show [a] => a -> String -BOTTOM LINE: use vanilla, non-overlappable skolems when inferring-             the context for the derived instance.-             Hence tcInstSkolTyVars not tcInstSuperSkolTyVars+As a result, we use vanilla, non-overlappable skolems when inferring the+context for the derived instances. Hence, we instantiate the type variables+using tcInstSkolTyVars, not tcInstSuperSkolTyVars. +We do this skolemisation in GHC.Tc.Deriv.mkEqnHelp, a function which occurs+very early in the deriving pipeline, so that by the time GHC needs to infer the+instance context, all of the types in the computed DerivSpec have been+skolemised appropriately. After the instance context inference has completed,+GHC zonks the TcTyVars in the DerivSpec to ensure that types like+a[sk:1] do not appear in -ddump-deriv output.++All of this is only needed when inferring an instance context, i.e., the+InferContext case. For the SupplyContext case, we don't bother skolemising+at all.+ Note [Gathering and simplifying constraints for DeriveAnyClass] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ DeriveAnyClass works quite differently from stock and newtype deriving in@@ -909,7 +868,7 @@   $gdm_bar x y = show x ++ show (range (y,y))  (and similarly for baz).  Now consider a 'deriving' clause-  data Maybe s = ... deriving Foo+  data Maybe s = ... deriving anyclass Foo  This derives an instance of the form:   instance (CX) => Foo (Maybe s) where@@ -918,15 +877,35 @@  Now it is GHC's job to fill in a suitable instance context (CX).  If GHC were typechecking the binding-   bar = $gdm bar+   bar = $gdm_bar it would    * skolemise the expected type of bar    * instantiate the type of $gdm_bar with meta-type variables    * build an implication constraint  [STEP DAC BUILD]-So that's what we do.  We build the constraint (call it C1)+So that's what we do. Fortunately, there is already functionality within GHC+to that does all of the above—namely, tcSubTypeSigma. In the example above,+we want to use tcSubTypeSigma to check the following subtyping relation: +     forall c. (Show a, Ix c) => Maybe s -> c -> String -- actual type+  <= forall b.         (Ix b) => Maybe s -> b -> String -- expected type++That is, we check that the type of $gdm_bar (the actual type) is more+polymorphic than the type of bar (the expected type). We use SubTypePredSpec,+a special form of PredSpec that is only used by DeriveAnyClass, to store+the actual and expected types.++(Aside: having a separate SubTypePredSpec is not strictly necessary, as we+could theoretically construct this implication constraint by hand and store it+in a SimplePredSpec. In fact, GHC used to do this. However, this is easier+said than done, and there were numerous subtle bugs that resulted from getting+this step wrong, such as #20719. Ultimately, we decided that special-casing a+PredSpec specifically for DeriveAnyClass was worth it.)++tcSubTypeSigma will ultimately spit out an implication constraint, which will+look something like this (call it C1):+    forall[2] b. Ix b => (Show (Maybe s), Ix cc,                         Maybe s -> b -> String                             ~ Maybe s -> cc -> String)@@ -936,15 +915,32 @@   going to wrap it in a forall[1] in [STEP DAC RESIDUAL]  * The 'b' comes from the quantified type variable in the expected type-  of bar (i.e., 'to_anyclass_skols' in 'ThetaOrigin'). The 'cc' is a unification-  variable that comes from instantiating the quantified type variable 'c' in-  $gdm_bar's type (i.e., 'to_anyclass_metas' in 'ThetaOrigin).+  of bar. The 'cc' is a unification variable that comes from instantiating the+  quantified type variable 'c' in $gdm_bar's type. The finer details of+  skolemisation and metavariable instantiation are handled behind the scenes+  by tcSubTypeSigma. -* The (Ix b) constraint comes from the context of bar's type-  (i.e., 'to_wanted_givens' in 'ThetaOrigin'). The (Show (Maybe s)) and (Ix cc)-  constraints come from the context of $gdm_bar's type-  (i.e., 'to_anyclass_givens' in 'ThetaOrigin').+* It is important that `b` be distinct from `cc`. In this example, this is+  clearly the case, but it is not always so obvious when the type variables are+  hidden behind type synonyms. Suppose the example were written like this,+  for example: +    type Method a = forall b. Ix b => a -> b -> String+    class Foo a where+      bar :: Method a+      default bar :: Show a => Method a+      bar = ...++  Both method signatures quantify a `b` once the `Method` type synonym is+  expanded. To ensure that GHC doesn't confuse the two `b`s during+  typechecking, tcSubTypeSigma instantiates the `b` in the original signature+  with a fresh skolem and the `b` in the default signature with a fresh+  unification variable. Doing so prevents #20719 from happening.++* The (Ix b) constraint comes from the context of bar's type. The+  (Show (Maybe s)) and (Ix cc) constraints come from the context of $gdm_bar's+  type.+ * The equality constraint (Maybe s -> b -> String) ~ (Maybe s -> cc -> String)   comes from marrying up the instantiated type of $gdm_bar with the specified   type of bar. Notice that the type variables from the instance, 's' in this@@ -955,7 +951,7 @@ unification variable across multiple iterations, then bad things can happen, such as #14933. -Similarly for 'baz', giving the constraint C2+Similarly for 'baz', tcSubTypeSigma gives the constraint C2     forall[2]. Eq (Maybe s) => (Ord a, Show a,                               Maybe s -> Maybe s -> Bool
compiler/GHC/Tc/Deriv/Utils.hs view
@@ -4,20 +4,22 @@  -} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TypeFamilies #-}  -- | Error-checking and other utilities for @deriving@ clauses or declarations. module GHC.Tc.Deriv.Utils (         DerivM, DerivEnv(..),-        DerivSpec(..), pprDerivSpec, DerivInstTys(..),+        DerivSpec(..), pprDerivSpec, setDerivSpecTheta, zonkDerivSpec,         DerivSpecMechanism(..), derivSpecMechanismToStrategy, isDerivSpecStock,-        isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecVia,-        DerivContext(..), OriginativeDerivStatus(..),-        isStandaloneDeriv, isStandaloneWildcardDeriv, mkDerivOrigin,-        PredOrigin(..), ThetaOrigin(..), mkPredOrigin,-        mkThetaOrigin, mkThetaOriginFromPreds, substPredOrigin,+        isDerivSpecNewtype, isDerivSpecAnyClass,+        isDerivSpecVia, zonkDerivSpecMechanism,+        DerivContext(..), OriginativeDerivStatus(..), StockGenFns(..),+        isStandaloneDeriv, isStandaloneWildcardDeriv,+        askDerivUserTypeCtxt, mkDerivOrigin,+        PredSpec(..), ThetaSpec,+        mkDirectThetaSpec, substPredSpec, captureThetaSpecConstraints,         checkOriginativeSideConditions, hasStockDeriving,-        canDeriveAnyClass,         std_class_via_coercible, non_coercible_class,         newDerivClsInst, extendLocalInstEnv     ) where@@ -28,6 +30,7 @@ import GHC.Types.Basic import GHC.Core.Class import GHC.Core.DataCon+import GHC.Core.FamInstEnv import GHC.Driver.Session import GHC.Utils.Error import GHC.Types.Fixity.Env (lookupFixity)@@ -45,18 +48,21 @@ import GHC.Tc.Deriv.Generate import GHC.Tc.Deriv.Functor import GHC.Tc.Deriv.Generics+import GHC.Tc.Errors.Types+import GHC.Tc.Types.Constraint (WantedConstraints, mkNonCanonical) import GHC.Tc.Types.Origin import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType+import GHC.Tc.Utils.Unify (tcSubTypeSigma)+import GHC.Tc.Utils.Zonk import GHC.Builtin.Names.TH (liftClassKey) import GHC.Core.TyCon-import GHC.Core.Multiplicity-import GHC.Core.TyCo.Ppr (pprSourceTyCon) import GHC.Core.Type import GHC.Utils.Misc import GHC.Types.Var.Set  import Control.Monad.Trans.Reader+import Data.Foldable (traverse_) import Data.Maybe import qualified GHC.LanguageExtensions as LangExt import GHC.Data.List.SetOps (assocMaybe)@@ -84,6 +90,16 @@     go (InferContext wildcard) = isJust wildcard     go (SupplyContext {})      = False +-- | Return 'InstDeclCtxt' if processing with a standalone @deriving@+-- declaration or 'DerivClauseCtxt' if processing a @deriving@ clause.+askDerivUserTypeCtxt :: DerivM UserTypeCtxt+askDerivUserTypeCtxt = asks (go . denv_ctxt)+  where+    go :: DerivContext -> UserTypeCtxt+    go (SupplyContext {})     = InstDeclCtxt True+    go (InferContext Just{})  = InstDeclCtxt True+    go (InferContext Nothing) = DerivClauseCtxt+ -- | @'mkDerivOrigin' wc@ returns 'StandAloneDerivOrigin' if @wc@ is 'True', -- and 'DerivClauseOrigin' if @wc@ is 'False'. Useful for error-reporting. mkDerivOrigin :: Bool -> CtOrigin@@ -98,7 +114,13 @@   { denv_overlap_mode :: Maybe OverlapMode     -- ^ Is this an overlapping instance?   , denv_tvs          :: [TyVar]-    -- ^ Universally quantified type variables in the instance+    -- ^ Universally quantified type variables in the instance. If the+    --   @denv_ctxt@ is 'InferContext', these will be 'TcTyVar' skolems.+    --   If the @denv_ctxt@ is 'SupplyContext', these will be ordinary 'TyVar's.+    --   See @Note [Overlap and deriving]@ in "GHC.Tc.Deriv.Infer".+    --+    --   All type variables that appear in the 'denv_inst_tys', 'denv_ctxt',+    --   'denv_skol_info', and 'denv_strat' should come from 'denv_tvs'.   , denv_cls          :: Class     -- ^ Class for which we need to derive an instance   , denv_inst_tys     :: [Type]@@ -109,6 +131,9 @@     --   'InferContext' for @deriving@ clauses, or for standalone deriving that     --   uses a wildcard constraint.     --   See @Note [Inferring the instance context]@.+  , denv_skol_info    :: SkolemInfo+    -- ^ The 'SkolemInfo' used to skolemise the @denv_tvs@ in the case where+    --   the 'denv_ctxt' is 'InferContext'.   , denv_strat        :: Maybe (DerivStrategy GhcTc)     -- ^ 'Just' if user requests a particular deriving strategy.     --   Otherwise, 'Nothing'.@@ -120,6 +145,7 @@                 , denv_cls          = cls                 , denv_inst_tys     = inst_tys                 , denv_ctxt         = ctxt+                , denv_skol_info    = skol_info                 , denv_strat        = mb_strat })     = hang (text "DerivEnv")          2 (vcat [ text "denv_overlap_mode" <+> ppr overlap_mode@@ -127,6 +153,7 @@                  , text "denv_cls"          <+> ppr cls                  , text "denv_inst_tys"     <+> ppr inst_tys                  , text "denv_ctxt"         <+> ppr ctxt+                 , text "denv_skol_info"    <+> ppr skol_info                  , text "denv_strat"        <+> ppr mb_strat ])  data DerivSpec theta = DS { ds_loc                 :: SrcSpan@@ -135,6 +162,8 @@                           , ds_theta               :: theta                           , ds_cls                 :: Class                           , ds_tys                 :: [Type]+                          , ds_skol_info           :: SkolemInfo+                          , ds_user_ctxt           :: UserTypeCtxt                           , ds_overlap             :: Maybe OverlapMode                           , ds_standalone_wildcard :: Maybe SrcSpan                               -- See Note [Inferring the instance context]@@ -143,11 +172,20 @@         -- This spec implies a dfun declaration of the form         --       df :: forall tvs. theta => C tys         -- The Name is the name for the DFun we'll build-        -- The tyvars bind all the variables in the theta+        -- The tyvars bind all the variables in the rest of the DerivSpec.+        -- If we are inferring an instance context, the tyvars will be TcTyVar+        -- skolems. After the instance context inference is over, the tyvars+        -- will be zonked to TyVars. See+        -- Note [Overlap and deriving] in GHC.Tc.Deriv.Infer.          -- the theta is either the given and final theta, in standalone deriving,         -- or the not-yet-simplified list of constraints together with their origin +        -- The ds_skol_info is the SkolemInfo that was used to skolemise the+        -- TcTyVars (if we are inferring an instance context). The ds_user_ctxt+        -- is the UserTypeCtxt that allows error messages to know if we are in+        -- a deriving clause or a standalone deriving declaration.+         -- ds_mechanism specifies the means by which GHC derives the instance.         -- See Note [Deriving strategies] in GHC.Tc.Deriv @@ -165,7 +203,7 @@  pprDerivSpec :: Outputable theta => DerivSpec theta -> SDoc pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs, ds_cls = c,-                   ds_tys = tys, ds_theta = rhs,+                   ds_tys = tys, ds_theta = rhs, ds_skol_info = skol_info,                    ds_standalone_wildcard = wildcard, ds_mechanism = mech })   = hang (text "DerivSpec")        2 (vcat [ text "ds_loc                  =" <+> ppr l@@ -174,40 +212,34 @@                , text "ds_cls                  =" <+> ppr c                , text "ds_tys                  =" <+> ppr tys                , text "ds_theta                =" <+> ppr rhs+               , text "ds_skol_info            =" <+> ppr skol_info                , text "ds_standalone_wildcard  =" <+> ppr wildcard                , text "ds_mechanism            =" <+> ppr mech ])  instance Outputable theta => Outputable (DerivSpec theta) where   ppr = pprDerivSpec --- | Information about the arguments to the class in a stock- or--- newtype-derived instance.--- See @Note [DerivEnv and DerivSpecMechanism]@.-data DerivInstTys = DerivInstTys-  { dit_cls_tys     :: [Type]-    -- ^ Other arguments to the class except the last-  , dit_tc          :: TyCon-    -- ^ Type constructor for which the instance is requested-    --   (last arguments to the type class)-  , dit_tc_args     :: [Type]-    -- ^ Arguments to the type constructor-  , dit_rep_tc      :: TyCon-    -- ^ The representation tycon for 'dit_tc'-    --   (for data family instances). Otherwise the same as 'dit_tc'.-  , dit_rep_tc_args :: [Type]-    -- ^ The representation types for 'dit_tc_args'-    --   (for data family instances). Otherwise the same as 'dit_tc_args'.-  }+-- | Set the 'ds_theta' in a 'DerivSpec'.+setDerivSpecTheta :: theta' -> DerivSpec theta -> DerivSpec theta'+setDerivSpecTheta theta ds = ds{ds_theta = theta} -instance Outputable DerivInstTys where-  ppr (DerivInstTys { dit_cls_tys = cls_tys, dit_tc = tc, dit_tc_args = tc_args-                    , dit_rep_tc = rep_tc, dit_rep_tc_args = rep_tc_args })-    = hang (text "DITTyConHead")-         2 (vcat [ text "dit_cls_tys"     <+> ppr cls_tys-                 , text "dit_tc"          <+> ppr tc-                 , text "dit_tc_args"     <+> ppr tc_args-                 , text "dit_rep_tc"      <+> ppr rep_tc-                 , text "dit_rep_tc_args" <+> ppr rep_tc_args ])+-- | Zonk the 'TcTyVar's in a 'DerivSpec' to 'TyVar's.+-- See @Note [What is zonking?]@ in "GHC.Tc.Utils.TcMType".+--+-- This is only used in the final zonking step when inferring+-- the context for a derived instance.+-- See @Note [Overlap and deriving]@ in "GHC.Tc.Deriv.Infer".+zonkDerivSpec :: DerivSpec ThetaType -> TcM (DerivSpec ThetaType)+zonkDerivSpec ds@(DS { ds_tvs = tvs, ds_theta = theta+                     , ds_tys = tys, ds_mechanism = mechanism+                     }) = do+  (ze, tvs') <- zonkTyBndrs tvs+  theta'     <- zonkTcTypesToTypesX ze theta+  tys'       <- zonkTcTypesToTypesX ze tys+  mechanism' <- zonkDerivSpecMechanism ze mechanism+  pure ds{ ds_tvs = tvs', ds_theta = theta'+         , ds_tys = tys', ds_mechanism = mechanism'+         }  -- | What action to take in order to derive a class instance. -- See @Note [DerivEnv and DerivSpecMechanism]@, as well as@@ -219,29 +251,9 @@       -- ^ Information about the arguments to the class in the derived       -- instance, including what type constructor the last argument is       -- headed by. See @Note [DerivEnv and DerivSpecMechanism]@.-    , dsm_stock_gen_fn ::-        SrcSpan -> TyCon  -- dit_rep_tc-                -> [Type] -- dit_rep_tc_args-                -> [Type] -- inst_tys-                -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name])-      -- ^ This function returns four things:-      ---      -- 1. @LHsBinds GhcPs@: The derived instance's function bindings-      --    (e.g., @compare (T x) (T y) = compare x y@)-      ---      -- 2. @[LSig GhcPs]@: A list of instance specific signatures/pragmas.-      --    Most likely INLINE pragmas for class methods.-      ---      -- 3. @BagDerivStuff@: Auxiliary bindings needed to support the derived-      --    instance. As examples, derived 'Generic' instances require-      --    associated type family instances, and derived 'Eq' and 'Ord'-      --    instances require top-level @con2tag@ functions.-      --    See @Note [Auxiliary binders]@ in "GHC.Tc.Deriv.Generate".-      ---      -- 4. @[Name]@: A list of Names for which @-Wunused-binds@ should be-      --    suppressed. This is used to suppress unused warnings for record-      --    selectors when deriving 'Read', 'Show', or 'Generic'.-      --    See @Note [Deriving and unused record selectors]@.+    , dsm_stock_gen_fns :: StockGenFns+      -- ^ How to generate the instance bindings and associated type family+      -- instances.     }      -- | @GeneralizedNewtypeDeriving@@@ -288,6 +300,44 @@ isDerivSpecVia (DerivSpecVia{}) = True isDerivSpecVia _                = False +-- | Zonk the 'TcTyVar's in a 'DerivSpecMechanism' to 'TyVar's.+-- See @Note [What is zonking?]@ in "GHC.Tc.Utils.TcMType".+--+-- This is only used in the final zonking step when inferring+-- the context for a derived instance.+-- See @Note [Overlap and deriving]@ in "GHC.Tc.Deriv.Infer".+zonkDerivSpecMechanism :: ZonkEnv -> DerivSpecMechanism -> TcM DerivSpecMechanism+zonkDerivSpecMechanism ze mechanism =+  case mechanism of+    DerivSpecStock { dsm_stock_dit     = dit+                   , dsm_stock_gen_fns = gen_fns+                   } -> do+      dit' <- zonkDerivInstTys ze dit+      pure $ DerivSpecStock { dsm_stock_dit     = dit'+                            , dsm_stock_gen_fns = gen_fns+                            }+    DerivSpecNewtype { dsm_newtype_dit    = dit+                     , dsm_newtype_rep_ty = rep_ty+                     } -> do+      dit'    <- zonkDerivInstTys ze dit+      rep_ty' <- zonkTcTypeToTypeX ze rep_ty+      pure $ DerivSpecNewtype { dsm_newtype_dit    = dit'+                              , dsm_newtype_rep_ty = rep_ty'+                              }+    DerivSpecAnyClass ->+      pure DerivSpecAnyClass+    DerivSpecVia { dsm_via_cls_tys = cls_tys+                 , dsm_via_inst_ty = inst_ty+                 , dsm_via_ty      = via_ty+                 } -> do+      cls_tys' <- zonkTcTypesToTypesX ze cls_tys+      inst_ty' <- zonkTcTypeToTypeX ze inst_ty+      via_ty'  <- zonkTcTypeToTypeX ze via_ty+      pure $ DerivSpecVia { dsm_via_cls_tys = cls_tys'+                          , dsm_via_inst_ty = inst_ty'+                          , dsm_via_ty      = via_ty'+                          }+ instance Outputable DerivSpecMechanism where   ppr (DerivSpecStock{dsm_stock_dit = dit})     = hang (text "DerivSpecStock")@@ -334,13 +384,16 @@    This extra structure is witnessed by the DerivInstTys data type, which stores   arg_1 through arg_(n-1) (dit_cls_tys), the algebraic type constructor-  (dit_tc), and its arguments (dit_tc_args). If dit_tc is an ordinary data type-  constructor, then dit_rep_tc/dit_rep_tc_args are the same as-  dit_tc/dit_tc_args. If dit_tc is a data family type constructor, then-  dit_rep_tc is the representation type constructor for the data family-  instance, and dit_rep_tc_args are the arguments to the representation type-  constructor in the corresponding instance.+  (dit_tc), and its arguments (dit_tc_args). A DerivInstTys value can be seen+  as a more structured representation of the denv_inst_tys field of DerivEnv. +  If dit_tc is an ordinary data type constructor, then+  dit_rep_tc/dit_rep_tc_args are the same as dit_tc/dit_tc_args. If dit_tc is a+  data family type constructor, then dit_rep_tc is the representation type+  constructor for the data family instance, and dit_rep_tc_args are the+  arguments to the representation type constructor in the corresponding+  instance.+ * newtype (DerivSpecNewtype):    Newtype deriving imposes the same DerivInstTys requirements as stock@@ -429,45 +482,102 @@ -- -- See @Note [Deriving strategies]@ in "GHC.Tc.Deriv". data OriginativeDerivStatus-  = CanDeriveStock            -- Stock class, can derive-      (SrcSpan -> TyCon -> [Type] -> [Type]-               -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name]))-  | StockClassError SDoc      -- Stock class, but can't do it+  = CanDeriveStock StockGenFns -- Stock class, can derive+  | StockClassError !DeriveInstanceErrReason -- Stock class, but can't do it   | CanDeriveAnyClass         -- See Note [Deriving any class]-  | NonDerivableClass SDoc    -- Cannot derive with either stock or anyclass+  | NonDerivableClass -- Cannot derive with either stock or anyclass +-- | Describes how to generate instance bindings ('stock_gen_binds') and+-- associated type family instances ('stock_gen_fam_insts') for a particular+-- stock-derived instance.+data StockGenFns = StockGenFns+  { stock_gen_binds ::+         SrcSpan -> DerivInstTys+      -> TcM (LHsBinds GhcPs, [LSig GhcPs], Bag AuxBindSpec, [Name])+    -- ^ Describes how to generate instance bindings for a stock-derived+    -- instance.+    --+    -- This function takes two arguments:+    --+    -- 1. 'SrcSpan': the source location where the instance is being derived.+    --    This will eventually be instantiated with the 'ds_loc' field of a+    --    'DerivSpec'.+    --+    -- 2. 'DerivInstTys': information about the argument types to which a+    --    class is applied in a derived instance. This will eventually be+    --    instantiated with the 'dsm_stock_dit' field of a+    --    'DerivSpecMechanism'.+    --+    -- This function returns four things:+    --+    -- 1. @'LHsBinds' 'GhcPs'@: The derived instance's function bindings+    --    (e.g., @compare (T x) (T y) = compare x y@)+    --+    -- 2. @['LSig' 'GhcPs']@: A list of instance specific signatures/pragmas.+    --    Most likely @INLINE@ pragmas for class methods.+    --+    -- 3. @'Bag' 'AuxBindSpec'@: Auxiliary bindings needed to support the+    --    derived instance. As examples, derived 'Eq' and 'Ord' instances+    --    sometimes require top-level @con2tag@ functions.+    --    See @Note [Auxiliary binders]@ in "GHC.Tc.Deriv.Generate".+    --+    -- 4. @['Name']@: A list of Names for which @-Wunused-binds@ should be+    --    suppressed. This is used to suppress unused warnings for record+    --    selectors when deriving 'Read', 'Show', or 'Generic'.+    --    See @Note [Deriving and unused record selectors]@.+  , stock_gen_fam_insts ::+         SrcSpan -> DerivInstTys+      -> TcM [FamInst]+    -- ^ Describes how to generate associated type family instances for a+    -- stock-derived instance. This function takes the same arguments as the+    -- 'stock_gen_binds' function but returns a list of 'FamInst's instead.+    -- Generating type family instances is done separately from+    -- 'stock_gen_binds' since the type family instances must be generated+    -- before the instance bindings can be typechecked. See+    -- @Note [Staging of tcDeriving]@ in "GHC.Tc.Deriv".+  }+ -- A stock class is one either defined in the Haskell report or for which GHC -- otherwise knows how to generate code for (possibly requiring the use of a -- language extension), such as Eq, Ord, Ix, Data, Generic, etc.) --- | A 'PredType' annotated with the origin of the constraint 'CtOrigin',--- and whether or the constraint deals in types or kinds.-data PredOrigin = PredOrigin PredType CtOrigin TypeOrKind+-- | A 'PredSpec' specifies a constraint to emitted when inferring the+-- instance context for a derived instance in 'GHC.Tc.Deriv.simplifyInfer'.+data PredSpec+  = -- | An ordinary 'PredSpec' that directly stores a 'PredType', which+    -- will be emitted as a wanted constraint in the constraint solving+    -- machinery. This is the simple case, as there are no skolems,+    -- metavariables, or given constraints involved.+    SimplePredSpec+      { sps_pred :: TcPredType+        -- ^ The constraint to emit as a wanted+      , sps_origin :: CtOrigin+        -- ^ The origin of the constraint+      , sps_type_or_kind :: TypeOrKind+        -- ^ Whether the constraint is a type or kind+      }+  | -- | A special 'PredSpec' that is only used by @DeriveAnyClass@. This+    -- will check if @stps_ty_actual@ is a subtype of (i.e., more polymorphic+    -- than) @stps_ty_expected@ in the constraint solving machinery, emitting an+    -- implication constraint as a side effect. For more details on how this+    -- works, see @Note [Gathering and simplifying constraints for DeriveAnyClass]@+    -- in "GHC.Tc.Deriv.Infer".+    SubTypePredSpec+      { stps_ty_actual :: TcSigmaType+        -- ^ The actual type. In the context of @DeriveAnyClass@, this is the+        -- default method type signature.+      , stps_ty_expected :: TcSigmaType+        -- ^ The expected type. In the context of @DeriveAnyClass@, this is the+        -- original method type signature.+      , stps_origin :: CtOrigin+        -- ^ The origin of the constraint+      } --- | A list of wanted 'PredOrigin' constraints ('to_wanted_origins') to--- simplify when inferring a derived instance's context. These are used in all--- deriving strategies, but in the particular case of @DeriveAnyClass@, we--- need extra information. In particular, we need:------ * 'to_anyclass_skols', the list of type variables bound by a class method's---   regular type signature, which should be rigid.------ * 'to_anyclass_metas', the list of type variables bound by a class method's---   default type signature. These can be unified as necessary.------ * 'to_anyclass_givens', the list of constraints from a class method's---   regular type signature, which can be used to help solve constraints---   in the 'to_wanted_origins'.------ (Note that 'to_wanted_origins' will likely contain type variables from the--- derived type class or data type, neither of which will appear in--- 'to_anyclass_skols' or 'to_anyclass_metas'.)------ For all other deriving strategies, it is always the case that--- 'to_anyclass_skols', 'to_anyclass_metas', and 'to_anyclass_givens' are--- empty.------ Here is an example to illustrate this:+-- | A list of 'PredSpec' constraints to simplify when inferring a+-- derived instance's context. For the @stock@, @newtype@, and @via@ deriving+-- strategies, these will consist of 'SimplePredSpec's, and for+-- @DeriveAnyClass@, these will consist of 'SubTypePredSpec's. Here is an+-- example to illustrate the latter: -- -- @ -- class Foo a where@@ -482,71 +592,120 @@ -- data Quux q = Quux deriving anyclass Foo -- @ ----- Then it would generate two 'ThetaOrigin's, one for each method:+-- Then it would generate two 'SubTypePredSpec's, one for each method: -- -- @--- [ ThetaOrigin { to_anyclass_skols  = [b]---               , to_anyclass_metas  = [y]---               , to_anyclass_givens = [Ix b]---               , to_wanted_origins  = [ Show (Quux q), Ix y---                                      , (Quux q -> b -> String) ~---                                        (Quux q -> y -> String)---                                      ] }--- , ThetaOrigin { to_anyclass_skols  = []---               , to_anyclass_metas  = []---               , to_anyclass_givens = [Eq (Quux q)]---               , to_wanted_origins  = [ Ord (Quux q)---                                      , (Quux q -> Quux q -> Bool) ~---                                        (Quux q -> Quux q -> Bool)---                                      ] }+-- [ SubTypePredSpec+--     { stps_ty_actual   = forall y. (Show (Quux q), Ix y) => Quux q -> y -> String+--     , stps_ty_expected = forall b.                (Ix b) => Quux q -> b -> String+--     , stps_ty_origin   = DerivClauseCtxt+--     }+-- , SubTypePredSpec+--     { stps_ty_actual   = Ord (Quux q) => Quux q -> Quux q -> Bool+--     , stps_ty_expected = Eq  (Quux q) => Quux q -> Quux q -> Bool+--     , stps_ty_origin   = DerivClauseCtxt+--     } -- ] -- @ -- -- (Note that the type variable @q@ is bound by the data type @Quux@, and thus--- it appears in neither 'to_anyclass_skols' nor 'to_anyclass_metas'.)+-- appears free in the 'stps_ty_actual's and 'stps_ty_expected's.) -- -- See @Note [Gathering and simplifying constraints for DeriveAnyClass]@--- in "GHC.Tc.Deriv.Infer" for an explanation of how 'to_wanted_origins' are--- determined in @DeriveAnyClass@, as well as how 'to_anyclass_skols',--- 'to_anyclass_metas', and 'to_anyclass_givens' are used.-data ThetaOrigin-  = ThetaOrigin { to_anyclass_skols  :: [TyVar]-                , to_anyclass_metas  :: [TyVar]-                , to_anyclass_givens :: ThetaType-                , to_wanted_origins  :: [PredOrigin] }+-- in "GHC.Tc.Deriv.Infer" for an explanation of how these 'SubTypePredSpec's+-- are used to compute implication constraints.+type ThetaSpec = [PredSpec] -instance Outputable PredOrigin where-  ppr (PredOrigin ty _ _) = ppr ty -- The origin is not so interesting when debugging+instance Outputable PredSpec where+  ppr (SimplePredSpec{sps_pred = ty}) =+    hang (text "SimplePredSpec")+       2 (vcat [ text "sps_pred" <+> ppr ty ])+  ppr (SubTypePredSpec { stps_ty_actual = ty_actual+                       , stps_ty_expected = ty_expected }) =+    hang (text "SubTypePredSpec")+       2 (vcat [ text "stps_ty_actual"   <+> ppr ty_actual+               , text "stps_ty_expected" <+> ppr ty_expected+               ]) -instance Outputable ThetaOrigin where-  ppr (ThetaOrigin { to_anyclass_skols  = ac_skols-                   , to_anyclass_metas  = ac_metas-                   , to_anyclass_givens = ac_givens-                   , to_wanted_origins  = wanted_origins })-    = hang (text "ThetaOrigin")-         2 (vcat [ text "to_anyclass_skols  =" <+> ppr ac_skols-                 , text "to_anyclass_metas  =" <+> ppr ac_metas-                 , text "to_anyclass_givens =" <+> ppr ac_givens-                 , text "to_wanted_origins  =" <+> ppr wanted_origins ])+-- | Build a list of 'SimplePredSpec's, using the supplied 'CtOrigin' and+-- 'TypeOrKind' values for each 'PredType'.+mkDirectThetaSpec :: CtOrigin -> TypeOrKind -> ThetaType -> ThetaSpec+mkDirectThetaSpec origin t_or_k =+  map (\p -> SimplePredSpec+               { sps_pred = p+               , sps_origin = origin+               , sps_type_or_kind = t_or_k+               }) -mkPredOrigin :: CtOrigin -> TypeOrKind -> PredType -> PredOrigin-mkPredOrigin origin t_or_k pred = PredOrigin pred origin t_or_k+substPredSpec :: HasCallStack => TCvSubst -> PredSpec -> PredSpec+substPredSpec subst ps =+  case ps of+    SimplePredSpec { sps_pred = pred+                   , sps_origin = origin+                   , sps_type_or_kind = t_or_k+                   }+      -> SimplePredSpec { sps_pred = substTy subst pred+                        , sps_origin = origin+                        , sps_type_or_kind = t_or_k+                        } -mkThetaOrigin :: CtOrigin -> TypeOrKind-              -> [TyVar] -> [TyVar] -> ThetaType -> ThetaType-              -> ThetaOrigin-mkThetaOrigin origin t_or_k skols metas givens-  = ThetaOrigin skols metas givens . map (mkPredOrigin origin t_or_k)+    SubTypePredSpec { stps_ty_actual = ty_actual+                    , stps_ty_expected = ty_expected+                    , stps_origin = origin+                    }+      -> SubTypePredSpec { stps_ty_actual = substTy subst ty_actual+                         , stps_ty_expected = substTy subst ty_expected+                         , stps_origin = origin+                         } --- A common case where the ThetaOrigin only contains wanted constraints, with--- no givens or locally scoped type variables.-mkThetaOriginFromPreds :: [PredOrigin] -> ThetaOrigin-mkThetaOriginFromPreds = ThetaOrigin [] [] []+-- | Capture wanted constraints from a 'ThetaSpec'.+captureThetaSpecConstraints ::+     UserTypeCtxt -- ^ Used to inform error messages as to whether+                  -- we are in a @deriving@ clause or a standalone+                  -- @deriving@ declaration+  -> ThetaSpec    -- ^ The specs from which constraints will be created+  -> TcM (TcLevel, WantedConstraints)+captureThetaSpecConstraints user_ctxt theta =+  pushTcLevelM $ mk_wanteds theta+  where+    -- Create the constraints we need to solve. For stock and newtype+    -- deriving, these constraints will be simple wanted constraints+    -- like (C a, Ord b).+    -- But with DeriveAnyClass, we make an implication constraint.+    -- See Note [Gathering and simplifying constraints for DeriveAnyClass]+    -- in GHC.Tc.Deriv.Infer.+    mk_wanteds :: ThetaSpec -> TcM WantedConstraints+    mk_wanteds preds+      = do { (_, wanteds) <- captureConstraints $+                             traverse_ emit_constraints preds+           ; pure wanteds } -substPredOrigin :: HasCallStack => TCvSubst -> PredOrigin -> PredOrigin-substPredOrigin subst (PredOrigin pred origin t_or_k)-  = PredOrigin (substTy subst pred) origin t_or_k+    -- Emit the appropriate constraints depending on what sort of+    -- PredSpec we are dealing with.+    emit_constraints :: PredSpec -> TcM ()+    emit_constraints ps =+      case ps of+        -- For constraints like (C a, Ord b), emit the+        -- constraints directly as simple wanted constraints.+        SimplePredSpec { sps_pred = wanted+                       , sps_origin = orig+                       , sps_type_or_kind = t_or_k+                       } -> do+          ev <- newWanted orig (Just t_or_k) wanted+          emitSimple (mkNonCanonical ev) +        -- For DeriveAnyClass, check if ty_actual is a subtype of+        -- ty_expected, which emits an implication constraint as a+        -- side effect. See+        -- Note [Gathering and simplifying constraints for DeriveAnyClass].+        -- in GHC.Tc.Deriv.Infer.+        SubTypePredSpec { stps_ty_actual   = ty_actual+                        , stps_ty_expected = ty_expected+                        , stps_origin      = orig+                        } -> do+          _ <- tcSubTypeSigma orig user_ctxt ty_actual ty_expected+          return ()+ {- ************************************************************************ *                                                                      *@@ -561,63 +720,70 @@ stock class to be able to be derived successfully.  A class might be able to be used in a deriving clause if -XDeriveAnyClass-is willing to support it. The canDeriveAnyClass function checks if this is the-case.+is willing to support it. -}  hasStockDeriving-  :: Class -> Maybe (SrcSpan-                     -> TyCon-                     -> [Type]-                     -> [Type]-                     -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name]))+  :: Class -> Maybe StockGenFns hasStockDeriving clas   = assocMaybe gen_list (getUnique clas)   where-    gen_list-      :: [(Unique, SrcSpan-                   -> TyCon-                   -> [Type]-                   -> [Type]-                   -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name]))]-    gen_list = [ (eqClassKey,          simpleM gen_Eq_binds)-               , (ordClassKey,         simpleM gen_Ord_binds)-               , (enumClassKey,        simpleM gen_Enum_binds)-               , (boundedClassKey,     simple gen_Bounded_binds)-               , (ixClassKey,          simpleM gen_Ix_binds)-               , (showClassKey,        read_or_show gen_Show_binds)-               , (readClassKey,        read_or_show gen_Read_binds)-               , (dataClassKey,        simpleM gen_Data_binds)-               , (functorClassKey,     simple gen_Functor_binds)-               , (foldableClassKey,    simple gen_Foldable_binds)-               , (traversableClassKey, simple gen_Traversable_binds)-               , (liftClassKey,        simple gen_Lift_binds)-               , (genClassKey,         generic (gen_Generic_binds Gen0))-               , (gen1ClassKey,        generic (gen_Generic_binds Gen1)) ]+    gen_list :: [(Unique, StockGenFns)]+    gen_list =+      [ (eqClassKey,          mk (simple_bindsM gen_Eq_binds) no_fam_insts)+      , (ordClassKey,         mk (simple_bindsM gen_Ord_binds) no_fam_insts)+      , (enumClassKey,        mk (simple_bindsM gen_Enum_binds) no_fam_insts)+      , (boundedClassKey,     mk (simple_binds gen_Bounded_binds) no_fam_insts)+      , (ixClassKey,          mk (simple_bindsM gen_Ix_binds) no_fam_insts)+      , (showClassKey,        mk (read_or_show_binds gen_Show_binds) no_fam_insts)+      , (readClassKey,        mk (read_or_show_binds gen_Read_binds) no_fam_insts)+      , (dataClassKey,        mk (simple_bindsM gen_Data_binds) no_fam_insts)+      , (functorClassKey,     mk (simple_binds gen_Functor_binds) no_fam_insts)+      , (foldableClassKey,    mk (simple_binds gen_Foldable_binds) no_fam_insts)+      , (traversableClassKey, mk (simple_binds gen_Traversable_binds) no_fam_insts)+      , (liftClassKey,        mk (simple_binds gen_Lift_binds) no_fam_insts)+      , (genClassKey,         mk (generic_binds Gen0) (generic_fam_inst Gen0))+      , (gen1ClassKey,        mk (generic_binds Gen1) (generic_fam_inst Gen1))+      ] -    simple gen_fn loc tc tc_args _-      = let (binds, deriv_stuff) = gen_fn loc tc tc_args-        in return (binds, [], deriv_stuff, [])+    mk gen_binds_fn gen_fam_insts_fn = StockGenFns+      { stock_gen_binds     = gen_binds_fn+      , stock_gen_fam_insts = gen_fam_insts_fn+      } +    simple_binds gen_fn loc dit+      = let (binds, aux_specs) = gen_fn loc dit+        in return (binds, [], aux_specs, [])+     -- Like `simple`, but monadic. The only monadic thing that these functions     -- do is allocate new Uniques, which are used for generating the names of     -- auxiliary bindings.     -- See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate.-    simpleM gen_fn loc tc tc_args _-      = do { (binds, deriv_stuff) <- gen_fn loc tc tc_args-           ; return (binds, [], deriv_stuff, []) }+    simple_bindsM gen_fn loc dit+      = do { (binds, aux_specs) <- gen_fn loc dit+           ; return (binds, [], aux_specs, []) } -    read_or_show gen_fn loc tc tc_args _-      = do { fix_env <- getDataConFixityFun tc-           ; let (binds, deriv_stuff) = gen_fn fix_env loc tc tc_args-                 field_names          = all_field_names tc-           ; return (binds, [], deriv_stuff, field_names) }+    read_or_show_binds gen_fn loc dit+      = do { let tc = dit_rep_tc dit+           ; fix_env <- getDataConFixityFun tc+           ; let (binds, aux_specs) = gen_fn fix_env loc dit+                 field_names        = all_field_names tc+           ; return (binds, [], aux_specs, field_names) } -    generic gen_fn _ tc _ inst_tys-      = do { (binds, sigs, faminst) <- gen_fn tc inst_tys+    generic_binds gk loc dit+      = do { let tc = dit_rep_tc dit+           ; (binds, sigs) <- gen_Generic_binds gk loc dit            ; let field_names = all_field_names tc-           ; return (binds, sigs, unitBag (DerivFamInst faminst), field_names) }+           ; return (binds, sigs, emptyBag, field_names) } +    generic_fam_inst gk loc dit+      = do { let tc = dit_rep_tc dit+           ; fix_env <- getDataConFixityFun tc+           ; faminst <- gen_Generic_fam_inst gk fix_env loc dit+           ; return [faminst] }++    no_fam_insts _ _ = pure []+     -- See Note [Deriving and unused record selectors]     all_field_names = map flSelector . concatMap dataConFieldLabels                                      . tyConDataCons@@ -648,7 +814,7 @@ Show, and Generic, as their derived code all depend on the record selectors of the derived data type's constructors. -See also Note [Newtype deriving and unused constructors] in GHC.Tc.Deriv for+See also Note [Unused constructors and deriving clauses] in GHC.Tc.Deriv for another example of a similar trick. -} @@ -656,7 +822,7 @@ -- If the TyCon is locally defined, we want the local fixity env; -- but if it is imported (which happens for standalone deriving) -- we need to get the fixity env from the interface file--- c.f. GHC.Rename.Env.lookupFixity, and #9830+-- c.f. GHC.Rename.Env.lookupFixity, #9830, and #20994 getDataConFixityFun tc   = do { this_mod <- getModule        ; if nameIsLocalOrFrom this_mod name@@ -681,36 +847,39 @@ -- the data constructors - but we need to be careful to fall back to the -- family tycon (with indexes) in error messages. -checkOriginativeSideConditions-  :: DynFlags -> DerivContext -> Class -> [TcType]-  -> TyCon -> TyCon-  -> OriginativeDerivStatus-checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys tc rep_tc-    -- First, check if stock deriving is possible...-  | Just cond <- stockSideConditions deriv_ctxt cls-  = case (cond dflags tc rep_tc) of-        NotValid err -> StockClassError err  -- Class-specific error-        IsValid  | null (filterOutInvisibleTypes (classTyCon cls) cls_tys)-                   -- All stock derivable classes are unary in the sense that-                   -- there should be not types in cls_tys (i.e., no type args-                   -- other than last). Note that cls_types can contain-                   -- invisible types as well (e.g., for Generic1, which is-                   -- poly-kinded), so make sure those are not counted.-                 , Just gen_fn <- hasStockDeriving cls-                   -> CanDeriveStock gen_fn-                 | otherwise -> StockClassError (classArgsErr cls cls_tys)-                   -- e.g. deriving( Eq s )+checkOriginativeSideConditions :: DerivInstTys -> DerivM OriginativeDerivStatus+checkOriginativeSideConditions dit@(DerivInstTys{dit_cls_tys = cls_tys}) =+  do DerivEnv { denv_cls  = cls+              , denv_ctxt = deriv_ctxt } <- ask+     dflags <- getDynFlags -    -- ...if not, try falling back on DeriveAnyClass.-  | NotValid err <- canDeriveAnyClass dflags-  = NonDerivableClass err  -- Neither anyclass nor stock work+     if    -- First, check if stock deriving is possible...+        |  Just cond <- stockSideConditions deriv_ctxt cls+        -> case cond dflags dit of+             NotValid err -> pure $ StockClassError err  -- Class-specific error+             IsValid  |  null (filterOutInvisibleTypes (classTyCon cls) cls_tys)+                         -- All stock derivable classes are unary in the sense that+                         -- there should be not types in cls_tys (i.e., no type args+                         -- other than last). Note that cls_types can contain+                         -- invisible types as well (e.g., for Generic1, which is+                         -- poly-kinded), so make sure those are not counted.+                      ,  Just gen_fn <- hasStockDeriving cls+                      -> pure $ CanDeriveStock gen_fn+                      |  otherwise+                      -> pure $ StockClassError $ classArgsErr cls cls_tys+                        -- e.g. deriving( Eq s ) -  | otherwise-  = CanDeriveAnyClass   -- DeriveAnyClass should work+           -- ...if not, try falling back on DeriveAnyClass.+        |  xopt LangExt.DeriveAnyClass dflags+        -> pure CanDeriveAnyClass   -- DeriveAnyClass should work -classArgsErr :: Class -> [Type] -> SDoc-classArgsErr cls cls_tys = quotes (ppr (mkClassPred cls cls_tys)) <+> text "is not a class"+        |  otherwise+        -> pure NonDerivableClass -- Neither anyclass nor stock work ++classArgsErr :: Class -> [Type] -> DeriveInstanceErrReason+classArgsErr cls cls_tys = DerivErrNotAClass (mkClassPred cls cls_tys)+ -- Side conditions (whether the datatype must have at least one constructor, -- required language extensions, etc.) for using GHC's stock deriving -- mechanism on certain classes (as opposed to classes that require@@ -756,39 +925,19 @@     cond_vanilla = cond_stdOK deriv_ctxt True       -- Vanilla data constructors but allow no data cons or polytype arguments -canDeriveAnyClass :: DynFlags -> Validity--- IsValid: we can (try to) derive it via an empty instance declaration--- NotValid s:  we can't, reason s-canDeriveAnyClass dflags-  | not (xopt LangExt.DeriveAnyClass dflags)-  = NotValid (text "Try enabling DeriveAnyClass")-  | otherwise-  = IsValid   -- OK!- type Condition    = DynFlags -  -> TyCon    -- ^ The data type's 'TyCon'. For data families, this is the-              -- family 'TyCon'.--  -> TyCon    -- ^ For data families, this is the representation 'TyCon'.-              -- Otherwise, this is the same as the other 'TyCon' argument.--  -> Validity -- ^ 'IsValid' if deriving an instance for this 'TyCon' is-              -- possible. Otherwise, it's @'NotValid' err@, where @err@-              -- explains what went wrong.+  -> DerivInstTys -- ^ Information about the type arguments to the class. -orCond :: Condition -> Condition -> Condition-orCond c1 c2 dflags tc rep_tc-  = case (c1 dflags tc rep_tc, c2 dflags tc rep_tc) of-     (IsValid,    _)          -> IsValid    -- c1 succeeds-     (_,          IsValid)    -> IsValid    -- c21 succeeds-     (NotValid x, NotValid y) -> NotValid (x $$ text "  or" $$ y)-                                            -- Both fail+  -> Validity' DeriveInstanceErrReason+     -- ^ 'IsValid' if deriving an instance for this type is+     -- possible. Otherwise, it's @'NotValid' err@, where @err@+     -- explains what went wrong.  andCond :: Condition -> Condition -> Condition-andCond c1 c2 dflags tc rep_tc-  = c1 dflags tc rep_tc `andValid` c2 dflags tc rep_tc+andCond c1 c2 dflags dit+  = c1 dflags dit `andValid` c2 dflags dit  -- | Some common validity checks shared among stock derivable classes. One -- check that absolutely must hold is that if an instance @C (T a)@ is being@@ -818,18 +967,18 @@                   -- the -XEmptyDataDeriving extension.    -> Condition-cond_stdOK deriv_ctxt permissive dflags tc rep_tc+cond_stdOK deriv_ctxt permissive dflags+           dit@(DerivInstTys{dit_tc = tc, dit_rep_tc = rep_tc})   = valid_ADT `andValid` valid_misc   where-    valid_ADT, valid_misc :: Validity+    valid_ADT, valid_misc :: Validity' DeriveInstanceErrReason     valid_ADT       | isAlgTyCon tc || isDataFamilyTyCon tc       = IsValid       | otherwise         -- Complain about functions, primitive types, and other tycons that         -- stock deriving can't handle.-      = NotValid $ text "The last argument of the instance must be a"-               <+> text "data or newtype application"+      = NotValid DerivErrLastArgMustBeApp      valid_misc       = case deriv_ctxt of@@ -840,68 +989,77 @@          InferContext wildcard            | null data_cons -- 1.            , not permissive-           -> checkFlag LangExt.EmptyDataDeriving dflags tc rep_tc `orValid`-              NotValid (no_cons_why rep_tc $$ empty_data_suggestion)+           , not (xopt LangExt.EmptyDataDeriving dflags)+           -> NotValid (no_cons_why rep_tc)            | not (null con_whys)-           -> NotValid (vcat con_whys $$ possible_fix_suggestion wildcard)+           -> NotValid $ DerivErrBadConstructor (Just $ has_wildcard wildcard) con_whys            | otherwise            -> IsValid -    empty_data_suggestion =-      text "Use EmptyDataDeriving to enable deriving for empty data types"-    possible_fix_suggestion wildcard+    has_wildcard wildcard       = case wildcard of-          Just _ ->-            text "Possible fix: fill in the wildcard constraint yourself"-          Nothing ->-            text "Possible fix: use a standalone deriving declaration instead"+          Just _  -> YesHasWildcard+          Nothing -> NoHasWildcard     data_cons  = tyConDataCons rep_tc     con_whys   = getInvalids (map check_con data_cons) -    check_con :: DataCon -> Validity+    check_con :: DataCon -> Validity' DeriveInstanceBadConstructor     check_con con       | not (null eq_spec) -- 2.-      = bad "is a GADT"+      = bad DerivErrBadConIsGADT       | not (null ex_tvs) -- 3.-      = bad "has existential type variables in its type"+      = bad DerivErrBadConHasExistentials       | not (null theta) -- 4.-      = bad "has constraints in its type"-      | not (permissive || all isTauTy (map scaledThing $ dataConOrigArgTys con)) -- 5.-      = bad "has a higher-rank type"+      = bad DerivErrBadConHasConstraints+      | not (permissive || all isTauTy (derivDataConInstArgTys con dit)) -- 5.+      = bad DerivErrBadConHasHigherRankType       | otherwise       = IsValid       where         (_, ex_tvs, eq_spec, theta, _, _) = dataConFullSig con-        bad msg = NotValid (badCon con (text msg))+        bad mkErr = NotValid $ mkErr con -no_cons_why :: TyCon -> SDoc-no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+>-                     text "must have at least one data constructor"+no_cons_why :: TyCon -> DeriveInstanceErrReason+no_cons_why = DerivErrNoConstructors  cond_RepresentableOk :: Condition-cond_RepresentableOk _ _ rep_tc = canDoGenerics rep_tc+cond_RepresentableOk _ dit =+  case canDoGenerics dit of+    IsValid -> IsValid+    NotValid generic_errs -> NotValid $ DerivErrGenerics generic_errs  cond_Representable1Ok :: Condition-cond_Representable1Ok _ _ rep_tc = canDoGenerics1 rep_tc+cond_Representable1Ok _ dit =+  case canDoGenerics1 dit of+    IsValid -> IsValid+    NotValid generic_errs -> NotValid $ DerivErrGenerics generic_errs  cond_enumOrProduct :: Class -> Condition cond_enumOrProduct cls = cond_isEnumeration `orCond`                          (cond_isProduct `andCond` cond_args cls)+  where+    orCond :: Condition -> Condition -> Condition+    orCond c1 c2 dflags dit+      = case (c1 dflags dit, c2 dflags dit) of+         (IsValid,    _)          -> IsValid    -- c1 succeeds+         (_,          IsValid)    -> IsValid    -- c21 succeeds+         (NotValid x, NotValid y) -> NotValid $ DerivErrEnumOrProduct x y+                                                -- Both fail + cond_args :: Class -> Condition -- ^ For some classes (eg 'Eq', 'Ord') we allow unlifted arg types -- by generating specialised code.  For others (eg 'Data') we don't. -- For even others (eg 'Lift'), unlifted types aren't even a special -- consideration!-cond_args cls _ _ rep_tc+cond_args cls _ dit@(DerivInstTys{dit_rep_tc = rep_tc})   = case bad_args of       []     -> IsValid-      (ty:_) -> NotValid (hang (text "Don't know how to derive" <+> quotes (ppr cls))-                             2 (text "for type" <+> quotes (ppr ty)))+      (ty:_) -> NotValid $ DerivErrDunnoHowToDeriveForType ty   where     bad_args = [ arg_ty | con <- tyConDataCons rep_tc-                        , Scaled _ arg_ty <- dataConOrigArgTys con-                        , isLiftedType_maybe arg_ty /= Just True+                        , arg_ty <- derivDataConInstArgTys con dit+                        , mightBeUnliftedType arg_ty                         , not (ok_ty arg_ty) ]      cls_key = classKey cls@@ -909,7 +1067,7 @@      | cls_key == eqClassKey   = check_in arg_ty ordOpTbl      | cls_key == ordClassKey  = check_in arg_ty ordOpTbl      | cls_key == showClassKey = check_in arg_ty boxConTbl-     | cls_key == liftClassKey = True     -- Lift is levity-polymorphic+     | cls_key == liftClassKey = True     -- Lift is representation-polymorphic      | otherwise               = False    -- Read, Ix etc      check_in :: Type -> [(Type,a)] -> Bool@@ -917,22 +1075,16 @@   cond_isEnumeration :: Condition-cond_isEnumeration _ _ rep_tc+cond_isEnumeration _ (DerivInstTys{dit_rep_tc = rep_tc})   | isEnumerationTyCon rep_tc = IsValid-  | otherwise                 = NotValid why-  where-    why = sep [ quotes (pprSourceTyCon rep_tc) <+>-                  text "must be an enumeration type"-              , text "(an enumeration consists of one or more nullary, non-GADT constructors)" ]-                  -- See Note [Enumeration types] in GHC.Core.TyCon+  | otherwise                 = NotValid $ DerivErrMustBeEnumType rep_tc  cond_isProduct :: Condition-cond_isProduct _ _ rep_tc-  | Just _ <- tyConSingleDataCon_maybe rep_tc = IsValid-  | otherwise                                 = NotValid why-  where-    why = quotes (pprSourceTyCon rep_tc) <+>-          text "must have precisely one constructor"+cond_isProduct _ (DerivInstTys{dit_rep_tc = rep_tc})+  | Just _ <- tyConSingleDataCon_maybe rep_tc+  = IsValid+  | otherwise+  = NotValid $ DerivErrMustHaveExactlyOneConstructor rep_tc  cond_functorOK :: Bool -> Bool -> Condition -- OK for Functor/Foldable/Traversable class@@ -941,14 +1093,16 @@ --            (c) don't use argument in the wrong place, e.g. data T a = T (X a a) --            (d) optionally: don't use function types --            (e) no "stupid context" on data type-cond_functorOK allowFunctions allowExQuantifiedLastTyVar _ _ rep_tc+cond_functorOK allowFunctions allowExQuantifiedLastTyVar _+               dit@(DerivInstTys{dit_rep_tc = rep_tc})   | null tc_tvs-  = NotValid (text "Data type" <+> quotes (ppr rep_tc)-              <+> text "must have some type parameters")+  = NotValid $ DerivErrMustHaveSomeParameters rep_tc +    -- We can't handle stupid contexts that mention the last type argument,+    -- so error out if we encounter one.+    -- See Note [The stupid context] in GHC.Core.DataCon.   | not (null bad_stupid_theta)-  = NotValid (text "Data type" <+> quotes (ppr rep_tc)-              <+> text "must not have a class context:" <+> pprTheta bad_stupid_theta)+  = NotValid $ DerivErrMustNotHaveClassContext rep_tc bad_stupid_theta    | otherwise   = allValid (map check_con data_cons)@@ -960,9 +1114,9 @@       -- See Note [Check that the type variable is truly universal]      data_cons = tyConDataCons rep_tc-    check_con con = allValid (check_universal con : foldDataConArgs (ft_check con) con)+    check_con con = allValid (check_universal con : foldDataConArgs (ft_check con) con dit) -    check_universal :: DataCon -> Validity+    check_universal :: DataCon -> Validity' DeriveInstanceErrReason     check_universal con       | allowExQuantifiedLastTyVar       = IsValid -- See Note [DeriveFoldable with ExistentialQuantification]@@ -972,31 +1126,26 @@       , not (tv `elemVarSet` exactTyCoVarsOfTypes (dataConTheta con))       = IsValid   -- See Note [Check that the type variable is truly universal]       | otherwise-      = NotValid (badCon con existential)+      = NotValid $ DerivErrBadConstructor Nothing [DerivErrBadConExistential con] -    ft_check :: DataCon -> FFoldType Validity+    ft_check :: DataCon -> FFoldType (Validity' DeriveInstanceErrReason)     ft_check con = FT { ft_triv = IsValid, ft_var = IsValid-                      , ft_co_var = NotValid (badCon con covariant)+                      , ft_co_var = NotValid $ DerivErrBadConstructor Nothing [DerivErrBadConCovariant con]                       , ft_fun = \x y -> if allowFunctions then x `andValid` y-                                                           else NotValid (badCon con functions)+                                                           else NotValid $ DerivErrBadConstructor Nothing [DerivErrBadConFunTypes con]                       , ft_tup = \_ xs  -> allValid xs                       , ft_ty_app = \_ _ x -> x-                      , ft_bad_app = NotValid (badCon con wrong_arg)+                      , ft_bad_app = NotValid $ DerivErrBadConstructor Nothing [DerivErrBadConWrongArg con]                       , ft_forall = \_ x   -> x } -    existential = text "must be truly polymorphic in the last argument of the data type"-    covariant   = text "must not use the type variable in a function argument"-    functions   = text "must not contain function types"-    wrong_arg   = text "must use the type variable only as the last argument of a data type"  checkFlag :: LangExt.Extension -> Condition-checkFlag flag dflags _ _+checkFlag flag dflags _   | xopt flag dflags = IsValid   | otherwise        = NotValid why   where-    why = text "You need " <> text flag_str-          <+> text "to derive an instance for this class"-    flag_str = case [ flagSpecName f | f <- xFlags , flagSpecFlag f == flag ] of+    why = DerivErrLangExtRequired the_flag+    the_flag = case [ flagSpecFlag f | f <- xFlags , flagSpecFlag f == flag ] of                  [s]   -> s                  other -> pprPanic "checkFlag" (ppr other) @@ -1021,14 +1170,12 @@                          , genClassKey, gen1ClassKey, typeableClassKey                          , traversableClassKey, liftClassKey ]) -badCon :: DataCon -> SDoc -> SDoc-badCon con msg = text "Constructor" <+> quotes (ppr con) <+> msg- ------------------------------------------------------------------ -newDerivClsInst :: ThetaType -> DerivSpec theta -> TcM ClsInst-newDerivClsInst theta (DS { ds_name = dfun_name, ds_overlap = overlap_mode-                          , ds_tvs = tvs, ds_cls = clas, ds_tys = tys })+newDerivClsInst :: DerivSpec ThetaType -> TcM ClsInst+newDerivClsInst (DS { ds_name = dfun_name, ds_overlap = overlap_mode+                    , ds_tvs = tvs, ds_theta = theta+                    , ds_cls = clas, ds_tys = tys })   = newClsInst overlap_mode dfun_name tvs theta clas tys  extendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
compiler/GHC/Tc/Errors.hs view
@@ -1,3145 +1,2495 @@-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE LambdaCase          #-}-{-# LANGUAGE ScopedTypeVariables #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}--module GHC.Tc.Errors(-       reportUnsolved, reportAllUnsolved, warnAllUnsolved,-       warnDefaulting,--       solverDepthErrorTcS-  ) where--#include "GhclibHsVersions.h"--import GHC.Prelude--import GHC.Tc.Types-import GHC.Tc.Utils.Monad-import GHC.Tc.Types.Constraint-import GHC.Core.Predicate-import GHC.Tc.Utils.TcMType-import GHC.Tc.Utils.Env( tcInitTidyEnv )-import GHC.Tc.Utils.TcType-import GHC.Tc.Utils.Unify ( checkTyVarEq )-import GHC.Tc.Types.Origin-import GHC.Rename.Unbound ( unknownNameSuggestions )-import GHC.Core.Type-import GHC.Core.Coercion-import GHC.Core.TyCo.Rep-import GHC.Core.TyCo.Ppr  ( pprTyVars, pprWithExplicitKindsWhen, pprSourceTyCon, pprWithTYPE )-import GHC.Core.Unify     ( tcMatchTys, flattenTys )-import GHC.Unit.Module-import GHC.Tc.Instance.Family-import GHC.Tc.Utils.Instantiate-import GHC.Core.InstEnv-import GHC.Core.TyCon-import GHC.Core.Class-import GHC.Core.DataCon-import GHC.Tc.Types.Evidence-import GHC.Tc.Types.EvTerm-import GHC.Hs.Binds ( PatSynBind(..) )-import GHC.Types.Name-import GHC.Types.Name.Reader ( lookupGRE_Name, GlobalRdrEnv, mkRdrUnqual )-import GHC.Builtin.Names ( typeableClassName )-import GHC.Types.Id-import GHC.Types.Var-import GHC.Types.Var.Set-import GHC.Types.Var.Env-import GHC.Types.Name.Env-import GHC.Types.Name.Set-import GHC.Data.Bag-import GHC.Utils.Error  ( pprLocMsgEnvelope )-import GHC.Types.Basic-import GHC.Types.Error-import GHC.Types.Unique.Set ( nonDetEltsUniqSet )-import GHC.Core.ConLike ( ConLike(..))-import GHC.Utils.Misc-import GHC.Data.FastString-import GHC.Utils.Outputable as O-import GHC.Utils.Panic-import GHC.Types.SrcLoc-import GHC.Driver.Session-import GHC.Driver.Ppr-import GHC.Data.List.SetOps ( equivClasses )-import GHC.Data.Maybe-import qualified GHC.LanguageExtensions as LangExt-import GHC.Utils.FV ( fvVarList, unionFV )--import Control.Monad    ( when, foldM, forM_ )-import Data.Foldable    ( toList )-import Data.List        ( partition, mapAccumL, sortBy, unfoldr )--import {-# SOURCE #-} GHC.Tc.Errors.Hole ( findValidHoleFits )---- import Data.Semigroup   ( Semigroup )-import qualified Data.Semigroup as Semigroup---{--************************************************************************-*                                                                      *-\section{Errors and contexts}-*                                                                      *-************************************************************************--ToDo: for these error messages, should we note the location as coming-from the insts, or just whatever seems to be around in the monad just-now?--Note [Deferring coercion errors to runtime]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-While developing, sometimes it is desirable to allow compilation to succeed even-if there are type errors in the code. Consider the following case:--  module Main where--  a :: Int-  a = 'a'--  main = print "b"--Even though `a` is ill-typed, it is not used in the end, so if all that we're-interested in is `main` it is handy to be able to ignore the problems in `a`.--Since we treat type equalities as evidence, this is relatively simple. Whenever-we run into a type mismatch in GHC.Tc.Utils.Unify, we normally just emit an error. But it-is always safe to defer the mismatch to the main constraint solver. If we do-that, `a` will get transformed into--  co :: Int ~ Char-  co = ...--  a :: Int-  a = 'a' `cast` co--The constraint solver would realize that `co` is an insoluble constraint, and-emit an error with `reportUnsolved`. But we can also replace the right-hand side-of `co` with `error "Deferred type error: Int ~ Char"`. This allows the program-to compile, and it will run fine unless we evaluate `a`. This is what-`deferErrorsToRuntime` does.--It does this by keeping track of which errors correspond to which coercion-in GHC.Tc.Errors. GHC.Tc.Errors.reportTidyWanteds does not print the errors-and does not fail if -fdefer-type-errors is on, so that we can continue-compilation. The errors are turned into warnings in `reportUnsolved`.--}---- | Report unsolved goals as errors or warnings. We may also turn some into--- deferred run-time errors if `-fdefer-type-errors` is on.-reportUnsolved :: WantedConstraints -> TcM (Bag EvBind)-reportUnsolved wanted-  = do { binds_var <- newTcEvBinds-       ; defer_errors <- goptM Opt_DeferTypeErrors-       ; warn_errors <- woptM Opt_WarnDeferredTypeErrors -- implement #10283-       ; let type_errors | not defer_errors = TypeError-                         | warn_errors      = TypeWarn (Reason Opt_WarnDeferredTypeErrors)-                         | otherwise        = TypeDefer--       ; defer_holes <- goptM Opt_DeferTypedHoles-       ; warn_holes  <- woptM Opt_WarnTypedHoles-       ; let expr_holes | not defer_holes = HoleError-                        | warn_holes      = HoleWarn-                        | otherwise       = HoleDefer--       ; partial_sigs      <- xoptM LangExt.PartialTypeSignatures-       ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures-       ; let type_holes | not partial_sigs  = HoleError-                        | warn_partial_sigs = HoleWarn-                        | otherwise         = HoleDefer--       ; defer_out_of_scope <- goptM Opt_DeferOutOfScopeVariables-       ; warn_out_of_scope <- woptM Opt_WarnDeferredOutOfScopeVariables-       ; let out_of_scope_holes | not defer_out_of_scope = HoleError-                                | warn_out_of_scope      = HoleWarn-                                | otherwise              = HoleDefer--       ; report_unsolved type_errors expr_holes-                         type_holes out_of_scope_holes-                         binds_var wanted--       ; ev_binds <- getTcEvBindsMap binds_var-       ; return (evBindMapBinds ev_binds)}---- | Report *all* unsolved goals as errors, even if -fdefer-type-errors is on--- However, do not make any evidence bindings, because we don't--- have any convenient place to put them.--- NB: Type-level holes are OK, because there are no bindings.--- See Note [Deferring coercion errors to runtime]--- Used by solveEqualities for kind equalities---      (see Note [Fail fast on kind errors] in "GHC.Tc.Solver")-reportAllUnsolved :: WantedConstraints -> TcM ()-reportAllUnsolved wanted-  = do { ev_binds <- newNoTcEvBinds--       ; partial_sigs      <- xoptM LangExt.PartialTypeSignatures-       ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures-       ; let type_holes | not partial_sigs  = HoleError-                        | warn_partial_sigs = HoleWarn-                        | otherwise         = HoleDefer--       ; report_unsolved TypeError HoleError type_holes HoleError-                         ev_binds wanted }---- | Report all unsolved goals as warnings (but without deferring any errors to--- run-time). See Note [Safe Haskell Overlapping Instances Implementation] in--- "GHC.Tc.Solver"-warnAllUnsolved :: WantedConstraints -> TcM ()-warnAllUnsolved wanted-  = do { ev_binds <- newTcEvBinds-       ; report_unsolved (TypeWarn NoReason) HoleWarn HoleWarn HoleWarn-                         ev_binds wanted }---- | Report unsolved goals as errors or warnings.-report_unsolved :: TypeErrorChoice   -- Deferred type errors-                -> HoleChoice        -- Expression holes-                -> HoleChoice        -- Type holes-                -> HoleChoice        -- Out of scope holes-                -> EvBindsVar        -- cec_binds-                -> WantedConstraints -> TcM ()-report_unsolved type_errors expr_holes-    type_holes out_of_scope_holes binds_var wanted-  | isEmptyWC wanted-  = return ()-  | otherwise-  = do { traceTc "reportUnsolved {" $-         vcat [ text "type errors:" <+> ppr type_errors-              , text "expr holes:" <+> ppr expr_holes-              , text "type holes:" <+> ppr type_holes-              , text "scope holes:" <+> ppr out_of_scope_holes ]-       ; traceTc "reportUnsolved (before zonking and tidying)" (ppr wanted)--       ; wanted <- zonkWC wanted   -- Zonk to reveal all information-       ; let tidy_env = tidyFreeTyCoVars emptyTidyEnv free_tvs-             free_tvs = filterOut isCoVar $-                        tyCoVarsOfWCList wanted-                        -- tyCoVarsOfWC returns free coercion *holes*, even though-                        -- they are "bound" by other wanted constraints. They in-                        -- turn may mention variables bound further in, which makes-                        -- no sense. Really we should not return those holes at all;-                        -- for now we just filter them out.--       ; traceTc "reportUnsolved (after zonking):" $-         vcat [ text "Free tyvars:" <+> pprTyVars free_tvs-              , text "Tidy env:" <+> ppr tidy_env-              , text "Wanted:" <+> ppr wanted ]--       ; warn_redundant <- woptM Opt_WarnRedundantConstraints-       ; exp_syns <- goptM Opt_PrintExpandedSynonyms-       ; let err_ctxt = CEC { cec_encl  = []-                            , cec_tidy  = tidy_env-                            , cec_defer_type_errors = type_errors-                            , cec_expr_holes = expr_holes-                            , cec_type_holes = type_holes-                            , cec_out_of_scope_holes = out_of_scope_holes-                            , cec_suppress = insolubleWC wanted-                                 -- See Note [Suppressing error messages]-                                 -- Suppress low-priority errors if there-                                 -- are insoluble errors anywhere;-                                 -- See #15539 and c.f. setting ic_status-                                 -- in GHC.Tc.Solver.setImplicationStatus-                            , cec_warn_redundant = warn_redundant-                            , cec_expand_syns = exp_syns-                            , cec_binds    = binds_var }--       ; tc_lvl <- getTcLevel-       ; reportWanteds err_ctxt tc_lvl wanted-       ; traceTc "reportUnsolved }" empty }-------------------------------------------------      Internal functions------------------------------------------------- | An error Report collects messages categorised by their importance.--- See Note [Error report] for details.-data Report-  = Report { report_important :: [SDoc]-           , report_relevant_bindings :: [SDoc]-           , report_valid_hole_fits :: [SDoc]-           }--instance Outputable Report where   -- Debugging only-  ppr (Report { report_important = imp-              , report_relevant_bindings = rel-              , report_valid_hole_fits = val })-    = vcat [ text "important:" <+> vcat imp-           , text "relevant:"  <+> vcat rel-           , text "valid:"  <+> vcat val ]--{- Note [Error report]-The idea is that error msgs are divided into three parts: the main msg, the-context block (\"In the second argument of ...\"), and the relevant bindings-block, which are displayed in that order, with a mark to divide them.  The-idea is that the main msg ('report_important') varies depending on the error-in question, but context and relevant bindings are always the same, which-should simplify visual parsing.--The context is added when the Report is passed off to 'mkErrorReport'.-Unfortunately, unlike the context, the relevant bindings are added in-multiple places so they have to be in the Report.--}--instance Semigroup Report where-    Report a1 b1 c1 <> Report a2 b2 c2 = Report (a1 ++ a2) (b1 ++ b2) (c1 ++ c2)--instance Monoid Report where-    mempty = Report [] [] []-    mappend = (Semigroup.<>)---- | Put a doc into the important msgs block.-important :: SDoc -> Report-important doc = mempty { report_important = [doc] }---- | Put a doc into the relevant bindings block.-mk_relevant_bindings :: SDoc -> Report-mk_relevant_bindings doc = mempty { report_relevant_bindings = [doc] }---- | Put a doc into the valid hole fits block.-valid_hole_fits :: SDoc -> Report-valid_hole_fits docs = mempty { report_valid_hole_fits = [docs] }--data TypeErrorChoice   -- What to do for type errors found by the type checker-  = TypeError     -- A type error aborts compilation with an error message-  | TypeWarn WarnReason-                  -- A type error is deferred to runtime, plus a compile-time warning-                  -- The WarnReason should usually be (Reason Opt_WarnDeferredTypeErrors)-                  -- but it isn't for the Safe Haskell Overlapping Instances warnings-                  -- see warnAllUnsolved-  | TypeDefer     -- A type error is deferred to runtime; no error or warning at compile time--data HoleChoice-  = HoleError     -- A hole is a compile-time error-  | HoleWarn      -- Defer to runtime, emit a compile-time warning-  | HoleDefer     -- Defer to runtime, no warning--instance Outputable HoleChoice where-  ppr HoleError = text "HoleError"-  ppr HoleWarn  = text "HoleWarn"-  ppr HoleDefer = text "HoleDefer"--instance Outputable TypeErrorChoice  where-  ppr TypeError         = text "TypeError"-  ppr (TypeWarn reason) = text "TypeWarn" <+> ppr reason-  ppr TypeDefer         = text "TypeDefer"--data ReportErrCtxt-    = CEC { cec_encl :: [Implication]  -- Enclosing implications-                                       --   (innermost first)-                                       -- ic_skols and givens are tidied, rest are not-          , cec_tidy  :: TidyEnv--          , cec_binds :: EvBindsVar    -- Make some errors (depending on cec_defer)-                                       -- into warnings, and emit evidence bindings-                                       -- into 'cec_binds' for unsolved constraints--          , cec_defer_type_errors :: TypeErrorChoice -- Defer type errors until runtime--          -- cec_expr_holes is a union of:-          --   cec_type_holes - a set of typed holes: '_', '_a', '_foo'-          --   cec_out_of_scope_holes - a set of variables which are-          --                            out of scope: 'x', 'y', 'bar'-          , cec_expr_holes :: HoleChoice           -- Holes in expressions-          , cec_type_holes :: HoleChoice           -- Holes in types-          , cec_out_of_scope_holes :: HoleChoice   -- Out of scope holes--          , cec_warn_redundant :: Bool    -- True <=> -Wredundant-constraints-          , cec_expand_syns    :: Bool    -- True <=> -fprint-expanded-synonyms--          , cec_suppress :: Bool    -- True <=> More important errors have occurred,-                                    --          so create bindings if need be, but-                                    --          don't issue any more errors/warnings-                                    -- See Note [Suppressing error messages]-      }--instance Outputable ReportErrCtxt where-  ppr (CEC { cec_binds              = bvar-           , cec_defer_type_errors  = dte-           , cec_expr_holes         = eh-           , cec_type_holes         = th-           , cec_out_of_scope_holes = osh-           , cec_warn_redundant     = wr-           , cec_expand_syns        = es-           , cec_suppress           = sup })-    = text "CEC" <+> braces (vcat-         [ text "cec_binds"              <+> equals <+> ppr bvar-         , text "cec_defer_type_errors"  <+> equals <+> ppr dte-         , text "cec_expr_holes"         <+> equals <+> ppr eh-         , text "cec_type_holes"         <+> equals <+> ppr th-         , text "cec_out_of_scope_holes" <+> equals <+> ppr osh-         , text "cec_warn_redundant"     <+> equals <+> ppr wr-         , text "cec_expand_syns"        <+> equals <+> ppr es-         , text "cec_suppress"           <+> equals <+> ppr sup ])---- | Returns True <=> the ReportErrCtxt indicates that something is deferred-deferringAnyBindings :: ReportErrCtxt -> Bool-  -- Don't check cec_type_holes, as these don't cause bindings to be deferred-deferringAnyBindings (CEC { cec_defer_type_errors  = TypeError-                          , cec_expr_holes         = HoleError-                          , cec_out_of_scope_holes = HoleError }) = False-deferringAnyBindings _                                            = True--maybeSwitchOffDefer :: EvBindsVar -> ReportErrCtxt -> ReportErrCtxt--- Switch off defer-type-errors inside CoEvBindsVar--- See Note [Failing equalities with no evidence bindings]-maybeSwitchOffDefer evb ctxt- | CoEvBindsVar{} <- evb- = ctxt { cec_defer_type_errors  = TypeError-        , cec_expr_holes         = HoleError-        , cec_out_of_scope_holes = HoleError }- | otherwise- = ctxt--{- Note [Failing equalities with no evidence bindings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we go inside an implication that has no term evidence-(e.g. unifying under a forall), we can't defer type errors.  You could-imagine using the /enclosing/ bindings (in cec_binds), but that may-not have enough stuff in scope for the bindings to be well typed.  So-we just switch off deferred type errors altogether.  See #14605.--This is done by maybeSwitchOffDefer.  It's also useful in one other-place: see Note [Wrapping failing kind equalities] in GHC.Tc.Solver.--Note [Suppressing error messages]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The cec_suppress flag says "don't report any errors".  Instead, just create-evidence bindings (as usual).  It's used when more important errors have occurred.--Specifically (see reportWanteds)-  * If there are insoluble Givens, then we are in unreachable code and all bets-    are off.  So don't report any further errors.-  * If there are any insolubles (eg Int~Bool), here or in a nested implication,-    then suppress errors from the simple constraints here.  Sometimes the-    simple-constraint errors are a knock-on effect of the insolubles.--This suppression behaviour is controlled by the Bool flag in-ReportErrorSpec, as used in reportWanteds.--But we need to take care: flags can turn errors into warnings, and we-don't want those warnings to suppress subsequent errors (including-suppressing the essential addTcEvBind for them: #15152). So in-tryReporter we use askNoErrs to see if any error messages were-/actually/ produced; if not, we don't switch on suppression.--A consequence is that warnings never suppress warnings, so turning an-error into a warning may allow subsequent warnings to appear that were-previously suppressed.   (e.g. partial-sigs/should_fail/T14584)--}--reportImplic :: ReportErrCtxt -> Implication -> TcM ()-reportImplic ctxt implic@(Implic { ic_skols = tvs-                                 , ic_given = given-                                 , ic_wanted = wanted, ic_binds = evb-                                 , ic_status = status, ic_info = info-                                 , ic_tclvl = tc_lvl })-  | BracketSkol <- info-  , not insoluble-  = return ()        -- For Template Haskell brackets report only-                     -- definite errors. The whole thing will be re-checked-                     -- later when we plug it in, and meanwhile there may-                     -- certainly be un-satisfied constraints--  | otherwise-  = do { traceTc "reportImplic" (ppr implic')-       ; when bad_telescope $ reportBadTelescope ctxt tcl_env info tvs-               -- Do /not/ use the tidied tvs because then are in the-               -- wrong order, so tidying will rename things wrongly-       ; reportWanteds ctxt' tc_lvl wanted-       ; when (cec_warn_redundant ctxt) $-         warnRedundantConstraints ctxt' tcl_env info' dead_givens }-  where-    tcl_env      = ic_env implic-    insoluble    = isInsolubleStatus status-    (env1, tvs') = mapAccumL tidyVarBndr (cec_tidy ctxt) $-                   scopedSort tvs-        -- scopedSort: the ic_skols may not be in dependency order-        -- (see Note [Skolems in an implication] in GHC.Tc.Types.Constraint)-        -- but tidying goes wrong on out-of-order constraints;-        -- so we sort them here before tidying-    info'   = tidySkolemInfo env1 info-    implic' = implic { ic_skols = tvs'-                     , ic_given = map (tidyEvVar env1) given-                     , ic_info  = info' }--    ctxt1 = maybeSwitchOffDefer evb ctxt-    ctxt' = ctxt1 { cec_tidy     = env1-                  , cec_encl     = implic' : cec_encl ctxt--                  , cec_suppress = insoluble || cec_suppress ctxt-                        -- Suppress inessential errors if there-                        -- are insolubles anywhere in the-                        -- tree rooted here, or we've come across-                        -- a suppress-worthy constraint higher up (#11541)--                  , cec_binds    = evb }--    dead_givens = case status of-                    IC_Solved { ics_dead = dead } -> dead-                    _                             -> []--    bad_telescope = case status of-              IC_BadTelescope -> True-              _               -> False--warnRedundantConstraints :: ReportErrCtxt -> TcLclEnv -> SkolemInfo -> [EvVar] -> TcM ()--- See Note [Tracking redundant constraints] in GHC.Tc.Solver-warnRedundantConstraints ctxt env info ev_vars- | null redundant_evs- = return ()-- | SigSkol {} <- info- = setLclEnv env $  -- We want to add "In the type signature for f"-                    -- to the error context, which is a bit tiresome-   addErrCtxt (text "In" <+> ppr info) $-   do { env <- getLclEnv-      ; msg <- mkErrorReport ctxt env (important doc)-      ; reportWarning (Reason Opt_WarnRedundantConstraints) msg }-- | otherwise  -- But for InstSkol there already *is* a surrounding-              -- "In the instance declaration for Eq [a]" context-              -- and we don't want to say it twice. Seems a bit ad-hoc- = do { msg <- mkErrorReport ctxt env (important doc)-      ; reportWarning (Reason Opt_WarnRedundantConstraints) msg }- where-   doc = text "Redundant constraint" <> plural redundant_evs <> colon-         <+> pprEvVarTheta redundant_evs--   redundant_evs =-       filterOut is_type_error $-       case info of -- See Note [Redundant constraints in instance decls]-         InstSkol -> filterOut (improving . idType) ev_vars-         _        -> ev_vars--   -- See #15232-   is_type_error = isJust . userTypeError_maybe . idType--   improving pred -- (transSuperClasses p) does not include p-     = any isImprovementPred (pred : transSuperClasses pred)--reportBadTelescope :: ReportErrCtxt -> TcLclEnv -> SkolemInfo -> [TcTyVar] -> TcM ()-reportBadTelescope ctxt env (ForAllSkol telescope) skols-  = do { msg <- mkErrorReport ctxt env (important doc)-       ; reportError msg }-  where-    doc = hang (text "These kind and type variables:" <+> telescope $$-                text "are out of dependency order. Perhaps try this ordering:")-             2 (pprTyVars sorted_tvs)--    sorted_tvs = scopedSort skols--reportBadTelescope _ _ skol_info skols-  = pprPanic "reportBadTelescope" (ppr skol_info $$ ppr skols)--{- Note [Redundant constraints in instance decls]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For instance declarations, we don't report unused givens if-they can give rise to improvement.  Example (#10100):-    class Add a b ab | a b -> ab, a ab -> b-    instance Add Zero b b-    instance Add a b ab => Add (Succ a) b (Succ ab)-The context (Add a b ab) for the instance is clearly unused in terms-of evidence, since the dictionary has no fields.  But it is still-needed!  With the context, a wanted constraint-   Add (Succ Zero) beta (Succ Zero)-we will reduce to (Add Zero beta Zero), and thence we get beta := Zero.-But without the context we won't find beta := Zero.--This only matters in instance declarations..--}--reportWanteds :: ReportErrCtxt -> TcLevel -> WantedConstraints -> TcM ()-reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics-                              , wc_holes = holes })-  = do { traceTc "reportWanteds" (vcat [ text "Simples =" <+> ppr simples-                                       , text "Suppress =" <+> ppr (cec_suppress ctxt)-                                       , text "tidy_cts =" <+> ppr tidy_cts-                                       , text "tidy_holes = " <+> ppr tidy_holes ])--         -- First, deal with any out-of-scope errors:-       ; let (out_of_scope, other_holes) = partition isOutOfScopeHole tidy_holes-               -- don't suppress out-of-scope errors-             ctxt_for_scope_errs = ctxt { cec_suppress = False }-       ; (_, no_out_of_scope) <- askNoErrs $-                                 reportHoles tidy_cts ctxt_for_scope_errs out_of_scope--         -- Next, deal with things that are utterly wrong-         -- Like Int ~ Bool (incl nullary TyCons)-         -- or  Int ~ t a   (AppTy on one side)-         -- These /ones/ are not suppressed by the incoming context-         -- (but will be by out-of-scope errors)-       ; let ctxt_for_insols = ctxt { cec_suppress = not no_out_of_scope }-       ; reportHoles tidy_cts ctxt_for_insols other_holes-          -- holes never suppress--       ; (ctxt1, cts1) <- tryReporters ctxt_for_insols report1 tidy_cts--         -- Now all the other constraints.  We suppress errors here if-         -- any of the first batch failed, or if the enclosing context-         -- says to suppress-       ; let ctxt2 = ctxt { cec_suppress = cec_suppress ctxt || cec_suppress ctxt1 }-       ; (_, leftovers) <- tryReporters ctxt2 report2 cts1-       ; MASSERT2( null leftovers, ppr leftovers )--            -- All the Derived ones have been filtered out of simples-            -- by the constraint solver. This is ok; we don't want-            -- to report unsolved Derived goals as errors-            -- See Note [Do not report derived but soluble errors]--     ; mapBagM_ (reportImplic ctxt2) implics }-            -- NB ctxt2: don't suppress inner insolubles if there's only a-            -- wanted insoluble here; but do suppress inner insolubles-            -- if there's a *given* insoluble here (= inaccessible code)- where-    env = cec_tidy ctxt-    tidy_cts   = bagToList (mapBag (tidyCt env)   simples)-    tidy_holes = bagToList (mapBag (tidyHole env) holes)--    -- report1: ones that should *not* be suppressed by-    --          an insoluble somewhere else in the tree-    -- It's crucial that anything that is considered insoluble-    -- (see GHC.Tc.Utils.insolubleCt) is caught here, otherwise-    -- we might suppress its error message, and proceed on past-    -- type checking to get a Lint error later-    report1 = [ ("custom_error", unblocked is_user_type_error, True,  mkUserTypeErrorReporter)--              , given_eq_spec-              , ("insoluble2",   unblocked utterly_wrong,  True, mkGroupReporter mkEqErr)-              , ("skolem eq1",   unblocked very_wrong,     True, mkSkolReporter)-              , ("skolem eq2",   unblocked skolem_eq,      True, mkSkolReporter)-              , ("non-tv eq",    unblocked non_tv_eq,      True, mkSkolReporter)--                  -- The only remaining equalities are alpha ~ ty,-                  -- where alpha is untouchable; and representational equalities-                  -- Prefer homogeneous equalities over hetero, because the-                  -- former might be holding up the latter.-                  -- See Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical-              , ("Homo eqs",      unblocked is_homo_equality, True,  mkGroupReporter mkEqErr)-              , ("Other eqs",     unblocked is_equality,      True,  mkGroupReporter mkEqErr)-              , ("Blocked eqs",   is_equality,           False, mkSuppressReporter mkBlockedEqErr)]--    -- report2: we suppress these if there are insolubles elsewhere in the tree-    report2 = [ ("Implicit params", is_ip,           False, mkGroupReporter mkIPErr)-              , ("Irreds",          is_irred,        False, mkGroupReporter mkIrredErr)-              , ("Dicts",           is_dict,         False, mkGroupReporter mkDictErr) ]--    -- also checks to make sure the constraint isn't HoleBlockerReason-    -- See TcCanonical Note [Equalities with incompatible kinds], (4)-    unblocked :: (Ct -> Pred -> Bool) -> Ct -> Pred -> Bool-    unblocked _ (CIrredCan { cc_reason = HoleBlockerReason {}}) _ = False-    unblocked checker ct pred = checker ct pred--    -- rigid_nom_eq, rigid_nom_tv_eq,-    is_dict, is_equality, is_ip, is_irred :: Ct -> Pred -> Bool--    is_given_eq ct pred-       | EqPred {} <- pred = arisesFromGivens ct-       | otherwise         = False-       -- I think all given residuals are equalities--    -- Things like (Int ~N Bool)-    utterly_wrong _ (EqPred NomEq ty1 ty2) = isRigidTy ty1 && isRigidTy ty2-    utterly_wrong _ _                      = False--    -- Things like (a ~N Int)-    very_wrong _ (EqPred NomEq ty1 ty2) = isSkolemTy tc_lvl ty1 && isRigidTy ty2-    very_wrong _ _                      = False--    -- Things like (a ~N b) or (a  ~N  F Bool)-    skolem_eq _ (EqPred NomEq ty1 _) = isSkolemTy tc_lvl ty1-    skolem_eq _ _                    = False--    -- Things like (F a  ~N  Int)-    non_tv_eq _ (EqPred NomEq ty1 _) = not (isTyVarTy ty1)-    non_tv_eq _ _                    = False--    is_user_type_error ct _ = isUserTypeErrorCt ct--    is_homo_equality _ (EqPred _ ty1 ty2) = tcTypeKind ty1 `tcEqType` tcTypeKind ty2-    is_homo_equality _ _                  = False--    is_equality _ (EqPred {}) = True-    is_equality _ _           = False--    is_dict _ (ClassPred {}) = True-    is_dict _ _              = False--    is_ip _ (ClassPred cls _) = isIPClass cls-    is_ip _ _                 = False--    is_irred _ (IrredPred {}) = True-    is_irred _ _              = False--    given_eq_spec  -- See Note [Given errors]-      | has_gadt_match (cec_encl ctxt)-      = ("insoluble1a", is_given_eq, True,  mkGivenErrorReporter)-      | otherwise-      = ("insoluble1b", is_given_eq, False, ignoreErrorReporter)-          -- False means don't suppress subsequent errors-          -- Reason: we don't report all given errors-          --         (see mkGivenErrorReporter), and we should only suppress-          --         subsequent errors if we actually report this one!-          --         #13446 is an example--    -- See Note [Given errors]-    has_gadt_match [] = False-    has_gadt_match (implic : implics)-      | PatSkol {} <- ic_info implic-      , ic_given_eqs implic /= NoGivenEqs-      , ic_warn_inaccessible implic-          -- Don't bother doing this if -Winaccessible-code isn't enabled.-          -- See Note [Avoid -Winaccessible-code when deriving] in GHC.Tc.TyCl.Instance.-      = True-      | otherwise-      = has_gadt_match implics------------------isSkolemTy :: TcLevel -> Type -> Bool--- The type is a skolem tyvar-isSkolemTy tc_lvl ty-  | Just tv <- getTyVar_maybe ty-  =  isSkolemTyVar tv-  || (isTyVarTyVar tv && isTouchableMetaTyVar tc_lvl tv)-     -- The last case is for touchable TyVarTvs-     -- we postpone untouchables to a latter test (too obscure)--  | otherwise-  = False--isTyFun_maybe :: Type -> Maybe TyCon-isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of-                      Just (tc,_) | isTypeFamilyTyCon tc -> Just tc-                      _ -> Nothing-------------------------------------------------      Reporters-----------------------------------------------type Reporter-  = ReportErrCtxt -> [Ct] -> TcM ()-type ReporterSpec-  = ( String                     -- Name-    , Ct -> Pred -> Bool         -- Pick these ones-    , Bool                       -- True <=> suppress subsequent reporters-    , Reporter)                  -- The reporter itself--mkSkolReporter :: Reporter--- Suppress duplicates with either the same LHS, or same location-mkSkolReporter ctxt cts-  = mapM_ (reportGroup mkEqErr ctxt) (group cts)-  where-     group [] = []-     group (ct:cts) = (ct : yeses) : group noes-        where-          (yeses, noes) = partition (group_with ct) cts--     group_with ct1 ct2-       | EQ <- cmp_loc ct1 ct2 = True-       | eq_lhs_type   ct1 ct2 = True-       | otherwise             = False--reportHoles :: [Ct]  -- other (tidied) constraints-            -> ReportErrCtxt -> [Hole] -> TcM ()-reportHoles tidy_cts ctxt holes-  = do-      let holes' = filter (keepThisHole ctxt) holes-      -- Zonk and tidy all the TcLclEnvs before calling `mkHoleError`-      -- because otherwise types will be zonked and tidied many times over.-      (tidy_env', lcl_name_cache) <- zonkTidyTcLclEnvs (cec_tidy ctxt) (map (ctl_env . hole_loc) holes')-      let ctxt' = ctxt { cec_tidy = tidy_env' }-      forM_ holes' $ \hole ->-        do { err <- mkHoleError lcl_name_cache tidy_cts ctxt' hole-           ; maybeReportHoleError ctxt hole err-           ; maybeAddDeferredHoleBinding ctxt err hole }--keepThisHole :: ReportErrCtxt -> Hole -> Bool--- See Note [Skip type holes rapidly]-keepThisHole ctxt hole-  = case hole_sort hole of-       ExprHole {}    -> True-       TypeHole       -> keep_type_hole-       ConstraintHole -> keep_type_hole-  where-    keep_type_hole = case cec_type_holes ctxt of-                         HoleDefer -> False-                         _         -> True---- | zonkTidyTcLclEnvs takes a bunch of 'TcLclEnv's, each from a Hole.--- It returns a ('Name' :-> 'Type') mapping which gives the zonked, tidied--- type for each Id in any of the binder stacks in the  'TcLclEnv's.--- Since there is a huge overlap between these stacks, is is much,--- much faster to do them all at once, avoiding duplication.-zonkTidyTcLclEnvs :: TidyEnv -> [TcLclEnv] -> TcM (TidyEnv, NameEnv Type)-zonkTidyTcLclEnvs tidy_env lcls = foldM go (tidy_env, emptyNameEnv) (concatMap tcl_bndrs lcls)-  where-    go envs tc_bndr = case tc_bndr of-          TcTvBndr {} -> return envs-          TcIdBndr id _top_lvl -> go_one (idName id) (idType id) envs-          TcIdBndr_ExpType name et _top_lvl ->-            do { mb_ty <- readExpType_maybe et-                   -- et really should be filled in by now. But there's a chance-                   -- it hasn't, if, say, we're reporting a kind error en route to-                   -- checking a term. See test indexed-types/should_fail/T8129-                   -- Or we are reporting errors from the ambiguity check on-                   -- a local type signature-               ; case mb_ty of-                   Just ty -> go_one name ty envs-                   Nothing -> return envs-               }-    go_one name ty (tidy_env, name_env) = do-            if name `elemNameEnv` name_env-              then return (tidy_env, name_env)-              else do-                (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env ty-                return (tidy_env',  extendNameEnv name_env name tidy_ty)--{- Note [Skip type holes rapidly]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have module with a /lot/ of partial type signatures, and we-compile it while suppressing partial-type-signature warnings.  Then-we don't want to spend ages constructing error messages and lists of-relevant bindings that we never display! This happened in #14766, in-which partial type signatures in a Happy-generated parser cause a huge-increase in compile time.--The function ignoreThisHole short-circuits the error/warning generation-machinery, in cases where it is definitely going to be a no-op.--}--mkUserTypeErrorReporter :: Reporter-mkUserTypeErrorReporter ctxt-  = mapM_ $ \ct -> do { err <- mkUserTypeError ctxt ct-                      ; maybeReportError ctxt err-                      ; addDeferredBinding ctxt err ct }--mkUserTypeError :: ReportErrCtxt -> Ct -> TcM (MsgEnvelope DecoratedSDoc)-mkUserTypeError ctxt ct = mkErrorMsgFromCt ctxt ct-                        $ important-                        $ pprUserTypeErrorTy-                        $ case getUserTypeErrorMsg ct of-                            Just msg -> msg-                            Nothing  -> pprPanic "mkUserTypeError" (ppr ct)---mkGivenErrorReporter :: Reporter--- See Note [Given errors]-mkGivenErrorReporter ctxt cts-  = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct-       ; dflags <- getDynFlags-       ; let (implic:_) = cec_encl ctxt-                 -- Always non-empty when mkGivenErrorReporter is called-             ct' = setCtLoc ct (setCtLocEnv (ctLoc ct) (ic_env implic))-                   -- For given constraints we overwrite the env (and hence src-loc)-                   -- with one from the immediately-enclosing implication.-                   -- See Note [Inaccessible code]--             inaccessible_msg = hang (text "Inaccessible code in")-                                   2 (ppr (ic_info implic))-             report = important inaccessible_msg `mappend`-                      mk_relevant_bindings binds_msg--       ; err <- mkEqErr_help dflags ctxt report ct' ty1 ty2--       ; traceTc "mkGivenErrorReporter" (ppr ct)-       ; reportWarning (Reason Opt_WarnInaccessibleCode) err }-  where-    (ct : _ )  = cts    -- Never empty-    (ty1, ty2) = getEqPredTys (ctPred ct)--ignoreErrorReporter :: Reporter--- Discard Given errors that don't come from--- a pattern match; maybe we should warn instead?-ignoreErrorReporter ctxt cts-  = do { traceTc "mkGivenErrorReporter no" (ppr cts $$ ppr (cec_encl ctxt))-       ; return () }---{- Note [Given errors]-~~~~~~~~~~~~~~~~~~~~~~-Given constraints represent things for which we have (or will have)-evidence, so they aren't errors.  But if a Given constraint is-insoluble, this code is inaccessible, and we might want to at least-warn about that.  A classic case is--   data T a where-     T1 :: T Int-     T2 :: T a-     T3 :: T Bool--   f :: T Int -> Bool-   f T1 = ...-   f T2 = ...-   f T3 = ...  -- We want to report this case as inaccessible--We'd like to point out that the T3 match is inaccessible. It-will have a Given constraint [G] Int ~ Bool.--But we don't want to report ALL insoluble Given constraints.  See Trac-#12466 for a long discussion.  For example, if we aren't careful-we'll complain about-   f :: ((Int ~ Bool) => a -> a) -> Int-which arguably is OK.  It's more debatable for-   g :: (Int ~ Bool) => Int -> Int-but it's tricky to distinguish these cases so we don't report-either.--The bottom line is this: has_gadt_match looks for an enclosing-pattern match which binds some equality constraints.  If we-find one, we report the insoluble Given.--}--mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc))-                             -- Make error message for a group-                -> Reporter  -- Deal with lots of constraints--- Group together errors from same location,--- and report only the first (to avoid a cascade)-mkGroupReporter mk_err ctxt cts-  = mapM_ (reportGroup mk_err ctxt . toList) (equivClasses cmp_loc cts)---- Like mkGroupReporter, but doesn't actually print error messages-mkSuppressReporter :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc)) -> Reporter-mkSuppressReporter mk_err ctxt cts-  = mapM_ (suppressGroup mk_err ctxt . toList) (equivClasses cmp_loc cts)--eq_lhs_type :: Ct -> Ct -> Bool-eq_lhs_type ct1 ct2-  = case (classifyPredType (ctPred ct1), classifyPredType (ctPred ct2)) of-       (EqPred eq_rel1 ty1 _, EqPred eq_rel2 ty2 _) ->-         (eq_rel1 == eq_rel2) && (ty1 `eqType` ty2)-       _ -> pprPanic "mkSkolReporter" (ppr ct1 $$ ppr ct2)--cmp_loc :: Ct -> Ct -> Ordering-cmp_loc ct1 ct2 = get ct1 `compare` get ct2-  where-    get ct = realSrcSpanStart (ctLocSpan (ctLoc ct))-             -- Reduce duplication by reporting only one error from each-             -- /starting/ location even if the end location differs--reportGroup :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc)) -> Reporter-reportGroup mk_err ctxt cts =-  ASSERT( not (null cts))-  do { err <- mk_err ctxt cts-     ; traceTc "About to maybeReportErr" $-       vcat [ text "Constraint:"             <+> ppr cts-            , text "cec_suppress ="          <+> ppr (cec_suppress ctxt)-            , text "cec_defer_type_errors =" <+> ppr (cec_defer_type_errors ctxt) ]-     ; maybeReportError ctxt err-         -- But see Note [Always warn with -fdefer-type-errors]-     ; traceTc "reportGroup" (ppr cts)-     ; mapM_ (addDeferredBinding ctxt err) cts }-         -- Add deferred bindings for all-         -- Redundant if we are going to abort compilation,-         -- but that's hard to know for sure, and if we don't-         -- abort, we need bindings for all (e.g. #12156)---- like reportGroup, but does not actually report messages. It still adds--- -fdefer-type-errors bindings, though.-suppressGroup :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc)) -> Reporter-suppressGroup mk_err ctxt cts- = do { err <- mk_err ctxt cts-      ; traceTc "Suppressing errors for" (ppr cts)-      ; mapM_ (addDeferredBinding ctxt err) cts }--maybeReportHoleError :: ReportErrCtxt -> Hole -> MsgEnvelope DecoratedSDoc -> TcM ()-maybeReportHoleError ctxt hole err-  | isOutOfScopeHole hole-  -- Always report an error for out-of-scope variables-  -- Unless -fdefer-out-of-scope-variables is on,-  -- in which case the messages are discarded.-  -- See #12170, #12406-  = -- If deferring, report a warning only if -Wout-of-scope-variables is on-    case cec_out_of_scope_holes ctxt of-      HoleError -> reportError err-      HoleWarn  ->-        reportWarning (Reason Opt_WarnDeferredOutOfScopeVariables) err-      HoleDefer -> return ()---- Unlike maybeReportError, these "hole" errors are--- /not/ suppressed by cec_suppress.  We want to see them!-maybeReportHoleError ctxt (Hole { hole_sort = hole_sort }) err-  | case hole_sort of TypeHole       -> True-                      ConstraintHole -> True-                      _              -> False-  -- When -XPartialTypeSignatures is on, warnings (instead of errors) are-  -- generated for holes in partial type signatures.-  -- Unless -fwarn-partial-type-signatures is not on,-  -- in which case the messages are discarded.-  = -- For partial type signatures, generate warnings only, and do that-    -- only if -fwarn-partial-type-signatures is on-    case cec_type_holes ctxt of-       HoleError -> reportError err-       HoleWarn  -> reportWarning (Reason Opt_WarnPartialTypeSignatures) err-       HoleDefer -> return ()--maybeReportHoleError ctxt hole err-  -- Otherwise this is a typed hole in an expression,-  -- but not for an out-of-scope variable (because that goes through a-  -- different function)-  = -- If deferring, report a warning only if -Wtyped-holes is on-    ASSERT( not (isOutOfScopeHole hole) )-    case cec_expr_holes ctxt of-       HoleError -> reportError err-       HoleWarn  -> reportWarning (Reason Opt_WarnTypedHoles) err-       HoleDefer -> return ()--maybeReportError :: ReportErrCtxt -> MsgEnvelope DecoratedSDoc -> TcM ()--- Report the error and/or make a deferred binding for it-maybeReportError ctxt err-  | cec_suppress ctxt    -- Some worse error has occurred;-  = return ()            -- so suppress this error/warning--  | otherwise-  = case cec_defer_type_errors ctxt of-      TypeDefer       -> return ()-      TypeWarn reason -> reportWarning reason err-      TypeError       -> reportError err--addDeferredBinding :: ReportErrCtxt -> MsgEnvelope DecoratedSDoc -> Ct -> TcM ()--- See Note [Deferring coercion errors to runtime]-addDeferredBinding ctxt err ct-  | deferringAnyBindings ctxt-  , CtWanted { ctev_pred = pred, ctev_dest = dest } <- ctEvidence ct-    -- Only add deferred bindings for Wanted constraints-  = do { dflags <- getDynFlags-       ; let err_tm       = mkErrorTerm dflags pred err-             ev_binds_var = cec_binds ctxt--       ; case dest of-           EvVarDest evar-             -> addTcEvBind ev_binds_var $ mkWantedEvBind evar err_tm-           HoleDest hole-             -> do { -- See Note [Deferred errors for coercion holes]-                     let co_var = coHoleCoVar hole-                   ; addTcEvBind ev_binds_var $ mkWantedEvBind co_var err_tm-                   ; fillCoercionHole hole (mkTcCoVarCo co_var) }}--  | otherwise   -- Do not set any evidence for Given/Derived-  = return ()--mkErrorTerm :: DynFlags -> Type  -- of the error term-            -> MsgEnvelope DecoratedSDoc -> EvTerm-mkErrorTerm dflags ty err = evDelayedError ty err_fs-  where-    err_msg = pprLocMsgEnvelope err-    err_fs  = mkFastString $ showSDoc dflags $-              err_msg $$ text "(deferred type error)"--maybeAddDeferredHoleBinding :: ReportErrCtxt -> MsgEnvelope DecoratedSDoc -> Hole -> TcM ()-maybeAddDeferredHoleBinding ctxt err (Hole { hole_sort = ExprHole (HER ref ref_ty _) })--- Only add bindings for holes in expressions--- not for holes in partial type signatures--- cf. addDeferredBinding-  | deferringAnyBindings ctxt-  = do { dflags <- getDynFlags-       ; let err_tm = mkErrorTerm dflags ref_ty err-           -- NB: ref_ty, not hole_ty. hole_ty might be rewritten.-           -- See Note [Holes] in GHC.Tc.Types.Constraint-       ; writeMutVar ref err_tm }-  | otherwise-  = return ()-maybeAddDeferredHoleBinding _ _ (Hole { hole_sort = TypeHole })-  = return ()-maybeAddDeferredHoleBinding _ _ (Hole { hole_sort = ConstraintHole })-  = return ()--tryReporters :: ReportErrCtxt -> [ReporterSpec] -> [Ct] -> TcM (ReportErrCtxt, [Ct])--- Use the first reporter in the list whose predicate says True-tryReporters ctxt reporters cts-  = do { let (vis_cts, invis_cts) = partition (isVisibleOrigin . ctOrigin) cts-       ; traceTc "tryReporters {" (ppr vis_cts $$ ppr invis_cts)-       ; (ctxt', cts') <- go ctxt reporters vis_cts invis_cts-       ; traceTc "tryReporters }" (ppr cts')-       ; return (ctxt', cts') }-  where-    go ctxt [] vis_cts invis_cts-      = return (ctxt, vis_cts ++ invis_cts)--    go ctxt (r : rs) vis_cts invis_cts-       -- always look at *visible* Origins before invisible ones-       -- this is the whole point of isVisibleOrigin-      = do { (ctxt', vis_cts') <- tryReporter ctxt r vis_cts-           ; (ctxt'', invis_cts') <- tryReporter ctxt' r invis_cts-           ; go ctxt'' rs vis_cts' invis_cts' }-                -- Carry on with the rest, because we must make-                -- deferred bindings for them if we have -fdefer-type-errors-                -- But suppress their error messages--tryReporter :: ReportErrCtxt -> ReporterSpec -> [Ct] -> TcM (ReportErrCtxt, [Ct])-tryReporter ctxt (str, keep_me,  suppress_after, reporter) cts-  | null yeses-  = return (ctxt, cts)-  | otherwise-  = do { traceTc "tryReporter{ " (text str <+> ppr yeses)-       ; (_, no_errs) <- askNoErrs (reporter ctxt yeses)-       ; let suppress_now = not no_errs && suppress_after-                            -- See Note [Suppressing error messages]-             ctxt' = ctxt { cec_suppress = suppress_now || cec_suppress ctxt }-       ; traceTc "tryReporter end }" (text str <+> ppr (cec_suppress ctxt) <+> ppr suppress_after)-       ; return (ctxt', nos) }-  where-    (yeses, nos) = partition (\ct -> keep_me ct (classifyPredType (ctPred ct))) cts--pprArising :: CtOrigin -> SDoc--- Used for the main, top-level error message--- We've done special processing for TypeEq, KindEq, givens-pprArising (TypeEqOrigin {})         = empty-pprArising (KindEqOrigin {})         = empty-pprArising orig | isGivenOrigin orig = empty-                | otherwise          = pprCtOrigin orig---- Add the "arising from..." part to a message about bunch of dicts-addArising :: CtOrigin -> SDoc -> SDoc-addArising orig msg = hang msg 2 (pprArising orig)--pprWithArising :: [Ct] -> (CtLoc, SDoc)--- Print something like---    (Eq a) arising from a use of x at y---    (Show a) arising from a use of p at q--- Also return a location for the error message--- Works for Wanted/Derived only-pprWithArising []-  = panic "pprWithArising"-pprWithArising (ct:cts)-  | null cts-  = (loc, addArising (ctLocOrigin loc)-                     (pprTheta [ctPred ct]))-  | otherwise-  = (loc, vcat (map ppr_one (ct:cts)))-  where-    loc = ctLoc ct-    ppr_one ct' = hang (parens (pprType (ctPred ct')))-                     2 (pprCtLoc (ctLoc ct'))--mkErrorMsgFromCt :: ReportErrCtxt -> Ct -> Report -> TcM (MsgEnvelope DecoratedSDoc)-mkErrorMsgFromCt ctxt ct report-  = mkErrorReport ctxt (ctLocEnv (ctLoc ct)) report--mkErrorReport :: ReportErrCtxt -> TcLclEnv -> Report -> TcM (MsgEnvelope DecoratedSDoc)-mkErrorReport ctxt tcl_env (Report important relevant_bindings valid_subs)-  = do { context <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env)-       ; mkDecoratedSDocAt (RealSrcSpan (tcl_loc tcl_env) Nothing)-                           (vcat important)-                           context-                           (vcat $ relevant_bindings ++ valid_subs)-       }--type UserGiven = Implication--getUserGivens :: ReportErrCtxt -> [UserGiven]--- One item for each enclosing implication-getUserGivens (CEC {cec_encl = implics}) = getUserGivensFromImplics implics--getUserGivensFromImplics :: [Implication] -> [UserGiven]-getUserGivensFromImplics implics-  = reverse (filterOut (null . ic_given) implics)--{- Note [Always warn with -fdefer-type-errors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When -fdefer-type-errors is on we warn about *all* type errors, even-if cec_suppress is on.  This can lead to a lot more warnings than you-would get errors without -fdefer-type-errors, but if we suppress any of-them you might get a runtime error that wasn't warned about at compile-time.--This is an easy design choice to change; just flip the order of the-first two equations for maybeReportError--To be consistent, we should also report multiple warnings from a single-location in mkGroupReporter, when -fdefer-type-errors is on.  But that-is perhaps a bit *over*-consistent! Again, an easy choice to change.--With #10283, you can now opt out of deferred type error warnings.--Note [Deferred errors for coercion holes]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we need to defer a type error where the destination for the evidence-is a coercion hole. We can't just put the error in the hole, because we can't-make an erroneous coercion. (Remember that coercions are erased for runtime.)-Instead, we invent a new EvVar, bind it to an error and then make a coercion-from that EvVar, filling the hole with that coercion. Because coercions'-types are unlifted, the error is guaranteed to be hit before we get to the-coercion.--Note [Do not report derived but soluble errors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The wc_simples include Derived constraints that have not been solved,-but are not insoluble (in that case they'd be reported by 'report1').-We do not want to report these as errors:--* Superclass constraints. If we have an unsolved [W] Ord a, we'll also have-  an unsolved [D] Eq a, and we do not want to report that; it's just noise.--* Functional dependencies.  For givens, consider-      class C a b | a -> b-      data T a where-         MkT :: C a d => [d] -> T a-      f :: C a b => T a -> F Int-      f (MkT xs) = length xs-  Then we get a [D] b~d.  But there *is* a legitimate call to-  f, namely   f (MkT [True]) :: T Bool, in which b=d.  So we should-  not reject the program.--  For wanteds, something similar-      data T a where-        MkT :: C Int b => a -> b -> T a-      g :: C Int c => c -> ()-      f :: T a -> ()-      f (MkT x y) = g x-  Here we get [G] C Int b, [W] C Int a, hence [D] a~b.-  But again f (MkT True True) is a legitimate call.--(We leave the Deriveds in wc_simple until reportErrors, so that we don't lose-derived superclasses between iterations of the solver.)--For functional dependencies, here is a real example,-stripped off from libraries/utf8-string/Codec/Binary/UTF8/Generic.hs--  class C a b | a -> b-  g :: C a b => a -> b -> ()-  f :: C a b => a -> b -> ()-  f xa xb =-      let loop = g xa-      in loop xb--We will first try to infer a type for loop, and we will succeed:-    C a b' => b' -> ()-Subsequently, we will type check (loop xb) and all is good. But,-recall that we have to solve a final implication constraint:-    C a b => (C a b' => .... cts from body of loop .... ))-And now we have a problem as we will generate an equality b ~ b' and fail to-solve it.---************************************************************************-*                                                                      *-                Irreducible predicate errors-*                                                                      *-************************************************************************--}--mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc)-mkIrredErr ctxt cts-  = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1-       ; let orig = ctOrigin ct1-             msg  = couldNotDeduce (getUserGivens ctxt) (map ctPred cts, orig)-       ; mkErrorMsgFromCt ctxt ct1 $-         msg `mappend` mk_relevant_bindings binds_msg }-  where-    (ct1:_) = cts-------------------mkHoleError :: NameEnv Type -> [Ct] -> ReportErrCtxt -> Hole -> TcM (MsgEnvelope DecoratedSDoc)-mkHoleError _ _tidy_simples _ctxt hole@(Hole { hole_occ = occ-                                           , hole_ty = hole_ty-                                           , hole_loc = ct_loc })-  | isOutOfScopeHole hole-  = do { dflags  <- getDynFlags-       ; rdr_env <- getGlobalRdrEnv-       ; imp_info <- getImports-       ; curr_mod <- getModule-       ; hpt <- getHpt-       ; mkDecoratedSDocAt (RealSrcSpan (tcl_loc lcl_env) Nothing)-                           out_of_scope_msg O.empty-                           (unknownNameSuggestions dflags hpt curr_mod rdr_env-                            (tcl_rdr lcl_env) imp_info (mkRdrUnqual occ)) }-  where-    herald | isDataOcc occ = text "Data constructor not in scope:"-           | otherwise     = text "Variable not in scope:"--    out_of_scope_msg -- Print v :: ty only if the type has structure-      | boring_type = hang herald 2 (ppr occ)-      | otherwise   = hang herald 2 (pp_occ_with_type occ hole_ty)--    lcl_env     = ctLocEnv ct_loc-    boring_type = isTyVarTy hole_ty-- -- general case: not an out-of-scope error-mkHoleError lcl_name_cache tidy_simples ctxt hole@(Hole { hole_occ = occ-                                         , hole_ty = hole_ty-                                         , hole_sort = sort-                                         , hole_loc = ct_loc })-  = do { binds_msg-           <- relevant_bindings False lcl_env lcl_name_cache (tyCoVarsOfType hole_ty)-               -- The 'False' means "don't filter the bindings"; see Trac #8191--       ; show_hole_constraints <- goptM Opt_ShowHoleConstraints-       ; let constraints_msg-               | ExprHole _ <- sort, show_hole_constraints-               = givenConstraintsMsg ctxt-               | otherwise-               = empty--       ; show_valid_hole_fits <- goptM Opt_ShowValidHoleFits-       ; (ctxt, sub_msg) <- if show_valid_hole_fits-                            then validHoleFits ctxt tidy_simples hole-                            else return (ctxt, empty)--       ; mkErrorReport ctxt lcl_env $-            important hole_msg `mappend`-            mk_relevant_bindings (binds_msg $$ constraints_msg) `mappend`-            valid_hole_fits sub_msg }--  where-    lcl_env     = ctLocEnv ct_loc-    hole_kind   = tcTypeKind hole_ty-    tyvars      = tyCoVarsOfTypeList hole_ty--    hole_msg = case sort of-      ExprHole _ -> vcat [ hang (text "Found hole:")-                            2 (pp_occ_with_type occ hole_ty)-                         , tyvars_msg, expr_hole_hint ]-      TypeHole -> vcat [ hang (text "Found type wildcard" <+> quotes (ppr occ))-                            2 (text "standing for" <+> quotes pp_hole_type_with_kind)-                       , tyvars_msg, type_hole_hint ]-      ConstraintHole -> vcat [ hang (text "Found extra-constraints wildcard standing for")-                                  2 (quotes $ pprType hole_ty)  -- always kind constraint-                             , tyvars_msg, type_hole_hint ]--    pp_hole_type_with_kind-      | isLiftedTypeKind hole_kind-        || isCoVarType hole_ty -- Don't print the kind of unlifted-                               -- equalities (#15039)-      = pprType hole_ty-      | otherwise-      = pprType hole_ty <+> dcolon <+> pprKind hole_kind--    tyvars_msg = ppUnless (null tyvars) $-                 text "Where:" <+> (vcat (map loc_msg other_tvs)-                                    $$ pprSkols ctxt skol_tvs)-       where-         (skol_tvs, other_tvs) = partition is_skol tyvars-         is_skol tv = isTcTyVar tv && isSkolemTyVar tv-                      -- Coercion variables can be free in the-                      -- hole, via kind casts--    type_hole_hint-         | HoleError <- cec_type_holes ctxt-         = text "To use the inferred type, enable PartialTypeSignatures"-         | otherwise-         = empty--    expr_hole_hint                       -- Give hint for, say,   f x = _x-         | lengthFS (occNameFS occ) > 1  -- Don't give this hint for plain "_"-         = text "Or perhaps" <+> quotes (ppr occ)-           <+> text "is mis-spelled, or not in scope"-         | otherwise-         = empty--    loc_msg tv-       | isTyVar tv-       = case tcTyVarDetails tv of-           MetaTv {} -> quotes (ppr tv) <+> text "is an ambiguous type variable"-           _         -> empty  -- Skolems dealt with already-       | otherwise  -- A coercion variable can be free in the hole type-       = ppWhenOption sdocPrintExplicitCoercions $-           quotes (ppr tv) <+> text "is a coercion variable"--pp_occ_with_type :: OccName -> Type -> SDoc-pp_occ_with_type occ hole_ty = hang (pprPrefixOcc occ) 2 (dcolon <+> pprType hole_ty)---- We unwrap the ReportErrCtxt here, to avoid introducing a loop in module--- imports-validHoleFits :: ReportErrCtxt -- The context we're in, i.e. the-                                        -- implications and the tidy environment-                       -> [Ct]          -- Unsolved simple constraints-                       -> Hole          -- The hole-                       -> TcM (ReportErrCtxt, SDoc) -- We return the new context-                                                    -- with a possibly updated-                                                    -- tidy environment, and-                                                    -- the message.-validHoleFits ctxt@(CEC {cec_encl = implics-                             , cec_tidy = lcl_env}) simps hole-  = do { (tidy_env, msg) <- findValidHoleFits lcl_env implics simps hole-       ; return (ctxt {cec_tidy = tidy_env}, msg) }---- See Note [Constraints include ...]-givenConstraintsMsg :: ReportErrCtxt -> SDoc-givenConstraintsMsg ctxt =-    let constraints :: [(Type, RealSrcSpan)]-        constraints =-          do { implic@Implic{ ic_given = given } <- cec_encl ctxt-             ; constraint <- given-             ; return (varType constraint, tcl_loc (ic_env implic)) }--        pprConstraint (constraint, loc) =-          ppr constraint <+> nest 2 (parens (text "from" <+> ppr loc))--    in ppUnless (null constraints) $-         hang (text "Constraints include")-            2 (vcat $ map pprConstraint constraints)-------------------mkIPErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc)-mkIPErr ctxt cts-  = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1-       ; let orig    = ctOrigin ct1-             preds   = map ctPred cts-             givens  = getUserGivens ctxt-             msg | null givens-                 = important $ addArising orig $-                   sep [ text "Unbound implicit parameter" <> plural cts-                       , nest 2 (pprParendTheta preds) ]-                 | otherwise-                 = couldNotDeduce givens (preds, orig)--       ; mkErrorMsgFromCt ctxt ct1 $-         msg `mappend` mk_relevant_bindings binds_msg }-  where-    (ct1:_) = cts--{--Note [Constraints include ...]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-'givenConstraintsMsg' returns the "Constraints include ..." message enabled by--fshow-hole-constraints. For example, the following hole:--    foo :: (Eq a, Show a) => a -> String-    foo x = _--would generate the message:--    Constraints include-      Eq a (from foo.hs:1:1-36)-      Show a (from foo.hs:1:1-36)--Constraints are displayed in order from innermost (closest to the hole) to-outermost. There's currently no filtering or elimination of duplicates.--************************************************************************-*                                                                      *-                Equality errors-*                                                                      *-************************************************************************--Note [Inaccessible code]-~~~~~~~~~~~~~~~~~~~~~~~~-Consider-   data T a where-     T1 :: T a-     T2 :: T Bool--   f :: (a ~ Int) => T a -> Int-   f T1 = 3-   f T2 = 4   -- Unreachable code--Here the second equation is unreachable. The original constraint-(a~Int) from the signature gets rewritten by the pattern-match to-(Bool~Int), so the danger is that we report the error as coming from-the *signature* (#7293).  So, for Given errors we replace the-env (and hence src-loc) on its CtLoc with that from the immediately-enclosing implication.--Note [Error messages for untouchables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider (#9109)-  data G a where { GBool :: G Bool }-  foo x = case x of GBool -> True--Here we can't solve (t ~ Bool), where t is the untouchable result-meta-var 't', because of the (a ~ Bool) from the pattern match.-So we infer the type-   f :: forall a t. G a -> t-making the meta-var 't' into a skolem.  So when we come to report-the unsolved (t ~ Bool), t won't look like an untouchable meta-var-any more.  So we don't assert that it is.--}---- Don't have multiple equality errors from the same location--- E.g.   (Int,Bool) ~ (Bool,Int)   one error will do!-mkEqErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc)-mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct-mkEqErr _ [] = panic "mkEqErr"--mkEqErr1 :: ReportErrCtxt -> Ct -> TcM (MsgEnvelope DecoratedSDoc)-mkEqErr1 ctxt ct   -- Wanted or derived;-                   -- givens handled in mkGivenErrorReporter-  = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct-       ; rdr_env <- getGlobalRdrEnv-       ; fam_envs <- tcGetFamInstEnvs-       ; let coercible_msg = case ctEqRel ct of-               NomEq  -> empty-               ReprEq -> mkCoercibleExplanation rdr_env fam_envs ty1 ty2-       ; dflags <- getDynFlags-       ; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctOrigin ct))-       ; let report = mconcat [ important coercible_msg-                              , mk_relevant_bindings binds_msg]-       ; mkEqErr_help dflags ctxt report ct ty1 ty2 }-  where-    (ty1, ty2) = getEqPredTys (ctPred ct)---- | This function tries to reconstruct why a "Coercible ty1 ty2" constraint--- is left over.-mkCoercibleExplanation :: GlobalRdrEnv -> FamInstEnvs-                       -> TcType -> TcType -> SDoc-mkCoercibleExplanation rdr_env fam_envs ty1 ty2-  | Just (tc, tys) <- tcSplitTyConApp_maybe ty1-  , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys-  , Just msg <- coercible_msg_for_tycon rep_tc-  = msg-  | Just (tc, tys) <- splitTyConApp_maybe ty2-  , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys-  , Just msg <- coercible_msg_for_tycon rep_tc-  = msg-  | Just (s1, _) <- tcSplitAppTy_maybe ty1-  , Just (s2, _) <- tcSplitAppTy_maybe ty2-  , s1 `eqType` s2-  , has_unknown_roles s1-  = hang (text "NB: We cannot know what roles the parameters to" <+>-          quotes (ppr s1) <+> text "have;")-       2 (text "we must assume that the role is nominal")-  | otherwise-  = empty-  where-    coercible_msg_for_tycon tc-        | isAbstractTyCon tc-        = Just $ hsep [ text "NB: The type constructor"-                      , quotes (pprSourceTyCon tc)-                      , text "is abstract" ]-        | isNewTyCon tc-        , [data_con] <- tyConDataCons tc-        , let dc_name = dataConName data_con-        , isNothing (lookupGRE_Name rdr_env dc_name)-        = Just $ hang (text "The data constructor" <+> quotes (ppr dc_name))-                    2 (sep [ text "of newtype" <+> quotes (pprSourceTyCon tc)-                           , text "is not in scope" ])-        | otherwise = Nothing--    has_unknown_roles ty-      | Just (tc, tys) <- tcSplitTyConApp_maybe ty-      = tys `lengthAtLeast` tyConArity tc  -- oversaturated tycon-      | Just (s, _) <- tcSplitAppTy_maybe ty-      = has_unknown_roles s-      | isTyVarTy ty-      = True-      | otherwise-      = False--mkEqErr_help :: DynFlags -> ReportErrCtxt -> Report-             -> Ct-             -> TcType -> TcType -> TcM (MsgEnvelope DecoratedSDoc)-mkEqErr_help dflags ctxt report ct ty1 ty2-  | Just (tv1, _) <- tcGetCastedTyVar_maybe ty1-  = mkTyVarEqErr dflags ctxt report ct tv1 ty2-  | Just (tv2, _) <- tcGetCastedTyVar_maybe ty2-  = mkTyVarEqErr dflags ctxt report ct tv2 ty1-  | otherwise-  = reportEqErr ctxt report ct ty1 ty2--reportEqErr :: ReportErrCtxt -> Report-            -> Ct-            -> TcType -> TcType -> TcM (MsgEnvelope DecoratedSDoc)-reportEqErr ctxt report ct ty1 ty2-  = mkErrorMsgFromCt ctxt ct (mconcat [misMatch, report, eqInfo])-  where-    misMatch = misMatchOrCND False ctxt ct ty1 ty2-    eqInfo   = mkEqInfoMsg ct ty1 ty2--mkTyVarEqErr, mkTyVarEqErr'-  :: DynFlags -> ReportErrCtxt -> Report -> Ct-             -> TcTyVar -> TcType -> TcM (MsgEnvelope DecoratedSDoc)--- tv1 and ty2 are already tidied-mkTyVarEqErr dflags ctxt report ct tv1 ty2-  = do { traceTc "mkTyVarEqErr" (ppr ct $$ ppr tv1 $$ ppr ty2)-       ; mkTyVarEqErr' dflags ctxt report ct tv1 ty2 }--mkTyVarEqErr' dflags ctxt report ct tv1 ty2-     -- impredicativity is a simple error to understand; try it first-  | check_eq_result `cterHasProblem` cteImpredicative-  = let msg = vcat [ (if isSkolemTyVar tv1-                      then text "Cannot equate type variable"-                      else text "Cannot instantiate unification variable")-                     <+> quotes (ppr tv1)-                   , hang (text "with a" <+> what <+> text "involving polytypes:") 2 (ppr ty2) ]-    in-       -- Unlike the other reports, this discards the old 'report_important'-       -- instead of augmenting it.  This is because the details are not likely-       -- to be helpful since this is just an unimplemented feature.-    mkErrorMsgFromCt ctxt ct $ mconcat-        [ headline_msg-        , important msg-        , if isSkolemTyVar tv1 then extraTyVarEqInfo ctxt tv1 ty2 else mempty-        , report ]--  | isSkolemTyVar tv1  -- ty2 won't be a meta-tyvar; we would have-                       -- swapped in Solver.Canonical.canEqTyVarHomo-    || isTyVarTyVar tv1 && not (isTyVarTy ty2)-    || ctEqRel ct == ReprEq-     -- The cases below don't really apply to ReprEq (except occurs check)-  = mkErrorMsgFromCt ctxt ct $ mconcat-        [ headline_msg-        , extraTyVarEqInfo ctxt tv1 ty2-        , suggestAddSig ctxt ty1 ty2-        , report-        ]--  | cterHasOccursCheck check_eq_result-    -- We report an "occurs check" even for  a ~ F t a, where F is a type-    -- function; it's not insoluble (because in principle F could reduce)-    -- but we have certainly been unable to solve it-    -- See Note [Occurs check error] in GHC.Tc.Solver.Canonical-  = do { let extra2   = mkEqInfoMsg ct ty1 ty2--             interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $-                                  filter isTyVar $-                                  fvVarList $-                                  tyCoFVsOfType ty1 `unionFV` tyCoFVsOfType ty2-             extra3 = mk_relevant_bindings $-                      ppWhen (not (null interesting_tyvars)) $-                      hang (text "Type variable kinds:") 2 $-                      vcat (map (tyvar_binding . tidyTyCoVarOcc (cec_tidy ctxt))-                                interesting_tyvars)--             tyvar_binding tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv)-       ; mkErrorMsgFromCt ctxt ct $-         mconcat [headline_msg, extra2, extra3, report] }--  -- If the immediately-enclosing implication has 'tv' a skolem, and-  -- we know by now its an InferSkol kind of skolem, then presumably-  -- it started life as a TyVarTv, else it'd have been unified, given-  -- that there's no occurs-check or forall problem-  | (implic:_) <- cec_encl ctxt-  , Implic { ic_skols = skols } <- implic-  , tv1 `elem` skols-  = mkErrorMsgFromCt ctxt ct $ mconcat-        [ misMatchMsg ctxt ct ty1 ty2-        , extraTyVarEqInfo ctxt tv1 ty2-        , report-        ]--  -- Check for skolem escape-  | (implic:_) <- cec_encl ctxt   -- Get the innermost context-  , Implic { ic_skols = skols, ic_info = skol_info } <- implic-  , let esc_skols = filter (`elemVarSet` (tyCoVarsOfType ty2)) skols-  , not (null esc_skols)-  = do { let msg = misMatchMsg ctxt ct ty1 ty2-             esc_doc = sep [ text "because" <+> what <+> text "variable" <> plural esc_skols-                             <+> pprQuotedList esc_skols-                           , text "would escape" <+>-                             if isSingleton esc_skols then text "its scope"-                                                      else text "their scope" ]-             tv_extra = important $-                        vcat [ nest 2 $ esc_doc-                             , sep [ (if isSingleton esc_skols-                                      then text "This (rigid, skolem)" <+>-                                           what <+> text "variable is"-                                      else text "These (rigid, skolem)" <+>-                                           what <+> text "variables are")-                               <+> text "bound by"-                             , nest 2 $ ppr skol_info-                             , nest 2 $ text "at" <+>-                               ppr (tcl_loc (ic_env implic)) ] ]-       ; mkErrorMsgFromCt ctxt ct (mconcat [msg, tv_extra, report]) }--  -- Nastiest case: attempt to unify an untouchable variable-  -- So tv is a meta tyvar (or started that way before we-  -- generalised it).  So presumably it is an *untouchable*-  -- meta tyvar or a TyVarTv, else it'd have been unified-  -- See Note [Error messages for untouchables]-  | (implic:_) <- cec_encl ctxt   -- Get the innermost context-  , Implic { ic_given = given, ic_tclvl = lvl, ic_info = skol_info } <- implic-  = ASSERT2( not (isTouchableMetaTyVar lvl tv1)-           , ppr tv1 $$ ppr lvl )  -- See Note [Error messages for untouchables]-    do { let msg = misMatchMsg ctxt ct ty1 ty2-             tclvl_extra = important $-                  nest 2 $-                  sep [ quotes (ppr tv1) <+> text "is untouchable"-                      , nest 2 $ text "inside the constraints:" <+> pprEvVarTheta given-                      , nest 2 $ text "bound by" <+> ppr skol_info-                      , nest 2 $ text "at" <+>-                        ppr (tcl_loc (ic_env implic)) ]-             tv_extra = extraTyVarEqInfo ctxt tv1 ty2-             add_sig  = suggestAddSig ctxt ty1 ty2-       ; mkErrorMsgFromCt ctxt ct $ mconcat-            [msg, tclvl_extra, tv_extra, add_sig, report] }--  | otherwise-  = reportEqErr ctxt report ct (mkTyVarTy tv1) ty2-        -- This *can* happen (#6123)-        -- Consider an ambiguous top-level constraint (a ~ F a)-        -- Not an occurs check, because F is a type function.-  where-    headline_msg = misMatchOrCND insoluble_occurs_check ctxt ct ty1 ty2--    ty1 = mkTyVarTy tv1--    check_eq_result = case ct of-      CIrredCan { cc_reason = NonCanonicalReason result } -> result-      CIrredCan { cc_reason = HoleBlockerReason {} }      -> cteProblem cteHoleBlocker-      _ -> checkTyVarEq dflags tv1 ty2-        -- in T2627b, we report an error for F (F a0) ~ a0. Note that the type-        -- variable is on the right, so we don't get useful info for the CIrredCan,-        -- and have to compute the result of checkTyVarEq here.---    insoluble_occurs_check = check_eq_result `cterHasProblem` cteInsolubleOccurs--    what = text $ levelString $-           ctLocTypeOrKind_maybe (ctLoc ct) `orElse` TypeLevel--levelString :: TypeOrKind -> String-levelString TypeLevel = "type"-levelString KindLevel = "kind"--mkEqInfoMsg :: Ct -> TcType -> TcType -> Report--- Report (a) ambiguity if either side is a type function application---            e.g. F a0 ~ Int---        (b) warning about injectivity if both sides are the same---            type function application   F a ~ F b---            See Note [Non-injective type functions]-mkEqInfoMsg ct ty1 ty2-  = important (tyfun_msg $$ ambig_msg)-  where-    mb_fun1 = isTyFun_maybe ty1-    mb_fun2 = isTyFun_maybe ty2--    ambig_msg | isJust mb_fun1 || isJust mb_fun2-              = snd (mkAmbigMsg False ct)-              | otherwise = empty--    tyfun_msg | Just tc1 <- mb_fun1-              , Just tc2 <- mb_fun2-              , tc1 == tc2-              , not (isInjectiveTyCon tc1 Nominal)-              = text "NB:" <+> quotes (ppr tc1)-                <+> text "is a non-injective type family"-              | otherwise = empty--misMatchOrCND :: Bool -> ReportErrCtxt -> Ct-              -> TcType -> TcType -> Report--- If oriented then ty1 is actual, ty2 is expected-misMatchOrCND insoluble_occurs_check ctxt ct ty1 ty2-  | insoluble_occurs_check  -- See Note [Insoluble occurs check]-    || (isRigidTy ty1 && isRigidTy ty2)-    || isGivenCt ct-    || null givens-  = -- If the equality is unconditionally insoluble-    -- or there is no context, don't report the context-    misMatchMsg ctxt ct ty1 ty2--  | otherwise-  = mconcat [ couldNotDeduce givens ([eq_pred], orig)-            , important $ mk_supplementary_ea_msg ctxt level ty1 ty2 orig ]-  where-    ev      = ctEvidence ct-    eq_pred = ctEvPred ev-    orig    = ctEvOrigin ev-    level   = ctLocTypeOrKind_maybe (ctEvLoc ev) `orElse` TypeLevel-    givens  = [ given | given <- getUserGivens ctxt, ic_given_eqs given /= NoGivenEqs ]-              -- Keep only UserGivens that have some equalities.-              -- See Note [Suppress redundant givens during error reporting]--couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> Report-couldNotDeduce givens (wanteds, orig)-  = important $-    vcat [ addArising orig (text "Could not deduce:" <+> pprTheta wanteds)-         , vcat (pp_givens givens)]--pp_givens :: [UserGiven] -> [SDoc]-pp_givens givens-   = case givens of-         []     -> []-         (g:gs) ->      ppr_given (text "from the context:") g-                 : map (ppr_given (text "or from:")) gs-    where-       ppr_given herald implic@(Implic { ic_given = gs, ic_info = skol_info })-           = hang (herald <+> pprEvVarTheta (mkMinimalBySCs evVarPred gs))-             -- See Note [Suppress redundant givens during error reporting]-             -- for why we use mkMinimalBySCs above.-                2 (sep [ text "bound by" <+> ppr skol_info-                       , text "at" <+> ppr (tcl_loc (ic_env implic)) ])---- These are for the "blocked" equalities, as described in TcCanonical--- Note [Equalities with incompatible kinds], wrinkle (2). There should--- always be another unsolved wanted around, which will ordinarily suppress--- this message. But this can still be printed out with -fdefer-type-errors--- (sigh), so we must produce a message.-mkBlockedEqErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc)-mkBlockedEqErr ctxt (ct:_) = mkErrorMsgFromCt ctxt ct report-  where-    report = important msg-    msg = vcat [ hang (text "Cannot use equality for substitution:")-                   2 (ppr (ctPred ct))-               , text "Doing so would be ill-kinded." ]-          -- This is a terrible message. Perhaps worse, if the user-          -- has -fprint-explicit-kinds on, they will see that the two-          -- sides have the same kind, as there is an invisible cast.-          -- I really don't know how to do better.-mkBlockedEqErr _ [] = panic "mkBlockedEqErr no constraints"--{--Note [Suppress redundant givens during error reporting]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When GHC is unable to solve a constraint and prints out an error message, it-will print out what given constraints are in scope to provide some context to-the programmer. But we shouldn't print out /every/ given, since some of them-are not terribly helpful to diagnose type errors. Consider this example:--  foo :: Int :~: Int -> a :~: b -> a :~: c-  foo Refl Refl = Refl--When reporting that GHC can't solve (a ~ c), there are two givens in scope:-(Int ~ Int) and (a ~ b). But (Int ~ Int) is trivially soluble (i.e.,-redundant), so it's not terribly useful to report it in an error message.-To accomplish this, we discard any Implications that do not bind any-equalities by filtering the `givens` selected in `misMatchOrCND` (based on-the `ic_given_eqs` field of the Implication). Note that we discard givens-that have no equalities whatsoever, but we want to keep ones with only *local*-equalities, as these may be helpful to the user in understanding what went-wrong.--But this is not enough to avoid all redundant givens! Consider this example,-from #15361:--  goo :: forall (a :: Type) (b :: Type) (c :: Type).-         a :~~: b -> a :~~: c-  goo HRefl = HRefl--Matching on HRefl brings the /single/ given (* ~ *, a ~ b) into scope.-The (* ~ *) part arises due the kinds of (:~~:) being unified. More-importantly, (* ~ *) is redundant, so we'd like not to report it. However,-the Implication (* ~ *, a ~ b) /does/ bind an equality (as reported by its-ic_given_eqs field), so the test above will keep it wholesale.--To refine this given, we apply mkMinimalBySCs on it to extract just the (a ~ b)-part. This works because mkMinimalBySCs eliminates reflexive equalities in-addition to superclasses (see Note [Remove redundant provided dicts]-in GHC.Tc.TyCl.PatSyn).--}--extraTyVarEqInfo :: ReportErrCtxt -> TcTyVar -> TcType -> Report--- Add on extra info about skolem constants--- NB: The types themselves are already tidied-extraTyVarEqInfo ctxt tv1 ty2-  = important (extraTyVarInfo ctxt tv1 $$ ty_extra ty2)-  where-    ty_extra ty = case tcGetCastedTyVar_maybe ty of-                    Just (tv, _) -> extraTyVarInfo ctxt tv-                    Nothing      -> empty--extraTyVarInfo :: ReportErrCtxt -> TcTyVar -> SDoc-extraTyVarInfo ctxt tv-  = ASSERT2( isTyVar tv, ppr tv )-    case tcTyVarDetails tv of-          SkolemTv {}   -> pprSkols ctxt [tv]-          RuntimeUnk {} -> quotes (ppr tv) <+> text "is an interactive-debugger skolem"-          MetaTv {}     -> empty--suggestAddSig :: ReportErrCtxt -> TcType -> TcType -> Report--- See Note [Suggest adding a type signature]-suggestAddSig ctxt ty1 _ty2-  | null inferred_bndrs   -- No let-bound inferred binders in context-  = mempty-  | [bndr] <- inferred_bndrs-  = important $ text "Possible fix: add a type signature for" <+> quotes (ppr bndr)-  | otherwise-  = important $ text "Possible fix: add type signatures for some or all of" <+> (ppr inferred_bndrs)-  where-    inferred_bndrs = case tcGetTyVar_maybe ty1 of-                       Just tv | isSkolemTyVar tv -> find (cec_encl ctxt) False tv-                       _                          -> []--    -- 'find' returns the binders of an InferSkol for 'tv',-    -- provided there is an intervening implication with-    -- ic_given_eqs /= NoGivenEqs (i.e. a GADT match)-    find [] _ _ = []-    find (implic:implics) seen_eqs tv-       | tv `elem` ic_skols implic-       , InferSkol prs <- ic_info implic-       , seen_eqs-       = map fst prs-       | otherwise-       = find implics (seen_eqs || ic_given_eqs implic /= NoGivenEqs) tv-----------------------misMatchMsg :: ReportErrCtxt -> Ct -> TcType -> TcType -> Report--- Types are already tidy--- If oriented then ty1 is actual, ty2 is expected-misMatchMsg ctxt ct ty1 ty2-  = important $-    addArising orig $-    pprWithExplicitKindsWhenMismatch ty1 ty2 orig $-    sep [ case orig of-            TypeEqOrigin {} -> tk_eq_msg ctxt ct ty1 ty2 orig-            KindEqOrigin {} -> tk_eq_msg ctxt ct ty1 ty2 orig-            _ -> headline_eq_msg False ct ty1 ty2-        , sameOccExtra ty2 ty1 ]-  where-    orig = ctOrigin ct--headline_eq_msg :: Bool -> Ct -> Type -> Type -> SDoc--- Generates the main "Could't match 't1' against 't2'--- headline message-headline_eq_msg add_ea ct ty1 ty2--  | (isLiftedRuntimeRep ty1 && isUnliftedRuntimeRep ty2) ||-    (isLiftedRuntimeRep ty2 && isUnliftedRuntimeRep ty1) ||-    (isLiftedLevity ty1 && isUnliftedLevity ty2) ||-    (isLiftedLevity ty2 && isUnliftedLevity ty1)-  = text "Couldn't match a lifted type with an unlifted type"--  | isAtomicTy ty1 || isAtomicTy ty2-  = -- Print with quotes-    sep [ text herald1 <+> quotes (ppr ty1)-        , nest padding $-          text herald2 <+> quotes (ppr ty2) ]--  | otherwise-  = -- Print with vertical layout-    vcat [ text herald1 <> colon <+> ppr ty1-         , nest padding $-           text herald2 <> colon <+> ppr ty2 ]-  where-    herald1 = conc [ "Couldn't match"-                   , if is_repr then "representation of" else ""-                   , if add_ea then "expected"          else ""-                   , what ]-    herald2 = conc [ "with"-                   , if is_repr then "that of"          else ""-                   , if add_ea then ("actual " ++ what) else "" ]--    padding = length herald1 - length herald2--    is_repr = case ctEqRel ct of { ReprEq -> True; NomEq -> False }--    what = levelString (ctLocTypeOrKind_maybe (ctLoc ct) `orElse` TypeLevel)--    conc :: [String] -> String-    conc = foldr1 add_space--    add_space :: String -> String -> String-    add_space s1 s2 | null s1   = s2-                    | null s2   = s1-                    | otherwise = s1 ++ (' ' : s2)---tk_eq_msg :: ReportErrCtxt-          -> Ct -> Type -> Type -> CtOrigin -> SDoc-tk_eq_msg ctxt ct ty1 ty2 orig@(TypeEqOrigin { uo_actual = act-                                             , uo_expected = exp-                                             , uo_thing = mb_thing })-  -- We can use the TypeEqOrigin to-  -- improve the error message quite a lot--  | isUnliftedTypeKind act, isLiftedTypeKind exp-  = sep [ text "Expecting a lifted type, but"-        , thing_msg mb_thing (text "an") (text "unlifted") ]--  | isLiftedTypeKind act, isUnliftedTypeKind exp-  = sep [ text "Expecting an unlifted type, but"-        , thing_msg mb_thing (text "a") (text "lifted") ]--  | tcIsLiftedTypeKind exp-  = maybe_num_args_msg $$-    sep [ text "Expected a type, but"-        , case mb_thing of-            Nothing    -> text "found something with kind"-            Just thing -> quotes thing <+> text "has kind"-        , quotes (pprWithTYPE act) ]--  | Just nargs_msg <- num_args_msg-  = nargs_msg $$-    mk_ea_msg ctxt (Just ct) level orig--  | -- pprTrace "check" (ppr ea_looks_same $$ ppr exp $$ ppr act $$ ppr ty1 $$ ppr ty2) $-    ea_looks_same ty1 ty2 exp act-  = mk_ea_msg ctxt (Just ct) level orig--  | otherwise  -- The mismatched types are /inside/ exp and act-  = vcat [ headline_eq_msg False ct ty1 ty2-         , mk_ea_msg ctxt Nothing level orig ]--  where-    ct_loc = ctLoc ct-    level  = ctLocTypeOrKind_maybe ct_loc `orElse` TypeLevel--    thing_msg (Just thing) _  levity = quotes thing <+> text "is" <+> levity-    thing_msg Nothing      an levity = text "got" <+> an <+> levity <+> text "type"--    num_args_msg = case level of-      KindLevel-        | not (isMetaTyVarTy exp) && not (isMetaTyVarTy act)-           -- if one is a meta-tyvar, then it's possible that the user-           -- has asked for something impredicative, and we couldn't unify.-           -- Don't bother with counting arguments.-        -> let n_act = count_args act-               n_exp = count_args exp in-           case n_act - n_exp of-             n | n > 0   -- we don't know how many args there are, so don't-                         -- recommend removing args that aren't-               , Just thing <- mb_thing-               -> Just $ text "Expecting" <+> speakN (abs n) <+>-                         more <+> quotes thing-               where-                 more-                  | n == 1    = text "more argument to"-                  | otherwise = text "more arguments to"  -- n > 1-             _ -> Nothing--      _ -> Nothing--    maybe_num_args_msg = num_args_msg `orElse` empty--    count_args ty = count isVisibleBinder $ fst $ splitPiTys ty--tk_eq_msg ctxt ct ty1 ty2-          (KindEqOrigin cty1 cty2 sub_o mb_sub_t_or_k)-  = vcat [ headline_eq_msg False ct ty1 ty2-         , supplementary_msg ]-  where-    sub_t_or_k = mb_sub_t_or_k `orElse` TypeLevel-    sub_whats  = text (levelString sub_t_or_k) <> char 's'-                 -- "types" or "kinds"--    supplementary_msg-      = sdocOption sdocPrintExplicitCoercions $ \printExplicitCoercions ->-        if printExplicitCoercions-           || not (cty1 `pickyEqType` cty2)-          then vcat [ hang (text "When matching" <+> sub_whats)-                          2 (vcat [ ppr cty1 <+> dcolon <+>-                                   ppr (tcTypeKind cty1)-                                 , ppr cty2 <+> dcolon <+>-                                   ppr (tcTypeKind cty2) ])-                    , mk_supplementary_ea_msg ctxt sub_t_or_k cty1 cty2 sub_o ]-          else text "When matching the kind of" <+> quotes (ppr cty1)--tk_eq_msg _ _ _ _ _ = panic "typeeq_mismatch_msg"--ea_looks_same :: Type -> Type -> Type -> Type -> Bool--- True if the faulting types (ty1, ty2) look the same as--- the expected/actual types (exp, act).--- If so, we don't want to redundantly report the latter-ea_looks_same ty1 ty2 exp act-  = (act `looks_same` ty1 && exp `looks_same` ty2) ||-    (exp `looks_same` ty1 && act `looks_same` ty2)-  where-    looks_same t1 t2 = t1 `pickyEqType` t2-                    || t1 `eqType` liftedTypeKind && t2 `eqType` liftedTypeKind-      -- pickyEqType is sensitive to synonyms, so only replies True-      -- when the types really look the same.  However,-      -- (TYPE 'LiftedRep) and Type both print the same way.--mk_supplementary_ea_msg :: ReportErrCtxt -> TypeOrKind-                        -> Type -> Type -> CtOrigin -> SDoc-mk_supplementary_ea_msg ctxt level ty1 ty2 orig-  | TypeEqOrigin { uo_expected = exp, uo_actual = act } <- orig-  , not (ea_looks_same ty1 ty2 exp act)-  = mk_ea_msg ctxt Nothing level orig-  | otherwise-  = empty--mk_ea_msg :: ReportErrCtxt -> Maybe Ct -> TypeOrKind -> CtOrigin -> SDoc--- Constructs a "Couldn't match" message--- The (Maybe Ct) says whether this is the main top-level message (Just)---     or a supplementary message (Nothing)-mk_ea_msg ctxt at_top level-          (TypeEqOrigin { uo_actual = act, uo_expected = exp, uo_thing = mb_thing })-  | Just thing <- mb_thing-  , KindLevel <- level-  = hang (text "Expected" <+> kind_desc <> comma)-       2 (text "but" <+> quotes thing <+> text "has kind" <+>-          quotes (ppr act))--  | otherwise-  = vcat [ case at_top of-              Just ct -> headline_eq_msg True ct exp act-              Nothing -> supplementary_ea_msg-         , ppWhen expand_syns expandedTys ]--  where-    supplementary_ea_msg = vcat [ text "Expected:" <+> ppr exp-                                , text "  Actual:" <+> ppr act ]--    kind_desc | tcIsConstraintKind exp = text "a constraint"-              | Just arg <- kindRep_maybe exp  -- TYPE t0-              , tcIsTyVarTy arg = sdocOption sdocPrintExplicitRuntimeReps $ \case-                                   True  -> text "kind" <+> quotes (ppr exp)-                                   False -> text "a type"-              | otherwise       = text "kind" <+> quotes (ppr exp)--    expand_syns = cec_expand_syns ctxt--    expandedTys = ppUnless (expTy1 `pickyEqType` exp && expTy2 `pickyEqType` act) $ vcat-                  [ text "Type synonyms expanded:"-                  , text "Expected type:" <+> ppr expTy1-                  , text "  Actual type:" <+> ppr expTy2 ]--    (expTy1, expTy2) = expandSynonymsToMatch exp act--mk_ea_msg _ _ _ _ = empty---- | Prints explicit kinds (with @-fprint-explicit-kinds@) in an 'SDoc' when a--- type mismatch occurs to due invisible kind arguments.------ This function first checks to see if the 'CtOrigin' argument is a--- 'TypeEqOrigin', and if so, uses the expected/actual types from that to--- check for a kind mismatch (as these types typically have more surrounding--- types and are likelier to be able to glean information about whether a--- mismatch occurred in an invisible argument position or not). If the--- 'CtOrigin' is not a 'TypeEqOrigin', fall back on the actual mismatched types--- themselves.-pprWithExplicitKindsWhenMismatch :: Type -> Type -> CtOrigin-                                 -> SDoc -> SDoc-pprWithExplicitKindsWhenMismatch ty1 ty2 ct-  = pprWithExplicitKindsWhen show_kinds-  where-    (act_ty, exp_ty) = case ct of-      TypeEqOrigin { uo_actual = act-                   , uo_expected = exp } -> (act, exp)-      _                                  -> (ty1, ty2)-    show_kinds = tcEqTypeVis act_ty exp_ty-                 -- True when the visible bit of the types look the same,-                 -- so we want to show the kinds in the displayed type--{- Note [Insoluble occurs check]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider [G] a ~ [a],  [W] a ~ [a] (#13674).  The Given is insoluble-so we don't use it for rewriting.  The Wanted is also insoluble, and-we don't solve it from the Given.  It's very confusing to say-    Cannot solve a ~ [a] from given constraints a ~ [a]--And indeed even thinking about the Givens is silly; [W] a ~ [a] is-just as insoluble as Int ~ Bool.--Conclusion: if there's an insoluble occurs check (cteInsolubleOccurs)-then report it directly, not in the "cannot deduce X from Y" form.-This is done in misMatchOrCND (via the insoluble_occurs_check arg)--(NB: there are potentially-soluble ones, like (a ~ F a b), and we don't-want to be as draconian with them.)--Note [Expanding type synonyms to make types similar]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--In type error messages, if -fprint-expanded-types is used, we want to expand-type synonyms to make expected and found types as similar as possible, but we-shouldn't expand types too much to make type messages even more verbose and-harder to understand. The whole point here is to make the difference in expected-and found types clearer.--`expandSynonymsToMatch` does this, it takes two types, and expands type synonyms-only as much as necessary. Given two types t1 and t2:--  * If they're already same, it just returns the types.--  * If they're in form `C1 t1_1 .. t1_n` and `C2 t2_1 .. t2_m` (C1 and C2 are-    type constructors), it expands C1 and C2 if they're different type synonyms.-    Then it recursively does the same thing on expanded types. If C1 and C2 are-    same, then it applies the same procedure to arguments of C1 and arguments of-    C2 to make them as similar as possible.--    Most important thing here is to keep number of synonym expansions at-    minimum. For example, if t1 is `T (T3, T5, Int)` and t2 is `T (T5, T3,-    Bool)` where T5 = T4, T4 = T3, ..., T1 = X, it returns `T (T3, T3, Int)` and-    `T (T3, T3, Bool)`.--  * Otherwise types don't have same shapes and so the difference is clearly-    visible. It doesn't do any expansions and show these types.--Note that we only expand top-layer type synonyms. Only when top-layer-constructors are the same we start expanding inner type synonyms.--Suppose top-layer type synonyms of t1 and t2 can expand N and M times,-respectively. If their type-synonym-expanded forms will meet at some point (i.e.-will have same shapes according to `sameShapes` function), it's possible to find-where they meet in O(N+M) top-layer type synonym expansions and O(min(N,M))-comparisons. We first collect all the top-layer expansions of t1 and t2 in two-lists, then drop the prefix of the longer list so that they have same lengths.-Then we search through both lists in parallel, and return the first pair of-types that have same shapes. Inner types of these two types with same shapes-are then expanded using the same algorithm.--In case they don't meet, we return the last pair of types in the lists, which-has top-layer type synonyms completely expanded. (in this case the inner types-are not expanded at all, as the current form already shows the type error)--}---- | Expand type synonyms in given types only enough to make them as similar as--- possible. Returned types are the same in terms of used type synonyms.------ To expand all synonyms, see 'Type.expandTypeSynonyms'.------ See `ExpandSynsFail` tests in tests testsuite/tests/typecheck/should_fail for--- some examples of how this should work.-expandSynonymsToMatch :: Type -> Type -> (Type, Type)-expandSynonymsToMatch ty1 ty2 = (ty1_ret, ty2_ret)-  where-    (ty1_ret, ty2_ret) = go ty1 ty2--    -- | Returns (type synonym expanded version of first type,-    --            type synonym expanded version of second type)-    go :: Type -> Type -> (Type, Type)-    go t1 t2-      | t1 `pickyEqType` t2 =-        -- Types are same, nothing to do-        (t1, t2)--    go (TyConApp tc1 tys1) (TyConApp tc2 tys2)-      | tc1 == tc2-      , tys1 `equalLength` tys2 =-        -- Type constructors are same. They may be synonyms, but we don't-        -- expand further. The lengths of tys1 and tys2 must be equal;-        -- for example, with type S a = a, we don't want-        -- to zip (S Monad Int) and (S Bool).-        let (tys1', tys2') =-              unzip (zipWithEqual "expandSynonymsToMatch" go tys1 tys2)-         in (TyConApp tc1 tys1', TyConApp tc2 tys2')--    go (AppTy t1_1 t1_2) (AppTy t2_1 t2_2) =-      let (t1_1', t2_1') = go t1_1 t2_1-          (t1_2', t2_2') = go t1_2 t2_2-       in (mkAppTy t1_1' t1_2', mkAppTy t2_1' t2_2')--    go ty1@(FunTy _ w1 t1_1 t1_2) ty2@(FunTy _ w2 t2_1 t2_2) | w1 `eqType` w2 =-      let (t1_1', t2_1') = go t1_1 t2_1-          (t1_2', t2_2') = go t1_2 t2_2-       in ( ty1 { ft_arg = t1_1', ft_res = t1_2' }-          , ty2 { ft_arg = t2_1', ft_res = t2_2' })--    go (ForAllTy b1 t1) (ForAllTy b2 t2) =-      -- NOTE: We may have a bug here, but we just can't reproduce it easily.-      -- See D1016 comments for details and our attempts at producing a test-      -- case. Short version: We probably need RnEnv2 to really get this right.-      let (t1', t2') = go t1 t2-       in (ForAllTy b1 t1', ForAllTy b2 t2')--    go (CastTy ty1 _) ty2 = go ty1 ty2-    go ty1 (CastTy ty2 _) = go ty1 ty2--    go t1 t2 =-      -- See Note [Expanding type synonyms to make types similar] for how this-      -- works-      let-        t1_exp_tys = t1 : tyExpansions t1-        t2_exp_tys = t2 : tyExpansions t2-        t1_exps    = length t1_exp_tys-        t2_exps    = length t2_exp_tys-        dif        = abs (t1_exps - t2_exps)-      in-        followExpansions $-          zipEqual "expandSynonymsToMatch.go"-            (if t1_exps > t2_exps then drop dif t1_exp_tys else t1_exp_tys)-            (if t2_exps > t1_exps then drop dif t2_exp_tys else t2_exp_tys)--    -- | Expand the top layer type synonyms repeatedly, collect expansions in a-    -- list. The list does not include the original type.-    ---    -- Example, if you have:-    ---    --   type T10 = T9-    --   type T9  = T8-    --   ...-    --   type T0  = Int-    ---    -- `tyExpansions T10` returns [T9, T8, T7, ... Int]-    ---    -- This only expands the top layer, so if you have:-    ---    --   type M a = Maybe a-    ---    -- `tyExpansions (M T10)` returns [Maybe T10] (T10 is not expanded)-    tyExpansions :: Type -> [Type]-    tyExpansions = unfoldr (\t -> (\x -> (x, x)) `fmap` tcView t)--    -- | Drop the type pairs until types in a pair look alike (i.e. the outer-    -- constructors are the same).-    followExpansions :: [(Type, Type)] -> (Type, Type)-    followExpansions [] = pprPanic "followExpansions" empty-    followExpansions [(t1, t2)]-      | sameShapes t1 t2 = go t1 t2 -- expand subtrees-      | otherwise        = (t1, t2) -- the difference is already visible-    followExpansions ((t1, t2) : tss)-      -- Traverse subtrees when the outer shapes are the same-      | sameShapes t1 t2 = go t1 t2-      -- Otherwise follow the expansions until they look alike-      | otherwise = followExpansions tss--    sameShapes :: Type -> Type -> Bool-    sameShapes AppTy{}          AppTy{}          = True-    sameShapes (TyConApp tc1 _) (TyConApp tc2 _) = tc1 == tc2-    sameShapes (FunTy {})       (FunTy {})       = True-    sameShapes (ForAllTy {})    (ForAllTy {})    = True-    sameShapes (CastTy ty1 _)   ty2              = sameShapes ty1 ty2-    sameShapes ty1              (CastTy ty2 _)   = sameShapes ty1 ty2-    sameShapes _                _                = False--sameOccExtra :: TcType -> TcType -> SDoc--- See Note [Disambiguating (X ~ X) errors]-sameOccExtra ty1 ty2-  | Just (tc1, _) <- tcSplitTyConApp_maybe ty1-  , Just (tc2, _) <- tcSplitTyConApp_maybe ty2-  , let n1 = tyConName tc1-        n2 = tyConName tc2-        same_occ = nameOccName n1                   == nameOccName n2-        same_pkg = moduleUnit (nameModule n1) == moduleUnit (nameModule n2)-  , n1 /= n2   -- Different Names-  , same_occ   -- but same OccName-  = text "NB:" <+> (ppr_from same_pkg n1 $$ ppr_from same_pkg n2)-  | otherwise-  = empty-  where-    ppr_from same_pkg nm-      | isGoodSrcSpan loc-      = hang (quotes (ppr nm) <+> text "is defined at")-           2 (ppr loc)-      | otherwise  -- Imported things have an UnhelpfulSrcSpan-      = hang (quotes (ppr nm))-           2 (sep [ text "is defined in" <+> quotes (ppr (moduleName mod))-                  , ppUnless (same_pkg || pkg == mainUnit) $-                    nest 4 $ text "in package" <+> quotes (ppr pkg) ])-       where-         pkg = moduleUnit mod-         mod = nameModule nm-         loc = nameSrcSpan nm--{- Note [Suggest adding a type signature]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The OutsideIn algorithm rejects GADT programs that don't have a principal-type, and indeed some that do.  Example:-   data T a where-     MkT :: Int -> T Int--   f (MkT n) = n--Does this have type f :: T a -> a, or f :: T a -> Int?-The error that shows up tends to be an attempt to unify an-untouchable type variable.  So suggestAddSig sees if the offending-type variable is bound by an *inferred* signature, and suggests-adding a declared signature instead.--More specifically, we suggest adding a type sig if we have p ~ ty, and-p is a skolem bound by an InferSkol.  Those skolems were created from-unification variables in simplifyInfer.  Why didn't we unify?  It must-have been because of an intervening GADT or existential, making it-untouchable. Either way, a type signature would help.  For GADTs, it-might make it typeable; for existentials the attempt to write a-signature will fail -- or at least will produce a better error message-next time--This initially came up in #8968, concerning pattern synonyms.--Note [Disambiguating (X ~ X) errors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-See #8278--Note [Reporting occurs-check errors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Given (a ~ [a]), if 'a' is a rigid type variable bound by a user-supplied-type signature, then the best thing is to report that we can't unify-a with [a], because a is a skolem variable.  That avoids the confusing-"occur-check" error message.--But nowadays when inferring the type of a function with no type signature,-even if there are errors inside, we still generalise its signature and-carry on. For example-   f x = x:x-Here we will infer something like-   f :: forall a. a -> [a]-with a deferred error of (a ~ [a]).  So in the deferred unsolved constraint-'a' is now a skolem, but not one bound by the programmer in the context!-Here we really should report an occurs check.--So isUserSkolem distinguishes the two.--Note [Non-injective type functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's very confusing to get a message like-     Couldn't match expected type `Depend s'-            against inferred type `Depend s1'-so mkTyFunInfoMsg adds:-       NB: `Depend' is type function, and hence may not be injective--Warn of loopy local equalities that were dropped.---************************************************************************-*                                                                      *-                 Type-class errors-*                                                                      *-************************************************************************--}--mkDictErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc)-mkDictErr ctxt cts-  = ASSERT( not (null cts) )-    do { inst_envs <- tcGetInstEnvs-       ; let (ct1:_) = cts  -- ct1 just for its location-             min_cts = elim_superclasses cts-             lookups = map (lookup_cls_inst inst_envs) min_cts-             (no_inst_cts, overlap_cts) = partition is_no_inst lookups--       -- Report definite no-instance errors,-       -- or (iff there are none) overlap errors-       -- But we report only one of them (hence 'head') because they all-       -- have the same source-location origin, to try avoid a cascade-       -- of error from one location-       ; (ctxt, err) <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts))-       ; mkErrorMsgFromCt ctxt ct1 (important err) }-  where-    no_givens = null (getUserGivens ctxt)--    is_no_inst (ct, (matches, unifiers, _))-      =  no_givens-      && null matches-      && (null unifiers || all (not . isAmbiguousTyVar) (tyCoVarsOfCtList ct))--    lookup_cls_inst inst_envs ct-                -- Note [Flattening in error message generation]-      = (ct, lookupInstEnv True inst_envs clas (flattenTys emptyInScopeSet tys))-      where-        (clas, tys) = getClassPredTys (ctPred ct)---    -- When simplifying [W] Ord (Set a), we need-    --    [W] Eq a, [W] Ord a-    -- but we really only want to report the latter-    elim_superclasses cts = mkMinimalBySCs ctPred cts---- [Note: mk_dict_err]--- ~~~~~~~~~~~~~~~~~~~--- Different dictionary error messages are reported depending on the number of--- matches and unifiers:------   - No matches, regardless of unifiers: report "No instance for ...".---   - Two or more matches, regardless of unifiers: report "Overlapping instances for ...",---     and show the matching and unifying instances.---   - One match, one or more unifiers: report "Overlapping instances for", show the---     matching and unifying instances, and say "The choice depends on the instantion of ...,---     and the result of evaluating ...".-mk_dict_err :: ReportErrCtxt -> (Ct, ClsInstLookupResult)-            -> TcM (ReportErrCtxt, SDoc)--- Report an overlap error if this class constraint results--- from an overlap (returning Left clas), otherwise return (Right pred)-mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_overlapped))-  | null matches  -- No matches but perhaps several unifiers-  = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct-       ; candidate_insts <- get_candidate_instances-       ; return (ctxt, cannot_resolve_msg ct candidate_insts binds_msg) }--  | null unsafe_overlapped   -- Some matches => overlap errors-  = return (ctxt, overlap_msg)--  | otherwise-  = return (ctxt, safe_haskell_msg)-  where-    orig          = ctOrigin ct-    pred          = ctPred ct-    (clas, tys)   = getClassPredTys pred-    ispecs        = [ispec | (ispec, _) <- matches]-    unsafe_ispecs = [ispec | (ispec, _) <- unsafe_overlapped]-    useful_givens = discardProvCtxtGivens orig (getUserGivensFromImplics implics)-         -- useful_givens are the enclosing implications with non-empty givens,-         -- modulo the horrid discardProvCtxtGivens--    get_candidate_instances :: TcM [ClsInst]-    -- See Note [Report candidate instances]-    get_candidate_instances-      | [ty] <- tys   -- Only try for single-parameter classes-      = do { instEnvs <- tcGetInstEnvs-           ; return (filter (is_candidate_inst ty)-                            (classInstances instEnvs clas)) }-      | otherwise = return []--    is_candidate_inst ty inst -- See Note [Report candidate instances]-      | [other_ty] <- is_tys inst-      , Just (tc1, _) <- tcSplitTyConApp_maybe ty-      , Just (tc2, _) <- tcSplitTyConApp_maybe other_ty-      = let n1 = tyConName tc1-            n2 = tyConName tc2-            different_names = n1 /= n2-            same_occ_names = nameOccName n1 == nameOccName n2-        in different_names && same_occ_names-      | otherwise = False--    cannot_resolve_msg :: Ct -> [ClsInst] -> SDoc -> SDoc-    cannot_resolve_msg ct candidate_insts binds_msg-      = vcat [ no_inst_msg-             , nest 2 extra_note-             , vcat (pp_givens useful_givens)-             , mb_patsyn_prov `orElse` empty-             , ppWhen (has_ambig_tvs && not (null unifiers && null useful_givens))-               (vcat [ ppUnless lead_with_ambig ambig_msg, binds_msg, potential_msg ])--             , ppWhen (isNothing mb_patsyn_prov) $-                   -- Don't suggest fixes for the provided context of a pattern-                   -- synonym; the right fix is to bind more in the pattern-               show_fixes (ctxtFixes has_ambig_tvs pred implics-                           ++ drv_fixes)-             , ppWhen (not (null candidate_insts))-               (hang (text "There are instances for similar types:")-                   2 (vcat (map ppr candidate_insts))) ]-                   -- See Note [Report candidate instances]-      where-        orig = ctOrigin ct-        -- See Note [Highlighting ambiguous type variables]-        lead_with_ambig = has_ambig_tvs && not (any isRuntimeUnkSkol ambig_tvs)-                        && not (null unifiers) && null useful_givens--        (has_ambig_tvs, ambig_msg) = mkAmbigMsg lead_with_ambig ct-        ambig_tvs = uncurry (++) (getAmbigTkvs ct)--        no_inst_msg-          | lead_with_ambig-          = ambig_msg <+> pprArising orig-              $$ text "prevents the constraint" <+>  quotes (pprParendType pred)-              <+> text "from being solved."--          | null useful_givens-          = addArising orig $ text "No instance for"-            <+> pprParendType pred--          | otherwise-          = addArising orig $ text "Could not deduce"-            <+> pprParendType pred--        potential_msg-          = ppWhen (not (null unifiers) && want_potential orig) $-            sdocOption sdocPrintPotentialInstances $ \print_insts ->-            getPprStyle $ \sty ->-            pprPotentials (PrintPotentialInstances print_insts) sty potential_hdr unifiers--        potential_hdr-          = vcat [ ppWhen lead_with_ambig $-                     text "Probable fix: use a type annotation to specify what"-                     <+> pprQuotedList ambig_tvs <+> text "should be."-                 , text "These potential instance" <> plural unifiers-                   <+> text "exist:"]--        mb_patsyn_prov :: Maybe SDoc-        mb_patsyn_prov-          | not lead_with_ambig-          , ProvCtxtOrigin PSB{ psb_def = L _ pat } <- orig-          = Just (vcat [ text "In other words, a successful match on the pattern"-                       , nest 2 $ ppr pat-                       , text "does not provide the constraint" <+> pprParendType pred ])-          | otherwise = Nothing--    -- Report "potential instances" only when the constraint arises-    -- directly from the user's use of an overloaded function-    want_potential (TypeEqOrigin {}) = False-    want_potential _                 = True--    extra_note | any isFunTy (filterOutInvisibleTypes (classTyCon clas) tys)-               = text "(maybe you haven't applied a function to enough arguments?)"-               | className clas == typeableClassName  -- Avoid mysterious "No instance for (Typeable T)-               , [_,ty] <- tys                        -- Look for (Typeable (k->*) (T k))-               , Just (tc,_) <- tcSplitTyConApp_maybe ty-               , not (isTypeFamilyTyCon tc)-               = hang (text "GHC can't yet do polykinded")-                    2 (text "Typeable" <+>-                       parens (ppr ty <+> dcolon <+> ppr (tcTypeKind ty)))-               | otherwise-               = empty--    drv_fixes = case orig of-                   DerivClauseOrigin                  -> [drv_fix False]-                   StandAloneDerivOrigin              -> [drv_fix True]-                   DerivOriginDC _ _       standalone -> [drv_fix standalone]-                   DerivOriginCoerce _ _ _ standalone -> [drv_fix standalone]-                   _                -> []--    drv_fix standalone_wildcard-      | standalone_wildcard-      = text "fill in the wildcard constraint yourself"-      | otherwise-      = hang (text "use a standalone 'deriving instance' declaration,")-           2 (text "so you can specify the instance context yourself")--    -- Normal overlap error-    overlap_msg-      = ASSERT( not (null matches) )-        vcat [  addArising orig (text "Overlapping instances for"-                                <+> pprType (mkClassPred clas tys))--             ,  ppUnless (null matching_givens) $-                  sep [text "Matching givens (or their superclasses):"-                      , nest 2 (vcat matching_givens)]--             ,  sdocOption sdocPrintPotentialInstances $ \print_insts ->-                getPprStyle $ \sty ->-                pprPotentials (PrintPotentialInstances print_insts) sty (text "Matching instances:") $-                ispecs ++ unifiers--             ,  ppWhen (null matching_givens && isSingleton matches && null unifiers) $-                -- Intuitively, some given matched the wanted in their-                -- flattened or rewritten (from given equalities) form-                -- but the matcher can't figure that out because the-                -- constraints are non-flat and non-rewritten so we-                -- simply report back the whole given-                -- context. Accelerate Smart.hs showed this problem.-                  sep [ text "There exists a (perhaps superclass) match:"-                      , nest 2 (vcat (pp_givens useful_givens))]--             ,  ppWhen (isSingleton matches) $-                parens (vcat [ ppUnless (null tyCoVars) $-                                 text "The choice depends on the instantiation of" <+>-                                   quotes (pprWithCommas ppr tyCoVars)-                             , ppUnless (null famTyCons) $-                                 if (null tyCoVars)-                                   then-                                     text "The choice depends on the result of evaluating" <+>-                                       quotes (pprWithCommas ppr famTyCons)-                                   else-                                     text "and the result of evaluating" <+>-                                       quotes (pprWithCommas ppr famTyCons)-                             , ppWhen (null (matching_givens)) $-                               vcat [ text "To pick the first instance above, use IncoherentInstances"-                                    , text "when compiling the other instance declarations"]-                        ])]-      where-        tyCoVars = tyCoVarsOfTypesList tys-        famTyCons = filter isFamilyTyCon $ concatMap (nonDetEltsUniqSet . tyConsOfType) tys--    matching_givens = mapMaybe matchable useful_givens--    matchable implic@(Implic { ic_given = evvars, ic_info = skol_info })-      = case ev_vars_matching of-             [] -> Nothing-             _  -> Just $ hang (pprTheta ev_vars_matching)-                            2 (sep [ text "bound by" <+> ppr skol_info-                                   , text "at" <+>-                                     ppr (tcl_loc (ic_env implic)) ])-        where ev_vars_matching = [ pred-                                 | ev_var <- evvars-                                 , let pred = evVarPred ev_var-                                 , any can_match (pred : transSuperClasses pred) ]-              can_match pred-                 = case getClassPredTys_maybe pred of-                     Just (clas', tys') -> clas' == clas-                                          && isJust (tcMatchTys tys tys')-                     Nothing -> False--    -- Overlap error because of Safe Haskell (first-    -- match should be the most specific match)-    safe_haskell_msg-     = ASSERT( matches `lengthIs` 1 && not (null unsafe_ispecs) )-       vcat [ addArising orig (text "Unsafe overlapping instances for"-                       <+> pprType (mkClassPred clas tys))-            , sep [text "The matching instance is:",-                   nest 2 (pprInstance $ head ispecs)]-            , vcat [ text "It is compiled in a Safe module and as such can only"-                   , text "overlap instances from the same module, however it"-                   , text "overlaps the following instances from different" <+>-                     text "modules:"-                   , nest 2 (vcat [pprInstances $ unsafe_ispecs])-                   ]-            ]---ctxtFixes :: Bool -> PredType -> [Implication] -> [SDoc]-ctxtFixes has_ambig_tvs pred implics-  | not has_ambig_tvs-  , isTyVarClassPred pred-  , (skol:skols) <- usefulContext implics pred-  , let what | null skols-             , SigSkol (PatSynCtxt {}) _ _ <- skol-             = text "\"required\""-             | otherwise-             = empty-  = [sep [ text "add" <+> pprParendType pred-           <+> text "to the" <+> what <+> text "context of"-         , nest 2 $ ppr_skol skol $$-                    vcat [ text "or" <+> ppr_skol skol-                         | skol <- skols ] ] ]-  | otherwise = []-  where-    ppr_skol (PatSkol (RealDataCon dc) _) = text "the data constructor" <+> quotes (ppr dc)-    ppr_skol (PatSkol (PatSynCon ps)   _) = text "the pattern synonym"  <+> quotes (ppr ps)-    ppr_skol skol_info = ppr skol_info--discardProvCtxtGivens :: CtOrigin -> [UserGiven] -> [UserGiven]-discardProvCtxtGivens orig givens  -- See Note [discardProvCtxtGivens]-  | ProvCtxtOrigin (PSB {psb_id = L _ name}) <- orig-  = filterOut (discard name) givens-  | otherwise-  = givens-  where-    discard n (Implic { ic_info = SigSkol (PatSynCtxt n') _ _ }) = n == n'-    discard _ _                                                  = False--usefulContext :: [Implication] -> PredType -> [SkolemInfo]--- usefulContext picks out the implications whose context--- the programmer might plausibly augment to solve 'pred'-usefulContext implics pred-  = go implics-  where-    pred_tvs = tyCoVarsOfType pred-    go [] = []-    go (ic : ics)-       | implausible ic = rest-       | otherwise      = ic_info ic : rest-       where-          -- Stop when the context binds a variable free in the predicate-          rest | any (`elemVarSet` pred_tvs) (ic_skols ic) = []-               | otherwise                                 = go ics--    implausible ic-      | null (ic_skols ic)            = True-      | implausible_info (ic_info ic) = True-      | otherwise                     = False--    implausible_info (SigSkol (InfSigCtxt {}) _ _) = True-    implausible_info _                             = False-    -- Do not suggest adding constraints to an *inferred* type signature--{- Note [Report candidate instances]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have an unsolved (Num Int), where `Int` is not the Prelude Int,-but comes from some other module, then it may be helpful to point out-that there are some similarly named instances elsewhere.  So we get-something like-    No instance for (Num Int) arising from the literal ‘3’-    There are instances for similar types:-      instance Num GHC.Types.Int -- Defined in ‘GHC.Num’-Discussion in #9611.--Note [Highlighting ambiguous type variables]-~--------------------------------------------When we encounter ambiguous type variables (i.e. type variables-that remain metavariables after type inference), we need a few more-conditions before we can reason that *ambiguity* prevents constraints-from being solved:-  - We can't have any givens, as encountering a typeclass error-    with given constraints just means we couldn't deduce-    a solution satisfying those constraints and as such couldn't-    bind the type variable to a known type.-  - If we don't have any unifiers, we don't even have potential-    instances from which an ambiguity could arise.-  - Lastly, I don't want to mess with error reporting for-    unknown runtime types so we just fall back to the old message there.-Once these conditions are satisfied, we can safely say that ambiguity prevents-the constraint from being solved.--Note [discardProvCtxtGivens]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-In most situations we call all enclosing implications "useful". There is one-exception, and that is when the constraint that causes the error is from the-"provided" context of a pattern synonym declaration:--  pattern Pat :: (Num a, Eq a) => Show a   => a -> Maybe a-             --  required      => provided => type-  pattern Pat x <- (Just x, 4)--When checking the pattern RHS we must check that it does actually bind all-the claimed "provided" constraints; in this case, does the pattern (Just x, 4)-bind the (Show a) constraint.  Answer: no!--But the implication we generate for this will look like-   forall a. (Num a, Eq a) => [W] Show a-because when checking the pattern we must make the required-constraints available, since they are needed to match the pattern (in-this case the literal '4' needs (Num a, Eq a)).--BUT we don't want to suggest adding (Show a) to the "required" constraints-of the pattern synonym, thus:-  pattern Pat :: (Num a, Eq a, Show a) => Show a => a -> Maybe a-It would then typecheck but it's silly.  We want the /pattern/ to bind-the alleged "provided" constraints, Show a.--So we suppress that Implication in discardProvCtxtGivens.  It's-painfully ad-hoc but the truth is that adding it to the "required"-constraints would work.  Suppressing it solves two problems.  First,-we never tell the user that we could not deduce a "provided"-constraint from the "required" context. Second, we never give a-possible fix that suggests to add a "provided" constraint to the-"required" context.--For example, without this distinction the above code gives a bad error-message (showing both problems):--  error: Could not deduce (Show a) ... from the context: (Eq a)-         ... Possible fix: add (Show a) to the context of-         the signature for pattern synonym `Pat' ...---}--show_fixes :: [SDoc] -> SDoc-show_fixes []     = empty-show_fixes (f:fs) = sep [ text "Possible fix:"-                        , nest 2 (vcat (f : map (text "or" <+>) fs))]----- Avoid boolean blindness-newtype PrintPotentialInstances = PrintPotentialInstances Bool--pprPotentials :: PrintPotentialInstances -> PprStyle -> SDoc -> [ClsInst] -> SDoc--- See Note [Displaying potential instances]-pprPotentials (PrintPotentialInstances show_potentials) sty herald insts-  | null insts-  = empty--  | null show_these-  = hang herald-       2 (vcat [ not_in_scope_msg empty-               , flag_hint ])--  | otherwise-  = hang herald-       2 (vcat [ pprInstances show_these-               , ppWhen (n_in_scope_hidden > 0) $-                 text "...plus"-                   <+> speakNOf n_in_scope_hidden (text "other")-               , not_in_scope_msg (text "...plus")-               , flag_hint ])-  where-    n_show = 3 :: Int--    (in_scope, not_in_scope) = partition inst_in_scope insts-    sorted = sortBy fuzzyClsInstCmp in_scope-    show_these | show_potentials = sorted-               | otherwise       = take n_show sorted-    n_in_scope_hidden = length sorted - length show_these--       -- "in scope" means that all the type constructors-       -- are lexically in scope; these instances are likely-       -- to be more useful-    inst_in_scope :: ClsInst -> Bool-    inst_in_scope cls_inst = nameSetAll name_in_scope $-                             orphNamesOfTypes (is_tys cls_inst)--    name_in_scope name-      | isBuiltInSyntax name-      = True -- E.g. (->)-      | Just mod <- nameModule_maybe name-      = qual_in_scope (qualName sty mod (nameOccName name))-      | otherwise-      = True--    qual_in_scope :: QualifyName -> Bool-    qual_in_scope NameUnqual    = True-    qual_in_scope (NameQual {}) = True-    qual_in_scope _             = False--    not_in_scope_msg herald-      | null not_in_scope-      = empty-      | otherwise-      = hang (herald <+> speakNOf (length not_in_scope) (text "instance")-                     <+> text "involving out-of-scope types")-           2 (ppWhen show_potentials (pprInstances not_in_scope))--    flag_hint = ppUnless (show_potentials || equalLength show_these insts) $-                text "(use -fprint-potential-instances to see them all)"--{- Note [Displaying potential instances]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When showing a list of instances for-  - overlapping instances (show ones that match)-  - no such instance (show ones that could match)-we want to give it a bit of structure.  Here's the plan--* Say that an instance is "in scope" if all of the-  type constructors it mentions are lexically in scope.-  These are the ones most likely to be useful to the programmer.--* Show at most n_show in-scope instances,-  and summarise the rest ("plus 3 others")--* Summarise the not-in-scope instances ("plus 4 not in scope")--* Add the flag -fshow-potential-instances which replaces the-  summary with the full list--}--{--Note [Flattening in error message generation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider (C (Maybe (F x))), where F is a type function, and we have-instances-                C (Maybe Int) and C (Maybe a)-Since (F x) might turn into Int, this is an overlap situation, and-indeed the main solver will have refrained-from solving.  But by the time we get to error message generation, we've-un-flattened the constraint.  So we must *re*-flatten it before looking-up in the instance environment, lest we only report one matching-instance when in fact there are two.--Note [Kind arguments in error messages]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It can be terribly confusing to get an error message like (#9171)--    Couldn't match expected type ‘GetParam Base (GetParam Base Int)’-                with actual type ‘GetParam Base (GetParam Base Int)’--The reason may be that the kinds don't match up.  Typically you'll get-more useful information, but not when it's as a result of ambiguity.--To mitigate this, GHC attempts to enable the -fprint-explicit-kinds flag-whenever any error message arises due to a kind mismatch. This means that-the above error message would instead be displayed as:--    Couldn't match expected type-                  ‘GetParam @* @k2 @* Base (GetParam @* @* @k2 Base Int)’-                with actual type-                  ‘GetParam @* @k20 @* Base (GetParam @* @* @k20 Base Int)’--Which makes it clearer that the culprit is the mismatch between `k2` and `k20`.--}--mkAmbigMsg :: Bool -- True when message has to be at beginning of sentence-           -> Ct -> (Bool, SDoc)-mkAmbigMsg prepend_msg ct-  | null ambig_kvs && null ambig_tvs = (False, empty)-  | otherwise                        = (True,  msg)-  where-    (ambig_kvs, ambig_tvs) = getAmbigTkvs ct--    msg |  any isRuntimeUnkSkol ambig_kvs  -- See Note [Runtime skolems]-        || any isRuntimeUnkSkol ambig_tvs-        = vcat [ text "Cannot resolve unknown runtime type"-                 <> plural ambig_tvs <+> pprQuotedList ambig_tvs-               , text "Use :print or :force to determine these types"]--        | not (null ambig_tvs)-        = pp_ambig (text "type") ambig_tvs--        | otherwise-        = pp_ambig (text "kind") ambig_kvs--    pp_ambig what tkvs-      | prepend_msg -- "Ambiguous type variable 't0'"-      = text "Ambiguous" <+> what <+> text "variable"-        <> plural tkvs <+> pprQuotedList tkvs--      | otherwise -- "The type variable 't0' is ambiguous"-      = text "The" <+> what <+> text "variable" <> plural tkvs-        <+> pprQuotedList tkvs <+> isOrAre tkvs <+> text "ambiguous"--pprSkols :: ReportErrCtxt -> [TcTyVar] -> SDoc-pprSkols ctxt tvs-  = vcat (map pp_one (getSkolemInfo (cec_encl ctxt) tvs))-  where-    pp_one (UnkSkol, tvs)-      = hang (pprQuotedList tvs)-           2 (is_or_are tvs "an" "unknown")-    pp_one (RuntimeUnkSkol, tvs)-      = hang (pprQuotedList tvs)-           2 (is_or_are tvs "an" "unknown runtime")-    pp_one (skol_info, tvs)-      = vcat [ hang (pprQuotedList tvs)-                  2 (is_or_are tvs "a"  "rigid" <+> text "bound by")-             , nest 2 (pprSkolInfo skol_info)-             , nest 2 (text "at" <+> ppr (foldr1 combineSrcSpans (map getSrcSpan tvs))) ]--    is_or_are [_] article adjective = text "is" <+> text article <+> text adjective-                                      <+> text "type variable"-    is_or_are _   _       adjective = text "are" <+> text adjective-                                      <+> text "type variables"--getAmbigTkvs :: Ct -> ([Var],[Var])-getAmbigTkvs ct-  = partition (`elemVarSet` dep_tkv_set) ambig_tkvs-  where-    tkvs       = tyCoVarsOfCtList ct-    ambig_tkvs = filter isAmbiguousTyVar tkvs-    dep_tkv_set = tyCoVarsOfTypes (map tyVarKind tkvs)--getSkolemInfo :: [Implication] -> [TcTyVar]-              -> [(SkolemInfo, [TcTyVar])]                    -- #14628--- Get the skolem info for some type variables--- from the implication constraints that bind them.------ In the returned (skolem, tvs) pairs, the 'tvs' part is non-empty-getSkolemInfo _ []-  = []--getSkolemInfo [] tvs-  | all isRuntimeUnkSkol tvs = [(RuntimeUnkSkol, tvs)]        -- #14628-  | otherwise = pprPanic "No skolem info:" (ppr tvs)--getSkolemInfo (implic:implics) tvs-  | null tvs_here =                            getSkolemInfo implics tvs-  | otherwise   = (ic_info implic, tvs_here) : getSkolemInfo implics tvs_other-  where-    (tvs_here, tvs_other) = partition (`elem` ic_skols implic) tvs---------------------------- relevantBindings looks at the value environment and finds values whose--- types mention any of the offending type variables.  It has to be--- careful to zonk the Id's type first, so it has to be in the monad.--- We must be careful to pass it a zonked type variable, too.------ We always remove closed top-level bindings, though,--- since they are never relevant (cf #8233)--relevantBindings :: Bool  -- True <=> filter by tyvar; False <=> no filtering-                          -- See #8191-                 -> ReportErrCtxt -> Ct-                 -> TcM (ReportErrCtxt, SDoc, Ct)--- Also returns the zonked and tidied CtOrigin of the constraint-relevantBindings want_filtering ctxt ct-  = do { traceTc "relevantBindings" (ppr ct)-       ; (env1, tidy_orig) <- zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc)--             -- For *kind* errors, report the relevant bindings of the-             -- enclosing *type* equality, because that's more useful for the programmer-       ; let extra_tvs = case tidy_orig of-                             KindEqOrigin t1 t2 _ _ -> tyCoVarsOfTypes [t1,t2]-                             _                        -> emptyVarSet-             ct_fvs = tyCoVarsOfCt ct `unionVarSet` extra_tvs--             -- Put a zonked, tidied CtOrigin into the Ct-             loc'   = setCtLocOrigin loc tidy_orig-             ct'    = setCtLoc ct loc'--       ; (env2, lcl_name_cache) <- zonkTidyTcLclEnvs env1 [lcl_env]--       ; doc <- relevant_bindings want_filtering lcl_env lcl_name_cache ct_fvs-       ; let ctxt'  = ctxt { cec_tidy = env2 }-       ; return (ctxt', doc, ct') }-  where-    loc     = ctLoc ct-    lcl_env = ctLocEnv loc---- slightly more general version, to work also with holes-relevant_bindings :: Bool-                  -> TcLclEnv-                  -> NameEnv Type -- Cache of already zonked and tidied types-                  -> TyCoVarSet-                  -> TcM SDoc-relevant_bindings want_filtering lcl_env lcl_name_env ct_tvs-  = do { dflags <- getDynFlags-       ; traceTc "relevant_bindings" $-           vcat [ ppr ct_tvs-                , pprWithCommas id [ ppr id <+> dcolon <+> ppr (idType id)-                                   | TcIdBndr id _ <- tcl_bndrs lcl_env ]-                , pprWithCommas id-                    [ ppr id | TcIdBndr_ExpType id _ _ <- tcl_bndrs lcl_env ] ]--       ; (docs, discards)-              <- go dflags (maxRelevantBinds dflags)-                    emptyVarSet [] False-                    (removeBindingShadowing $ tcl_bndrs lcl_env)-         -- tcl_bndrs has the innermost bindings first,-         -- which are probably the most relevant ones--       ; let doc = ppUnless (null docs) $-                   hang (text "Relevant bindings include")-                      2 (vcat docs $$ ppWhen discards discardMsg)--       ; return doc }-  where-    run_out :: Maybe Int -> Bool-    run_out Nothing = False-    run_out (Just n) = n <= 0--    dec_max :: Maybe Int -> Maybe Int-    dec_max = fmap (\n -> n - 1)---    go :: DynFlags -> Maybe Int -> TcTyVarSet -> [SDoc]-       -> Bool                          -- True <=> some filtered out due to lack of fuel-       -> [TcBinder]-       -> TcM ([SDoc], Bool)   -- The bool says if we filtered any out-                                        -- because of lack of fuel-    go _ _ _ docs discards []-      = return (reverse docs, discards)-    go dflags n_left tvs_seen docs discards (tc_bndr : tc_bndrs)-      = case tc_bndr of-          TcTvBndr {} -> discard_it-          TcIdBndr id top_lvl -> go2 (idName id) top_lvl-          TcIdBndr_ExpType name et top_lvl ->-            do { mb_ty <- readExpType_maybe et-                   -- et really should be filled in by now. But there's a chance-                   -- it hasn't, if, say, we're reporting a kind error en route to-                   -- checking a term. See test indexed-types/should_fail/T8129-                   -- Or we are reporting errors from the ambiguity check on-                   -- a local type signature-               ; case mb_ty of-                   Just _ty -> go2 name top_lvl-                   Nothing -> discard_it  -- No info; discard-               }-      where-        discard_it = go dflags n_left tvs_seen docs-                        discards tc_bndrs-        go2 id_name top_lvl-          = do { let tidy_ty = case lookupNameEnv lcl_name_env id_name of-                                  Just tty -> tty-                                  Nothing -> pprPanic "relevant_bindings" (ppr id_name)-               ; traceTc "relevantBindings 1" (ppr id_name <+> dcolon <+> ppr tidy_ty)-               ; let id_tvs = tyCoVarsOfType tidy_ty-                     doc = sep [ pprPrefixOcc id_name <+> dcolon <+> ppr tidy_ty-                               , nest 2 (parens (text "bound at"-                                    <+> ppr (getSrcLoc id_name)))]-                     new_seen = tvs_seen `unionVarSet` id_tvs--               ; if (want_filtering && not (hasPprDebug dflags)-                                    && id_tvs `disjointVarSet` ct_tvs)-                          -- We want to filter out this binding anyway-                          -- so discard it silently-                 then discard_it--                 else if isTopLevel top_lvl && not (isNothing n_left)-                          -- It's a top-level binding and we have not specified-                          -- -fno-max-relevant-bindings, so discard it silently-                 then discard_it--                 else if run_out n_left && id_tvs `subVarSet` tvs_seen-                          -- We've run out of n_left fuel and this binding only-                          -- mentions already-seen type variables, so discard it-                 then go dflags n_left tvs_seen docs-                         True      -- Record that we have now discarded something-                         tc_bndrs--                          -- Keep this binding, decrement fuel-                 else go dflags (dec_max n_left) new_seen-                         (doc:docs) discards tc_bndrs }---discardMsg :: SDoc-discardMsg = text "(Some bindings suppressed;" <+>-             text "use -fmax-relevant-binds=N or -fno-max-relevant-binds)"--------------------------warnDefaulting :: [Ct] -> Type -> TcM ()-warnDefaulting wanteds default_ty-  = do { warn_default <- woptM Opt_WarnTypeDefaults-       ; env0 <- tcInitTidyEnv-       ; let tidy_env = tidyFreeTyCoVars env0 $-                        tyCoVarsOfCtsList (listToBag wanteds)-             tidy_wanteds = map (tidyCt tidy_env) wanteds-             (loc, ppr_wanteds) = pprWithArising tidy_wanteds-             warn_msg =-                hang (hsep [ text "Defaulting the following"-                           , text "constraint" <> plural tidy_wanteds-                           , text "to type"-                           , quotes (ppr default_ty) ])-                     2-                     ppr_wanteds-       ; setCtLocM loc $ warnTc (Reason Opt_WarnTypeDefaults) warn_default warn_msg }--{--Note [Runtime skolems]-~~~~~~~~~~~~~~~~~~~~~~-We want to give a reasonably helpful error message for ambiguity-arising from *runtime* skolems in the debugger.  These-are created by in GHC.Runtime.Heap.Inspect.zonkRTTIType.--************************************************************************-*                                                                      *-                 Error from the canonicaliser-         These ones are called *during* constraint simplification-*                                                                      *-************************************************************************--}--solverDepthErrorTcS :: CtLoc -> TcType -> TcM a-solverDepthErrorTcS loc ty-  = setCtLocM loc $-    do { ty <- zonkTcType ty-       ; env0 <- tcInitTidyEnv-       ; let tidy_env     = tidyFreeTyCoVars env0 (tyCoVarsOfTypeList ty)-             tidy_ty      = tidyType tidy_env ty-             msg-               = vcat [ text "Reduction stack overflow; size =" <+> ppr depth-                      , hang (text "When simplifying the following type:")-                           2 (ppr tidy_ty)-                      , note ]-       ; failWithTcM (tidy_env, msg) }-  where-    depth = ctLocDepth loc-    note = vcat-      [ text "Use -freduction-depth=0 to disable this check"-      , text "(any upper bound you could choose might fail unpredictably with"-      , text " minor updates to GHC, so disabling the check is recommended if"-      , text " you're sure that type checking should terminate)" ]++{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE NamedFieldPuns      #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+{-# LANGUAGE ParallelListComp #-}++module GHC.Tc.Errors(+       reportUnsolved, reportAllUnsolved, warnAllUnsolved,+       warnDefaulting,++       -- * GHC API helper functions+       solverReportMsg_ExpectedActuals,+       solverReportInfo_ExpectedActuals+  ) where++import GHC.Prelude++import GHC.Driver.Env (hsc_units)+import GHC.Driver.Session+import GHC.Driver.Ppr+import GHC.Driver.Config.Diagnostic++import GHC.Rename.Unbound++import GHC.Tc.Types+import GHC.Tc.Utils.Monad+import GHC.Tc.Errors.Types+import GHC.Tc.Errors.Ppr+import GHC.Tc.Types.Constraint+import GHC.Tc.Utils.TcMType+import GHC.Tc.Utils.Env( tcInitTidyEnv )+import GHC.Tc.Utils.TcType+import GHC.Tc.Utils.Unify ( checkTyVarEq )+import GHC.Tc.Types.Origin+import GHC.Tc.Types.Evidence+import GHC.Tc.Types.EvTerm+import GHC.Tc.Instance.Family+import GHC.Tc.Utils.Instantiate+import {-# SOURCE #-} GHC.Tc.Errors.Hole ( findValidHoleFits, getHoleFitDispConfig, pprHoleFit )++import GHC.Types.Name+import GHC.Types.Name.Reader ( lookupGRE_Name, GlobalRdrEnv, mkRdrUnqual+                             , emptyLocalRdrEnv, lookupGlobalRdrEnv , lookupLocalRdrOcc )+import GHC.Types.Id+import GHC.Types.Var+import GHC.Types.Var.Set+import GHC.Types.Var.Env+import GHC.Types.Name.Env+import GHC.Types.SrcLoc+import GHC.Types.Basic+import GHC.Types.Error+import qualified GHC.Types.Unique.Map as UM++--import GHC.Rename.Unbound ( unknownNameSuggestions, WhatLooking(..) )+import GHC.Unit.Module+import qualified GHC.LanguageExtensions as LangExt++import GHC.Core.Predicate+import GHC.Core.Type+import GHC.Core.Coercion+import GHC.Core.TyCo.Ppr  ( pprTyVars+                           )+import GHC.Core.InstEnv+import GHC.Core.TyCon+import GHC.Core.DataCon++import GHC.Utils.Error  (diagReasonSeverity,  pprLocMsgEnvelope )+import GHC.Utils.Misc+import GHC.Utils.Outputable as O+import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Utils.FV ( fvVarList, unionFV )++import GHC.Data.Bag+import GHC.Data.List.SetOps ( equivClasses, nubOrdBy )+import GHC.Data.Maybe+import qualified GHC.Data.Strict as Strict++import Control.Monad    ( unless, when, foldM, forM_ )+import Data.Foldable    ( toList )+import Data.Function    ( on )+import Data.List        ( partition, sort, sortBy )+import Data.List.NonEmpty ( NonEmpty(..), (<|) )+import qualified Data.List.NonEmpty as NE ( map, reverse )+import Data.Ord         ( comparing )+import qualified Data.Semigroup as S++{-+************************************************************************+*                                                                      *+\section{Errors and contexts}+*                                                                      *+************************************************************************++ToDo: for these error messages, should we note the location as coming+from the insts, or just whatever seems to be around in the monad just+now?++Note [Deferring coercion errors to runtime]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+While developing, sometimes it is desirable to allow compilation to succeed even+if there are type errors in the code. Consider the following case:++  module Main where++  a :: Int+  a = 'a'++  main = print "b"++Even though `a` is ill-typed, it is not used in the end, so if all that we're+interested in is `main` it is handy to be able to ignore the problems in `a`.++Since we treat type equalities as evidence, this is relatively simple. Whenever+we run into a type mismatch in GHC.Tc.Utils.Unify, we normally just emit an error. But it+is always safe to defer the mismatch to the main constraint solver. If we do+that, `a` will get transformed into++  co :: Int ~ Char+  co = ...++  a :: Int+  a = 'a' `cast` co++The constraint solver would realize that `co` is an insoluble constraint, and+emit an error with `reportUnsolved`. But we can also replace the right-hand side+of `co` with `error "Deferred type error: Int ~ Char"`. This allows the program+to compile, and it will run fine unless we evaluate `a`. This is what+`deferErrorsToRuntime` does.++It does this by keeping track of which errors correspond to which coercion+in GHC.Tc.Errors. GHC.Tc.Errors.reportTidyWanteds does not print the errors+and does not fail if -fdefer-type-errors is on, so that we can continue+compilation. The errors are turned into warnings in `reportUnsolved`.+-}++-- | Report unsolved goals as errors or warnings. We may also turn some into+-- deferred run-time errors if `-fdefer-type-errors` is on.+reportUnsolved :: WantedConstraints -> TcM (Bag EvBind)+reportUnsolved wanted+  = do { binds_var <- newTcEvBinds+       ; defer_errors <- goptM Opt_DeferTypeErrors+       ; let type_errors | not defer_errors = ErrorWithoutFlag+                         | otherwise        = WarningWithFlag Opt_WarnDeferredTypeErrors++       ; defer_holes <- goptM Opt_DeferTypedHoles+       ; let expr_holes | not defer_holes = ErrorWithoutFlag+                        | otherwise       = WarningWithFlag Opt_WarnTypedHoles++       ; partial_sigs      <- xoptM LangExt.PartialTypeSignatures+       ; let type_holes | not partial_sigs+                        = ErrorWithoutFlag+                        | otherwise+                        = WarningWithFlag Opt_WarnPartialTypeSignatures++       ; defer_out_of_scope <- goptM Opt_DeferOutOfScopeVariables+       ; let out_of_scope_holes | not defer_out_of_scope+                                = ErrorWithoutFlag+                                | otherwise+                                = WarningWithFlag Opt_WarnDeferredOutOfScopeVariables++       ; report_unsolved type_errors expr_holes+                         type_holes out_of_scope_holes+                         binds_var wanted++       ; ev_binds <- getTcEvBindsMap binds_var+       ; return (evBindMapBinds ev_binds)}++-- | Report *all* unsolved goals as errors, even if -fdefer-type-errors is on+-- However, do not make any evidence bindings, because we don't+-- have any convenient place to put them.+-- NB: Type-level holes are OK, because there are no bindings.+-- See Note [Deferring coercion errors to runtime]+-- Used by solveEqualities for kind equalities+--      (see Note [Fail fast on kind errors] in "GHC.Tc.Solver")+reportAllUnsolved :: WantedConstraints -> TcM ()+reportAllUnsolved wanted+  = do { ev_binds <- newNoTcEvBinds++       ; partial_sigs      <- xoptM LangExt.PartialTypeSignatures+       ; let type_holes | not partial_sigs  = ErrorWithoutFlag+                        | otherwise         = WarningWithFlag Opt_WarnPartialTypeSignatures++       ; report_unsolved ErrorWithoutFlag+                         ErrorWithoutFlag type_holes ErrorWithoutFlag+                         ev_binds wanted }++-- | Report all unsolved goals as warnings (but without deferring any errors to+-- run-time). See Note [Safe Haskell Overlapping Instances Implementation] in+-- "GHC.Tc.Solver"+warnAllUnsolved :: WantedConstraints -> TcM ()+warnAllUnsolved wanted+  = do { ev_binds <- newTcEvBinds+       ; report_unsolved WarningWithoutFlag+                         WarningWithoutFlag+                         WarningWithoutFlag+                         WarningWithoutFlag+                         ev_binds wanted }++-- | Report unsolved goals as errors or warnings.+report_unsolved :: DiagnosticReason -- Deferred type errors+                -> DiagnosticReason -- Expression holes+                -> DiagnosticReason -- Type holes+                -> DiagnosticReason -- Out of scope holes+                -> EvBindsVar        -- cec_binds+                -> WantedConstraints -> TcM ()+report_unsolved type_errors expr_holes+    type_holes out_of_scope_holes binds_var wanted+  | isEmptyWC wanted+  = return ()+  | otherwise+  = do { traceTc "reportUnsolved {" $+         vcat [ text "type errors:" <+> ppr type_errors+              , text "expr holes:" <+> ppr expr_holes+              , text "type holes:" <+> ppr type_holes+              , text "scope holes:" <+> ppr out_of_scope_holes ]+       ; traceTc "reportUnsolved (before zonking and tidying)" (ppr wanted)++       ; wanted <- zonkWC wanted   -- Zonk to reveal all information++       ; let tidy_env = tidyFreeTyCoVars emptyTidyEnv free_tvs+             free_tvs = filterOut isCoVar $+                        tyCoVarsOfWCList wanted+                        -- tyCoVarsOfWC returns free coercion *holes*, even though+                        -- they are "bound" by other wanted constraints. They in+                        -- turn may mention variables bound further in, which makes+                        -- no sense. Really we should not return those holes at all;+                        -- for now we just filter them out.++       ; traceTc "reportUnsolved (after zonking):" $+         vcat [ text "Free tyvars:" <+> pprTyVars free_tvs+              , text "Tidy env:" <+> ppr tidy_env+              , text "Wanted:" <+> ppr wanted ]++       ; warn_redundant <- woptM Opt_WarnRedundantConstraints+       ; exp_syns <- goptM Opt_PrintExpandedSynonyms+       ; let err_ctxt = CEC { cec_encl  = []+                            , cec_tidy  = tidy_env+                            , cec_defer_type_errors = type_errors+                            , cec_expr_holes = expr_holes+                            , cec_type_holes = type_holes+                            , cec_out_of_scope_holes = out_of_scope_holes+                            , cec_suppress = insolubleWC wanted+                                 -- See Note [Suppressing error messages]+                                 -- Suppress low-priority errors if there+                                 -- are insoluble errors anywhere;+                                 -- See #15539 and c.f. setting ic_status+                                 -- in GHC.Tc.Solver.setImplicationStatus+                            , cec_warn_redundant = warn_redundant+                            , cec_expand_syns = exp_syns+                            , cec_binds    = binds_var }++       ; tc_lvl <- getTcLevel+       ; reportWanteds err_ctxt tc_lvl wanted+       ; traceTc "reportUnsolved }" empty }++--------------------------------------------+--      Internal functions+--------------------------------------------++-- | Make a report from a single 'TcSolverReportMsg'.+important :: SolverReportErrCtxt -> TcSolverReportMsg -> SolverReport+important ctxt doc = mempty { sr_important_msgs = [SolverReportWithCtxt ctxt doc] }++mk_relevant_bindings :: RelevantBindings -> SolverReport+mk_relevant_bindings binds = mempty { sr_supplementary = [SupplementaryBindings binds] }++mk_report_hints :: [GhcHint] -> SolverReport+mk_report_hints hints = mempty { sr_hints = hints }++-- | Returns True <=> the SolverReportErrCtxt indicates that something is deferred+deferringAnyBindings :: SolverReportErrCtxt -> Bool+  -- Don't check cec_type_holes, as these don't cause bindings to be deferred+deferringAnyBindings (CEC { cec_defer_type_errors  = ErrorWithoutFlag+                          , cec_expr_holes         = ErrorWithoutFlag+                          , cec_out_of_scope_holes = ErrorWithoutFlag }) = False+deferringAnyBindings _                                                   = True++maybeSwitchOffDefer :: EvBindsVar -> SolverReportErrCtxt -> SolverReportErrCtxt+-- Switch off defer-type-errors inside CoEvBindsVar+-- See Note [Failing equalities with no evidence bindings]+maybeSwitchOffDefer evb ctxt+ | CoEvBindsVar{} <- evb+ = ctxt { cec_defer_type_errors  = ErrorWithoutFlag+        , cec_expr_holes         = ErrorWithoutFlag+        , cec_out_of_scope_holes = ErrorWithoutFlag }+ | otherwise+ = ctxt++{- Note [Failing equalities with no evidence bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we go inside an implication that has no term evidence+(e.g. unifying under a forall), we can't defer type errors.  You could+imagine using the /enclosing/ bindings (in cec_binds), but that may+not have enough stuff in scope for the bindings to be well typed.  So+we just switch off deferred type errors altogether.  See #14605.++This is done by maybeSwitchOffDefer.  It's also useful in one other+place: see Note [Wrapping failing kind equalities] in GHC.Tc.Solver.++Note [Suppressing error messages]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The cec_suppress flag says "don't report any errors".  Instead, just create+evidence bindings (as usual).  It's used when more important errors have occurred.++Specifically (see reportWanteds)+  * If there are insoluble Givens, then we are in unreachable code and all bets+    are off.  So don't report any further errors.+  * If there are any insolubles (eg Int~Bool), here or in a nested implication,+    then suppress errors from the simple constraints here.  Sometimes the+    simple-constraint errors are a knock-on effect of the insolubles.++This suppression behaviour is controlled by the Bool flag in+ReportErrorSpec, as used in reportWanteds.++But we need to take care: flags can turn errors into warnings, and we+don't want those warnings to suppress subsequent errors (including+suppressing the essential addTcEvBind for them: #15152). So in+tryReporter we use askNoErrs to see if any error messages were+/actually/ produced; if not, we don't switch on suppression.++A consequence is that warnings never suppress warnings, so turning an+error into a warning may allow subsequent warnings to appear that were+previously suppressed.   (e.g. partial-sigs/should_fail/T14584)+-}++reportImplic :: SolverReportErrCtxt -> Implication -> TcM ()+reportImplic ctxt implic@(Implic { ic_skols  = tvs+                                 , ic_given  = given+                                 , ic_wanted = wanted, ic_binds = evb+                                 , ic_status = status, ic_info = info+                                 , ic_env    = tcl_env+                                 , ic_tclvl  = tc_lvl })+  | BracketSkol <- info+  , not insoluble+  = return ()        -- For Template Haskell brackets report only+                     -- definite errors. The whole thing will be re-checked+                     -- later when we plug it in, and meanwhile there may+                     -- certainly be un-satisfied constraints++  | otherwise+  = do { traceTc "reportImplic" $ vcat+           [ text "tidy env:"   <+> ppr (cec_tidy ctxt)+           , text "skols:     " <+> pprTyVars tvs+           , text "tidy skols:" <+> pprTyVars tvs' ]++       ; when bad_telescope $ reportBadTelescope ctxt tcl_env info tvs+               -- Do /not/ use the tidied tvs because then are in the+               -- wrong order, so tidying will rename things wrongly+       ; reportWanteds ctxt' tc_lvl wanted+       ; when (cec_warn_redundant ctxt) $+         warnRedundantConstraints ctxt' tcl_env info' dead_givens }+  where+    insoluble    = isInsolubleStatus status+    (env1, tvs') = tidyVarBndrs (cec_tidy ctxt) $+                   scopedSort tvs+        -- scopedSort: the ic_skols may not be in dependency order+        -- (see Note [Skolems in an implication] in GHC.Tc.Types.Constraint)+        -- but tidying goes wrong on out-of-order constraints;+        -- so we sort them here before tidying+    info'   = tidySkolemInfoAnon env1 info+    implic' = implic { ic_skols = tvs'+                     , ic_given = map (tidyEvVar env1) given+                     , ic_info  = info' }++    ctxt1 = maybeSwitchOffDefer evb ctxt+    ctxt' = ctxt1 { cec_tidy     = env1+                  , cec_encl     = implic' : cec_encl ctxt++                  , cec_suppress = insoluble || cec_suppress ctxt+                        -- Suppress inessential errors if there+                        -- are insolubles anywhere in the+                        -- tree rooted here, or we've come across+                        -- a suppress-worthy constraint higher up (#11541)++                  , cec_binds    = evb }++    dead_givens = case status of+                    IC_Solved { ics_dead = dead } -> dead+                    _                             -> []++    bad_telescope = case status of+              IC_BadTelescope -> True+              _               -> False++warnRedundantConstraints :: SolverReportErrCtxt -> TcLclEnv -> SkolemInfoAnon -> [EvVar] -> TcM ()+-- See Note [Tracking redundant constraints] in GHC.Tc.Solver+warnRedundantConstraints ctxt env info ev_vars+ | null redundant_evs+ = return ()++ | SigSkol user_ctxt _ _ <- info+ -- When dealing with a user-written type signature,+ -- we want to add "In the type signature for f".+ = restoreLclEnv env $+   setSrcSpan (redundantConstraintsSpan user_ctxt) $+   report_redundant_msg True+                  --  ^^^^ add "In the type signature..."++ | otherwise+ -- But for InstSkol there already *is* a surrounding+ -- "In the instance declaration for Eq [a]" context+ -- and we don't want to say it twice. Seems a bit ad-hoc+ = restoreLclEnv env+ $ report_redundant_msg False+                 --   ^^^^^ don't add "In the type signature..."+ where+   report_redundant_msg :: Bool -- whether to add "In the type signature..." to the diagnostic+                        -> TcRn ()+   report_redundant_msg show_info+     = do { lcl_env <- getLclEnv+          ; msg <-+              mkErrorReport+                lcl_env+                (TcRnRedundantConstraints redundant_evs (info, show_info))+                (Just ctxt)+                []+          ; reportDiagnostic msg }++   redundant_evs =+       filterOut is_type_error $+       case info of -- See Note [Redundant constraints in instance decls]+         InstSkol -> filterOut (improving . idType) ev_vars+         _        -> ev_vars++   -- See #15232+   is_type_error = isJust . userTypeError_maybe . idType++   improving pred -- (transSuperClasses p) does not include p+     = any isImprovementPred (pred : transSuperClasses pred)++reportBadTelescope :: SolverReportErrCtxt -> TcLclEnv -> SkolemInfoAnon -> [TcTyVar] -> TcM ()+reportBadTelescope ctxt env (ForAllSkol telescope) skols+  = do { msg <- mkErrorReport+                  env+                  (TcRnSolverReport [report] ErrorWithoutFlag noHints)+                  (Just ctxt)+                  []+       ; reportDiagnostic msg }+  where+    report = SolverReportWithCtxt ctxt $ BadTelescope telescope skols++reportBadTelescope _ _ skol_info skols+  = pprPanic "reportBadTelescope" (ppr skol_info $$ ppr skols)++{- Note [Redundant constraints in instance decls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For instance declarations, we don't report unused givens if+they can give rise to improvement.  Example (#10100):+    class Add a b ab | a b -> ab, a ab -> b+    instance Add Zero b b+    instance Add a b ab => Add (Succ a) b (Succ ab)+The context (Add a b ab) for the instance is clearly unused in terms+of evidence, since the dictionary has no fields.  But it is still+needed!  With the context, a wanted constraint+   Add (Succ Zero) beta (Succ Zero)+we will reduce to (Add Zero beta Zero), and thence we get beta := Zero.+But without the context we won't find beta := Zero.++This only matters in instance declarations..+-}++-- | Should we completely ignore this constraint in error reporting?+-- It *must* be the case that any constraint for which this returns True+-- somehow causes an error to be reported elsewhere.+-- See Note [Constraints to ignore].+ignoreConstraint :: Ct -> Bool+ignoreConstraint ct+  | AssocFamPatOrigin <- ctOrigin ct+  = True+  | otherwise+  = False++-- | Makes an error item from a constraint, calculating whether or not+-- the item should be suppressed. See Note [Wanteds rewrite Wanteds]+-- in GHC.Tc.Types.Constraint. Returns Nothing if we should just ignore+-- a constraint. See Note [Constraints to ignore].+mkErrorItem :: Ct -> TcM (Maybe ErrorItem)+mkErrorItem ct+  | ignoreConstraint ct+  = do { traceTc "Ignoring constraint:" (ppr ct)+       ; return Nothing }   -- See Note [Constraints to ignore]++  | otherwise+  = do { let loc = ctLoc ct+             flav = ctFlavour ct++       ; (suppress, m_evdest) <- case ctEvidence ct of+           CtGiven {} -> return (False, Nothing)+           CtWanted { ctev_rewriters = rewriters, ctev_dest = dest }+             -> do { supp <- anyUnfilledCoercionHoles rewriters+                   ; return (supp, Just dest) }++       ; let m_reason = case ct of CIrredCan { cc_reason = reason } -> Just reason+                                   _                                -> Nothing++       ; return $ Just $ EI { ei_pred     = ctPred ct+                            , ei_evdest   = m_evdest+                            , ei_flavour  = flav+                            , ei_loc      = loc+                            , ei_m_reason = m_reason+                            , ei_suppress = suppress }}++----------------------------------------------------------------+reportWanteds :: SolverReportErrCtxt -> TcLevel -> WantedConstraints -> TcM ()+reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics+                                 , wc_errors = errs })+  | isEmptyWC wc = traceTc "reportWanteds empty WC" empty+  | otherwise+  = do { tidy_items <- mapMaybeM mkErrorItem tidy_cts+       ; traceTc "reportWanteds 1" (vcat [ text "Simples =" <+> ppr simples+                                         , text "Suppress =" <+> ppr (cec_suppress ctxt)+                                         , text "tidy_cts   =" <+> ppr tidy_cts+                                         , text "tidy_items =" <+> ppr tidy_items+                                         , text "tidy_errs =" <+> ppr tidy_errs ])++       -- This check makes sure that we aren't suppressing the only error that will+       -- actually stop compilation+       ; assertPprM+           ( do { errs_already <- ifErrsM (return True) (return False)+                ; return $+                    errs_already ||                  -- we already reported an error (perhaps from an outer implication)+                    null simples ||                  -- no errors to report here+                    any ignoreConstraint simples ||  -- one error is ignorable (is reported elsewhere)+                    not (all ei_suppress tidy_items) -- not all errors are suppressed+                } )+           (vcat [text "reportWanteds is suppressing all errors"])++         -- First, deal with any out-of-scope errors:+       ; let (out_of_scope, other_holes, not_conc_errs) = partition_errors tidy_errs+               -- don't suppress out-of-scope errors+             ctxt_for_scope_errs = ctxt { cec_suppress = False }+       ; (_, no_out_of_scope) <- askNoErrs $+                                 reportHoles tidy_items ctxt_for_scope_errs out_of_scope++         -- Next, deal with things that are utterly wrong+         -- Like Int ~ Bool (incl nullary TyCons)+         -- or  Int ~ t a   (AppTy on one side)+         -- These /ones/ are not suppressed by the incoming context+         -- (but will be by out-of-scope errors)+       ; let ctxt_for_insols = ctxt { cec_suppress = not no_out_of_scope }+       ; reportHoles tidy_items ctxt_for_insols other_holes+          -- holes never suppress++       ; reportNotConcreteErrs ctxt_for_insols not_conc_errs++          -- See Note [Suppressing confusing errors]+       ; let (suppressed_items, items0) = partition suppress tidy_items+       ; traceTc "reportWanteds suppressed:" (ppr suppressed_items)+       ; (ctxt1, items1) <- tryReporters ctxt_for_insols report1 items0++         -- Now all the other constraints.  We suppress errors here if+         -- any of the first batch failed, or if the enclosing context+         -- says to suppress+       ; let ctxt2 = ctxt1 { cec_suppress = cec_suppress ctxt || cec_suppress ctxt1 }+       ; (ctxt3, leftovers) <- tryReporters ctxt2 report2 items1+       ; massertPpr (null leftovers)+           (text "The following unsolved Wanted constraints \+                 \have not been reported to the user:"+           $$ ppr leftovers)++       ; mapBagM_ (reportImplic ctxt2) implics+            -- NB ctxt2: don't suppress inner insolubles if there's only a+            -- wanted insoluble here; but do suppress inner insolubles+            -- if there's a *given* insoluble here (= inaccessible code)++            -- Only now, if there are no errors, do we report suppressed ones+            -- See Note [Suppressing confusing errors]+            -- We don't need to update the context further because of the+            -- whenNoErrs guard+       ; whenNoErrs $+         do { (_, more_leftovers) <- tryReporters ctxt3 report3 suppressed_items+            ; massertPpr (null more_leftovers) (ppr more_leftovers) } }+ where+    env       = cec_tidy ctxt+    tidy_cts  = bagToList (mapBag (tidyCt env)   simples)+    tidy_errs = bagToList (mapBag (tidyDelayedError env) errs)++    partition_errors :: [DelayedError] -> ([Hole], [Hole], [NotConcreteError])+    partition_errors = go [] [] []+      where+        go out_of_scope other_holes syn_eqs []+          = (out_of_scope, other_holes, syn_eqs)+        go es1 es2 es3 (err:errs)+          | (es1, es2, es3) <- go es1 es2 es3 errs+          = case err of+              DE_Hole hole+                | isOutOfScopeHole hole+                -> (hole : es1, es2, es3)+                | otherwise+                -> (es1, hole : es2, es3)+              DE_NotConcrete err+                -> (es1, es2, err : es3)++      -- See Note [Suppressing confusing errors]+    suppress :: ErrorItem -> Bool+    suppress item+      | Wanted <- ei_flavour item+      = is_ww_fundep_item item+      | otherwise+      = False++    -- report1: ones that should *not* be suppressed by+    --          an insoluble somewhere else in the tree+    -- It's crucial that anything that is considered insoluble+    -- (see GHC.Tc.Utils.insolublWantedCt) is caught here, otherwise+    -- we might suppress its error message, and proceed on past+    -- type checking to get a Lint error later+    report1 = [ ("custom_error", is_user_type_error, True,  mkUserTypeErrorReporter)++              , given_eq_spec+              , ("insoluble2",      utterly_wrong,  True, mkGroupReporter mkEqErr)+              , ("skolem eq1",      very_wrong,     True, mkSkolReporter)+              , ("FixedRuntimeRep", is_FRR,         True, mkGroupReporter mkFRRErr)+              , ("skolem eq2",      skolem_eq,      True, mkSkolReporter)+              , ("non-tv eq",       non_tv_eq,      True, mkSkolReporter)++                  -- The only remaining equalities are alpha ~ ty,+                  -- where alpha is untouchable; and representational equalities+                  -- Prefer homogeneous equalities over hetero, because the+                  -- former might be holding up the latter.+                  -- See Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical+              , ("Homo eqs",      is_homo_equality,  True,  mkGroupReporter mkEqErr)+              , ("Other eqs",     is_equality,       True,  mkGroupReporter mkEqErr)+              ]++    -- report2: we suppress these if there are insolubles elsewhere in the tree+    report2 = [ ("Implicit params", is_ip,           False, mkGroupReporter mkIPErr)+              , ("Irreds",          is_irred,        False, mkGroupReporter mkIrredErr)+              , ("Dicts",           is_dict,         False, mkGroupReporter mkDictErr) ]++    -- report3: suppressed errors should be reported as categorized by either report1+    -- or report2. Keep this in sync with the suppress function above+    report3 = [ ("wanted/wanted fundeps", is_ww_fundep, True, mkGroupReporter mkEqErr)+              ]++    -- rigid_nom_eq, rigid_nom_tv_eq,+    is_dict, is_equality, is_ip, is_FRR, is_irred :: ErrorItem -> Pred -> Bool++    is_given_eq item pred+       | Given <- ei_flavour item+       , EqPred {} <- pred = True+       | otherwise         = False+       -- I think all given residuals are equalities++    -- Things like (Int ~N Bool)+    utterly_wrong _ (EqPred NomEq ty1 ty2) = isRigidTy ty1 && isRigidTy ty2+    utterly_wrong _ _                      = False++    -- Things like (a ~N Int)+    very_wrong _ (EqPred NomEq ty1 ty2) = isSkolemTy tc_lvl ty1 && isRigidTy ty2+    very_wrong _ _                      = False++    -- Representation-polymorphism errors, to be reported using mkFRRErr.+    is_FRR item _ = isJust $ fixedRuntimeRepOrigin_maybe item++    -- Things like (a ~N b) or (a  ~N  F Bool)+    skolem_eq _ (EqPred NomEq ty1 _) = isSkolemTy tc_lvl ty1+    skolem_eq _ _                    = False++    -- Things like (F a  ~N  Int)+    non_tv_eq _ (EqPred NomEq ty1 _) = not (isTyVarTy ty1)+    non_tv_eq _ _                    = False++    is_user_type_error item _ = isUserTypeError (errorItemPred item)++    is_homo_equality _ (EqPred _ ty1 ty2)+      = tcTypeKind ty1 `tcEqType` tcTypeKind ty2+    is_homo_equality _ _+      = False++    is_equality _(EqPred {}) = True+    is_equality _ _          = False++    is_dict _ (ClassPred {}) = True+    is_dict _ _              = False++    is_ip _ (ClassPred cls _) = isIPClass cls+    is_ip _ _                 = False++    is_irred _ (IrredPred {}) = True+    is_irred _ _              = False++     -- See situation (1) of Note [Suppressing confusing errors]+    is_ww_fundep item _ = is_ww_fundep_item item+    is_ww_fundep_item = isWantedWantedFunDepOrigin . errorItemOrigin++    given_eq_spec  -- See Note [Given errors]+      | has_gadt_match_here+      = ("insoluble1a", is_given_eq, True,  mkGivenErrorReporter)+      | otherwise+      = ("insoluble1b", is_given_eq, False, ignoreErrorReporter)+          -- False means don't suppress subsequent errors+          -- Reason: we don't report all given errors+          --         (see mkGivenErrorReporter), and we should only suppress+          --         subsequent errors if we actually report this one!+          --         #13446 is an example++    -- See Note [Given errors]+    has_gadt_match_here = has_gadt_match (cec_encl ctxt)+    has_gadt_match [] = False+    has_gadt_match (implic : implics)+      | PatSkol {} <- ic_info implic+      , ic_given_eqs implic /= NoGivenEqs+      , ic_warn_inaccessible implic+          -- Don't bother doing this if -Winaccessible-code isn't enabled.+          -- See Note [Avoid -Winaccessible-code when deriving] in GHC.Tc.TyCl.Instance.+      = True+      | otherwise+      = has_gadt_match implics++---------------+isSkolemTy :: TcLevel -> Type -> Bool+-- The type is a skolem tyvar+isSkolemTy tc_lvl ty+  | Just tv <- getTyVar_maybe ty+  =  isSkolemTyVar tv+  || (isTyVarTyVar tv && isTouchableMetaTyVar tc_lvl tv)+     -- The last case is for touchable TyVarTvs+     -- we postpone untouchables to a latter test (too obscure)++  | otherwise+  = False++isTyFun_maybe :: Type -> Maybe TyCon+isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of+                      Just (tc,_) | isTypeFamilyTyCon tc -> Just tc+                      _ -> Nothing++{- Note [Suppressing confusing errors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Certain errors we might encounter are potentially confusing to users.+If there are any other errors to report, at all, we want to suppress these.++Which errors (only 1 case right now):++1) Errors which arise from the interaction of two Wanted fun-dep constraints.+   Example:++     class C a b | a -> b where+       op :: a -> b -> b++     foo _ = op True Nothing++     bar _ = op False []++   Here, we could infer+     foo :: C Bool (Maybe a) => p -> Maybe a+     bar :: C Bool [a]       => p -> [a]++   (The unused arguments suppress the monomorphism restriction.) The problem+   is that these types can't both be correct, as they violate the functional+   dependency. Yet reporting an error here is awkward: we must+   non-deterministically choose either foo or bar to reject. We thus want+   to report this problem only when there is nothing else to report.+   See typecheck/should_fail/T13506 for an example of when to suppress+   the error. The case above is actually accepted, because foo and bar+   are checked separately, and thus the two fundep constraints never+   encounter each other. It is test case typecheck/should_compile/FunDepOrigin1.++   This case applies only when both fundeps are *Wanted* fundeps; when+   both are givens, the error represents unreachable code. For+   a Given/Wanted case, see #9612.++Mechanism:++We use the `suppress` function within reportWanteds to filter out these two+cases, then report all other errors. Lastly, we return to these suppressed+ones and report them only if there have been no errors so far.++Note [Constraints to ignore]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Some constraints are meant only to aid the solver by unification; a failure+to solve them is not necessarily an error to report to the user. It is critical+that compilation is aborted elsewhere if there are any ignored constraints here;+they will remain unfilled, and might have been used to rewrite another constraint.++Currently, the constraints to ignore are:++1) Constraints generated in order to unify associated type instance parameters+   with class parameters. Here are two illustrative examples:++     class C (a :: k) where+       type F (b :: k)++     instance C True where+       type F a = Int++     instance C Left where+       type F (Left :: a -> Either a b) = Bool++   In the first instance, we want to infer that `a` has type Bool. So we emit+   a constraint unifying kappa (the guessed type of `a`) with Bool. All is well.++   In the second instance, we process the associated type instance only+   after fixing the quantified type variables of the class instance. We thus+   have skolems a1 and b1 such that the class instance is for (Left :: a1 -> Either a1 b1).+   Unifying a1 and b1 with a and b in the type instance will fail, but harmlessly so.+   checkConsistentFamInst checks for this, and will fail if anything has gone+   awry. Really the equality constraints emitted are just meant as an aid, not+   a requirement. This is test case T13972.++   We detect this case by looking for an origin of AssocFamPatOrigin; constraints+   with this origin are dropped entirely during error message reporting.++   If there is any trouble, checkValidFamInst bleats, aborting compilation.++-}++++--------------------------------------------+--      Reporters+--------------------------------------------++type Reporter+  = SolverReportErrCtxt -> [ErrorItem] -> TcM ()+type ReporterSpec+  = ( String                      -- Name+    , ErrorItem -> Pred -> Bool  -- Pick these ones+    , Bool                        -- True <=> suppress subsequent reporters+    , Reporter)                   -- The reporter itself++mkSkolReporter :: Reporter+-- Suppress duplicates with either the same LHS, or same location+-- Pre-condition: all items are equalities+mkSkolReporter ctxt items+  = mapM_ (reportGroup mkEqErr ctxt) (group items)+  where+     group [] = []+     group (item:items) = (item : yeses) : group noes+        where+          (yeses, noes) = partition (group_with item) items++     group_with item1 item2+       | EQ <- cmp_loc item1 item2 = True+       | eq_lhs_type   item1 item2 = True+       | otherwise                 = False++reportHoles :: [ErrorItem]  -- other (tidied) constraints+            -> SolverReportErrCtxt -> [Hole] -> TcM ()+reportHoles tidy_items ctxt holes+  = do+      diag_opts <- initDiagOpts <$> getDynFlags+      let severity = diagReasonSeverity diag_opts (cec_type_holes ctxt)+          holes'   = filter (keepThisHole severity) holes+      -- Zonk and tidy all the TcLclEnvs before calling `mkHoleError`+      -- because otherwise types will be zonked and tidied many times over.+      (tidy_env', lcl_name_cache) <- zonkTidyTcLclEnvs (cec_tidy ctxt) (map (ctl_env . hole_loc) holes')+      let ctxt' = ctxt { cec_tidy = tidy_env' }+      forM_ holes' $ \hole -> do { msg <- mkHoleError lcl_name_cache tidy_items ctxt' hole+                                 ; reportDiagnostic msg }++keepThisHole :: Severity -> Hole -> Bool+-- See Note [Skip type holes rapidly]+keepThisHole sev hole+  = case hole_sort hole of+       ExprHole {}    -> True+       TypeHole       -> keep_type_hole+       ConstraintHole -> keep_type_hole+  where+    keep_type_hole = case sev of+                         SevIgnore -> False+                         _         -> True++-- | zonkTidyTcLclEnvs takes a bunch of 'TcLclEnv's, each from a Hole.+-- It returns a ('Name' :-> 'Type') mapping which gives the zonked, tidied+-- type for each Id in any of the binder stacks in the  'TcLclEnv's.+-- Since there is a huge overlap between these stacks, is is much,+-- much faster to do them all at once, avoiding duplication.+zonkTidyTcLclEnvs :: TidyEnv -> [TcLclEnv] -> TcM (TidyEnv, NameEnv Type)+zonkTidyTcLclEnvs tidy_env lcls = foldM go (tidy_env, emptyNameEnv) (concatMap tcl_bndrs lcls)+  where+    go envs tc_bndr = case tc_bndr of+          TcTvBndr {} -> return envs+          TcIdBndr id _top_lvl -> go_one (idName id) (idType id) envs+          TcIdBndr_ExpType name et _top_lvl ->+            do { mb_ty <- readExpType_maybe et+                   -- et really should be filled in by now. But there's a chance+                   -- it hasn't, if, say, we're reporting a kind error en route to+                   -- checking a term. See test indexed-types/should_fail/T8129+                   -- Or we are reporting errors from the ambiguity check on+                   -- a local type signature+               ; case mb_ty of+                   Just ty -> go_one name ty envs+                   Nothing -> return envs+               }+    go_one name ty (tidy_env, name_env) = do+            if name `elemNameEnv` name_env+              then return (tidy_env, name_env)+              else do+                (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env ty+                return (tidy_env',  extendNameEnv name_env name tidy_ty)++reportNotConcreteErrs :: SolverReportErrCtxt -> [NotConcreteError] -> TcM ()+reportNotConcreteErrs _ [] = return ()+reportNotConcreteErrs ctxt errs@(err0:_)+  = do { msg <- mkErrorReport (ctLocEnv (nce_loc err0)) diag (Just ctxt) []+       ; reportDiagnostic msg }++  where++    frr_origins = acc_errors errs+    diag = TcRnSolverReport+             [SolverReportWithCtxt ctxt (FixedRuntimeRepError frr_origins)]+             ErrorWithoutFlag noHints++    -- Accumulate the different kind of errors arising from syntactic equality.+    -- (Only SynEq_FRR origin for the moment.)+    acc_errors = go []+      where+        go frr_errs [] = frr_errs+        go frr_errs (err:errs)+          | frr_errs <- go frr_errs errs+          = case err of+              NCE_FRR+                { nce_frr_origin = frr_orig+                , nce_reasons = _not_conc } ->+                FRR_Info+                  { frr_info_origin       = frr_orig+                  , frr_info_not_concrete = Nothing }+                : frr_errs++{- Note [Skip type holes rapidly]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have module with a /lot/ of partial type signatures, and we+compile it while suppressing partial-type-signature warnings.  Then+we don't want to spend ages constructing error messages and lists of+relevant bindings that we never display! This happened in #14766, in+which partial type signatures in a Happy-generated parser cause a huge+increase in compile time.++The function ignoreThisHole short-circuits the error/warning generation+machinery, in cases where it is definitely going to be a no-op.+-}++mkUserTypeErrorReporter :: Reporter+mkUserTypeErrorReporter ctxt+  = mapM_ $ \item -> do { let err = important ctxt $ mkUserTypeError item+                        ; maybeReportError ctxt [item] err+                        ; addDeferredBinding ctxt err item }++mkUserTypeError :: ErrorItem -> TcSolverReportMsg+mkUserTypeError item =+  case getUserTypeErrorMsg (errorItemPred item) of+    Just msg -> UserTypeError msg+    Nothing  -> pprPanic "mkUserTypeError" (ppr item)++mkGivenErrorReporter :: Reporter+-- See Note [Given errors]+mkGivenErrorReporter ctxt items+  = do { (ctxt, relevant_binds, item) <- relevantBindings True ctxt item+       ; let (implic:_) = cec_encl ctxt+                 -- Always non-empty when mkGivenErrorReporter is called+             loc'  = setCtLocEnv (ei_loc item) (ic_env implic)+             item' = item { ei_loc = loc' }+                   -- For given constraints we overwrite the env (and hence src-loc)+                   -- with one from the immediately-enclosing implication.+                   -- See Note [Inaccessible code]++       ; (eq_err_msgs, _hints) <- mkEqErr_help ctxt item' ty1 ty2+       -- The hints wouldn't help in this situation, so we discard them.+       ; let supplementary = [ SupplementaryBindings relevant_binds ]+             msg = TcRnInaccessibleCode implic (NE.reverse . NE.map (SolverReportWithCtxt ctxt) $ eq_err_msgs)+       ; msg <- mkErrorReport (ctLocEnv loc') msg (Just ctxt) supplementary+       ; reportDiagnostic msg }+  where+    (item : _ )  = items    -- Never empty+    (ty1, ty2)   = getEqPredTys (errorItemPred item)++ignoreErrorReporter :: Reporter+-- Discard Given errors that don't come from+-- a pattern match; maybe we should warn instead?+ignoreErrorReporter ctxt items+  = do { traceTc "mkGivenErrorReporter no" (ppr items $$ ppr (cec_encl ctxt))+       ; return () }+++{- Note [Given errors]+~~~~~~~~~~~~~~~~~~~~~~+Given constraints represent things for which we have (or will have)+evidence, so they aren't errors.  But if a Given constraint is+insoluble, this code is inaccessible, and we might want to at least+warn about that.  A classic case is++   data T a where+     T1 :: T Int+     T2 :: T a+     T3 :: T Bool++   f :: T Int -> Bool+   f T1 = ...+   f T2 = ...+   f T3 = ...  -- We want to report this case as inaccessible++We'd like to point out that the T3 match is inaccessible. It+will have a Given constraint [G] Int ~ Bool.++But we don't want to report ALL insoluble Given constraints.  See Trac+#12466 for a long discussion.  For example, if we aren't careful+we'll complain about+   f :: ((Int ~ Bool) => a -> a) -> Int+which arguably is OK.  It's more debatable for+   g :: (Int ~ Bool) => Int -> Int+but it's tricky to distinguish these cases so we don't report+either.++The bottom line is this: has_gadt_match looks for an enclosing+pattern match which binds some equality constraints.  If we+find one, we report the insoluble Given.+-}++mkGroupReporter :: (SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport)+                             -- Make error message for a group+                -> Reporter  -- Deal with lots of constraints+-- Group together errors from same location,+-- and report only the first (to avoid a cascade)+mkGroupReporter mk_err ctxt items+  = mapM_ (reportGroup mk_err ctxt . toList) (equivClasses cmp_loc items)++eq_lhs_type :: ErrorItem -> ErrorItem -> Bool+eq_lhs_type item1 item2+  = case (classifyPredType (errorItemPred item1), classifyPredType (errorItemPred item2)) of+       (EqPred eq_rel1 ty1 _, EqPred eq_rel2 ty2 _) ->+         (eq_rel1 == eq_rel2) && (ty1 `eqType` ty2)+       _ -> pprPanic "mkSkolReporter" (ppr item1 $$ ppr item2)++cmp_loc :: ErrorItem -> ErrorItem -> Ordering+cmp_loc item1 item2 = get item1 `compare` get item2+  where+    get ei = realSrcSpanStart (ctLocSpan (errorItemCtLoc ei))+             -- Reduce duplication by reporting only one error from each+             -- /starting/ location even if the end location differs++reportGroup :: (SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport) -> Reporter+reportGroup mk_err ctxt items+  = do { err <- mk_err ctxt items+       ; traceTc "About to maybeReportErr" $+         vcat [ text "Constraint:"             <+> ppr items+              , text "cec_suppress ="          <+> ppr (cec_suppress ctxt)+              , text "cec_defer_type_errors =" <+> ppr (cec_defer_type_errors ctxt) ]+       ; maybeReportError ctxt items err+           -- But see Note [Always warn with -fdefer-type-errors]+       ; traceTc "reportGroup" (ppr items)+       ; mapM_ (addDeferredBinding ctxt err) items }+           -- Add deferred bindings for all+           -- Redundant if we are going to abort compilation,+           -- but that's hard to know for sure, and if we don't+           -- abort, we need bindings for all (e.g. #12156)++-- See Note [No deferring for multiplicity errors]+nonDeferrableOrigin :: CtOrigin -> Bool+nonDeferrableOrigin NonLinearPatternOrigin  = True+nonDeferrableOrigin (UsageEnvironmentOf {}) = True+nonDeferrableOrigin (FRROrigin {})          = True+nonDeferrableOrigin _                       = False++maybeReportError :: SolverReportErrCtxt+                 -> [ErrorItem]     -- items covered by the Report+                 -> SolverReport -> TcM ()+maybeReportError ctxt items@(item1:_) (SolverReport { sr_important_msgs = important+                                                    , sr_supplementary = supp+                                                    , sr_hints = hints })+  = unless (cec_suppress ctxt  -- Some worse error has occurred, so suppress this diagnostic+         || all ei_suppress items) $+                           -- if they're all to be suppressed, report nothing+                           -- if at least one is not suppressed, do report:+                           -- the function that generates the error message+                           -- should look for an unsuppressed error item+    do let reason | any (nonDeferrableOrigin . errorItemOrigin) items = ErrorWithoutFlag+                  | otherwise                                         = cec_defer_type_errors ctxt+                  -- See Note [No deferring for multiplicity errors]+           diag = TcRnSolverReport important reason hints+       msg <- mkErrorReport (ctLocEnv (errorItemCtLoc item1)) diag (Just ctxt) supp+       reportDiagnostic msg+maybeReportError _ _ _ = panic "maybeReportError"++addDeferredBinding :: SolverReportErrCtxt -> SolverReport -> ErrorItem -> TcM ()+-- See Note [Deferring coercion errors to runtime]+addDeferredBinding ctxt err (EI { ei_evdest = Just dest, ei_pred = item_ty+                                , ei_loc = loc })+     -- if evdest is Just, then the constraint was from a wanted+  | deferringAnyBindings ctxt+  = do { err_tm <- mkErrorTerm ctxt loc item_ty err+       ; let ev_binds_var = cec_binds ctxt++       ; case dest of+           EvVarDest evar+             -> addTcEvBind ev_binds_var $ mkWantedEvBind evar err_tm+           HoleDest hole+             -> do { -- See Note [Deferred errors for coercion holes]+                     let co_var = coHoleCoVar hole+                   ; addTcEvBind ev_binds_var $ mkWantedEvBind co_var err_tm+                   ; fillCoercionHole hole (mkTcCoVarCo co_var) } }+addDeferredBinding _ _ _ = return ()    -- Do not set any evidence for Given++mkErrorTerm :: SolverReportErrCtxt -> CtLoc -> Type  -- of the error term+            -> SolverReport -> TcM EvTerm+mkErrorTerm ctxt ct_loc ty (SolverReport { sr_important_msgs = important, sr_supplementary = supp })+  = do { msg <- mkErrorReport+                  (ctLocEnv ct_loc)+                  (TcRnSolverReport important ErrorWithoutFlag noHints) (Just ctxt) supp+         -- This will be reported at runtime, so we always want "error:" in the report, never "warning:"+       ; dflags <- getDynFlags+       ; let err_msg = pprLocMsgEnvelope msg+             err_str = showSDoc dflags $+                       err_msg $$ text "(deferred type error)"++       ; return $ evDelayedError ty err_str }++tryReporters :: SolverReportErrCtxt -> [ReporterSpec] -> [ErrorItem] -> TcM (SolverReportErrCtxt, [ErrorItem])+-- Use the first reporter in the list whose predicate says True+tryReporters ctxt reporters items+  = do { let (vis_items, invis_items)+               = partition (isVisibleOrigin . errorItemOrigin) items+       ; traceTc "tryReporters {" (ppr vis_items $$ ppr invis_items)+       ; (ctxt', items') <- go ctxt reporters vis_items invis_items+       ; traceTc "tryReporters }" (ppr items')+       ; return (ctxt', items') }+  where+    go ctxt [] vis_items invis_items+      = return (ctxt, vis_items ++ invis_items)++    go ctxt (r : rs) vis_items invis_items+       -- always look at *visible* Origins before invisible ones+       -- this is the whole point of isVisibleOrigin+      = do { (ctxt', vis_items') <- tryReporter ctxt r vis_items+           ; (ctxt'', invis_items') <- tryReporter ctxt' r invis_items+           ; go ctxt'' rs vis_items' invis_items' }+                -- Carry on with the rest, because we must make+                -- deferred bindings for them if we have -fdefer-type-errors+                -- But suppress their error messages++tryReporter :: SolverReportErrCtxt -> ReporterSpec -> [ErrorItem] -> TcM (SolverReportErrCtxt, [ErrorItem])+tryReporter ctxt (str, keep_me,  suppress_after, reporter) items+  | null yeses+  = return (ctxt, items)+  | otherwise+  = do { traceTc "tryReporter{ " (text str <+> ppr yeses)+       ; (_, no_errs) <- askNoErrs (reporter ctxt yeses)+       ; let suppress_now   = not no_errs && suppress_after+                            -- See Note [Suppressing error messages]+             ctxt' = ctxt { cec_suppress = suppress_now || cec_suppress ctxt }+       ; traceTc "tryReporter end }" (text str <+> ppr (cec_suppress ctxt) <+> ppr suppress_after)+       ; return (ctxt', nos) }+  where+    (yeses, nos) = partition keep items+    keep item = keep_me item (classifyPredType (errorItemPred item))++-- | Wrap an input 'TcRnMessage' with additional contextual information,+-- such as relevant bindings or valid hole fits.+mkErrorReport :: TcLclEnv+              -> TcRnMessage+                  -- ^ The main payload of the message.+              -> Maybe SolverReportErrCtxt+                  -- ^ The context to add, after the main diagnostic+                  -- but before the supplementary information.+                  -- Nothing <=> don't add any context.+              -> [SolverReportSupplementary]+                  -- ^ Supplementary information, to be added at the end of the message.+              -> TcM (MsgEnvelope TcRnMessage)+mkErrorReport tcl_env msg mb_ctxt supplementary+  = do { mb_context <- traverse (\ ctxt -> mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env)) mb_ctxt+       ; unit_state <- hsc_units <$> getTopEnv+       ; hfdc <- getHoleFitDispConfig+       ; let+           err_info =+             ErrInfo+               (fromMaybe empty mb_context)+               (vcat $ map (pprSolverReportSupplementary hfdc) supplementary)+       ; mkTcRnMessage+           (RealSrcSpan (tcl_loc tcl_env) Strict.Nothing)+           (TcRnMessageWithInfo unit_state $ TcRnMessageDetailed err_info msg) }++-- | Pretty-print supplementary information, to add to an error report.+pprSolverReportSupplementary :: HoleFitDispConfig -> SolverReportSupplementary -> SDoc+-- This function should be in "GHC.Tc.Errors.Ppr",+-- but we need it here because 'TcRnMessageDetails' needs an 'SDoc'.+pprSolverReportSupplementary hfdc = \case+  SupplementaryBindings binds -> pprRelevantBindings binds+  SupplementaryHoleFits fits  -> pprValidHoleFits hfdc fits+  SupplementaryCts      cts   -> pprConstraintsInclude cts++-- | Display a collection of valid hole fits.+pprValidHoleFits :: HoleFitDispConfig -> ValidHoleFits -> SDoc+-- This function should be in "GHC.Tc.Errors.Ppr",+-- but we need it here because 'TcRnMessageDetails' needs an 'SDoc'.+pprValidHoleFits hfdc (ValidHoleFits (Fits fits discarded_fits) (Fits refs discarded_refs))+  = fits_msg $$ refs_msg++  where+    fits_msg, refs_msg, fits_discard_msg, refs_discard_msg :: SDoc+    fits_msg = ppUnless (null fits) $+                    hang (text "Valid hole fits include") 2 $+                    vcat (map (pprHoleFit hfdc) fits)+                      $$ ppWhen  discarded_fits fits_discard_msg+    refs_msg = ppUnless (null refs) $+                  hang (text "Valid refinement hole fits include") 2 $+                  vcat (map (pprHoleFit hfdc) refs)+                    $$ ppWhen discarded_refs refs_discard_msg+    fits_discard_msg =+      text "(Some hole fits suppressed;" <+>+      text "use -fmax-valid-hole-fits=N" <+>+      text "or -fno-max-valid-hole-fits)"+    refs_discard_msg =+      text "(Some refinement hole fits suppressed;" <+>+      text "use -fmax-refinement-hole-fits=N" <+>+      text "or -fno-max-refinement-hole-fits)"++-- | Add a "Constraints include..." message.+--+-- See Note [Constraints include ...]+pprConstraintsInclude :: [(PredType, RealSrcSpan)] -> SDoc+-- This function should be in "GHC.Tc.Errors.Ppr",+-- but we need it here because 'TcRnMessageDetails' needs an 'SDoc'.+pprConstraintsInclude cts+  = ppUnless (null cts) $+     hang (text "Constraints include")+        2 (vcat $ map pprConstraint cts)+  where+    pprConstraint (constraint, loc) =+      ppr constraint <+> nest 2 (parens (text "from" <+> ppr loc))++{- Note [Always warn with -fdefer-type-errors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When -fdefer-type-errors is on we warn about *all* type errors, even+if cec_suppress is on.  This can lead to a lot more warnings than you+would get errors without -fdefer-type-errors, but if we suppress any of+them you might get a runtime error that wasn't warned about at compile+time.++To be consistent, we should also report multiple warnings from a single+location in mkGroupReporter, when -fdefer-type-errors is on.  But that+is perhaps a bit *over*-consistent!++With #10283, you can now opt out of deferred type error warnings.++Note [No deferring for multiplicity errors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As explained in Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify,+linear types do not support casts and any nontrivial coercion will raise+an error during desugaring.++This means that even if we defer a multiplicity mismatch during typechecking,+the desugarer will refuse to compile anyway. Worse: the error raised+by the desugarer would shadow the type mismatch warnings (#20083).+As a solution, we refuse to defer submultiplicity constraints. Test: T20083.++To determine whether a constraint arose from a submultiplicity check, we+look at the CtOrigin. All calls to tcSubMult use one of two origins,+UsageEnvironmentOf and NonLinearPatternOrigin. Those origins are not+used outside of linear types.++In the future, we should compile 'WpMultCoercion' to a runtime error with+-fdefer-type-errors, but the current implementation does not always+place the wrapper in the right place and the resulting program can fail Lint.+This plan is tracked in #20083.++Note [Deferred errors for coercion holes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we need to defer a type error where the destination for the evidence+is a coercion hole. We can't just put the error in the hole, because we can't+make an erroneous coercion. (Remember that coercions are erased for runtime.)+Instead, we invent a new EvVar, bind it to an error and then make a coercion+from that EvVar, filling the hole with that coercion. Because coercions'+types are unlifted, the error is guaranteed to be hit before we get to the+coercion.++************************************************************************+*                                                                      *+                Irreducible predicate errors+*                                                                      *+************************************************************************+-}++mkIrredErr :: SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport+mkIrredErr ctxt items+  = do { (ctxt, binds_msg, item1) <- relevantBindings True ctxt item1+       ; let msg = important ctxt $+                   CouldNotDeduce (getUserGivens ctxt) (item1 :| others) Nothing+       ; return $ msg `mappend` mk_relevant_bindings binds_msg }+  where+    (item1:others) = final_items++    filtered_items = filter (not . ei_suppress) items+    final_items | null filtered_items = items+                    -- they're all suppressed; must report *something*+                    -- NB: even though reportWanteds asserts that not+                    -- all items are suppressed, it's possible all the+                    -- irreducibles are suppressed, and so this function+                    -- might get all suppressed items+                | otherwise           = filtered_items++{- Note [Constructing Hole Errors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Whether or not 'mkHoleError' returns an error is not influenced by cec_suppress. In other terms,+these "hole" errors are /not/ suppressed by cec_suppress. We want to see them!++There are two cases to consider:++1. For out-of-scope variables we always report an error, unless -fdefer-out-of-scope-variables is on,+   in which case the messages are discarded. See also #12170 and #12406. If deferring, report a warning+   only if -Wout-of-scope-variables is on.++2. For the general case, when -XPartialTypeSignatures is on, warnings (instead of errors) are generated+   for holes in partial type signatures, unless -Wpartial-type-signatures is not on, in which case+   the messages are discarded. If deferring, report a warning only if -Wtyped-holes is on.++The above can be summarised into the following table:++| Hole Type    | Active Flags                                             | Outcome          |+|--------------|----------------------------------------------------------|------------------|+| out-of-scope | None                                                     | Error            |+| out-of-scope | -fdefer-out-of-scope-variables, -Wout-of-scope-variables | Warning          |+| out-of-scope | -fdefer-out-of-scope-variables                           | Ignore (discard) |+| type         | None                                                     | Error            |+| type         | -XPartialTypeSignatures, -Wpartial-type-signatures       | Warning          |+| type         | -XPartialTypeSignatures                                  | Ignore (discard) |+| expression   | None                                                     | Error            |+| expression   | -Wdefer-typed-holes, -Wtyped-holes                       | Warning          |+| expression   | -Wdefer-typed-holes                                      | Ignore (discard) |++See also 'reportUnsolved'.++-}++----------------+-- | Constructs a new hole error, unless this is deferred. See Note [Constructing Hole Errors].+mkHoleError :: NameEnv Type -> [ErrorItem] -> SolverReportErrCtxt -> Hole -> TcM (MsgEnvelope TcRnMessage)+mkHoleError _ _tidy_simples ctxt hole@(Hole { hole_occ = occ, hole_loc = ct_loc })+  | isOutOfScopeHole hole+  = do { dflags  <- getDynFlags+       ; rdr_env <- getGlobalRdrEnv+       ; imp_info <- getImports+       ; curr_mod <- getModule+       ; hpt <- getHpt+       ; let (imp_errs, hints)+                = unknownNameSuggestions WL_Anything+                    dflags hpt curr_mod rdr_env+                    (tcl_rdr lcl_env) imp_info (mkRdrUnqual occ)+             errs   = [SolverReportWithCtxt ctxt (ReportHoleError hole $ OutOfScopeHole imp_errs)]+             report = SolverReport errs [] hints++       ; maybeAddDeferredBindings ctxt hole report+       ; mkErrorReport lcl_env (TcRnSolverReport errs (cec_out_of_scope_holes ctxt) hints) Nothing []+          -- Pass the value 'Nothing' for the context, as it's generally not helpful+          -- to include the context here.+       }+  where+    lcl_env = ctLocEnv ct_loc++ -- general case: not an out-of-scope error+mkHoleError lcl_name_cache tidy_simples ctxt+  hole@(Hole { hole_ty = hole_ty+             , hole_sort = sort+             , hole_loc = ct_loc })+  = do { rel_binds+           <- relevant_bindings False lcl_env lcl_name_cache (tyCoVarsOfType hole_ty)+               -- The 'False' means "don't filter the bindings"; see Trac #8191++       ; show_hole_constraints <- goptM Opt_ShowHoleConstraints+       ; let relevant_cts+               | ExprHole _ <- sort, show_hole_constraints+               = givenConstraints ctxt+               | otherwise+               = []++       ; show_valid_hole_fits <- goptM Opt_ShowValidHoleFits+       ; (ctxt, hole_fits) <- if show_valid_hole_fits+                              then validHoleFits ctxt tidy_simples hole+                              else return (ctxt, noValidHoleFits)+       ; (grouped_skvs, other_tvs) <- zonkAndGroupSkolTvs hole_ty+       ; let reason | ExprHole _ <- sort = cec_expr_holes ctxt+                    | otherwise          = cec_type_holes ctxt+             errs = [SolverReportWithCtxt ctxt $ ReportHoleError hole $ HoleError sort other_tvs grouped_skvs]+             supp = [ SupplementaryBindings rel_binds+                    , SupplementaryCts      relevant_cts+                    , SupplementaryHoleFits hole_fits ]++       ; maybeAddDeferredBindings ctxt hole (SolverReport errs supp [])++       ; mkErrorReport lcl_env (TcRnSolverReport errs reason noHints) (Just ctxt) supp+       }++  where+    lcl_env = ctLocEnv ct_loc++-- | For all the skolem type variables in a type, zonk the skolem info and group together+-- all the type variables with the same origin.+zonkAndGroupSkolTvs :: Type -> TcM ([(SkolemInfoAnon, [TcTyVar])], [TcTyVar])+zonkAndGroupSkolTvs hole_ty = do+  zonked_info <- mapM (\(sk, tv) -> (,) <$> (zonkSkolemInfoAnon . getSkolemInfo $ sk) <*> pure (fst <$> tv)) skolem_list+  return (zonked_info, other_tvs)+  where+    tvs = tyCoVarsOfTypeList hole_ty+    (skol_tvs, other_tvs) = partition (\tv -> isTcTyVar tv && isSkolemTyVar tv) tvs++    group_skolems :: UM.UniqMap SkolemInfo ([(TcTyVar, Int)])+    group_skolems = bagToList <$> UM.listToUniqMap_C unionBags [(skolemSkolInfo tv, unitBag (tv, n)) | tv <- skol_tvs | n <- [0..]]++    skolem_list = sortBy (comparing (sort . map snd . snd)) (UM.nonDetEltsUniqMap group_skolems)++{- Note [Adding deferred bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++When working with typed holes we have to deal with the case where+we want holes to be reported as warnings to users during compile time but+as errors during runtime. Therefore, we have to call 'maybeAddDeferredBindings'+so that the correct 'Severity' can be computed out of that later on.++-}+++-- | Adds deferred bindings (as errors).+-- See Note [Adding deferred bindings].+maybeAddDeferredBindings :: SolverReportErrCtxt+                         -> Hole+                         -> SolverReport+                         -> TcM ()+maybeAddDeferredBindings ctxt hole report = do+  case hole_sort hole of+    ExprHole (HER ref ref_ty _) -> do+      -- Only add bindings for holes in expressions+      -- not for holes in partial type signatures+      -- cf. addDeferredBinding+      when (deferringAnyBindings ctxt) $ do+        err_tm <- mkErrorTerm ctxt (hole_loc hole) ref_ty report+          -- NB: ref_ty, not hole_ty. hole_ty might be rewritten.+          -- See Note [Holes] in GHC.Tc.Types.Constraint+        writeMutVar ref err_tm+    _ -> pure ()++-- We unwrap the SolverReportErrCtxt here, to avoid introducing a loop in module+-- imports+validHoleFits :: SolverReportErrCtxt    -- ^ The context we're in, i.e. the+                                        -- implications and the tidy environment+              -> [ErrorItem]      -- ^ Unsolved simple constraints+              -> Hole             -- ^ The hole+              -> TcM (SolverReportErrCtxt, ValidHoleFits)+                -- ^ We return the new context+                -- with a possibly updated+                -- tidy environment, and+                -- the valid hole fits.+validHoleFits ctxt@(CEC { cec_encl = implics+                        , cec_tidy = lcl_env}) simps hole+  = do { (tidy_env, fits) <- findValidHoleFits lcl_env implics (map mk_wanted simps) hole+       ; return (ctxt {cec_tidy = tidy_env}, fits) }+  where+    mk_wanted :: ErrorItem -> CtEvidence+    mk_wanted (EI { ei_pred = pred, ei_evdest = Just dest, ei_loc = loc })+         = CtWanted { ctev_pred      = pred+                    , ctev_dest      = dest+                    , ctev_loc       = loc+                    , ctev_rewriters = emptyRewriterSet }+    mk_wanted item = pprPanic "validHoleFits no evdest" (ppr item)++-- See Note [Constraints include ...]+givenConstraints :: SolverReportErrCtxt -> [(Type, RealSrcSpan)]+givenConstraints ctxt+  = do { implic@Implic{ ic_given = given } <- cec_encl ctxt+       ; constraint <- given+       ; return (varType constraint, tcl_loc (ic_env implic)) }++----------------++mkIPErr :: SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport+-- What would happen if an item is suppressed because of+-- Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint? Very unclear+-- what's best. Let's not worry about this.+mkIPErr ctxt items+  = do { (ctxt, binds_msg, item1) <- relevantBindings True ctxt item1+       ; let msg = important ctxt $ UnboundImplicitParams (item1 :| others)+       ; return $ msg `mappend` mk_relevant_bindings binds_msg }+  where+    item1:others = items++----------------++-- | Report a representation-polymorphism error to the user:+-- a type is required to havehave a fixed runtime representation,+-- but doesn't.+--+-- See Note [Reporting representation-polymorphism errors] in GHC.Tc.Types.Origin.+mkFRRErr :: HasDebugCallStack => SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport+mkFRRErr ctxt items+  = do { -- Process the error items.+       ; (_tidy_env, frr_infos) <-+          zonkTidyFRRInfos (cec_tidy ctxt) $+            -- Zonk/tidy to show useful variable names.+          nubOrdBy (nonDetCmpType `on` (frr_type . frr_info_origin)) $+            -- Remove duplicates: only one representation-polymorphism error per type.+          map (expectJust "mkFRRErr" . fixedRuntimeRepOrigin_maybe)+          items+       ; return $ important ctxt $ FixedRuntimeRepError frr_infos }++-- | Whether to report something using the @FixedRuntimeRep@ mechanism.+fixedRuntimeRepOrigin_maybe :: HasDebugCallStack => ErrorItem -> Maybe FixedRuntimeRepErrorInfo+fixedRuntimeRepOrigin_maybe item+  -- An error that arose directly from a representation-polymorphism check.+  | FRROrigin frr_orig <- errorItemOrigin item+  = Just $ FRR_Info { frr_info_origin = frr_orig+                    , frr_info_not_concrete = Nothing }+  -- Unsolved nominal equalities involving a concrete type variable,+  -- such as @alpha[conc] ~# rr[sk]@ or @beta[conc] ~# RR@ for a+  -- type family application @RR@, are handled by 'mkTyVarEqErr''.+  | otherwise+  = Nothing++{-+Note [Constraints include ...]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+'givenConstraintsMsg' returns the "Constraints include ..." message enabled by+-fshow-hole-constraints. For example, the following hole:++    foo :: (Eq a, Show a) => a -> String+    foo x = _++would generate the message:++    Constraints include+      Eq a (from foo.hs:1:1-36)+      Show a (from foo.hs:1:1-36)++Constraints are displayed in order from innermost (closest to the hole) to+outermost. There's currently no filtering or elimination of duplicates.++************************************************************************+*                                                                      *+                Equality errors+*                                                                      *+************************************************************************++Note [Inaccessible code]+~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   data T a where+     T1 :: T a+     T2 :: T Bool++   f :: (a ~ Int) => T a -> Int+   f T1 = 3+   f T2 = 4   -- Unreachable code++Here the second equation is unreachable. The original constraint+(a~Int) from the signature gets rewritten by the pattern-match to+(Bool~Int), so the danger is that we report the error as coming from+the *signature* (#7293).  So, for Given errors we replace the+env (and hence src-loc) on its CtLoc with that from the immediately+enclosing implication.++Note [Error messages for untouchables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (#9109)+  data G a where { GBool :: G Bool }+  foo x = case x of GBool -> True++Here we can't solve (t ~ Bool), where t is the untouchable result+meta-var 't', because of the (a ~ Bool) from the pattern match.+So we infer the type+   f :: forall a t. G a -> t+making the meta-var 't' into a skolem.  So when we come to report+the unsolved (t ~ Bool), t won't look like an untouchable meta-var+any more.  So we don't assert that it is.+-}++-- Don't have multiple equality errors from the same location+-- E.g.   (Int,Bool) ~ (Bool,Int)   one error will do!+mkEqErr :: SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport+mkEqErr ctxt items+  | item:_ <- filter (not . ei_suppress) items+  = mkEqErr1 ctxt item++  | item:_ <- items  -- they're all suppressed. still need an error message+                     -- for -fdefer-type-errors though+  = mkEqErr1 ctxt item++  | otherwise+  = panic "mkEqErr"  -- guaranteed to have at least one item++mkEqErr1 :: SolverReportErrCtxt -> ErrorItem -> TcM SolverReport+mkEqErr1 ctxt item   -- Wanted only+                     -- givens handled in mkGivenErrorReporter+  = do { (ctxt, binds_msg, item) <- relevantBindings True ctxt item+       ; rdr_env <- getGlobalRdrEnv+       ; fam_envs <- tcGetFamInstEnvs+       ; let mb_coercible_msg = case errorItemEqRel item of+               NomEq  -> Nothing+               ReprEq -> ReportCoercibleMsg <$> mkCoercibleExplanation rdr_env fam_envs ty1 ty2+       ; traceTc "mkEqErr1" (ppr item $$ pprCtOrigin (errorItemOrigin item))+       ; (last_msg :| prev_msgs, hints) <- mkEqErr_help ctxt item ty1 ty2+       ; let+           report = foldMap (important ctxt) (reverse prev_msgs)+                  `mappend` (important ctxt $ mkTcReportWithInfo last_msg $ maybeToList mb_coercible_msg)+                  `mappend` (mk_relevant_bindings binds_msg)+                  `mappend` (mk_report_hints hints)+       ; return report }+  where+    (ty1, ty2) = getEqPredTys (errorItemPred item)++-- | This function tries to reconstruct why a "Coercible ty1 ty2" constraint+-- is left over.+mkCoercibleExplanation :: GlobalRdrEnv -> FamInstEnvs+                       -> TcType -> TcType -> Maybe CoercibleMsg+mkCoercibleExplanation rdr_env fam_envs ty1 ty2+  | Just (tc, tys) <- tcSplitTyConApp_maybe ty1+  , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys+  , Just msg <- coercible_msg_for_tycon rep_tc+  = Just msg+  | Just (tc, tys) <- splitTyConApp_maybe ty2+  , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys+  , Just msg <- coercible_msg_for_tycon rep_tc+  = Just msg+  | Just (s1, _) <- tcSplitAppTy_maybe ty1+  , Just (s2, _) <- tcSplitAppTy_maybe ty2+  , s1 `eqType` s2+  , has_unknown_roles s1+  = Just $ UnknownRoles s1+  | otherwise+  = Nothing+  where+    coercible_msg_for_tycon tc+        | isAbstractTyCon tc+        = Just $ TyConIsAbstract tc+        | isNewTyCon tc+        , [data_con] <- tyConDataCons tc+        , let dc_name = dataConName data_con+        , isNothing (lookupGRE_Name rdr_env dc_name)+        = Just $ OutOfScopeNewtypeConstructor tc data_con+        | otherwise = Nothing++    has_unknown_roles ty+      | Just (tc, tys) <- tcSplitTyConApp_maybe ty+      = tys `lengthAtLeast` tyConArity tc  -- oversaturated tycon+      | Just (s, _) <- tcSplitAppTy_maybe ty+      = has_unknown_roles s+      | isTyVarTy ty+      = True+      | otherwise+      = False++-- | Accumulated messages in reverse order.+type AccReportMsgs = NonEmpty TcSolverReportMsg++mkEqErr_help :: SolverReportErrCtxt+             -> ErrorItem+             -> TcType -> TcType -> TcM (AccReportMsgs, [GhcHint])+mkEqErr_help ctxt item ty1 ty2+  | Just casted_tv1 <- tcGetCastedTyVar_maybe ty1+  = mkTyVarEqErr ctxt item casted_tv1 ty2+  | Just casted_tv2 <- tcGetCastedTyVar_maybe ty2+  = mkTyVarEqErr ctxt item casted_tv2 ty1+  | otherwise+  = return (reportEqErr ctxt item ty1 ty2 :| [], [])++reportEqErr :: SolverReportErrCtxt+            -> ErrorItem+            -> TcType -> TcType -> TcSolverReportMsg+reportEqErr ctxt item ty1 ty2+  = mkTcReportWithInfo mismatch eqInfos+  where+    mismatch = misMatchOrCND False ctxt item ty1 ty2+    eqInfos  = eqInfoMsgs ty1 ty2++mkTyVarEqErr :: SolverReportErrCtxt -> ErrorItem+             -> (TcTyVar, TcCoercionN) -> TcType -> TcM (AccReportMsgs, [GhcHint])+-- tv1 and ty2 are already tidied+mkTyVarEqErr ctxt item casted_tv1 ty2+  = do { traceTc "mkTyVarEqErr" (ppr item $$ ppr casted_tv1 $$ ppr ty2)+       ; mkTyVarEqErr' ctxt item casted_tv1 ty2 }++mkTyVarEqErr' :: SolverReportErrCtxt -> ErrorItem+              -> (TcTyVar, TcCoercionN) -> TcType -> TcM (AccReportMsgs, [GhcHint])+mkTyVarEqErr' ctxt item (tv1, co1) ty2++  -- Is this a representation-polymorphism error, e.g.+  -- alpha[conc] ~# rr[sk] ? If so, handle that first.+  | Just frr_info <- mb_concrete_reason+  = do+      (_, infos) <- zonkTidyFRRInfos (cec_tidy ctxt) [frr_info]+      return (FixedRuntimeRepError infos :| [], [])++  -- Impredicativity is a simple error to understand; try it before+  -- anything more complicated.+  | check_eq_result `cterHasProblem` cteImpredicative+  = do+    tyvar_eq_info <- extraTyVarEqInfo tv1 ty2+    let+        poly_msg = CannotUnifyWithPolytype item tv1 ty2+        poly_msg_with_info+          | isSkolemTyVar tv1+          = mkTcReportWithInfo poly_msg tyvar_eq_info+          | otherwise+          = poly_msg+        -- Unlike the other reports, this discards the old 'report_important'+        -- instead of augmenting it.  This is because the details are not likely+        -- to be helpful since this is just an unimplemented feature.+    return (poly_msg_with_info <| headline_msg :| [], [])++  | isSkolemTyVar tv1  -- ty2 won't be a meta-tyvar; we would have+                       -- swapped in Solver.Canonical.canEqTyVarHomo+    || isTyVarTyVar tv1 && not (isTyVarTy ty2)+    || errorItemEqRel item == ReprEq+     -- The cases below don't really apply to ReprEq (except occurs check)+  = do+    tv_extra     <- extraTyVarEqInfo tv1 ty2+    return (mkTcReportWithInfo headline_msg tv_extra :| [], add_sig)++  | cterHasOccursCheck check_eq_result+    -- We report an "occurs check" even for  a ~ F t a, where F is a type+    -- function; it's not insoluble (because in principle F could reduce)+    -- but we have certainly been unable to solve it+  = let extras2 = eqInfoMsgs ty1 ty2++        interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $+                             filter isTyVar $+                             fvVarList $+                             tyCoFVsOfType ty1 `unionFV` tyCoFVsOfType ty2++        extras3 = case interesting_tyvars of+          [] -> []+          (tv : tvs) -> [OccursCheckInterestingTyVars (tv :| tvs)]++    in return (mkTcReportWithInfo headline_msg (extras2 ++ extras3) :| [], [])++    -- This is wrinkle (4) in Note [Equalities with incompatible kinds] in+    -- GHC.Tc.Solver.Canonical+  | hasCoercionHoleCo co1 || hasCoercionHoleTy ty2+  = return (mkBlockedEqErr item :| [], [])++  -- If the immediately-enclosing implication has 'tv' a skolem, and+  -- we know by now its an InferSkol kind of skolem, then presumably+  -- it started life as a TyVarTv, else it'd have been unified, given+  -- that there's no occurs-check or forall problem+  | (implic:_) <- cec_encl ctxt+  , Implic { ic_skols = skols } <- implic+  , tv1 `elem` skols+  = do+    tv_extra     <- extraTyVarEqInfo tv1 ty2+    return (mkTcReportWithInfo mismatch_msg tv_extra :| [], [])++  -- Check for skolem escape+  | (implic:_) <- cec_encl ctxt   -- Get the innermost context+  , Implic { ic_skols = skols } <- implic+  , let esc_skols = filter (`elemVarSet` (tyCoVarsOfType ty2)) skols+  , not (null esc_skols)+  = return (SkolemEscape item implic esc_skols :| [mismatch_msg], [])++  -- Nastiest case: attempt to unify an untouchable variable+  -- So tv is a meta tyvar (or started that way before we+  -- generalised it).  So presumably it is an *untouchable*+  -- meta tyvar or a TyVarTv, else it'd have been unified+  -- See Note [Error messages for untouchables]+  | (implic:_) <- cec_encl ctxt   -- Get the innermost context+  , Implic { ic_tclvl = lvl } <- implic+  = assertPpr (not (isTouchableMetaTyVar lvl tv1))+              (ppr tv1 $$ ppr lvl) $ do -- See Note [Error messages for untouchables]+    let tclvl_extra = UntouchableVariable tv1 implic+    tv_extra     <- extraTyVarEqInfo tv1 ty2+    return (mkTcReportWithInfo tclvl_extra tv_extra :| [mismatch_msg], add_sig)++  | otherwise+  = return (reportEqErr ctxt item (mkTyVarTy tv1) ty2 :| [], [])+        -- This *can* happen (#6123)+        -- Consider an ambiguous top-level constraint (a ~ F a)+        -- Not an occurs check, because F is a type function.+  where+    headline_msg = misMatchOrCND insoluble_occurs_check ctxt item ty1 ty2+    mismatch_msg = mkMismatchMsg item ty1 ty2+    add_sig      = maybeToList $ suggestAddSig ctxt ty1 ty2++    -- The following doesn't use the cterHasProblem mechanism because+    -- we need to retrieve the ConcreteTvOrigin. Just knowing whether+    -- there is an error is not sufficient. See #21430.+    mb_concrete_reason+      | Just frr_orig <- isConcreteTyVar_maybe tv1+      , not (isConcrete ty2)+      = Just $ frr_reason frr_orig tv1 ty2+      | Just (tv2, frr_orig) <- isConcreteTyVarTy_maybe ty2+      , not (isConcreteTyVar tv1)+      = Just $ frr_reason frr_orig tv2 ty1+      -- NB: if it's an unsolved equality in which both sides are concrete+      -- (e.g. a concrete type variable on both sides), then it's not a+      -- representation-polymorphism problem.+      | otherwise+      = Nothing+    frr_reason (ConcreteFRR frr_orig) conc_tv not_conc+      = FRR_Info { frr_info_origin = frr_orig+                 , frr_info_not_concrete = Just (conc_tv, not_conc) }++    ty1 = mkTyVarTy tv1++    check_eq_result = case ei_m_reason item of+      Just (NonCanonicalReason result) -> result+      _ -> checkTyVarEq tv1 ty2+        -- in T2627b, we report an error for F (F a0) ~ a0. Note that the type+        -- variable is on the right, so we don't get useful info for the CIrredCan,+        -- and have to compute the result of checkTyVarEq here.++    insoluble_occurs_check = check_eq_result `cterHasProblem` cteInsolubleOccurs++eqInfoMsgs :: TcType -> TcType -> [TcSolverReportInfo]+-- Report (a) ambiguity if either side is a type function application+--            e.g. F a0 ~ Int+--        (b) warning about injectivity if both sides are the same+--            type function application   F a ~ F b+--            See Note [Non-injective type functions]+eqInfoMsgs ty1 ty2+  = catMaybes [tyfun_msg, ambig_msg]+  where+    mb_fun1 = isTyFun_maybe ty1+    mb_fun2 = isTyFun_maybe ty2++      -- if a type isn't headed by a type function, then any ambiguous+      -- variables need not be reported as such. e.g.: F a ~ t0 -> t0, where a is a skolem+    ambig_tkvs1 = maybe mempty (\_ -> ambigTkvsOfTy ty1) mb_fun1+    ambig_tkvs2 = maybe mempty (\_ -> ambigTkvsOfTy ty2) mb_fun2++    ambig_tkvs@(ambig_kvs, ambig_tvs) = ambig_tkvs1 S.<> ambig_tkvs2++    ambig_msg | isJust mb_fun1 || isJust mb_fun2+              , not (null ambig_kvs && null ambig_tvs)+              = Just $ Ambiguity False ambig_tkvs+              | otherwise+              = Nothing++    tyfun_msg | Just tc1 <- mb_fun1+              , Just tc2 <- mb_fun2+              , tc1 == tc2+              , not (isInjectiveTyCon tc1 Nominal)+              = Just $ NonInjectiveTyFam tc1+              | otherwise+              = Nothing++misMatchOrCND :: Bool -> SolverReportErrCtxt -> ErrorItem+              -> TcType -> TcType -> TcSolverReportMsg+-- If oriented then ty1 is actual, ty2 is expected+misMatchOrCND insoluble_occurs_check ctxt item ty1 ty2+  | insoluble_occurs_check  -- See Note [Insoluble occurs check]+    || (isRigidTy ty1 && isRigidTy ty2)+    || (ei_flavour item == Given)+    || null givens+  = -- If the equality is unconditionally insoluble+    -- or there is no context, don't report the context+    mkMismatchMsg item ty1 ty2++  | otherwise+  = CouldNotDeduce givens (item :| []) (Just $ CND_Extra level ty1 ty2)++  where+    level   = ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel+    givens  = [ given | given <- getUserGivens ctxt, ic_given_eqs given /= NoGivenEqs ]+              -- Keep only UserGivens that have some equalities.+              -- See Note [Suppress redundant givens during error reporting]++-- These are for the "blocked" equalities, as described in TcCanonical+-- Note [Equalities with incompatible kinds], wrinkle (2). There should+-- always be another unsolved wanted around, which will ordinarily suppress+-- this message. But this can still be printed out with -fdefer-type-errors+-- (sigh), so we must produce a message.+mkBlockedEqErr :: ErrorItem -> TcSolverReportMsg+mkBlockedEqErr item = BlockedEquality item++{-+Note [Suppress redundant givens during error reporting]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When GHC is unable to solve a constraint and prints out an error message, it+will print out what given constraints are in scope to provide some context to+the programmer. But we shouldn't print out /every/ given, since some of them+are not terribly helpful to diagnose type errors. Consider this example:++  foo :: Int :~: Int -> a :~: b -> a :~: c+  foo Refl Refl = Refl++When reporting that GHC can't solve (a ~ c), there are two givens in scope:+(Int ~ Int) and (a ~ b). But (Int ~ Int) is trivially soluble (i.e.,+redundant), so it's not terribly useful to report it in an error message.+To accomplish this, we discard any Implications that do not bind any+equalities by filtering the `givens` selected in `misMatchOrCND` (based on+the `ic_given_eqs` field of the Implication). Note that we discard givens+that have no equalities whatsoever, but we want to keep ones with only *local*+equalities, as these may be helpful to the user in understanding what went+wrong.++But this is not enough to avoid all redundant givens! Consider this example,+from #15361:++  goo :: forall (a :: Type) (b :: Type) (c :: Type).+         a :~~: b -> a :~~: c+  goo HRefl = HRefl++Matching on HRefl brings the /single/ given (* ~ *, a ~ b) into scope.+The (* ~ *) part arises due the kinds of (:~~:) being unified. More+importantly, (* ~ *) is redundant, so we'd like not to report it. However,+the Implication (* ~ *, a ~ b) /does/ bind an equality (as reported by its+ic_given_eqs field), so the test above will keep it wholesale.++To refine this given, we apply mkMinimalBySCs on it to extract just the (a ~ b)+part. This works because mkMinimalBySCs eliminates reflexive equalities in+addition to superclasses (see Note [Remove redundant provided dicts]+in GHC.Tc.TyCl.PatSyn).+-}++extraTyVarEqInfo :: TcTyVar -> TcType -> TcM [TcSolverReportInfo]+-- Add on extra info about skolem constants+-- NB: The types themselves are already tidied+extraTyVarEqInfo tv1 ty2+  = (:) <$> extraTyVarInfo tv1 <*> ty_extra ty2+  where+    ty_extra ty = case tcGetCastedTyVar_maybe ty of+                    Just (tv, _) -> (:[]) <$> extraTyVarInfo tv+                    Nothing      -> return []++extraTyVarInfo :: TcTyVar -> TcM TcSolverReportInfo+extraTyVarInfo tv = assertPpr (isTyVar tv) (ppr tv) $+  case tcTyVarDetails tv of+    SkolemTv skol_info lvl overlaps -> do+      new_skol_info <- zonkSkolemInfo skol_info+      return $ TyVarInfo (mkTcTyVar (tyVarName tv) (tyVarKind tv) (SkolemTv new_skol_info lvl overlaps))+    _ -> return $ TyVarInfo tv+++suggestAddSig :: SolverReportErrCtxt -> TcType -> TcType -> Maybe GhcHint+-- See Note [Suggest adding a type signature]+suggestAddSig ctxt ty1 _ty2+  | bndr : bndrs <- inferred_bndrs+  = Just $ SuggestAddTypeSignatures $ NamedBindings (bndr :| bndrs)+  | otherwise+  = Nothing+  where+    inferred_bndrs =+      case tcGetTyVar_maybe ty1 of+        Just tv | isSkolemTyVar tv -> find (cec_encl ctxt) False tv+        _                          -> []++    -- 'find' returns the binders of an InferSkol for 'tv',+    -- provided there is an intervening implication with+    -- ic_given_eqs /= NoGivenEqs (i.e. a GADT match)+    find [] _ _ = []+    find (implic:implics) seen_eqs tv+       | tv `elem` ic_skols implic+       , InferSkol prs <- ic_info implic+       , seen_eqs+       = map fst prs+       | otherwise+       = find implics (seen_eqs || ic_given_eqs implic /= NoGivenEqs) tv++--------------------+mkMismatchMsg :: ErrorItem -> Type -> Type -> TcSolverReportMsg+mkMismatchMsg item ty1 ty2 =+  case orig of+    TypeEqOrigin { uo_actual, uo_expected, uo_thing = mb_thing } ->+      mkTcReportWithInfo+        (TypeEqMismatch+          { teq_mismatch_ppr_explicit_kinds = ppr_explicit_kinds+          , teq_mismatch_item = item+          , teq_mismatch_ty1  = ty1+          , teq_mismatch_ty2  = ty2+          , teq_mismatch_actual   = uo_actual+          , teq_mismatch_expected = uo_expected+          , teq_mismatch_what     = mb_thing})+        extras+    KindEqOrigin cty1 cty2 sub_o mb_sub_t_or_k ->+      mkTcReportWithInfo (Mismatch False item ty1 ty2)+        (WhenMatching cty1 cty2 sub_o mb_sub_t_or_k : extras)+    _ ->+      mkTcReportWithInfo+        (Mismatch False item ty1 ty2)+        extras+  where+    orig = errorItemOrigin item+    extras = sameOccExtras ty2 ty1+    ppr_explicit_kinds = shouldPprWithExplicitKinds ty1 ty2 orig++-- | Whether to print explicit kinds (with @-fprint-explicit-kinds@)+-- in an 'SDoc' when a type mismatch occurs to due invisible kind arguments.+--+-- This function first checks to see if the 'CtOrigin' argument is a+-- 'TypeEqOrigin'. If so, it first checks whether the equality is a visible+-- equality; if it's not, definitely print the kinds. Even if the equality is+-- a visible equality, check the expected/actual types to see if the types+-- have equal visible components. If the 'CtOrigin' is+-- not a 'TypeEqOrigin', fall back on the actual mismatched types themselves.+shouldPprWithExplicitKinds :: Type -> Type -> CtOrigin -> Bool+shouldPprWithExplicitKinds _ty1 _ty2 (TypeEqOrigin { uo_actual = act+                                                   , uo_expected = exp+                                                   , uo_visible = vis })+  | not vis   = True                  -- See tests T15870, T16204c+  | otherwise = tcEqTypeVis act exp   -- See tests T9171, T9144.+shouldPprWithExplicitKinds ty1 ty2 _ct+  = tcEqTypeVis ty1 ty2++{- Note [Insoluble occurs check]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider [G] a ~ [a],  [W] a ~ [a] (#13674).  The Given is insoluble+so we don't use it for rewriting.  The Wanted is also insoluble, and+we don't solve it from the Given.  It's very confusing to say+    Cannot solve a ~ [a] from given constraints a ~ [a]++And indeed even thinking about the Givens is silly; [W] a ~ [a] is+just as insoluble as Int ~ Bool.++Conclusion: if there's an insoluble occurs check (cteInsolubleOccurs)+then report it directly, not in the "cannot deduce X from Y" form.+This is done in misMatchOrCND (via the insoluble_occurs_check arg)++(NB: there are potentially-soluble ones, like (a ~ F a b), and we don't+want to be as draconian with them.)+-}++sameOccExtras :: TcType -> TcType -> [TcSolverReportInfo]+-- See Note [Disambiguating (X ~ X) errors]+sameOccExtras ty1 ty2+  | Just (tc1, _) <- tcSplitTyConApp_maybe ty1+  , Just (tc2, _) <- tcSplitTyConApp_maybe ty2+  , let n1 = tyConName tc1+        n2 = tyConName tc2+        same_occ = nameOccName n1                   == nameOccName n2+        same_pkg = moduleUnit (nameModule n1) == moduleUnit (nameModule n2)+  , n1 /= n2   -- Different Names+  , same_occ   -- but same OccName+  = [SameOcc same_pkg n1 n2]+  | otherwise+  = []++{- Note [Suggest adding a type signature]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The OutsideIn algorithm rejects GADT programs that don't have a principal+type, and indeed some that do.  Example:+   data T a where+     MkT :: Int -> T Int++   f (MkT n) = n++Does this have type f :: T a -> a, or f :: T a -> Int?+The error that shows up tends to be an attempt to unify an+untouchable type variable.  So suggestAddSig sees if the offending+type variable is bound by an *inferred* signature, and suggests+adding a declared signature instead.++More specifically, we suggest adding a type sig if we have p ~ ty, and+p is a skolem bound by an InferSkol.  Those skolems were created from+unification variables in simplifyInfer.  Why didn't we unify?  It must+have been because of an intervening GADT or existential, making it+untouchable. Either way, a type signature would help.  For GADTs, it+might make it typeable; for existentials the attempt to write a+signature will fail -- or at least will produce a better error message+next time++This initially came up in #8968, concerning pattern synonyms.++Note [Disambiguating (X ~ X) errors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See #8278++Note [Reporting occurs-check errors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Given (a ~ [a]), if 'a' is a rigid type variable bound by a user-supplied+type signature, then the best thing is to report that we can't unify+a with [a], because a is a skolem variable.  That avoids the confusing+"occur-check" error message.++But nowadays when inferring the type of a function with no type signature,+even if there are errors inside, we still generalise its signature and+carry on. For example+   f x = x:x+Here we will infer something like+   f :: forall a. a -> [a]+with a deferred error of (a ~ [a]).  So in the deferred unsolved constraint+'a' is now a skolem, but not one bound by the programmer in the context!+Here we really should report an occurs check.++So isUserSkolem distinguishes the two.++Note [Non-injective type functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's very confusing to get a message like+     Couldn't match expected type `Depend s'+            against inferred type `Depend s1'+so mkTyFunInfoMsg adds:+       NB: `Depend' is type function, and hence may not be injective++Warn of loopy local equalities that were dropped.+++************************************************************************+*                                                                      *+                 Type-class errors+*                                                                      *+************************************************************************+-}++mkDictErr :: HasDebugCallStack => SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport+mkDictErr ctxt orig_items+  = assert (not (null items)) $+    do { inst_envs <- tcGetInstEnvs+       ; let min_items = elim_superclasses items+             lookups = map (lookup_cls_inst inst_envs) min_items+             (no_inst_items, overlap_items) = partition is_no_inst lookups++       -- Report definite no-instance errors,+       -- or (iff there are none) overlap errors+       -- But we report only one of them (hence 'head') because they all+       -- have the same source-location origin, to try avoid a cascade+       -- of error from one location+       ; err <- mk_dict_err ctxt (head (no_inst_items ++ overlap_items))+       ; return $ important ctxt err }+  where+    filtered_items = filter (not . ei_suppress) orig_items+    items | null filtered_items = orig_items  -- all suppressed, but must report+                                              -- something for -fdefer-type-errors+          | otherwise           = filtered_items  -- common case++    no_givens = null (getUserGivens ctxt)++    is_no_inst (item, (matches, unifiers, _))+      =  no_givens+      && null matches+      && (nullUnifiers unifiers || all (not . isAmbiguousTyVar) (tyCoVarsOfTypeList (errorItemPred item)))++    lookup_cls_inst inst_envs item+      = (item, lookupInstEnv True inst_envs clas tys)+      where+        (clas, tys) = getClassPredTys (errorItemPred item)+++    -- When simplifying [W] Ord (Set a), we need+    --    [W] Eq a, [W] Ord a+    -- but we really only want to report the latter+    elim_superclasses items = mkMinimalBySCs errorItemPred items++-- Note [mk_dict_err]+-- ~~~~~~~~~~~~~~~~~~~+-- Different dictionary error messages are reported depending on the number of+-- matches and unifiers:+--+--   - No matches, regardless of unifiers: report "No instance for ...".+--   - Two or more matches, regardless of unifiers: report "Overlapping instances for ...",+--     and show the matching and unifying instances.+--   - One match, one or more unifiers: report "Overlapping instances for", show the+--     matching and unifying instances, and say "The choice depends on the instantion of ...,+--     and the result of evaluating ...".+mk_dict_err :: HasCallStack => SolverReportErrCtxt -> (ErrorItem, ClsInstLookupResult)+            -> TcM TcSolverReportMsg+-- Report an overlap error if this class constraint results+-- from an overlap (returning Left clas), otherwise return (Right pred)+mk_dict_err ctxt (item, (matches, unifiers, unsafe_overlapped))+  | null matches  -- No matches but perhaps several unifiers+  = do { (_, rel_binds, item) <- relevantBindings True ctxt item+       ; candidate_insts <- get_candidate_instances+       ; (imp_errs, field_suggestions) <- record_field_suggestions+       ; return (cannot_resolve_msg item candidate_insts rel_binds imp_errs field_suggestions) }++  | null unsafe_overlapped   -- Some matches => overlap errors+  = return $ overlap_msg++  | otherwise+  = return $ safe_haskell_msg+  where+    orig          = errorItemOrigin item+    pred          = errorItemPred item+    (clas, tys)   = getClassPredTys pred+    ispecs        = [ispec | (ispec, _) <- matches]+    unsafe_ispecs = [ispec | (ispec, _) <- unsafe_overlapped]++    get_candidate_instances :: TcM [ClsInst]+    -- See Note [Report candidate instances]+    get_candidate_instances+      | [ty] <- tys   -- Only try for single-parameter classes+      = do { instEnvs <- tcGetInstEnvs+           ; return (filter (is_candidate_inst ty)+                            (classInstances instEnvs clas)) }+      | otherwise = return []++    is_candidate_inst ty inst -- See Note [Report candidate instances]+      | [other_ty] <- is_tys inst+      , Just (tc1, _) <- tcSplitTyConApp_maybe ty+      , Just (tc2, _) <- tcSplitTyConApp_maybe other_ty+      = let n1 = tyConName tc1+            n2 = tyConName tc2+            different_names = n1 /= n2+            same_occ_names = nameOccName n1 == nameOccName n2+        in different_names && same_occ_names+      | otherwise = False++    -- See Note [Out-of-scope fields with -XOverloadedRecordDot]+    record_field_suggestions :: TcM ([ImportError], [GhcHint])+    record_field_suggestions = flip (maybe $ return ([], noHints)) record_field $ \name ->+       do { glb_env <- getGlobalRdrEnv+          ; lcl_env <- getLocalRdrEnv+          ; if occ_name_in_scope glb_env lcl_env name+            then return ([], noHints)+            else do { dflags   <- getDynFlags+                    ; imp_info <- getImports+                    ; curr_mod <- getModule+                    ; hpt      <- getHpt+                    ; return (unknownNameSuggestions WL_RecField dflags hpt curr_mod+                        glb_env emptyLocalRdrEnv imp_info (mkRdrUnqual name)) } }++    occ_name_in_scope glb_env lcl_env occ_name = not $+      null (lookupGlobalRdrEnv glb_env occ_name) &&+      isNothing (lookupLocalRdrOcc lcl_env occ_name)++    record_field = case orig of+      HasFieldOrigin name -> Just (mkVarOccFS name)+      _                   -> Nothing++    cannot_resolve_msg :: ErrorItem -> [ClsInst] -> RelevantBindings+                       -> [ImportError] -> [GhcHint] -> TcSolverReportMsg+    cannot_resolve_msg item candidate_insts binds imp_errs field_suggestions+      = CannotResolveInstance item (getPotentialUnifiers unifiers) candidate_insts imp_errs field_suggestions binds++    -- Overlap errors.+    overlap_msg, safe_haskell_msg :: TcSolverReportMsg+    -- Normal overlap error+    overlap_msg+      = assert (not (null matches)) $ OverlappingInstances item ispecs (getPotentialUnifiers unifiers)++    -- Overlap error because of Safe Haskell (first+    -- match should be the most specific match)+    safe_haskell_msg+     = assert (matches `lengthIs` 1 && not (null unsafe_ispecs)) $+       UnsafeOverlap item ispecs unsafe_ispecs++{- Note [Report candidate instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have an unsolved (Num Int), where `Int` is not the Prelude Int,+but comes from some other module, then it may be helpful to point out+that there are some similarly named instances elsewhere.  So we get+something like+    No instance for (Num Int) arising from the literal ‘3’+    There are instances for similar types:+      instance Num GHC.Types.Int -- Defined in ‘GHC.Num’+Discussion in #9611.++Note [Highlighting ambiguous type variables]+~-------------------------------------------+When we encounter ambiguous type variables (i.e. type variables+that remain metavariables after type inference), we need a few more+conditions before we can reason that *ambiguity* prevents constraints+from being solved:+  - We can't have any givens, as encountering a typeclass error+    with given constraints just means we couldn't deduce+    a solution satisfying those constraints and as such couldn't+    bind the type variable to a known type.+  - If we don't have any unifiers, we don't even have potential+    instances from which an ambiguity could arise.+  - Lastly, I don't want to mess with error reporting for+    unknown runtime types so we just fall back to the old message there.+Once these conditions are satisfied, we can safely say that ambiguity prevents+the constraint from being solved.++Note [Out-of-scope fields with -XOverloadedRecordDot]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+With -XOverloadedRecordDot, when a field isn't in scope, the error that appears+is produces here, and it says+    No instance for (GHC.Record.HasField "<fieldname>" ...).++Additionally, though, we want to suggest similar field names that are in scope+or could be in scope with different import lists.++However, we can still get an error about a missing HasField instance when a+field is in scope (if the types are wrong), and so it's important that we don't+suggest similar names here if the record field is in scope, either qualified or+unqualified, since qualification doesn't matter for -XOverloadedRecordDot.++Example:++    import Data.Monoid (Alt(..))++    foo = undefined.getAll++results in++     No instance for (GHC.Records.HasField "getAll" r0 a0)+        arising from selecting the field ‘getAll’+      Perhaps you meant ‘getAlt’ (imported from Data.Monoid)+      Perhaps you want to add ‘getAll’ to the import list+      in the import of ‘Data.Monoid’+-}++{-+Note [Kind arguments in error messages]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It can be terribly confusing to get an error message like (#9171)++    Couldn't match expected type ‘GetParam Base (GetParam Base Int)’+                with actual type ‘GetParam Base (GetParam Base Int)’++The reason may be that the kinds don't match up.  Typically you'll get+more useful information, but not when it's as a result of ambiguity.++To mitigate this, GHC attempts to enable the -fprint-explicit-kinds flag+whenever any error message arises due to a kind mismatch. This means that+the above error message would instead be displayed as:++    Couldn't match expected type+                  ‘GetParam @* @k2 @* Base (GetParam @* @* @k2 Base Int)’+                with actual type+                  ‘GetParam @* @k20 @* Base (GetParam @* @* @k20 Base Int)’++Which makes it clearer that the culprit is the mismatch between `k2` and `k20`.+-}++-----------------------+-- relevantBindings looks at the value environment and finds values whose+-- types mention any of the offending type variables.  It has to be+-- careful to zonk the Id's type first, so it has to be in the monad.+-- We must be careful to pass it a zonked type variable, too.+--+-- We always remove closed top-level bindings, though,+-- since they are never relevant (cf #8233)++relevantBindings :: Bool  -- True <=> filter by tyvar; False <=> no filtering+                          -- See #8191+                 -> SolverReportErrCtxt -> ErrorItem+                 -> TcM (SolverReportErrCtxt, RelevantBindings, ErrorItem)+-- Also returns the zonked and tidied CtOrigin of the constraint+relevantBindings want_filtering ctxt item+  = do { traceTc "relevantBindings" (ppr item)+       ; (env1, tidy_orig) <- zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc)++             -- For *kind* errors, report the relevant bindings of the+             -- enclosing *type* equality, because that's more useful for the programmer+       ; let extra_tvs = case tidy_orig of+                             KindEqOrigin t1 t2 _ _ -> tyCoVarsOfTypes [t1,t2]+                             _                      -> emptyVarSet+             ct_fvs = tyCoVarsOfType (errorItemPred item) `unionVarSet` extra_tvs++             -- Put a zonked, tidied CtOrigin into the ErrorItem+             loc'   = setCtLocOrigin loc tidy_orig+             item'  = item { ei_loc = loc' }++       ; (env2, lcl_name_cache) <- zonkTidyTcLclEnvs env1 [lcl_env]++       ; relev_bds <- relevant_bindings want_filtering lcl_env lcl_name_cache ct_fvs+       ; let ctxt'  = ctxt { cec_tidy = env2 }+       ; return (ctxt', relev_bds, item') }+  where+    loc     = errorItemCtLoc item+    lcl_env = ctLocEnv loc++-- slightly more general version, to work also with holes+relevant_bindings :: Bool+                  -> TcLclEnv+                  -> NameEnv Type -- Cache of already zonked and tidied types+                  -> TyCoVarSet+                  -> TcM RelevantBindings+relevant_bindings want_filtering lcl_env lcl_name_env ct_tvs+  = do { dflags <- getDynFlags+       ; traceTc "relevant_bindings" $+           vcat [ ppr ct_tvs+                , pprWithCommas id [ ppr id <+> dcolon <+> ppr (idType id)+                                   | TcIdBndr id _ <- tcl_bndrs lcl_env ]+                , pprWithCommas id+                    [ ppr id | TcIdBndr_ExpType id _ _ <- tcl_bndrs lcl_env ] ]++       ; go dflags (maxRelevantBinds dflags)+                    emptyVarSet (RelevantBindings [] False)+                    (removeBindingShadowing $ tcl_bndrs lcl_env)+         -- tcl_bndrs has the innermost bindings first,+         -- which are probably the most relevant ones+  }+  where+    run_out :: Maybe Int -> Bool+    run_out Nothing = False+    run_out (Just n) = n <= 0++    dec_max :: Maybe Int -> Maybe Int+    dec_max = fmap (\n -> n - 1)+++    go :: DynFlags -> Maybe Int -> TcTyVarSet+       -> RelevantBindings+       -> [TcBinder]+       -> TcM RelevantBindings+    go _ _ _ (RelevantBindings bds discards) []+      = return $ RelevantBindings (reverse bds) discards+    go dflags n_left tvs_seen rels@(RelevantBindings bds discards) (tc_bndr : tc_bndrs)+      = case tc_bndr of+          TcTvBndr {} -> discard_it+          TcIdBndr id top_lvl -> go2 (idName id) top_lvl+          TcIdBndr_ExpType name et top_lvl ->+            do { mb_ty <- readExpType_maybe et+                   -- et really should be filled in by now. But there's a chance+                   -- it hasn't, if, say, we're reporting a kind error en route to+                   -- checking a term. See test indexed-types/should_fail/T8129+                   -- Or we are reporting errors from the ambiguity check on+                   -- a local type signature+               ; case mb_ty of+                   Just _ty -> go2 name top_lvl+                   Nothing -> discard_it  -- No info; discard+               }+      where+        discard_it = go dflags n_left tvs_seen rels tc_bndrs+        go2 id_name top_lvl+          = do { let tidy_ty = case lookupNameEnv lcl_name_env id_name of+                                  Just tty -> tty+                                  Nothing -> pprPanic "relevant_bindings" (ppr id_name)+               ; traceTc "relevantBindings 1" (ppr id_name <+> dcolon <+> ppr tidy_ty)+               ; let id_tvs = tyCoVarsOfType tidy_ty+                     bd = (id_name, tidy_ty)+                     new_seen = tvs_seen `unionVarSet` id_tvs++               ; if (want_filtering && not (hasPprDebug dflags)+                                    && id_tvs `disjointVarSet` ct_tvs)+                          -- We want to filter out this binding anyway+                          -- so discard it silently+                 then discard_it++                 else if isTopLevel top_lvl && not (isNothing n_left)+                          -- It's a top-level binding and we have not specified+                          -- -fno-max-relevant-bindings, so discard it silently+                 then discard_it++                 else if run_out n_left && id_tvs `subVarSet` tvs_seen+                          -- We've run out of n_left fuel and this binding only+                          -- mentions already-seen type variables, so discard it+                 then go dflags n_left tvs_seen (RelevantBindings bds True) -- Record that we have now discarded something+                         tc_bndrs++                          -- Keep this binding, decrement fuel+                 else go dflags (dec_max n_left) new_seen+                         (RelevantBindings (bd:bds) discards) tc_bndrs }++-----------------------+warnDefaulting :: TcTyVar -> [Ct] -> Type -> TcM ()+warnDefaulting _ [] _+  = panic "warnDefaulting: empty Wanteds"+warnDefaulting the_tv wanteds@(ct:_) default_ty+  = do { warn_default <- woptM Opt_WarnTypeDefaults+       ; env0 <- tcInitTidyEnv+            -- don't want to report all the superclass constraints, which+            -- add unhelpful clutter+       ; let filtered = filter (not . isWantedSuperclassOrigin . ctOrigin) wanteds+             tidy_env = tidyFreeTyCoVars env0 $+                        tyCoVarsOfCtsList (listToBag filtered)+             tidy_wanteds = map (tidyCt tidy_env) filtered+             tidy_tv = lookupVarEnv (snd tidy_env) the_tv+             diag = TcRnWarnDefaulting tidy_wanteds tidy_tv default_ty+             loc = ctLoc ct+       ; setCtLocM loc $ diagnosticTc warn_default diag }++{-+Note [Runtime skolems]+~~~~~~~~~~~~~~~~~~~~~~+We want to give a reasonably helpful error message for ambiguity+arising from *runtime* skolems in the debugger.  These+are created by in GHC.Runtime.Heap.Inspect.zonkRTTIType.+-}++{-**********************************************************************+*                                                                      *+                      GHC API helper functions+*                                                                      *+**********************************************************************-}++-- | If the 'TcSolverReportMsg' is a type mismatch between+-- an actual and an expected type, return the actual and expected types+-- (in that order).+--+-- Prefer using this over manually inspecting the 'TcSolverReportMsg' datatype+-- if you just want this information, as the datatype itself is subject to change+-- across GHC versions.+solverReportMsg_ExpectedActuals :: TcSolverReportMsg -> [(Type, Type)]+solverReportMsg_ExpectedActuals+  = \case+    TcReportWithInfo msg infos ->+      solverReportMsg_ExpectedActuals msg+      ++ (solverReportInfo_ExpectedActuals =<< toList infos)+    Mismatch { mismatch_ty1 = exp, mismatch_ty2 = act } ->+      [(exp, act)]+    KindMismatch { kmismatch_expected = exp, kmismatch_actual = act } ->+      [(exp, act)]+    TypeEqMismatch { teq_mismatch_expected = exp, teq_mismatch_actual = act } ->+      [(exp,act)]+    _ -> []++-- | Retrieves all @"expected"/"actual"@ messages from a 'TcSolverReportInfo'.+--+-- Prefer using this over inspecting the 'TcSolverReportInfo' datatype if+-- you just need this information, as the datatype itself is subject to change+-- across GHC versions.+solverReportInfo_ExpectedActuals :: TcSolverReportInfo -> [(Type, Type)]+solverReportInfo_ExpectedActuals+  = \case+    ExpectedActual { ea_expected = exp, ea_actual = act } ->+      [(exp, act)]+    ExpectedActualAfterTySynExpansion+      { ea_expanded_expected = exp, ea_expanded_actual = act } ->+      [(exp, act)]+    _ -> []
compiler/GHC/Tc/Errors/Hole.hs view
@@ -1,7 +1,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ExistentialQuantification #-}+ {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+ module GHC.Tc.Errors.Hole    ( findValidHoleFits    , tcCheckHoleFit@@ -16,7 +18,7 @@    , getHoleFitDispConfig    , HoleFitDispConfig (..)    , HoleFitSortingAlg (..)-   , relevantCts+   , relevantCtEvidence    , zonkSubs     , sortHoleFitsByGraph@@ -30,6 +32,8 @@  import GHC.Prelude +import GHC.Tc.Errors.Types ( HoleFitDispConfig(..), FitsMbSuppressed(..)+                           , ValidHoleFits(..), noValidHoleFits ) import GHC.Tc.Types import GHC.Tc.Utils.Monad import GHC.Tc.Types.Constraint@@ -64,18 +68,23 @@ import Data.Graph       ( graphFromEdges, topSort )  -import GHC.Tc.Solver    ( simplifyTopWanteds, runTcSDeriveds )+import GHC.Tc.Solver    ( simplifyTopWanteds )+import GHC.Tc.Solver.Monad ( runTcSEarlyAbort ) import GHC.Tc.Utils.Unify ( tcSubTypeSigma )  import GHC.HsToCore.Docs ( extractDocs )-import qualified Data.Map as Map-import GHC.Hs.Doc      ( unpackHDS, DeclDocMap(..) )+import GHC.Hs.Doc import GHC.Unit.Module.ModIface ( ModIface_(..) )-import GHC.Iface.Load  ( loadInterfaceForNameMaybe )+import GHC.Iface.Load  ( loadInterfaceForName )  import GHC.Builtin.Utils (knownKeyNames)  import GHC.Tc.Errors.Hole.FitTypes+import qualified Data.Set as Set+import GHC.Types.SrcLoc+import GHC.Utils.Trace (warnPprTrace)+import GHC.Data.FastString (unpackFS)+import GHC.Types.Unique.Map   {-@@ -185,7 +194,7 @@       Given = $dShow_a1pc :: Show a_a1pa[sk:2]       Wanted =         WC {wc_simple =-              [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CDictCan(psc))}+              [W] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CDictCan(psc))}       Binds = EvBindsVar<a1pi>       Needed inner = []       Needed outer = []@@ -201,7 +210,7 @@ `tcCheckHoleFit`, the call to `tcSubType` will end up unifying the meta type variable `a0_a1pd[tau:2] := a_a1pa[sk:2]`. By wrapping the wanted constraints needed by tcSubType_NC and the relevant constraints (see Note [Relevant-Constraints] for more details) in the nested implications, we can pass the+constraints] for more details) in the nested implications, we can pass the information in the givens along to the simplifier. For our example, we end up needing to check whether the following constraints are soluble. @@ -214,7 +223,7 @@           Given = $dShow_a1pc :: Show a_a1pa[sk:2]           Wanted =             WC {wc_simple =-                  [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical)}+                  [W] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical)}           Binds = EvBindsVar<a1pl>           Needed inner = []           Needed outer = []@@ -357,7 +366,7 @@  Here, the hole is given type a0_a1kv[tau:1]. Then, the emitted constraint is: -  [WD] $dShow_a1kw {0}:: Show a0_a1kv[tau:1] (CNonCanonical)+  [W] $dShow_a1kw {0}:: Show a0_a1kv[tau:1] (CNonCanonical)  However, when there are multiple holes, we need to be more careful. As an example, Let's take a look at the following code:@@ -369,8 +378,8 @@ _b :: a1_a1po[tau:2]. Then, the simple constraints passed to findValidHoleFits are: -  [[WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical),-    [WD] $dShow_a1pp {0}:: Show a1_a1po[tau:2] (CNonCanonical)]+  [[W] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical),+    [W] $dShow_a1pp {0}:: Show a1_a1po[tau:2] (CNonCanonical)]  When we are looking for a match for the hole `_a`, we filter the simple constraints to the "Relevant constraints", by throwing out any constraints@@ -389,14 +398,28 @@ would cause the type checker to error, it is not a valid hole fit, and thus it is discarded. --}+Note [Speeding up valid hole-fits]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To fix #16875 we noted that a lot of time was being spent on uneccessary work. -data HoleFitDispConfig = HFDC { showWrap :: Bool-                              , showWrapVars :: Bool-                              , showType :: Bool-                              , showProv :: Bool-                              , showMatches :: Bool }+When we'd call `tcCheckHoleFit hole hole_ty ty`, we would end up by generating+a constraint to show that `hole_ty ~ ty`, including any constraints in `ty`. For+example, if `hole_ty = Int` and `ty = Foldable t => (a -> Bool) -> t a -> Bool`,+we'd have `(a_a1pa[sk:1] -> Bool) -> t_t2jk[sk:1] a_a1pa[sk:1] -> Bool ~# Int`+from the coercion, as well as `Foldable t_t2jk[sk:1]`. By adding a flag to+`TcSEnv` and adding a `runTcSEarlyAbort`, we can fail as soon as we hit+an insoluble constraint. Since we don't need the result in the case that it+fails, a boolean `False` (i.e. "it didn't work" from `runTcSEarlyAbort`)+is sufficient. +We also check whether the type of the hole is an immutable type variable (i.e.+a skolem). In that case, the only possible fits are fits of exactly that type,+which can only come from the locals. This speeds things up quite a bit when we+don't know anything about the type of the hole. This also helps with degenerate+fits like (`id (_ :: a)` and `head (_ :: [a])`) when looking for fits of type+`a`, where `a` is a skolem.+-}+ -- We read the various -no-show-*-of-hole-fits flags -- and set the display config accordingly. getHoleFitDispConfig :: TcM HoleFitDispConfig@@ -437,21 +460,40 @@ addHoleFitDocs fits =   do { showDocs <- goptM Opt_ShowDocsOfHoleFits      ; if showDocs-       then do { (_, DeclDocMap lclDocs, _) <- getGblEnv >>= extractDocs-               ; mapM (upd lclDocs) fits }+       then do { dflags <- getDynFlags+               ; mb_local_docs <- extractDocs dflags =<< getGblEnv+               ; (mods_without_docs, fits') <- mapAccumM (upd mb_local_docs) Set.empty fits+               ; report mods_without_docs+               ; return fits' }        else return fits }   where    msg = text "GHC.Tc.Errors.Hole addHoleFitDocs"-   lookupInIface name (ModIface { mi_decl_docs = DeclDocMap dmap })-     = Map.lookup name dmap-   upd lclDocs fit@(HoleFit {hfCand = cand}) =-        do { let name = getName cand-           ; doc <- if hfIsLcl fit-                    then pure (Map.lookup name lclDocs)-                    else do { mbIface <- loadInterfaceForNameMaybe msg name-                            ; return $ mbIface >>= lookupInIface name }-           ; return $ fit {hfDoc = doc} }-   upd _ fit = return fit+   upd mb_local_docs mods_without_docs fit@(HoleFit {hfCand = cand}) =+     let name = getName cand in+     do { mb_docs <- if hfIsLcl fit+                     then pure mb_local_docs+                     else mi_docs <$> loadInterfaceForName msg name+        ; case mb_docs of+            { Nothing -> return (Set.insert (nameOrigin name) mods_without_docs, fit)+            ; Just docs -> do+                { let doc = lookupUniqMap (docs_decls docs) name+                ; return $ (mods_without_docs, fit {hfDoc = map hsDocString <$> doc}) }}}+   upd _ mods_without_docs fit = pure (mods_without_docs, fit)+   nameOrigin name = case nameModule_maybe name of+     Just m  -> Right m+     Nothing ->+       Left $ case nameSrcLoc name of+         RealSrcLoc r _ -> unpackFS $ srcLocFile r+         UnhelpfulLoc s -> unpackFS $ s+   report mods = do+     { let warning =+             text "WARNING: Couldn't find any documentation for the following modules:" $+$+             nest 2+                  (fsep (punctuate comma+                                   (either text ppr <$> Set.toList mods)) $+$+                   text "Make sure the modules are compiled with '-haddock'.")+     ; warnPprTrace (not $ Set.null mods)"addHoleFitDocs" warning (pure ())+     }  -- For pretty printing hole fits, we display the name and type of the fit, -- with added '_' to represent any extra arguments in case of a non-zero@@ -462,12 +504,10 @@  hang display 2 provenance  where tyApp = sep $ zipWithEqual "pprHoleFit" pprArg vars hfWrap          where pprArg b arg = case binderArgFlag b of-                                -- See Note [Explicit Case Statement for Specificity]-                                (Invisible spec) -> case spec of-                                  SpecifiedSpec -> text "@" <> pprParendType arg+                                Specified -> text "@" <> pprParendType arg                                   -- Do not print type application for inferred                                   -- variables (#16456)-                                  InferredSpec  -> empty+                                Inferred  -> empty                                 Required  -> pprPanic "pprHoleFit: bad Required"                                                          (ppr b <+> ppr arg)        tyAppVars = sep $ punctuate comma $@@ -500,9 +540,7 @@                                      then occDisp <+> tyApp                                      else tyAppVars        docs = case hfDoc of-                Just d -> text "{-^" <>-                          (vcat . map text . lines . unpackHDS) d-                          <> text "-}"+                Just d -> pprHsDocStrings d                 _ -> empty        funcInfo = ppWhen (has hfMatches && sTy) $                     text "where" <+> occDisp <+> tyDisp@@ -536,25 +574,24 @@ -- See Note [Valid hole fits include ...] findValidHoleFits :: TidyEnv        -- ^ The tidy_env for zonking                   -> [Implication]  -- ^ Enclosing implications for givens-                  -> [Ct]+                  -> [CtEvidence]                   -- ^ The  unsolved simple constraints in the implication for                   -- the hole.                   -> Hole-                  -> TcM (TidyEnv, SDoc)+                  -> TcM (TidyEnv, ValidHoleFits) findValidHoleFits tidy_env implics simples h@(Hole { hole_sort = ExprHole _                                                    , hole_loc  = ct_loc                                                    , hole_ty   = hole_ty }) =   do { rdr_env <- getGlobalRdrEnv      ; lclBinds <- getLocalBindings tidy_env ct_loc      ; maxVSubs <- maxValidHoleFits <$> getDynFlags-     ; hfdc <- getHoleFitDispConfig      ; sortingAlg <- getHoleFitSortingAlg      ; dflags <- getDynFlags      ; hfPlugs <- tcg_hf_plugins <$> getGblEnv      ; let findVLimit = if sortingAlg > HFSNoSorting then Nothing else maxVSubs            refLevel = refLevelHoleFits dflags            hole = TypedHole { th_relevant_cts =-                                listToBag (relevantCts hole_ty simples)+                                listToBag (relevantCtEvidence hole_ty simples)                             , th_implics      = implics                             , th_hole         = Just h }            (candidatePlugins, fitPlugins) =@@ -572,7 +609,11 @@                       map IdHFCand lclBinds ++ map GreHFCand lcl            globals = map GreHFCand gbl            syntax = map NameHFCand builtIns-           to_check = locals ++ syntax ++ globals+           -- If the hole is a rigid type-variable, then we only check the+           -- locals, since only they can match the type (in a meaningful way).+           only_locals = any isImmutableTyVar $ getTyVar_maybe hole_ty+           to_check = if only_locals then locals+                      else locals ++ syntax ++ globals      ; cands <- foldM (flip ($)) to_check candidatePlugins      ; traceTc "numPlugins are:" $ ppr (length candidatePlugins)      ; (searchDiscards, subs) <-@@ -583,12 +624,11 @@      ; let (pVDisc, limited_subs) = possiblyDiscard maxVSubs plugin_handled_subs            vDiscards = pVDisc || searchDiscards      ; subs_with_docs <- addHoleFitDocs limited_subs-     ; let vMsg = ppUnless (null subs_with_docs) $-                    hang (text "Valid hole fits include") 2 $-                      vcat (map (pprHoleFit hfdc) subs_with_docs)-                        $$ ppWhen vDiscards subsDiscardMsg+     ; let subs = Fits subs_with_docs vDiscards      -- Refinement hole fits. See Note [Valid refinement hole fits include ...]-     ; (tidy_env, refMsg) <- if refLevel >= Just 0 then+     ; (tidy_env, rsubs) <-+       if refLevel >= Just 0+       then          do { maxRSubs <- maxRefHoleFits <$> getDynFlags             -- We can use from just, since we know that Nothing >= _ is False.             ; let refLvls = [1..(fromJust refLevel)]@@ -616,14 +656,11 @@                     possiblyDiscard maxRSubs $ plugin_handled_rsubs                   rDiscards = pRDisc || any fst refDs             ; rsubs_with_docs <- addHoleFitDocs exact_last_rfits-            ; return (tidy_env,-                ppUnless (null rsubs_with_docs) $-                  hang (text "Valid refinement hole fits include") 2 $-                  vcat (map (pprHoleFit hfdc) rsubs_with_docs)-                    $$ ppWhen rDiscards refSubsDiscardMsg) }-       else return (tidy_env, empty)+            ; return (tidy_env, Fits rsubs_with_docs rDiscards) }+       else return (tidy_env, Fits [] False)      ; traceTc "findingValidHoleFitsFor }" empty-     ; return (tidy_env, vMsg $$ refMsg) }+     ; let hole_fits = ValidHoleFits subs rsubs+     ; return (tidy_env, hole_fits) }   where     -- We extract the TcLevel from the constraint.     hole_lvl = ctLocLevel ct_loc@@ -664,19 +701,6 @@                <*> sortHoleFitsByGraph (sort gblFits)         where (lclFits, gblFits) = span hfIsLcl subs -    subsDiscardMsg :: SDoc-    subsDiscardMsg =-        text "(Some hole fits suppressed;" <+>-        text "use -fmax-valid-hole-fits=N" <+>-        text "or -fno-max-valid-hole-fits)"--    refSubsDiscardMsg :: SDoc-    refSubsDiscardMsg =-        text "(Some refinement hole fits suppressed;" <+>-        text "use -fmax-refinement-hole-fits=N" <+>-        text "or -fno-max-refinement-hole-fits)"--     -- Based on the flags, we might possibly discard some or all the     -- fits we've found.     possiblyDiscard :: Maybe Int -> [HoleFit] -> (Bool, [HoleFit])@@ -685,24 +709,23 @@   -- We don't (as of yet) handle holes in types, only in expressions.-findValidHoleFits env _ _ _ = return (env, empty)+findValidHoleFits env _ _ _ = return (env, noValidHoleFits)  -- See Note [Relevant constraints]-relevantCts :: Type -> [Ct] -> [Ct]-relevantCts hole_ty simples = if isEmptyVarSet (fvVarSet hole_fvs) then []-                              else filter isRelevant simples-  where ctFreeVarSet :: Ct -> VarSet-        ctFreeVarSet = fvVarSet . tyCoFVsOfType . ctPred-        hole_fvs = tyCoFVsOfType hole_ty+relevantCtEvidence :: Type -> [CtEvidence] -> [CtEvidence]+relevantCtEvidence hole_ty simples+  = if isEmptyVarSet (fvVarSet hole_fvs)+    then []+    else filter isRelevant simples+  where hole_fvs = tyCoFVsOfType hole_ty         hole_fv_set = fvVarSet hole_fvs-        anyFVMentioned :: Ct -> Bool-        anyFVMentioned ct = ctFreeVarSet ct `intersectsVarSet` hole_fv_set         -- We filter out those constraints that have no variables (since         -- they won't be solved by finding a type for the type variable         -- representing the hole) and also other holes, since we're not         -- trying to find hole fits for many holes at once.-        isRelevant ct = not (isEmptyVarSet (ctFreeVarSet ct))-                        && anyFVMentioned ct+        isRelevant ctev = not (isEmptyVarSet fvs) &&+                          (fvs `intersectsVarSet` hole_fv_set)+          where fvs = tyCoVarsOfCtEv ctev  -- We zonk the hole fits so that the output aligns with the rest -- of the typed hole error message output.@@ -874,7 +897,6 @@          ; traceTc "Did it fit?" $ ppr fits          ; traceTc "wrap is: " $ ppr wrp          ; traceTc "checkingFitOf }" empty-         ; z_wrp_tys <- zonkTcTypes (unfoldWrapper wrp)          -- We'd like to avoid refinement suggestions like `id _ _` or          -- `head _ _`, and only suggest refinements where our all phantom          -- variables got unified during the checking. This can be disabled@@ -883,24 +905,26 @@          -- variables, i.e. zonk them to read their final value to check for          -- abstract refinements, and to report what the type of the simulated          -- holes must be for this to be a match.-         ; if fits-           then if null ref_vars-                then return (Just (z_wrp_tys, []))-                else do { let -- To be concrete matches, matches have to-                              -- be more than just an invented type variable.-                              fvSet = fvVarSet fvs-                              notAbstract :: TcType -> Bool-                              notAbstract t = case getTyVar_maybe t of-                                                Just tv -> tv `elemVarSet` fvSet-                                                _ -> True-                              allConcrete = all notAbstract z_wrp_tys-                        ; z_vars  <- zonkTcTyVars ref_vars-                        ; let z_mtvs = mapMaybe tcGetTyVar_maybe z_vars-                        ; allFilled <- not <$> anyM isFlexiTyVar z_mtvs-                        ; allowAbstract <- goptM Opt_AbstractRefHoleFits-                        ; if allowAbstract || (allFilled && allConcrete )-                          then return $ Just (z_wrp_tys, z_vars)-                          else return Nothing }+         ; if fits then do {+              -- Zonking is expensive, so we only do it if required.+              z_wrp_tys <- zonkTcTypes (unfoldWrapper wrp)+            ; if null ref_vars+              then return (Just (z_wrp_tys, []))+              else do { let -- To be concrete matches, matches have to+                            -- be more than just an invented type variable.+                            fvSet = fvVarSet fvs+                            notAbstract :: TcType -> Bool+                            notAbstract t = case getTyVar_maybe t of+                                              Just tv -> tv `elemVarSet` fvSet+                                              _ -> True+                            allConcrete = all notAbstract z_wrp_tys+                      ; z_vars  <- zonkTcTyVars ref_vars+                      ; let z_mtvs = mapMaybe tcGetTyVar_maybe z_vars+                      ; allFilled <- not <$> anyM isFlexiTyVar z_mtvs+                      ; allowAbstract <- goptM Opt_AbstractRefHoleFits+                      ; if allowAbstract || (allFilled && allConcrete )+                        then return $ Just (z_wrp_tys, z_vars)+                        else return Nothing }}            else return Nothing }      where fvs = mkFVs ref_vars `unionFV` hole_fvs `unionFV` tyCoFVsOfType ty            hole = typed_hole { th_hole = Nothing }@@ -940,7 +964,8 @@ -- constraints on the type of the hole. tcCheckHoleFit :: TypedHole   -- ^ The hole to check against                -> TcSigmaType-               -- ^ The type to check against (possibly modified, e.g. refined)+               -- ^ The type of the hole to check against (possibly modified,+               -- e.g. refined with additional holes for refinement hole-fits.)                -> TcSigmaType -- ^ The type to check whether fits.                -> TcM (Bool, HsWrapper)                -- ^ Whether it was a match, and the wrapper from hole_ty to ty.@@ -958,7 +983,7 @@                           -- imp is the innermost implication                           (imp:_) -> return (ic_tclvl imp)      ; (wrap, wanted) <- setTcLevel innermost_lvl $ captureConstraints $-                         tcSubTypeSigma orig ExprSigCtxt ty hole_ty+                         tcSubTypeSigma orig (ExprSigCtxt NoRRC) ty hole_ty      ; traceTc "Checking hole fit {" empty      ; traceTc "wanteds are: " $ ppr wanted      ; if isEmptyWC wanted && isEmptyBag th_relevant_cts@@ -967,28 +992,28 @@        else do { fresh_binds <- newTcEvBinds                 -- The relevant constraints may contain HoleDests, so we must                 -- take care to clone them as well (to avoid #15370).-               ; cloned_relevants <- mapBagM cloneWanted th_relevant_cts-                 -- We wrap the WC in the nested implications, see+               ; cloned_relevants <- mapBagM cloneWantedCtEv th_relevant_cts+                 -- We wrap the WC in the nested implications, for details, see                  -- Note [Checking hole fits]-               ; let outermost_first = reverse th_implics-                    -- We add the cloned relevants to the wanteds generated by-                    -- the call to tcSubType_NC, see Note [Relevant constraints]-                    -- There's no need to clone the wanteds, because they are-                    -- freshly generated by `tcSubtype_NC`.-                     w_rel_cts = addSimples wanted cloned_relevants-                     final_wc  = foldr (setWCAndBinds fresh_binds) w_rel_cts outermost_first+               ; let wrapInImpls cts = foldl (flip (setWCAndBinds fresh_binds)) cts th_implics+                     final_wc  = wrapInImpls $ addSimples wanted $+                                                          mapBag mkNonCanonical cloned_relevants+                 -- We add the cloned relevants to the wanteds generated+                 -- by the call to tcSubType_NC, for details, see+                 -- Note [Relevant constraints]. There's no need to clone+                 -- the wanteds, because they are freshly generated by the+                 -- call to`tcSubtype_NC`.                ; traceTc "final_wc is: " $ ppr final_wc-               ; rem <- runTcSDeriveds $ simplifyTopWanteds final_wc-               -- We don't want any insoluble or simple constraints left, but-               -- solved implications are ok (and necessary for e.g. undefined)-               ; traceTc "rems was:" $ ppr rem+                 -- See Note [Speeding up valid hole-fits]+               ; (rem, _) <- tryTc $ runTcSEarlyAbort $ simplifyTopWanteds final_wc                ; traceTc "}" empty-               ; return (isSolvedWC rem, wrap) } }-     where-       orig = ExprHoleOrigin (hole_occ <$> th_hole)-       setWCAndBinds :: EvBindsVar         -- Fresh ev binds var.-                     -> Implication        -- The implication to put WC in.-                     -> WantedConstraints  -- The WC constraints to put implic.-                     -> WantedConstraints  -- The new constraints.-       setWCAndBinds binds imp wc-         = mkImplicWC $ unitBag $ imp { ic_wanted = wc , ic_binds = binds }+               ; return (any isSolvedWC rem, wrap) } }+  where+    orig = ExprHoleOrigin (hole_occ <$> th_hole)++    setWCAndBinds :: EvBindsVar         -- Fresh ev binds var.+                  -> Implication        -- The implication to put WC in.+                  -> WantedConstraints  -- The WC constraints to put implic.+                  -> WantedConstraints  -- The new constraints.+    setWCAndBinds binds imp wc+      = mkImplicWC $ unitBag $ imp { ic_wanted = wc , ic_binds = binds }
compiler/GHC/Tc/Errors/Hole.hs-boot view
@@ -5,20 +5,21 @@ module GHC.Tc.Errors.Hole where  import GHC.Types.Var ( Id )+import GHC.Tc.Errors.Types ( HoleFitDispConfig, ValidHoleFits ) import GHC.Tc.Types  ( TcM )-import GHC.Tc.Types.Constraint ( Ct, CtLoc, Hole, Implication )+import GHC.Tc.Types.Constraint ( CtEvidence, CtLoc, Hole, Implication ) import GHC.Utils.Outputable ( SDoc ) import GHC.Types.Var.Env ( TidyEnv ) import GHC.Tc.Errors.Hole.FitTypes ( HoleFit, TypedHole, HoleFitCandidate )-import GHC.Tc.Utils.TcType ( TcType, TcSigmaType, Type, TcTyVar )+import GHC.Tc.Utils.TcType ( TcType, TcSigmaType, TcTyVar ) import GHC.Tc.Types.Evidence ( HsWrapper ) import GHC.Utils.FV ( FV ) import Data.Bool ( Bool ) import Data.Maybe ( Maybe ) import Data.Int ( Int ) -findValidHoleFits :: TidyEnv -> [Implication] -> [Ct] -> Hole-                  -> TcM (TidyEnv, SDoc)+findValidHoleFits :: TidyEnv -> [Implication] -> [CtEvidence] -> Hole+                  -> TcM (TidyEnv, ValidHoleFits)  tcCheckHoleFit :: TypedHole -> TcSigmaType -> TcSigmaType                -> TcM (Bool, HsWrapper)@@ -30,14 +31,12 @@ getLocalBindings :: TidyEnv -> CtLoc -> TcM [Id] addHoleFitDocs :: [HoleFit] -> TcM [HoleFit] -data HoleFitDispConfig data HoleFitSortingAlg  pprHoleFit :: HoleFitDispConfig -> HoleFit -> SDoc getHoleFitSortingAlg :: TcM HoleFitSortingAlg getHoleFitDispConfig :: TcM HoleFitDispConfig -relevantCts :: Type -> [Ct] -> [Ct] zonkSubs :: TidyEnv -> [HoleFit] -> TcM (TidyEnv, [HoleFit]) sortHoleFitsBySize :: [HoleFit] -> TcM [HoleFit] sortHoleFitsByGraph :: [HoleFit] -> TcM [HoleFit]
compiler/GHC/Tc/Gen/Annotation.hs view
@@ -15,6 +15,7 @@ import GHC.Driver.Session import GHC.Driver.Env +import GHC.Tc.Errors.Types import {-# SOURCE #-} GHC.Tc.Gen.Splice ( runAnnotation ) import GHC.Tc.Utils.Monad @@ -43,9 +44,7 @@ --- No GHCI; emit a warning (not an error) and ignore. cf #4268 warnAnns [] = return [] warnAnns anns@(L loc _ : _)-  = do { setSrcSpanA loc $ addWarnTc NoReason $-             (text "Ignoring ANN annotation" <> plural anns <> comma-             <+> text "because this is a stage-1 compiler without -fexternal-interpreter or doesn't support GHCi")+  = do { setSrcSpanA loc $ addDiagnosticTc (TcRnIgnoringAnnotations anns)        ; return [] }  tcAnnotation :: LAnnDecl GhcRn -> TcM Annotation@@ -58,11 +57,8 @@     setSrcSpanA loc $ addErrCtxt (annCtxt ann) $ do       -- See #10826 -- Annotations allow one to bypass Safe Haskell.       dflags <- getDynFlags-      when (safeLanguageOn dflags) $ failWithTc safeHsErr+      when (safeLanguageOn dflags) $ failWithTc TcRnAnnotationInSafeHaskell       runAnnotation target expr-    where-      safeHsErr = vcat [ text "Annotations are not compatible with Safe Haskell."-                  , text "See https://gitlab.haskell.org/ghc/ghc/issues/10826" ]  annProvenanceToTarget :: Module -> AnnProvenance GhcRn                       -> AnnTarget Name
compiler/GHC/Tc/Gen/App.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE DataKinds           #-} {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE GADTs               #-}+{-# LANGUAGE LambdaCase          #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies        #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]@@ -21,12 +22,21 @@  import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcPolyExpr ) -import GHC.Builtin.Types (multiplicityTy)+import GHC.Types.Basic ( Arity, ExprOrPat(Expression) )+import GHC.Types.Id ( idArity, idName, hasNoBinding )+import GHC.Types.Name ( isWiredInName )+import GHC.Types.Var+import GHC.Builtin.Types ( multiplicityTy )+import GHC.Core.ConLike  ( ConLike(..) )+import GHC.Core.DataCon ( dataConRepArity+                        , isNewDataCon, isUnboxedSumDataCon, isUnboxedTupleDataCon ) import GHC.Tc.Gen.Head import GHC.Hs+import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Unify import GHC.Tc.Utils.Instantiate+import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) import GHC.Tc.Instance.Family ( tcGetFamInstEnvs, tcLookupDataFamInst_maybe ) import GHC.Tc.Gen.HsType import GHC.Tc.Utils.TcMType@@ -54,8 +64,6 @@ import Control.Monad import Data.Function -#include "GhclibHsVersions.h"- import GHC.Prelude  {- *********************************************************************@@ -140,7 +148,7 @@   = addExprCtxt rn_expr $     setSrcSpanA loc     $     do { do_ql <- wantQuickLook rn_fun-       ; (_tc_fun, fun_sigma) <- tcInferAppHead fun rn_args Nothing+       ; (_tc_fun, fun_sigma) <- tcInferAppHead fun rn_args        ; (_delta, inst_args, app_res_sigma) <- tcInstFun do_ql inst fun fun_sigma rn_args        ; _tc_args <- tcValArgs do_ql inst_args        ; return app_res_sigma }@@ -164,12 +172,12 @@      |  ( app )             -- HsPar: parens      |  {-# PRAGMA #-} app  -- HsPragE: pragmas -head ::= f             -- HsVar:    variables-      |  fld           -- HsRecFld: record field selectors-      |  (expr :: ty)  -- ExprWithTySig: expr with user type sig-      |  lit           -- HsOverLit: overloaded literals+head ::= f                -- HsVar:    variables+      |  fld              -- HsRecSel: record field selectors+      |  (expr :: ty)     -- ExprWithTySig: expr with user type sig+      |  lit              -- HsOverLit: overloaded literals       |  $([| head |])    -- HsSpliceE+HsSpliced+HsSplicedExpr: untyped TH expression splices-      |  other_expr    -- Other expressions+      |  other_expr       -- Other expressions  When tcExpr sees something that starts an application chain (namely, any of the constructors in 'app' or 'head'), it invokes tcApp to@@ -239,7 +247,7 @@ 2. Use tcInferAppHead to infer the type of the function,      as an (uninstantiated) TcSigmaType    There are special cases for-     HsVar, HsRecFld, and ExprWithTySig+     HsVar, HsRecSel, and ExprWithTySig    Otherwise, delegate back to tcExpr, which      infers an (instantiated) TcRhoType @@ -282,14 +290,13 @@ * ($): For a long time GHC has had a special typing rule for ($), that   allows it to type (runST $ foo), which requires impredicative instantiation   of ($), without language flags.  It's a bit ad-hoc, but it's been that-  way for ages.  Using quickLookIds is the only special treatment ($) needs+  way for ages.  Using quickLookKeys is the only special treatment ($) needs   now, which is a lot better.  * leftSection, rightSection: these are introduced by the expansion step in   the renamer (Note [Handling overloaded and rebindable constructs] in   GHC.Rename.Expr), and we want them to be instantiated impredicatively   so that (f `op`), say, will work OK even if `f` is higher rank.-  See Note [Left and right sections] in GHC.Rename.Expr.  Note [Unify with expected type before typechecking arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -325,12 +332,27 @@ tcApp rn_expr exp_res_ty   | (fun@(rn_fun, fun_ctxt), rn_args) <- splitHsApps rn_expr   = do { (tc_fun, fun_sigma) <- tcInferAppHead fun rn_args-                                    (checkingExpType_maybe exp_res_ty)         -- Instantiate        ; do_ql <- wantQuickLook rn_fun        ; (delta, inst_args, app_res_rho) <- tcInstFun do_ql True fun fun_sigma rn_args +       -- Check for representation polymorphism in the case that+       -- the head of the application is a primop or data constructor+       -- which has argument types that are representation-polymorphic.+       -- This amounts to checking that the leftover argument types,+       -- up until the arity, are not representation-polymorphic,+       -- so that we can perform eta-expansion later without introducing+       -- representation-polymorphic binders.+       --+       -- See Note [Checking for representation-polymorphic built-ins]+       ; traceTc "tcApp FRR" $+           vcat+             [ text "tc_fun =" <+> ppr tc_fun+             , text "inst_args =" <+> ppr inst_args+             , text "app_res_rho =" <+> ppr app_res_rho ]+       ; hasFixedRuntimeRep_remainingValArgs inst_args app_res_rho tc_fun+        -- Quick look at result        ; app_res_rho <- if do_ql                         then quickLookResultType delta app_res_rho exp_res_ty@@ -350,26 +372,12 @@                  = addFunResCtxt rn_fun rn_args app_res_rho exp_res_ty $                    thing_inside -       -- Match up app_res_rho: the result type of rn_expr-       --     with exp_res_ty:  the expected result type-       ; do_ds <- xoptM LangExt.DeepSubsumption        ; res_wrap <- perhaps_add_res_ty_ctxt $-            if not do_ds-            then -- No deep subsumption-                 -- app_res_rho and exp_res_ty are both rho-types,-                 -- so with simple subsumption we can just unify them-                 -- No need to zonk; the unifier does that-                 do { co <- unifyExpectedType rn_expr app_res_rho exp_res_ty-                    ; return (mkWpCastN co) }--            else -- Deep subsumption-                 -- Even though both app_res_rho and exp_res_ty are rho-types,-                 -- they may have nested polymorphism, so if deep subsumption-                 -- is on we must call tcSubType.-                 -- Zonk app_res_rho first, becuase QL may have instantiated some-                 -- delta variables to polytypes, and tcSubType doesn't expect that-                 do { app_res_rho <- zonkQuickLook do_ql app_res_rho-                    ; tcSubTypeDS rn_expr app_res_rho exp_res_ty }+                     tcSubTypeNC (exprCtOrigin rn_expr) GenSigCtxt (Just $ HsExprRnThing rn_expr)+                                 app_res_rho exp_res_ty+                     -- Need tcSubType because of the possiblity of deep subsumption.+                     -- app_res_rho and exp_res_ty are both rho-types, so without+                     -- deep subsumption unifyExpectedType would be sufficient         ; whenDOptM Opt_D_dump_tc_trace $          do { inst_args <- mapM zonkArg inst_args  -- Only when tracing@@ -385,16 +393,228 @@        -- Typecheck the value arguments        ; tc_args <- tcValArgs do_ql inst_args -       -- Reconstruct, with special case for tagToEnum#-       ; tc_expr <- if isTagToEnum rn_fun-                    then tcTagToEnum tc_fun fun_ctxt tc_args app_res_rho-                    else return (rebuildHsApps tc_fun fun_ctxt tc_args)+       -- Reconstruct, with a special cases for tagToEnum#.+       ; tc_expr <-+          if isTagToEnum rn_fun+          then tcTagToEnum tc_fun fun_ctxt tc_args app_res_rho+          else do return (rebuildHsApps tc_fun fun_ctxt tc_args)         -- Wrap the result        ; return (mkHsWrap res_wrap tc_expr) } +{-+Note [Checking for representation-polymorphic built-ins]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We cannot have representation-polymorphic or levity-polymorphic+function arguments. See Note [Representation polymorphism invariants]+in GHC.Core.  That is checked by the calls to `hasFixedRuntimeRep` in+`tcEValArg`.++But some /built-in/ functions have representation-polymorphic argument+types. Users can't define such Ids; they are all GHC built-ins or data+constructors.  Specifically they are:++1. A few wired-in Ids like unsafeCoerce#, with compulsory unfoldings.+2. Primops, such as raise#.+3. Newtype constructors with `UnliftedNewtypes` that have+   a representation-polymorphic argument.+4. Representation-polymorphic data constructors: unboxed tuples+   and unboxed sums.++For (1) consider+  badId :: forall r (a :: TYPE r). a -> a+  badId = unsafeCoerce# @r @r @a @a++The wired-in function+  unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)+                   (a :: TYPE r1) (b :: TYPE r2).+                   a -> b+has a convenient but representation-polymorphic type. It has no+binding; instead it has a compulsory unfolding, after which we+would have+  badId = /\r /\(a :: TYPE r). \(x::a). ...body of unsafeCorece#...+And this is no good because of that rep-poly \(x::a).  So we want+to reject this.++On the other hand+  goodId :: forall (a :: Type). a -> a+  goodId = unsafeCoerce# @LiftedRep @LiftedRep @a @a++is absolutely fine, because after we inline the unfolding, the \(x::a)+is representation-monomorphic.++Test cases: T14561, RepPolyWrappedVar2.++For primops (2) the situation is similar; they are eta-expanded in+CorePrep to be saturated, and that eta-expansion must not add a+representation-polymorphic lambda.++Test cases: T14561b, RepPolyWrappedVar, UnliftedNewtypesCoerceFail.++For (3), consider a representation-polymorphic newtype with+UnliftedNewtypes:++  type Id :: forall r. TYPE r -> TYPE r+  newtype Id a where { MkId :: a }++  bad :: forall r (a :: TYPE r). a -> Id a+  bad = MkId @r @a             -- Want to reject++  good :: forall (a :: Type). a -> Id a+  good = MkId @LiftedRep @a   -- Want to accept++Test cases: T18481, UnliftedNewtypesLevityBinder++So these three cases need special treatment. We add a special case+in tcApp to check whether an application of an Id has any remaining+representation-polymorphic arguments, after instantiation and application+of previous arguments.  This is achieved by the hasFixedRuntimeRep_remainingValArgs+function, which computes the types of the remaining value arguments, and checks+that each of these have a fixed runtime representation using hasFixedRuntimeRep.++Wrinkles++* Because of Note [Typechecking data constructors] in GHC.Tc.Gen.Head,+  we desugar a representation-polymorphic data constructor application+  like this:+     (/\(r :: RuntimeRep) (a :: TYPE r) \(x::a). K r a x) @LiftedRep Int 4+  That is, a rep-poly lambda applied to arguments that instantiate it in+  a rep-mono way.  It's a bit like a compulsory unfolding that has been+  inlined, but not yet beta-reduced.++  Because we want to accept this, we switch off Lint's representation+  polymorphism checks when Lint checks the output of the desugarer;+  see the lf_check_fixed_rep flag in GHC.Core.Lint.lintCoreBindings.++  We then rely on the simple optimiser to beta reduce these+  representation-polymorphic lambdas (e.g. GHC.Core.SimpleOpt.simple_app).++* Arity.  We don't want to check for arguments past the+  arity of the function.  For example++      raise# :: forall {r :: RuntimeRep} (a :: Type) (b :: TYPE r). a -> b++  has arity 1, so an instantiation such as:++      foo :: forall w r (z :: TYPE r). w -> z -> z+      foo = raise# @w @(z -> z)++  is unproblematic.  This means we must take care not to perform a+  representation-polymorphism check on `z`.++  To achieve this, we consult the arity of the 'Id' which is the head+  of the application (or just use 1 for a newtype constructor),+  and keep track of how many value-level arguments we have seen,+  to ensure we stop checking once we reach the arity.+  This is slightly complicated by the need to include both visible+  and invisible arguments, as the arity counts both:+  see GHC.Tc.Gen.Head.countVisAndInvisValArgs.++  Test cases: T20330{a,b}++-}++-- | Check for representation-polymorphism in the remaining argument types+-- of a variable or data constructor, after it has been instantiated and applied to some arguments.+--+-- See Note [Checking for representation-polymorphic built-ins]+hasFixedRuntimeRep_remainingValArgs :: [HsExprArg 'TcpInst] -> TcRhoType -> HsExpr GhcTc -> TcM ()+hasFixedRuntimeRep_remainingValArgs applied_args app_res_rho = \case++  HsVar _ (L _ fun_id)++    -- (1): unsafeCoerce#+    -- 'unsafeCoerce#' is peculiar: it is patched in manually as per+    -- Note [Wiring in unsafeCoerce#] in GHC.HsToCore.+    -- Unfortunately, even though its arity is set to 1 in GHC.HsToCore.mkUnsafeCoercePrimPair,+    -- at this stage, if we query idArity, we get 0. This is because+    -- we end up looking at the non-patched version of unsafeCoerce#+    -- defined in Unsafe.Coerce, and that one indeed has arity 0.+    --+    -- We thus manually specify the correct arity of 1 here.+    | idName fun_id == unsafeCoercePrimName+    -> check_thing fun_id 1 (FRRNoBindingResArg fun_id)++    -- (2): primops and other wired-in representation-polymorphic functions,+    -- such as 'rightSection', 'oneShot', etc; see bindings with Compulsory unfoldings+    -- in GHC.Types.Id.Make+    | isWiredInName (idName fun_id) && hasNoBinding fun_id+    -> check_thing fun_id (idArity fun_id) (FRRNoBindingResArg fun_id)+       -- NB: idArity consults the IdInfo of the Id. This can be a problem+       -- in the presence of hs-boot files, as we might not have finished+       -- typechecking; inspecting the IdInfo at this point can cause+       -- strange Core Lint errors (see #20447).+       -- We avoid this entirely by only checking wired-in names,+       -- as those are the only ones this check is applicable to anyway.+++  XExpr (ConLikeTc (RealDataCon con) _ _)+  -- (3): Representation-polymorphic newtype constructors.+    | isNewDataCon con+  -- (4): Unboxed tuples and unboxed sums+    || isUnboxedTupleDataCon con+    || isUnboxedSumDataCon con+    -> check_thing con (dataConRepArity con) (FRRDataConArg Expression con)++  _ -> return ()++  where+    nb_applied_vis_val_args :: Int+    nb_applied_vis_val_args = count isHsValArg applied_args++    nb_applied_val_args :: Int+    nb_applied_val_args = countVisAndInvisValArgs applied_args++    arg_tys :: [(Type,AnonArgFlag)]+    arg_tys = getRuntimeArgTys app_res_rho+    -- We do not need to zonk app_res_rho first, because the number of arrows+    -- in the (possibly instantiated) inferred type of the function will+    -- be at least the arity of the function.++    check_thing :: Outputable thing+                => thing+                -> Arity+                -> (Int -> FixedRuntimeRepContext)+                -> TcM ()+    check_thing thing arity mk_frr_orig = do+      traceTc "tcApp remainingValArgs check_thing" (debug_msg thing arity)+      go (nb_applied_vis_val_args + 1) (nb_applied_val_args + 1) arg_tys+      where+        go :: Int -- visible value argument index, starting from 1+                  -- only used to report the argument position in error messages+           -> Int -- value argument index, starting from 1+                  -- used to count up to the arity to ensure we don't check too many argument types+           -> [(Type, AnonArgFlag)] -- run-time argument types+           -> TcM ()+        go _ i_val _+          | i_val > arity+          = return ()+        go _ _ []+          -- Should never happen: it would mean that the arity is higher+          -- than the number of arguments apparent from the type+          = pprPanic "hasFixedRuntimeRep_remainingValArgs" (debug_msg thing arity)+        go i_visval !i_val ((arg_ty, af) : tys)+          = case af of+              InvisArg ->+                go i_visval (i_val + 1) tys+              VisArg   -> do+                hasFixedRuntimeRep_syntactic (mk_frr_orig i_visval) arg_ty+                go (i_visval + 1) (i_val + 1) tys++    -- A message containing all the relevant info, in case this functions+    -- needs to be debugged again at some point.+    debug_msg :: Outputable thing => thing -> Arity -> SDoc+    debug_msg thing arity =+      vcat+        [ text "thing =" <+> ppr thing+        , text "arity =" <+> ppr arity+        , text "applied_args =" <+> ppr applied_args+        , text "nb_applied_val_args =" <+> ppr nb_applied_val_args+        , text "arg_tys =" <+> ppr arg_tys ]+ -------------------- wantQuickLook :: HsExpr GhcRn -> TcM Bool+-- GHC switches on impredicativity all the time for ($) wantQuickLook (HsVar _ (L _ f))   | getUnique f `elem` quickLookKeys = return True wantQuickLook _                      = xoptM LangExt.ImpredicativeTypes@@ -464,7 +684,7 @@            ; return (eva { eva_arg    = ValArg arg'                          , eva_arg_ty = Scaled mult arg_ty }) } -tcEValArg :: AppCtxt -> EValArg 'TcpInst -> TcSigmaType -> TcM (LHsExpr GhcTc)+tcEValArg :: AppCtxt -> EValArg 'TcpInst -> TcSigmaTypeFRR -> TcM (LHsExpr GhcTc) -- Typecheck one value argument of a function call tcEValArg ctxt (ValArg larg@(L arg_loc arg)) exp_arg_sigma   = addArgCtxt ctxt larg $@@ -479,9 +699,9 @@     do { traceTc "tcEValArgQL {" (vcat [ ppr inner_fun <+> ppr inner_args ])        ; tc_args <- tcValArgs True inner_args        ; co      <- unifyType Nothing app_res_rho exp_arg_sigma-       ; traceTc "tcEValArg }" empty-       ; return (L arg_loc $ mkHsWrapCo co $-                 rebuildHsApps inner_fun fun_ctxt tc_args) }+       ; let arg' = mkHsWrapCo co $ rebuildHsApps inner_fun fun_ctxt tc_args+       ; traceTc "tcEValArgQL }" empty+       ; return (L arg_loc arg') }  {- ********************************************************************* *                                                                      *@@ -530,9 +750,6 @@           VAExpansion orig _ -> addExprCtxt orig thing_inside           VACall {}          -> thing_inside -    herald = sep [ text "The function" <+> quotes (ppr rn_fun)-                 , text "is applied to"]-     -- Count value args only when complaining about a function     -- applied to too many value args     -- See Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify.@@ -543,25 +760,30 @@           HsUnboundVar {} -> True           _               -> False -    inst_all :: ArgFlag -> Bool+    inst_all, inst_inferred, inst_none :: ArgFlag -> Bool     inst_all (Invisible {}) = True     inst_all Required       = False -    inst_inferred :: ArgFlag -> Bool     inst_inferred (Invisible InferredSpec)  = True     inst_inferred (Invisible SpecifiedSpec) = False     inst_inferred Required                  = False +    inst_none _ = False+     inst_fun :: [HsExprArg 'TcpRn] -> ArgFlag -> Bool     inst_fun [] | inst_final  = inst_all-                | otherwise   = inst_inferred+                | otherwise   = inst_none+                -- Using `inst_none` for `:type` avoids+                -- `forall {r1} (a :: TYPE r1) {r2} (b :: TYPE r2). a -> b`+                -- turning into `forall a {r2} (b :: TYPE r2). a -> b`.+                -- See #21088.     inst_fun (EValArg {} : _) = inst_all     inst_fun _                = inst_inferred      -----------     go, go1 :: Delta-            -> [HsExprArg 'TcpInst]  -- Accumulator, reversed-            -> [Scaled TcSigmaType]  -- Value args to which applied so far+            -> [HsExprArg 'TcpInst]     -- Accumulator, reversed+            -> [Scaled TcSigmaTypeFRR]  -- Value args to which applied so far             -> TcSigmaType -> [HsExprArg 'TcpRn]             -> TcM (Delta, [HsExprArg 'TcpInst], TcSigmaType) @@ -657,10 +879,12 @@      -- Rule IARG from Fig 4 of the QL paper:     go1 delta acc so_far fun_ty-        (eva@(EValArg { eva_arg = ValArg arg, eva_ctxt = ctxt })  : rest_args)-      = do { (wrap, arg_ty, res_ty) <- matchActualFunTySigma herald-                                          (Just (ppr rn_fun))-                                          (n_val_args, so_far) fun_ty+        (eva@(EValArg { eva_arg = ValArg arg, eva_ctxt = ctxt }) : rest_args)+      = do { (wrap, arg_ty, res_ty) <-+                matchActualFunTySigma+                  (ExpectedFunTyArg (HsExprRnThing rn_fun) (unLoc arg))+                  (Just $ HsExprRnThing rn_fun)+                  (n_val_args, so_far) fun_ty           ; (delta', arg') <- if do_ql                               then addArgCtxt ctxt arg $                                    -- Context needed for constraints@@ -725,9 +949,7 @@    | otherwise   = do { (_, fun_ty) <- zonkTidyTcType emptyTidyEnv fun_ty-       ; failWith $-         text "Cannot apply expression of type" <+> quotes (ppr fun_ty) $$-         text "to a visible type argument" <+> quotes (ppr hs_ty) }+       ; failWith $ TcRnInvalidTypeApplication fun_ty hs_ty }  {- Note [Required quantifiers in the type of a term] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -753,7 +975,7 @@ Suppose 'wurble' is not in scope, and we have    (wurble @Int @Bool True 'x') -Then the renamer will make (HsUnboundVar "wurble) for 'wurble',+Then the renamer will make (HsUnboundVar "wurble") for 'wurble', and the typechecker will typecheck it with tcUnboundId, giving it a type 'alpha', and emitting a deferred Hole constraint, to be reported later.@@ -777,7 +999,7 @@ that may abandon an entire instance decl, which (in the presence of -fdefer-type-errors) leads to leading to #17792. -Downside; the typechecked term has lost its visible type arguments; we+Downside: the typechecked term has lost its visible type arguments; we don't even kind-check them.  But let's jump that bridge if we come to it.  Meanwhile, let's not crash! @@ -839,8 +1061,8 @@  ---------------- quickLookArg :: Delta-             -> LHsExpr GhcRn       -- Argument-             -> Scaled TcSigmaType  -- Type expected by the function+             -> LHsExpr GhcRn          -- ^ Argument+             -> Scaled TcSigmaTypeFRR  -- ^ Type expected by the function              -> TcM (Delta, EValArg 'TcpInst) -- See Note [Quick Look at value arguments] --@@ -879,11 +1101,11 @@   | Just {} <- tcSplitAppTy_maybe ty        = True   | otherwise                               = False -quickLookArg1 :: Bool -> Delta -> LHsExpr GhcRn -> TcSigmaType+quickLookArg1 :: Bool -> Delta -> LHsExpr GhcRn -> TcSigmaTypeFRR               -> TcM (Delta, EValArg 'TcpInst) quickLookArg1 guarded delta larg@(L _ arg) arg_ty   = do { let (fun@(rn_fun, fun_ctxt), rn_args) = splitHsApps arg-       ; mb_fun_ty <- tcInferAppHead_maybe rn_fun rn_args (Just arg_ty)+       ; mb_fun_ty <- tcInferAppHead_maybe rn_fun rn_args        ; traceTc "quickLookArg 1" $          vcat [ text "arg:" <+> ppr arg               , text "head:" <+> ppr rn_fun <+> dcolon <+> ppr mb_fun_ty@@ -1020,7 +1242,7 @@      ----------------     go_kappa bvs kappa ty2-      = ASSERT2( isMetaTyVar kappa, ppr kappa )+      = assertPpr (isMetaTyVar kappa) (ppr kappa) $         do { info <- readMetaTyVar kappa            ; case info of                Indirect ty1 -> go bvs ty1 ty2@@ -1037,7 +1259,7 @@           -- Passes the occurs check       = do { let ty2_kind   = typeKind ty2                  kappa_kind = tyVarKind kappa-           ; co <- unifyKind (Just (ppr ty2)) ty2_kind kappa_kind+           ; co <- unifyKind (Just (TypeThing ty2)) ty2_kind kappa_kind                    -- unifyKind: see Note [Actual unification in qlUnify]             ; traceTc "qlUnify:update" $@@ -1187,7 +1409,7 @@         -- Check that the type is algebraic        ; case tcSplitTyConApp_maybe res_ty of {-           Nothing -> do { addErrTc (mk_error res_ty doc1)+           Nothing -> do { addErrTc (TcRnTagToEnumUnspecifiedResTy res_ty)                          ; vanilla_result } ;            Just (tc, tc_args) -> @@ -1207,24 +1429,14 @@        ; return (mkHsWrap df_wrap tc_expr) }}}}}    | otherwise-  = failWithTc (text "tagToEnum# must appear applied to one value argument")+  = failWithTc TcRnTagToEnumMissingValArg    where     vanilla_result = return (rebuildHsApps tc_fun fun_ctxt tc_args)      check_enumeration ty' tc       | isEnumerationTyCon tc = return ()-      | otherwise             = addErrTc (mk_error ty' doc2)--    doc1 = vcat [ text "Specify the type by giving a type signature"-               , text "e.g. (tagToEnum# x) :: Bool" ]-    doc2 = text "Result type must be an enumeration type"--    mk_error :: TcType -> SDoc -> SDoc-    mk_error ty what-      = hang (text "Bad call to tagToEnum#"-               <+> text "at type" <+> ppr ty)-           2 what+      | otherwise             = addErrTc (TcRnTagToEnumResTyNotAnEnum ty')   {- *********************************************************************
compiler/GHC/Tc/Gen/Arrow.hs view
@@ -1,5 +1,6 @@-{-# LANGUAGE RankNTypes    #-}-{-# LANGUAGE TypeFamilies  #-}+{-# LANGUAGE RankNTypes     #-}+{-# LANGUAGE TypeFamilies   #-}+{-# LANGUAGE BlockArguments #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -18,9 +19,10 @@                                        , tcCheckPolyExpr )  import GHC.Hs+import GHC.Tc.Errors.Types import GHC.Tc.Gen.Match import GHC.Tc.Gen.Head( tcCheckId )-import GHC.Tc.Utils.Zonk( hsLPatType )+import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) import GHC.Tc.Utils.TcType import GHC.Tc.Utils.TcMType import GHC.Tc.Gen.Bind@@ -37,6 +39,7 @@ import GHC.Types.Var.Set import GHC.Builtin.Types.Prim import GHC.Types.Basic( Arity )+import GHC.Types.Error import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Utils.Panic@@ -89,13 +92,14 @@        -> ExpRhoType                            -- Expected type of whole proc expression        -> TcM (LPat GhcTc, LHsCmdTop GhcTc, TcCoercion) -tcProc pat cmd@(L _ (HsCmdTop names _)) exp_ty+tcProc pat cmd@(L loc (HsCmdTop names _)) exp_ty   = do  { exp_ty <- expTypeToType exp_ty  -- no higher-rank stuff with arrows         ; (co, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty         ; (co1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1         -- start with the names as they are used to desugar the proc itself         -- See #17423-        ; names' <- mapM (tcSyntaxName ProcOrigin arr_ty) names+        ; names' <- setSrcSpanA loc $+            mapM (tcSyntaxName ProcOrigin arr_ty) names         ; let cmd_env = CmdEnv { cmd_arr = arr_ty }         ; (pat', cmd') <- newArrowScope                           $ tcCheckPat (ArrowMatchCtxt ProcExpr) pat (unrestricted arg_ty)@@ -132,40 +136,46 @@          -> TcM (LHsCmdTop GhcTc)  tcCmdTop env names (L loc (HsCmdTop _names cmd)) cmd_ty@(cmd_stk, res_ty)-  = setSrcSpan loc $+  = setSrcSpanA loc $     do  { cmd' <- tcCmd env cmd cmd_ty         ; return (L loc $ HsCmdTop (CmdTopTc cmd_stk res_ty names) cmd') }  ---------------------------------------- tcCmd  :: CmdEnv -> LHsCmd GhcRn -> CmdType -> TcM (LHsCmd GhcTc)         -- The main recursive function-tcCmd env (L loc cmd) res_ty+tcCmd env (L loc cmd) cmd_ty@(_, res_ty)   = setSrcSpan (locA loc) $ do-        { cmd' <- tc_cmd env cmd res_ty+        { cmd' <- tc_cmd env cmd cmd_ty+        ; hasFixedRuntimeRep_syntactic (FRRArrow $ ArrowCmdResTy cmd) res_ty         ; return (L loc cmd') }  tc_cmd :: CmdEnv -> HsCmd GhcRn  -> CmdType -> TcM (HsCmd GhcTc)-tc_cmd env (HsCmdPar x cmd) res_ty+tc_cmd env (HsCmdPar x lpar cmd rpar) res_ty   = do  { cmd' <- tcCmd env cmd res_ty-        ; return (HsCmdPar x cmd') }+        ; return (HsCmdPar x lpar cmd' rpar) } -tc_cmd env (HsCmdLet x binds (L body_loc body)) res_ty+tc_cmd env (HsCmdLet x tkLet binds tkIn (L body_loc body)) res_ty   = do  { (binds', body') <- tcLocalBinds binds         $                              setSrcSpan (locA body_loc) $                              tc_cmd env body res_ty-        ; return (HsCmdLet x binds' (L body_loc body')) }+        ; return (HsCmdLet x tkLet binds' tkIn (L body_loc body')) }  tc_cmd env in_cmd@(HsCmdCase x scrut matches) (stk, res_ty)   = addErrCtxt (cmdCtxt in_cmd) $ do       (scrut', scrut_ty) <- tcInferRho scrut+      hasFixedRuntimeRep_syntactic+        (FRRArrow $ ArrowCmdCase)+        scrut_ty       matches' <- tcCmdMatches env scrut_ty matches (stk, res_ty)       return (HsCmdCase x scrut' matches') -tc_cmd env in_cmd@(HsCmdLamCase x matches) (stk, res_ty)-  = addErrCtxt (cmdCtxt in_cmd) $ do-      (co, [scrut_ty], stk') <- matchExpectedCmdArgs 1 stk-      matches' <- tcCmdMatches env scrut_ty matches (stk', res_ty)-      return (mkHsCmdWrap (mkWpCastN co) (HsCmdLamCase x matches'))+tc_cmd env cmd@(HsCmdLamCase x lc_variant match) cmd_ty+  = addErrCtxt (cmdCtxt cmd)+      do { let match_ctxt = ArrowLamCaseAlt lc_variant+         ; checkPatCounts (ArrowMatchCtxt match_ctxt) match+         ; (wrap, match') <-+             tcCmdMatchLambda env match_ctxt match cmd_ty+         ; return (mkHsCmdWrap wrap (HsCmdLamCase x lc_variant match')) }  tc_cmd env (HsCmdIf x NoSyntaxExprRn pred b1 b2) res_ty    -- Ordinary 'if'   = do  { pred' <- tcCheckMonoExpr pred boolTy@@ -179,14 +189,15 @@         -- For arrows, need ifThenElse :: forall r. T -> r -> r -> r         -- because we're going to apply it to the environment, not         -- the return value.-        ; (_, [r_tv]) <- tcInstSkolTyVars [alphaTyVar]+        ; skol_info <- mkSkolemInfo ArrowReboundIfSkol+        ; (_, [r_tv]) <- tcInstSkolTyVars skol_info [alphaTyVar]         ; let r_ty = mkTyVarTy r_tv         ; checkTc (not (r_tv `elemVarSet` tyCoVarsOfType pred_ty))-                  (text "Predicate type of `ifThenElse' depends on result type")-        ; (pred', fun')-            <- tcSyntaxOp IfOrigin fun (map synKnownType [pred_ty, r_ty, r_ty])-                                       (mkCheckExpType r_ty) $ \ _ _ ->-               tcCheckMonoExpr pred pred_ty+                  TcRnArrowIfThenElsePredDependsOnResultTy+        ; (pred', fun') <- tcSyntaxOp IfThenElseOrigin fun+                              (map synKnownType [pred_ty, r_ty, r_ty])+                              (mkCheckExpType r_ty) $ \ _ _ ->+                           tcCheckMonoExpr pred pred_ty          ; b1'   <- tcCmd env b1 res_ty         ; b2'   <- tcCmd env b2 res_ty@@ -217,6 +228,10 @@          ; arg' <- tcCheckMonoExpr arg arg_ty +        ; hasFixedRuntimeRep_syntactic+            (FRRArrow $ ArrowCmdArrApp (unLoc fun) (unLoc arg) ho_app)+            fun_ty+         ; return (HsCmdArrApp fun_ty fun' arg' ho_app lr) }   where        -- Before type-checking f, use the environment of the enclosing@@ -241,6 +256,9 @@     do  { arg_ty <- newOpenFlexiTyVarTy         ; fun'   <- tcCmd env fun (mkPairTy arg_ty cmd_stk, res_ty)         ; arg'   <- tcCheckMonoExpr arg arg_ty+        ; hasFixedRuntimeRep_syntactic+            (FRRArrow $ ArrowCmdApp (unLoc fun) (unLoc arg))+            arg_ty         ; return (HsCmdApp x fun' arg') }  -------------------------------------------@@ -250,44 +268,9 @@ -- ------------------------------ -- D;G |-a (\x.cmd) : (t,stk) --> res -tc_cmd env-       (HsCmdLam x (MG { mg_alts = L l [L mtch_loc-                                   (match@(Match { m_pats = pats, m_grhss = grhss }))],-                         mg_origin = origin }))-       (cmd_stk, res_ty)-  = addErrCtxt (pprMatchInCtxt match)        $-    do  { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk--                -- Check the patterns, and the GRHSs inside-        ; (pats', grhss') <- setSrcSpanA mtch_loc                                 $-                             tcPats (ArrowMatchCtxt KappaExpr)-                               pats (map (unrestricted . mkCheckExpType) arg_tys) $-                             tc_grhss grhss cmd_stk' (mkCheckExpType res_ty)--        ; let match' = L mtch_loc (Match { m_ext = noAnn-                                         , m_ctxt = ArrowMatchCtxt KappaExpr-                                         , m_pats = pats'-                                         , m_grhss = grhss' })-              arg_tys = map (unrestricted . hsLPatType) pats'-              cmd' = HsCmdLam x (MG { mg_alts = L l [match']-                                    , mg_ext = MatchGroupTc arg_tys res_ty-                                    , mg_origin = origin })-        ; return (mkHsCmdWrap (mkWpCastN co) cmd') }-  where-    n_pats     = length pats-    match_ctxt = ArrowMatchCtxt KappaExpr-    pg_ctxt    = PatGuard match_ctxt--    tc_grhss (GRHSs x grhss binds) stk_ty res_ty-        = do { (binds', grhss') <- tcLocalBinds binds $-                                   mapM (wrapLocM (tc_grhs stk_ty res_ty)) grhss-             ; return (GRHSs x grhss' binds') }--    tc_grhs stk_ty res_ty (GRHS x guards body)-        = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $-                                  \ res_ty -> tcCmd env body-                                                (stk_ty, checkingExpType "tc_grhs" res_ty)-             ; return (GRHS x guards' rhs') }+tc_cmd env (HsCmdLam x match) cmd_ty+  = do { (wrap, match') <- tcCmdMatchLambda env KappaExpr match cmd_ty+       ; return (mkHsCmdWrap wrap (HsCmdLam x match')) }  ------------------------------------------- --              Do notation@@ -313,7 +296,7 @@ --      D; G |-a  (| e c1 ... cn |)  :  stk --> t  tc_cmd env cmd@(HsCmdArrForm x expr f fixity cmd_args) (cmd_stk, res_ty)-  = addErrCtxt (cmdCtxt cmd)    $+  = addErrCtxt (cmdCtxt cmd)     do  { (cmd_args', cmd_tys) <- mapAndUnzipM tc_cmd_arg cmd_args                               -- We use alphaTyVar for 'w'         ; let e_ty = mkInfForAllTy alphaTyVar $@@ -324,27 +307,19 @@    where     tc_cmd_arg :: LHsCmdTop GhcRn -> TcM (LHsCmdTop GhcTc, TcType)-    tc_cmd_arg cmd@(L _ (HsCmdTop names _))+    tc_cmd_arg cmd@(L loc (HsCmdTop names _))        = do { arr_ty <- newFlexiTyVarTy arrowTyConKind             ; stk_ty <- newFlexiTyVarTy liftedTypeKind             ; res_ty <- newFlexiTyVarTy liftedTypeKind-            ; names' <- mapM (tcSyntaxName ProcOrigin arr_ty) names+            ; names' <- setSrcSpanA loc $+                mapM (tcSyntaxName ArrowCmdOrigin arr_ty) names             ; let env' = env { cmd_arr = arr_ty }             ; cmd' <- tcCmdTop env' names' cmd (stk_ty, res_ty)             ; return (cmd',  mkCmdArrTy env' (mkPairTy alphaTy stk_ty) res_ty) } ---------------------------------------------------------------------              Base case for illegal commands--- This is where expressions that aren't commands get rejected--tc_cmd _ cmd _-  = failWithTc (vcat [text "The expression", nest 2 (ppr cmd),-                      text "was found where an arrow command was expected"])---- | Typechecking for case command alternatives. Used for both--- 'HsCmdCase' and 'HsCmdLamCase'.+-- | Typechecking for case command alternatives. Used for 'HsCmdCase'. tcCmdMatches :: CmdEnv-             -> TcType                           -- ^ type of the scrutinee+             -> TcTypeFRR -- ^ Type of the scrutinee.              -> MatchGroup GhcRn (LHsCmd GhcRn)  -- ^ case alternatives              -> CmdType              -> TcM (MatchGroup GhcTc (LHsCmd GhcTc))@@ -356,7 +331,57 @@     mc_body body res_ty' = do { res_ty' <- expTypeToType res_ty'                               ; tcCmd env body (stk, res_ty') } -matchExpectedCmdArgs :: Arity -> TcType -> TcM (TcCoercionN, [TcType], TcType)+-- | Typechecking for 'HsCmdLam' and 'HsCmdLamCase'.+tcCmdMatchLambda :: CmdEnv+                 -> HsArrowMatchContext+                 -> MatchGroup GhcRn (LHsCmd GhcRn)+                 -> CmdType+                 -> TcM (HsWrapper, MatchGroup GhcTc (LHsCmd GhcTc))+tcCmdMatchLambda env+                 ctxt+                 mg@MG { mg_alts = L l matches }+                 (cmd_stk, res_ty)+  = do { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk++       ; let check_arg_tys = map (unrestricted . mkCheckExpType) arg_tys+       ; matches' <- forM matches $+           addErrCtxt . pprMatchInCtxt . unLoc <*> tc_match check_arg_tys cmd_stk'++       ; let arg_tys' = map unrestricted arg_tys+             mg' = mg { mg_alts = L l matches'+                      , mg_ext = MatchGroupTc arg_tys' res_ty }++       ; return (mkWpCastN co, mg') }+  where+    n_pats | isEmptyMatchGroup mg = 1   -- must be lambda-case+           | otherwise            = matchGroupArity mg++    -- Check the patterns, and the GRHSs inside+    tc_match arg_tys cmd_stk' (L mtch_loc (Match { m_pats = pats, m_grhss = grhss }))+      = do { (pats', grhss') <- setSrcSpanA mtch_loc           $+                                tcPats match_ctxt pats arg_tys $+                                tc_grhss grhss cmd_stk' (mkCheckExpType res_ty)++           ; return $ L mtch_loc (Match { m_ext = noAnn+                                        , m_ctxt = match_ctxt+                                        , m_pats = pats'+                                        , m_grhss = grhss' }) }++    match_ctxt = ArrowMatchCtxt ctxt+    pg_ctxt    = PatGuard match_ctxt++    tc_grhss (GRHSs x grhss binds) stk_ty res_ty+        = do { (binds', grhss') <- tcLocalBinds binds $+                                   mapM (wrapLocMA (tc_grhs stk_ty res_ty)) grhss+             ; return (GRHSs x grhss' binds') }++    tc_grhs stk_ty res_ty (GRHS x guards body)+        = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $+                                  \ res_ty -> tcCmd env body+                                                (stk_ty, checkingExpType "tc_grhs" res_ty)+             ; return (GRHS x guards' rhs') }++matchExpectedCmdArgs :: Arity -> TcType -> TcM (TcCoercionN, [TcTypeFRR], TcType) matchExpectedCmdArgs 0 ty   = return (mkTcNomReflCo ty, [], ty) matchExpectedCmdArgs n ty@@ -410,7 +435,7 @@                 -- NB:  The rec_ids for the recursive things                 --      already scope over this part. This binding may shadow                 --      some of them with polymorphic things with the same Name-                --      (see note [RecStmt] in GHC.Hs.Expr)+                --      (see Note [RecStmt] in GHC.Hs.Expr)          ; let rec_ids = takeList rec_names tup_ids         ; later_ids <- tcLookupLocalIds later_names
compiler/GHC/Tc/Gen/Bind.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE RankNTypes          #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -18,7 +18,6 @@    , tcHsBootSigs    , tcPolyCheck    , chooseInferredQuantifiers-   , badBootDeclErr    ) where @@ -33,19 +32,25 @@ import GHC.Driver.Session import GHC.Data.FastString import GHC.Hs+import GHC.Tc.Errors.Types import GHC.Tc.Gen.Sig+import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) import GHC.Tc.Utils.Monad import GHC.Tc.Types.Origin import GHC.Tc.Utils.Env import GHC.Tc.Utils.Unify import GHC.Tc.Solver import GHC.Tc.Types.Evidence+import GHC.Tc.Types.Constraint+import GHC.Core.Predicate import GHC.Tc.Gen.HsType import GHC.Tc.Gen.Pat import GHC.Tc.Utils.TcMType+import GHC.Core.Reduction ( Reduction(..) ) import GHC.Core.Multiplicity import GHC.Core.FamInstEnv( normaliseType ) import GHC.Tc.Instance.Family( tcGetFamInstEnvs )+import GHC.Core.Class   ( Class ) import GHC.Tc.Utils.TcType import GHC.Core.Type (mkStrLitTy, tidyOpenType, mkCastTy) import GHC.Builtin.Types ( mkBoxedTupleTy )@@ -79,8 +84,6 @@ import Control.Monad import Data.Foldable (find) -#include "GhclibHsVersions.h"- {- ************************************************************************ *                                                                      *@@ -179,13 +182,10 @@ -- The TcLclEnv has an extended type envt for the new bindings tcTopBinds binds sigs   = do  { -- Pattern synonym bindings populate the global environment-          (binds', (tcg_env, tcl_env)) <- tcValBinds TopLevel binds sigs $-            do { gbl <- getGblEnv-               ; lcl <- getLclEnv-               ; return (gbl, lcl) }+          (binds', (tcg_env, tcl_env)) <- tcValBinds TopLevel binds sigs getEnvs         ; specs <- tcImpPrags sigs   -- SPECIALISE prags for imported Ids -        ; complete_matches <- setEnvs (tcg_env, tcl_env) $ tcCompleteSigs sigs+        ; complete_matches <- restoreEnvs (tcg_env, tcl_env) $ tcCompleteSigs sigs         ; traceTc "complete_matches" (ppr binds $$ ppr sigs)         ; traceTc "complete_matches" (ppr complete_matches) @@ -224,20 +224,17 @@ -- A hs-boot file has only one BindGroup, and it only has type -- signatures in it.  The renamer checked all this tcHsBootSigs binds sigs-  = do  { checkTc (null binds) badBootDeclErr+  = do  { checkTc (null binds) TcRnIllegalHsBootFileDecl         ; concatMapM (addLocMA tc_boot_sig) (filter isTypeLSig sigs) }   where     tc_boot_sig (TypeSig _ lnames hs_ty) = mapM f lnames       where         f (L _ name)-          = do { sigma_ty <- tcHsSigWcType (FunSigCtxt name False) hs_ty+          = do { sigma_ty <- tcHsSigWcType (FunSigCtxt name NoRRC) hs_ty                ; return (mkVanillaGlobal name sigma_ty) }         -- Notice that we make GlobalIds, not LocalIds     tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s) -badBootDeclErr :: SDoc-badBootDeclErr = text "Illegal declarations in an hs-boot file"- ------------------------ tcLocalBinds :: HsLocalBinds GhcRn -> TcM thing              -> TcM (HsLocalBinds GhcTc, thing)@@ -256,48 +253,36 @@         ; (given_ips, ip_binds') <-             mapAndUnzipM (wrapLocSndMA (tc_ip_bind ipClass)) ip_binds -        -- If the binding binds ?x = E, we  must now-        -- discharge any ?x constraints in expr_lie-        -- See Note [Implicit parameter untouchables]+        -- Add all the IP bindings as givens for the body of the 'let'         ; (ev_binds, result) <- checkConstraints (IPSkol ips)                                   [] given_ips thing_inside          ; return (HsIPBinds x (IPBinds ev_binds ip_binds') , result) }   where-    ips = [ip | (L _ (IPBind _ (Left (L _ ip)) _)) <- ip_binds]+    ips = [ip | (L _ (IPBind _ (L _ ip) _)) <- ip_binds]          -- I wonder if we should do these one at a time         -- Consider     ?x = 4         --              ?y = ?x + 1-    tc_ip_bind ipClass (IPBind _ (Left (L _ ip)) expr)+    tc_ip_bind :: Class -> IPBind GhcRn -> TcM (DictId, IPBind GhcTc)+    tc_ip_bind ipClass (IPBind _ l_name@(L _ ip) expr)        = do { ty <- newOpenFlexiTyVarTy             ; let p = mkStrLitTy $ hsIPNameFS ip             ; ip_id <- newDict ipClass [ p, ty ]             ; expr' <- tcCheckMonoExpr expr ty-            ; let d = toDict ipClass p ty `fmap` expr'-            ; return (ip_id, (IPBind noAnn (Right ip_id) d)) }-    tc_ip_bind _ (IPBind _ (Right {}) _) = panic "tc_ip_bind"+            ; let d = mapLoc (toDict ipClass p ty) expr'+            ; return (ip_id, (IPBind ip_id l_name d)) }      -- Coerces a `t` into a dictionary for `IP "x" t`.     -- co : t -> IP "x" t+    toDict :: Class  -- IP class+           -> Type   -- type-level string for name of IP+           -> Type   -- type of IP+           -> HsExpr GhcTc   -- def'n of IP variable+           -> HsExpr GhcTc   -- dictionary for IP     toDict ipClass x ty = mkHsWrap $ mkWpCastR $                           wrapIP $ mkClassPred ipClass [x,ty] -{- Note [Implicit parameter untouchables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We add the type variables in the types of the implicit parameters-as untouchables, not so much because we really must not unify them,-but rather because we otherwise end up with constraints like this-    Num alpha, Implic { wanted = alpha ~ Int }-The constraint solver solves alpha~Int by unification, but then-doesn't float that solved constraint out (it's not an unsolved-wanted).  Result disaster: the (Num alpha) is again solved, this-time by defaulting.  No no no.--However [Oct 10] this is all handled automatically by the-untouchable-range idea.--}- tcValBinds :: TopLevelFlag            -> [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn]            -> TcM thing@@ -428,23 +413,16 @@     tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind]     tc_scc (CyclicSCC binds) = tc_sub_group Recursive    binds -    tc_sub_group rec_tc binds =-      tcPolyBinds sig_fn prag_fn Recursive rec_tc closed binds+    tc_sub_group rec_tc binds = tcPolyBinds top_lvl sig_fn prag_fn+                                            Recursive rec_tc closed binds -recursivePatSynErr ::-     (OutputableBndrId p, CollectPass (GhcPass p))-  => SrcSpan -- ^ The location of the first pattern synonym binding+recursivePatSynErr+  :: SrcSpan -- ^ The location of the first pattern synonym binding              --   (for error reporting)-  -> LHsBinds (GhcPass p)+  -> LHsBinds GhcRn   -> TcM a recursivePatSynErr loc binds-  = failAt loc $-    hang (text "Recursive pattern synonym definition with following bindings:")-       2 (vcat $ map pprLBind . bagToList $ binds)-  where-    pprLoc loc  = parens (text "defined at" <+> ppr loc)-    pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders CollNoDictBinders bind)-                                <+> pprLoc (locA loc)+  = failAt loc $ TcRnRecursivePatternSynonym binds  tc_single :: forall thing.             TopLevelFlag -> TcSigFun -> TcPragEnv@@ -459,7 +437,7 @@        }  tc_single top_lvl sig_fn prag_fn lbind closed thing_inside-  = do { (binds1, ids) <- tcPolyBinds sig_fn prag_fn+  = do { (binds1, ids) <- tcPolyBinds top_lvl sig_fn prag_fn                                       NonRecursive NonRecursive                                       closed                                       [lbind]@@ -496,7 +474,7 @@                                      , bndr <- collectHsBindBinders CollNoDictBinders bind ]  -------------------------tcPolyBinds :: TcSigFun -> TcPragEnv+tcPolyBinds :: TopLevelFlag -> TcSigFun -> TcPragEnv             -> RecFlag         -- Whether the group is really recursive             -> RecFlag         -- Whether it's recursive after breaking                                -- dependencies based on type signatures@@ -515,7 +493,7 @@ -- Knows nothing about the scope of the bindings -- None of the bindings are pattern synonyms -tcPolyBinds sig_fn prag_fn rec_group rec_tc closed bind_list+tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc closed bind_list   = setSrcSpan loc                              $     recoverM (recoveryCode binder_names sig_fn) $ do         -- Set up main recover; take advantage of any type sigs@@ -523,13 +501,17 @@     { traceTc "------------------------------------------------" Outputable.empty     ; traceTc "Bindings for {" (ppr binder_names)     ; dflags   <- getDynFlags-    ; let plan = decideGeneralisationPlan dflags bind_list closed sig_fn+    ; let plan = decideGeneralisationPlan dflags top_lvl closed sig_fn bind_list     ; traceTc "Generalisation plan" (ppr plan)     ; result@(_, poly_ids) <- case plan of          NoGen              -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list          InferGen mn        -> tcPolyInfer rec_tc prag_fn sig_fn mn bind_list          CheckGen lbind sig -> tcPolyCheck prag_fn sig lbind +    ; mapM_ (\ poly_id ->+        hasFixedRuntimeRep_syntactic (FRRBinder $ idName poly_id) (idType poly_id))+        poly_ids+     ; traceTc "} End of bindings for" (vcat [ ppr binder_names, ppr rec_group                                             , vcat [ppr id <+> ppr (idType id) | id <- poly_ids]                                           ])@@ -633,7 +615,7 @@                 --    See Note [Relevant bindings and the binder stack]                  setSrcSpanA bind_loc $-                tcMatchesFun (L nm_loc mono_name) matches+                tcMatchesFun (L nm_loc mono_id) matches                              (mkCheckExpType rho_ty)         -- We make a funny AbsBinds, abstracting over nothing,@@ -655,15 +637,13 @@                              , fun_ext     = wrap_gen <.> wrap_res                              , fun_tick    = tick } -             export = ABE { abe_ext   = noExtField-                          , abe_wrap  = idHsWrapper+             export = ABE { abe_wrap  = idHsWrapper                           , abe_poly  = poly_id                           , abe_mono  = poly_id2                           , abe_prags = SpecPrags spec_prags } -             abs_bind = L bind_loc $-                        AbsBinds { abs_ext      = noExtField-                                 , abs_tvs      = []+             abs_bind = L bind_loc $ XHsBindsLR $+                        AbsBinds { abs_tvs      = []                                  , abs_ev_vars  = []                                  , abs_ev_binds = []                                  , abs_exports  = [export]@@ -734,18 +714,24 @@        ; mapM_ (checkOverloadedSig mono) sigs         ; traceTc "simplifyInfer call" (ppr tclvl $$ ppr name_taus $$ ppr wanted)-       ; (qtvs, givens, ev_binds, insoluble)-                 <- simplifyInfer tclvl infer_mode sigs name_taus wanted+       ; ((qtvs, givens, ev_binds, insoluble), residual)+            <- captureConstraints $ simplifyInfer tclvl infer_mode sigs name_taus wanted         ; let inferred_theta = map evVarPred givens        ; exports <- checkNoErrs $-                    mapM (mkExport prag_fn insoluble qtvs inferred_theta) mono_infos+                    mapM (mkExport prag_fn residual insoluble qtvs inferred_theta) mono_infos +         -- NB: *after* the checkNoErrs call above. This ensures that we don't get an error+         -- cascade in case mkExport runs into trouble. In particular, this avoids duplicate+         -- errors when a partial type signature cannot be quantified in chooseInferredQuantifiers.+         -- See Note [Quantification and partial signatures] in GHC.Tc.Solver, Wrinkle 4.+         -- Tested in partial-sigs/should_fail/NamedWilcardExplicitForall.+       ; emitConstraints residual+        ; loc <- getSrcSpanM        ; let poly_ids = map abe_poly exports-             abs_bind = L (noAnnSrcSpan loc) $-                        AbsBinds { abs_ext = noExtField-                                 , abs_tvs = qtvs+             abs_bind = L (noAnnSrcSpan loc) $ XHsBindsLR $+                        AbsBinds { abs_tvs = qtvs                                  , abs_ev_vars = givens, abs_ev_binds = [ev_binds]                                  , abs_exports = exports, abs_binds = binds'                                  , abs_sig = False }@@ -756,11 +742,12 @@  -------------- mkExport :: TcPragEnv+         -> WantedConstraints  -- residual constraints, already emitted (for errors only)          -> Bool                        -- True <=> there was an insoluble type error                                         --          when typechecking the bindings          -> [TyVar] -> TcThetaType      -- Both already zonked          -> MonoBindInfo-         -> TcM (ABExport GhcTc)+         -> TcM ABExport -- Only called for generalisation plan InferGen, not by CheckGen or NoGen -- -- mkExport generates exports with@@ -774,12 +761,12 @@  -- Pre-condition: the qtvs and theta are already zonked -mkExport prag_fn insoluble qtvs theta-         mono_info@(MBI { mbi_poly_name = poly_name-                        , mbi_sig       = mb_sig-                        , mbi_mono_id   = mono_id })+mkExport prag_fn residual insoluble qtvs theta+         (MBI { mbi_poly_name = poly_name+              , mbi_sig       = mb_sig+              , mbi_mono_id   = mono_id })   = do  { mono_ty <- zonkTcType (idType mono_id)-        ; poly_id <- mkInferredPolyId insoluble qtvs theta poly_name mb_sig mono_ty+        ; poly_id <- mkInferredPolyId residual insoluble qtvs theta poly_name mb_sig mono_ty          -- NB: poly_id has a zonked type         ; poly_id <- addInlinePrags poly_id prag_sigs@@ -801,16 +788,20 @@                   then return idHsWrapper  -- Fast path; also avoids complaint when we infer                                            -- an ambiguous type and have AllowAmbiguousType                                            -- e..g infer  x :: forall a. F a -> Int-                  else addErrCtxtM (mk_impedance_match_msg mono_info sel_poly_ty poly_ty) $-                       tcSubTypeSigma GhcBug20076 sig_ctxt sel_poly_ty poly_ty+                  else tcSubTypeSigma GhcBug20076+                                      sig_ctxt sel_poly_ty poly_ty+                       -- as Note [Impedance matching] explains, this should never fail,+                       -- and thus we'll never see an error message. It *may* do+                       -- instantiation, but no message will ever be printed to the+                       -- user, and so we use Shouldn'tHappenOrigin.+                       -- Actually, there is a bug here: #20076. So we tell the user+                       -- that they hit the bug. Once #20076 is fixed, change this+                       -- back to Shouldn'tHappenOrigin. -        ; warn_missing_sigs <- woptM Opt_WarnMissingLocalSignatures-        ; when warn_missing_sigs $-              localSigWarn Opt_WarnMissingLocalSignatures poly_id mb_sig+        ; localSigWarn poly_id mb_sig -        ; return (ABE { abe_ext = noExtField-                      , abe_wrap = wrap-                        -- abe_wrap :: idType poly_id ~ (forall qtvs. theta => mono_ty)+        ; return (ABE { abe_wrap = wrap+                        -- abe_wrap :: (forall qtvs. theta => mono_ty) ~ idType poly_id                       , abe_poly  = poly_id                       , abe_mono  = mono_id                       , abe_prags = SpecPrags spec_prags }) }@@ -818,12 +809,13 @@     prag_sigs = lookupPragEnv prag_fn poly_name     sig_ctxt  = InfSigCtxt poly_name -mkInferredPolyId :: Bool  -- True <=> there was an insoluble error when+mkInferredPolyId :: WantedConstraints   -- the residual constraints, already emitted+                 -> Bool  -- True <=> there was an insoluble error when                           --          checking the binding group for this Id                  -> [TyVar] -> TcThetaType                  -> Name -> Maybe TcIdSigInst -> TcType                  -> TcM TcId-mkInferredPolyId insoluble qtvs inferred_theta poly_name mb_sig_inst mono_ty+mkInferredPolyId residual insoluble qtvs inferred_theta poly_name mb_sig_inst mono_ty   | Just (TISI { sig_inst_sig = sig })  <- mb_sig_inst   , CompleteSig { sig_bndr = poly_id } <- sig   = return poly_id@@ -834,7 +826,7 @@                    -- a duplicate ambiguity error.  There is a similar                    -- checkNoErrs for complete type signatures too.     do { fam_envs <- tcGetFamInstEnvs-       ; let (_co, mono_ty') = normaliseType fam_envs Nominal mono_ty+       ; let mono_ty' = reductionReducedType $ normaliseType fam_envs Nominal mono_ty                -- Unification may not have normalised the type,                -- so do it here to make it as uncomplicated as possible.                -- Example: f :: [F Int] -> Bool@@ -843,7 +835,7 @@                -- We can discard the coercion _co, because we'll reconstruct                -- it in the call to tcSubType below -       ; (binders, theta') <- chooseInferredQuantifiers inferred_theta+       ; (binders, theta') <- chooseInferredQuantifiers residual inferred_theta                                 (tyCoVarsOfType mono_ty') qtvs mb_sig_inst         ; let inferred_poly_ty = mkInvisForAllTys binders (mkPhiTy theta' mono_ty')@@ -861,14 +853,16 @@        ; return (mkLocalId poly_name Many inferred_poly_ty) }  -chooseInferredQuantifiers :: TcThetaType   -- inferred+chooseInferredQuantifiers :: WantedConstraints  -- residual constraints+                          -> TcThetaType   -- inferred                           -> TcTyVarSet    -- tvs free in tau type                           -> [TcTyVar]     -- inferred quantified tvs                           -> Maybe TcIdSigInst                           -> TcM ([InvisTVBinder], TcThetaType)-chooseInferredQuantifiers inferred_theta tau_tvs qtvs Nothing+chooseInferredQuantifiers _residual inferred_theta tau_tvs qtvs Nothing   = -- No type signature (partial or complete) for this binder,     do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta tau_tvs)+                        -- See Note [growThetaTyVars vs closeWrtFunDeps] in GHC.Tc.Solver                         -- Include kind variables!  #7916              my_theta = pickCapturedPreds free_tvs inferred_theta              binders  = [ mkTyVarBinder InferredSpec tv@@ -876,11 +870,11 @@                         , tv `elemVarSet` free_tvs ]        ; return (binders, my_theta) } -chooseInferredQuantifiers inferred_theta tau_tvs qtvs-                          (Just (TISI { sig_inst_sig   = sig  -- Always PartialSig-                                      , sig_inst_wcx   = wcx-                                      , sig_inst_theta = annotated_theta-                                      , sig_inst_skols = annotated_tvs }))+chooseInferredQuantifiers residual inferred_theta tau_tvs qtvs+  (Just (TISI { sig_inst_sig   = sig@(PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty })+              , sig_inst_wcx   = wcx+              , sig_inst_theta = annotated_theta+              , sig_inst_skols = annotated_tvs }))   = -- Choose quantifiers for a partial type signature     do { let (psig_qtv_nms, psig_qtv_bndrs) = unzip annotated_tvs        ; psig_qtv_bndrs <- mapM zonkInvisTVBinder psig_qtv_bndrs@@ -898,8 +892,8 @@             -- signature is not actually quantified.  How can that happen?             -- See Note [Quantification and partial signatures] Wrinkle 4             --     in GHC.Tc.Solver-       ; mapM_ report_mono_sig_tv_err [ n | (n,tv) <- psig_qtv_prs-                                          , not (tv `elem` qtvs) ]+       ; mapM_ report_mono_sig_tv_err [ pr | pr@(_,tv) <- psig_qtv_prs+                                           , not (tv `elem` qtvs) ]         ; annotated_theta      <- zonkTcTypes annotated_theta        ; (free_tvs, my_theta) <- choose_psig_context psig_qtv_set annotated_theta wcx@@ -915,22 +909,20 @@        ; return (final_qtvs, my_theta) }   where     report_dup_tyvar_tv_err (n1,n2)-      | PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty } <- sig-      = addErrTc (hang (text "Couldn't match" <+> quotes (ppr n1)-                        <+> text "with" <+> quotes (ppr n2))-                     2 (hang (text "both bound by the partial type signature:")-                           2 (ppr fn_name <+> dcolon <+> ppr hs_ty)))--      | otherwise -- Can't happen; by now we know it's a partial sig-      = pprPanic "report_tyvar_tv_err" (ppr sig)+      = addErrTc (TcRnPartialTypeSigTyVarMismatch n1 n2 fn_name hs_ty) -    report_mono_sig_tv_err n-      | PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty } <- sig-      = addErrTc (hang (text "Can't quantify over" <+> quotes (ppr n))-                     2 (hang (text "bound by the partial type signature:")-                           2 (ppr fn_name <+> dcolon <+> ppr hs_ty)))-      | otherwise -- Can't happen; by now we know it's a partial sig-      = pprPanic "report_mono_sig_tv_err" (ppr sig)+    report_mono_sig_tv_err (n,tv)+      = addErrTc (TcRnPartialTypeSigBadQuantifier n fn_name m_unif_ty hs_ty)+      where+        m_unif_ty = listToMaybe+                      [ rhs+                      -- recall that residuals are always implications+                      | residual_implic <- bagToList $ wc_impl residual+                      , residual_ct <- bagToList $ wc_simple (ic_wanted residual_implic)+                      , let residual_pred = ctPred residual_ct+                      , Just (Nominal, lhs, rhs) <- [ getEqPredTys_maybe residual_pred ]+                      , Just lhs_tv <- [ tcGetTyVar_maybe lhs ]+                      , lhs_tv == tv ]      choose_psig_context :: VarSet -> TcThetaType -> Maybe TcType                         -> TcM (VarSet, TcThetaType)@@ -941,7 +933,8 @@      choose_psig_context psig_qtvs annotated_theta (Just wc_var_ty)       = do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta seed_tvs)-                            -- growThetaVars just like the no-type-sig case+                            -- growThetaTyVars just like the no-type-sig case+                            -- See Note [growThetaTyVars vs closeWrtFunDeps] in GHC.Tc.Solver                             -- Omitting this caused #12844                  seed_tvs = tyCoVarsOfTypes annotated_theta  -- These are put there                             `unionVarSet` tau_tvs            --       by the user@@ -977,25 +970,8 @@        -- Hack alert!  See GHC.Tc.Gen.HsType:        -- Note [Extra-constraint holes in partial type signatures] -mk_impedance_match_msg :: MonoBindInfo-                       -> TcType -> TcType-                       -> TidyEnv -> TcM (TidyEnv, SDoc)--- This is a rare but rather awkward error messages-mk_impedance_match_msg (MBI { mbi_poly_name = name, mbi_sig = mb_sig })-                       inf_ty sig_ty tidy_env- = do { (tidy_env1, inf_ty) <- zonkTidyTcType tidy_env  inf_ty-      ; (tidy_env2, sig_ty) <- zonkTidyTcType tidy_env1 sig_ty-      ; let msg = vcat [ text "When checking that the inferred type"-                       , nest 2 $ ppr name <+> dcolon <+> ppr inf_ty-                       , text "is as general as its" <+> what <+> text "signature"-                       , nest 2 $ ppr name <+> dcolon <+> ppr sig_ty ]-      ; return (tidy_env2, msg) }-  where-    what = case mb_sig of-             Nothing                     -> text "inferred"-             Just sig | isPartialSig sig -> text "(partial)"-                      | otherwise        -> empty-+chooseInferredQuantifiers _ _ _ _ (Just (TISI { sig_inst_sig = sig@(CompleteSig {}) }))+  = pprPanic "chooseInferredQuantifiers" (ppr sig)  mk_inf_msg :: Name -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc) mk_inf_msg poly_name poly_ty tidy_env@@ -1004,23 +980,19 @@                        , nest 2 $ ppr poly_name <+> dcolon <+> ppr poly_ty ]       ; return (tidy_env1, msg) } - -- | Warn the user about polymorphic local binders that lack type signatures.-localSigWarn :: WarningFlag -> Id -> Maybe TcIdSigInst -> TcM ()-localSigWarn flag id mb_sig+localSigWarn :: Id -> Maybe TcIdSigInst -> TcM ()+localSigWarn id mb_sig   | Just _ <- mb_sig               = return ()   | not (isSigmaTy (idType id))    = return ()-  | otherwise                      = warnMissingSignatures flag msg id-  where-    msg = text "Polymorphic local binding with no type signature:"+  | otherwise                      = warnMissingSignatures id -warnMissingSignatures :: WarningFlag -> SDoc -> Id -> TcM ()-warnMissingSignatures flag msg id+warnMissingSignatures :: Id -> TcM ()+warnMissingSignatures id   = do  { env0 <- tcInitTidyEnv         ; let (env1, tidy_ty) = tidyOpenType env0 (idType id)-        ; addWarnTcM (Reason flag) (env1, mk_msg tidy_ty) }-  where-    mk_msg ty = sep [ msg, nest 2 $ pprPrefixName (idName id) <+> dcolon <+> ppr ty ]+        ; let dia = TcRnPolymorphicBinderMissingSig (idName id) tidy_ty+        ; addDiagnosticTcM (env1, dia) }  checkOverloadedSig :: Bool -> TcIdSigInst -> TcM () -- Example:@@ -1034,9 +1006,7 @@   , monomorphism_restriction_applies   , let orig_sig = sig_inst_sig sig   = setSrcSpan (sig_loc orig_sig) $-    failWith $-    hang (text "Overloaded signature conflicts with monomorphism restriction")-       2 (ppr orig_sig)+    failWith $ TcRnOverloadedSig orig_sig   | otherwise   = return () @@ -1124,7 +1094,6 @@                                 or multi-parameter type classes  - an inferred type that includes unboxed tuples - Note [Impedance matching] ~~~~~~~~~~~~~~~~~~~~~~~~~ Consider@@ -1149,8 +1118,8 @@    tuple :: forall a b. (Eq a, Num a) => (a -> Bool -> Bool, [b] -> Bool -> Bool)    tuple a b d1 d1 = let ...bind f_mono, g_mono in (f_mono, g_mono) -   f a d1 d2 = case tuple a Any d1 d2 of (f, g) -> f-   g b = case tuple Integer b dEqInteger dNumInteger of (f,g) -> g+   f a d1 d2 = case tuple a Any d1 d2 of (f_mono, g_mono) -> f_mono+   g b = case tuple Integer b dEqInteger dNumInteger of (f_mono,g_mono) -> g_mono  Suppose the shared quantified tyvars are qtvs and constraints theta. Then we want to check that@@ -1159,13 +1128,10 @@  Notice that the impedance matcher may do defaulting.  See #7173. -It also cleverly does an ambiguity check; for example, rejecting-   f :: F a -> F a-where F is a non-injective type function.--}-+If we've gotten the constraints right during inference (and we assume we have),+this sub-type check should never fail. It's not really a check -- it's more of+a procedure to produce the right wrapper. -{- Note [SPECIALISE pragmas] ~~~~~~~~~~~~~~~~~~~~~~~~~ There is no point in a SPECIALISE pragma for a non-overloaded function:@@ -1208,7 +1174,7 @@             -> [LHsBind GhcRn]             -> TcM (LHsBinds GhcTc, [MonoBindInfo]) --- SPECIAL CASE 1: see Note [Inference for non-recursive function bindings]+-- SPECIAL CASE 1: see Note [Special case for non-recursive function bindings] tcMonoBinds is_rec sig_fn no_gen            [ L b_loc (FunBind { fun_id = L nm_loc name                               , fun_matches = matches })]@@ -1216,15 +1182,19 @@   | NonRecursive <- is_rec   -- ...binder isn't mentioned in RHS   , Nothing <- sig_fn name   -- ...with no type signature   = setSrcSpanA b_loc    $-    do  { ((co_fn, matches'), rhs_ty)-            <- tcInfer $ \ exp_ty ->-               tcExtendBinderStack [TcIdBndr_ExpType name exp_ty NotTopLevel] $-                  -- We extend the error context even for a non-recursive-                  -- function so that in type error messages we show the-                  -- type of the thing whose rhs we are type checking-               tcMatchesFun (L nm_loc name) matches exp_ty+    do  { ((co_fn, matches'), mono_id, _) <- fixM $ \ ~(_, _, rhs_ty) ->+                                          -- See Note [fixM for rhs_ty in tcMonoBinds]+            do  { mono_id <- newLetBndr no_gen name Many rhs_ty+                ; (matches', rhs_ty')+                    <- tcInfer $ \ exp_ty ->+                       tcExtendBinderStack [TcIdBndr_ExpType name exp_ty NotTopLevel] $+                          -- We extend the error context even for a non-recursive+                          -- function so that in type error messages we show the+                          -- type of the thing whose rhs we are type checking+                       tcMatchesFun (L nm_loc mono_id) matches exp_ty+                ; return (matches', mono_id, rhs_ty')+                } -        ; mono_id <- newLetBndr no_gen name Many rhs_ty         ; return (unitBag $ L b_loc $                      FunBind { fun_id = L nm_loc mono_id,                                fun_matches = matches',@@ -1233,7 +1203,7 @@                        , mbi_sig       = Nothing                        , mbi_mono_id   = mono_id }]) } --- SPECIAL CASE 2: see Note [Inference for non-recursive pattern bindings]+-- SPECIAL CASE 2: see Note [Special case for non-recursive pattern bindings] tcMonoBinds is_rec sig_fn no_gen            [L b_loc (PatBind { pat_lhs = pat, pat_rhs = grhss })]   | NonRecursive <- is_rec   -- ...binder isn't mentioned in RHS@@ -1242,7 +1212,7 @@     do { (grhss', pat_ty) <- tcInfer $ \ exp_ty ->                              tcGRHSsPat grhss exp_ty -       ; let exp_pat_ty :: Scaled ExpSigmaType+       ; let exp_pat_ty :: Scaled ExpSigmaTypeFRR              exp_pat_ty = unrestricted (mkCheckExpType pat_ty)        ; (pat', mbis) <- tcLetPat (const Nothing) no_gen pat exp_pat_ty $                          mapM lookupMBI bndrs@@ -1336,6 +1306,20 @@ correctly elaborate 'id'. But we want to /infer/ q's higher rank type.  There seems to be no way to do this.  So currently we only switch to inference when we have no signature for any of the binders.++Note [fixM for rhs_ty in tcMonoBinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In order to create mono_id we need rhs_ty but we don't have it yet,+we only get it from tcMatchesFun later (which needs mono_id to put+into HsMatchContext for pretty printing). To solve this, create+a thunk of rhs_ty with fixM that we fill in later.++This is fine only because neither newLetBndr or tcMatchesFun look+at the varType field of the Id. tcMatchesFun only looks at idName+of mono_id.++Also see #20415 for the bigger picture of why tcMatchesFun needs+mono_id in the first place. -}  @@ -1358,7 +1342,7 @@ data TcMonoBind         -- Half completed; LHS done, RHS not done   = TcFunBind  MonoBindInfo  SrcSpan (MatchGroup GhcRn (LHsExpr GhcRn))   | TcPatBind [MonoBindInfo] (LPat GhcTc) (GRHSs GhcRn (LHsExpr GhcRn))-              TcSigmaType+              TcSigmaTypeFRR  tcLhs :: TcSigFun -> LetBndrSpec -> HsBind GhcRn -> TcM TcMonoBind -- Only called with plan InferGen (LetBndrSpec = LetLclBndr)@@ -1400,7 +1384,7 @@             -- See Note [Existentials in pattern bindings]         ; ((pat', nosig_mbis), pat_ty)             <- addErrCtxt (patMonoBindsCtxt pat grhss) $-               tcInfer $ \ exp_ty ->+               tcInferFRR FRRPatBind $ \ exp_ty ->                tcLetPat inst_sig_fun no_gen pat (unrestricted exp_ty) $                  -- The above inferred type get an unrestricted multiplicity. It may be                  -- worth it to try and find a finer-grained multiplicity here@@ -1463,7 +1447,7 @@   = tcExtendIdBinderStackForRhs [info]  $     tcExtendTyVarEnvForRhs mb_sig       $     do  { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))-        ; (co_fn, matches') <- tcMatchesFun (L (noAnnSrcSpan loc) (idName mono_id))+        ; (co_fn, matches') <- tcMatchesFun (L (noAnnSrcSpan loc) mono_id)                                  matches (mkCheckExpType $ idType mono_id)         ; return ( FunBind { fun_id = L (noAnnSrcSpan loc) mono_id                            , fun_matches = matches'@@ -1479,6 +1463,7 @@     do  { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty)         ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $                     tcGRHSsPat grhss (mkCheckExpType pat_ty)+         ; return ( PatBind { pat_lhs = pat', pat_rhs = grhss'                            , pat_ext = pat_ty                            , pat_ticks = ([],[]) } )}@@ -1662,12 +1647,12 @@   ppr (CheckGen _ s) = text "CheckGen" <+> ppr s  decideGeneralisationPlan-   :: DynFlags -> [LHsBind GhcRn] -> IsGroupClosed -> TcSigFun-   -> GeneralisationPlan-decideGeneralisationPlan dflags lbinds closed sig_fn+   :: DynFlags -> TopLevelFlag -> IsGroupClosed -> TcSigFun+   -> [LHsBind GhcRn] -> GeneralisationPlan+decideGeneralisationPlan dflags top_lvl closed sig_fn lbinds   | has_partial_sigs                         = InferGen (and partial_sig_mrs)   | Just (bind, sig) <- one_funbind_with_sig = CheckGen bind sig-  | do_not_generalise closed                 = NoGen+  | do_not_generalise                        = NoGen   | otherwise                                = InferGen mono_restriction   where     binds = map unLoc lbinds@@ -1683,17 +1668,22 @@             <- mapMaybe sig_fn (collectHsBindListBinders CollNoDictBinders lbinds)         , let (mtheta, _) = splitLHsQualTy (hsSigWcType hs_ty) ] -    has_partial_sigs   = not (null partial_sig_mrs)+    has_partial_sigs = not (null partial_sig_mrs)      mono_restriction  = xopt LangExt.MonomorphismRestriction dflags                      && any restricted binds -    do_not_generalise (IsGroupClosed _ True) = False+    do_not_generalise+      | isTopLevel top_lvl             = False+        -- See Note [Always generalise top-level bindings]++      | IsGroupClosed _ True <- closed = False         -- The 'True' means that all of the group's         -- free vars have ClosedTypeId=True; so we can ignore         -- -XMonoLocalBinds, and generalise anyway-    do_not_generalise _ = xopt LangExt.MonoLocalBinds dflags +      | otherwise = xopt LangExt.MonoLocalBinds dflags+     -- With OutsideIn, all nested bindings are monomorphic     -- except a single function binding with a signature     one_funbind_with_sig@@ -1767,6 +1757,21 @@                -- These won't be in the local type env.                -- Ditto class method etc from the current module +{- Note [Always generalise top-level bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It is very confusing to apply NoGen to a top level binding. Consider (#20123):+   module M where+     x = 5+     f y = (x, y)++The MR means that x=5 is not generalise, so f's binding is no Closed.  So we'd+be tempted to use NoGen. But that leads to f :: Any -> (Integer, Any), which+is plain stupid.++NoGen is good when we have call sites, but not at top level, where the+function may be exported.  And it's easier to grok "MonoLocalBinds" as+applying to, well, local bindings.+-}  {- ********************************************************************* *                                                                      *
compiler/GHC/Tc/Gen/Default.hs view
@@ -14,6 +14,7 @@ import GHC.Core.Class import GHC.Core.Type ( typeKind ) import GHC.Types.Var( tyVarKind )+import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Env import GHC.Tc.Gen.HsType@@ -22,10 +23,10 @@ import GHC.Tc.Validity import GHC.Tc.Utils.TcType import GHC.Builtin.Names+import GHC.Types.Error import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Data.FastString import qualified GHC.LanguageExtensions as LangExt  tcDefaults :: [LDefaultDecl GhcRn]@@ -80,7 +81,7 @@          -- Check that the type is an instance of at least one of the deflt_clss         ; oks <- mapM (check_instance ty) deflt_clss-        ; checkTc (or oks) (badDefaultTy ty deflt_clss)+        ; checkTc (or oks) (TcRnBadDefaultType ty deflt_clss)         ; return ty }  check_instance :: Type -> Class -> TcM Bool@@ -102,17 +103,7 @@ defaultDeclCtxt :: SDoc defaultDeclCtxt = text "When checking the types in a default declaration" -dupDefaultDeclErr :: [LDefaultDecl GhcRn] -> SDoc+dupDefaultDeclErr :: [LDefaultDecl GhcRn] -> TcRnMessage dupDefaultDeclErr (L _ (DefaultDecl _ _) : dup_things)-  = hang (text "Multiple default declarations")-       2 (vcat (map pp dup_things))-  where-    pp :: LDefaultDecl GhcRn -> SDoc-    pp (L locn (DefaultDecl _ _))-      = text "here was another default declaration" <+> ppr (locA locn)+  = TcRnMultipleDefaultDeclarations dup_things dupDefaultDeclErr [] = panic "dupDefaultDeclErr []"--badDefaultTy :: Type -> [Class] -> SDoc-badDefaultTy ty deflt_clss-  = hang (text "The default type" <+> quotes (ppr ty) <+> ptext (sLit "is not an instance of"))-       2 (foldr1 (\a b -> a <+> text "or" <+> b) (map (quotes. ppr) deflt_clss))
compiler/GHC/Tc/Gen/Export.hs view
@@ -10,6 +10,7 @@ import GHC.Hs import GHC.Types.FieldLabel import GHC.Builtin.Names+import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Env import GHC.Tc.Utils.TcType@@ -25,11 +26,9 @@ import GHC.Core.ConLike import GHC.Core.PatSyn import GHC.Data.Maybe-import GHC.Utils.Misc (capitalise) import GHC.Data.FastString (fsLit) import GHC.Driver.Env -import GHC.Types.TyThing( tyThingCategory ) import GHC.Types.Unique.Set import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Name@@ -45,6 +44,7 @@ import GHC.Driver.Session import GHC.Parser.PostProcess ( setRdrNameSpace ) import Data.Either            ( partitionEithers )+import GHC.Rename.Doc  {- ************************************************************************@@ -175,7 +175,7 @@                        , tcg_rdr_env = rdr_env                        , tcg_imports = imports                        , tcg_src     = hsc_src } = tcg_env-              default_main | mainModIs hsc_env == this_mod+              default_main | mainModIs (hsc_HUE hsc_env) == this_mod                            , Just main_fun <- mainFunIs dflags                            = mkUnqual varName (fsLit main_fun)                            | otherwise@@ -236,10 +236,8 @@    -- so that's how we handle it, except we also export the data family    -- when a data instance is exported.   = do {-    ; warnMissingExportList <- woptM Opt_WarnMissingExportList-    ; warnIfFlag Opt_WarnMissingExportList-        warnMissingExportList-        (missingModuleExportWarn $ moduleName _this_mod)+    ; addDiagnostic+        (TcRnMissingExportList $ moduleName _this_mod)     ; let avails =             map fix_faminst . gresToAvailInfo               . filter isLocalGRE . globalRdrEnvElts $ rdr_env@@ -284,8 +282,7 @@     exports_from_item (ExportAccum occs earlier_mods)                       (L loc ie@(IEModuleContents _ lmod@(L _ mod)))         | mod `elementOfUniqSet` earlier_mods    -- Duplicate export of M-        = do { warnIfFlag Opt_WarnDuplicateExports True-                          (dupModuleExport mod) ;+        = do { addDiagnostic (TcRnDupeModuleExport mod) ;                return Nothing }          | otherwise@@ -299,10 +296,8 @@                    ; mods        = addOneToUniqSet earlier_mods mod                    } -             ; checkErr exportValid (moduleNotImported mod)-             ; warnIfFlag Opt_WarnDodgyExports-                          (exportValid && null gre_prs)-                          (nullModuleExport mod)+             ; checkErr exportValid (TcRnExportedModNotImported mod)+             ; warnIf (exportValid && null gre_prs) (TcRnNullExportedModule mod)               ; traceRn "efa" (ppr mod $$ ppr all_gres)              ; addUsedGREs all_gres@@ -322,12 +317,12 @@                             , ( L loc (IEModuleContents noExtField lmod)                               , new_exports))) } -    exports_from_item acc@(ExportAccum occs mods) (L loc ie)-        | Just new_ie <- lookup_doc_ie ie-        = return (Just (acc, (L loc new_ie, [])))--        | otherwise-        = do (new_ie, avail) <- lookup_ie ie+    exports_from_item acc@(ExportAccum occs mods) (L loc ie) = do+        m_new_ie <- lookup_doc_ie ie+        case m_new_ie of+          Just new_ie -> return (Just (acc, (L loc new_ie, [])))+          Nothing -> do+             (new_ie, avail) <- lookup_ie ie              if isUnboundName (ieName new_ie)                   then return Nothing    -- Avoid error cascade                   else do@@ -393,23 +388,24 @@              let gres = findChildren kids_env name                  (non_flds, flds) = classifyGREs gres              addUsedKids (ieWrappedName rdr) gres-             warnDodgyExports <- woptM Opt_WarnDodgyExports              when (null gres) $                   if isTyConName name-                  then when warnDodgyExports $-                           addWarn (Reason Opt_WarnDodgyExports)-                                   (dodgyExportWarn name)+                  then addTcRnDiagnostic (TcRnDodgyExports name)                   else -- This occurs when you export T(..), but                        -- only import T abstractly, or T is a synonym.-                       addErr (exportItemErr ie)+                       addErr (TcRnExportHiddenComponents ie)              return (L (locA l) name, non_flds, flds)      --------------    lookup_doc_ie :: IE GhcPs -> Maybe (IE GhcRn)-    lookup_doc_ie (IEGroup _ lev doc) = Just (IEGroup noExtField lev doc)-    lookup_doc_ie (IEDoc _ doc)       = Just (IEDoc noExtField doc)-    lookup_doc_ie (IEDocNamed _ str)  = Just (IEDocNamed noExtField str)-    lookup_doc_ie _ = Nothing+    lookup_doc_ie :: IE GhcPs -> RnM (Maybe (IE GhcRn))+    lookup_doc_ie (IEGroup _ lev doc) = do+      doc' <- rnLHsDoc doc+      pure $ Just (IEGroup noExtField lev doc')+    lookup_doc_ie (IEDoc _ doc)       = do+      doc' <- rnLHsDoc doc+      pure $ Just (IEDoc noExtField doc')+    lookup_doc_ie (IEDocNamed _ str)  = pure $ Just (IEDocNamed noExtField str)+    lookup_doc_ie _ = pure Nothing      -- In an export item M.T(A,B,C), we want to treat the uses of     -- A,B,C as if they were M.A, M.B, M.C@@ -582,7 +578,7 @@ -- | Given a resolved name in the children export list and a parent. Decide -- whether we are allowed to export the child with the parent. -- Invariant: gre_par == NoParent--- See note [Typing Pattern Synonym Exports]+-- See Note [Typing Pattern Synonym Exports] checkPatSynParent :: Name    -- ^ Alleged parent type constructor                              -- User wrote T( P, Q )                   -> Parent  -- The parent of P we discovered@@ -614,19 +610,16 @@     psErr  = exportErrCtxt "pattern synonym"     selErr = exportErrCtxt "pattern synonym record selector" -    assocClassErr :: SDoc-    assocClassErr = text "Pattern synonyms can be bundled only with datatypes."-     handle_pat_syn :: SDoc-                   -> TyCon      -- ^ Parent TyCon-                   -> PatSyn     -- ^ Corresponding bundled PatSyn-                                 --   and pretty printed origin+                   -> TyCon      -- Parent TyCon+                   -> PatSyn     -- Corresponding bundled PatSyn+                                 -- and pretty printed origin                    -> TcM ()     handle_pat_syn doc ty_con pat_syn -      -- 2. See note [Types of TyCon]+      -- 2. See Note [Types of TyCon]       | not $ isTyConWithSrcDataCons ty_con-      = addErrCtxt doc $ failWithTc assocClassErr+      = addErrCtxt doc $ failWithTc TcRnPatSynBundledWithNonDataCon        -- 3. Is the head a type variable?       | Nothing <- mtycon@@ -634,7 +627,8 @@       -- 4. Ok. Check they are actually the same type constructor.        | Just p_ty_con <- mtycon, p_ty_con /= ty_con-      = addErrCtxt doc $ failWithTc typeMismatchError+      = addErrCtxt doc $ failWithTc+          (TcRnPatSynBundledWithWrongType expected_res_ty res_ty)        -- 5. We passed!       | otherwise@@ -644,13 +638,6 @@         expected_res_ty = mkTyConApp ty_con (mkTyVarTys (tyConTyVars ty_con))         (_, _, _, _, _, res_ty) = patSynSig pat_syn         mtycon = fst <$> tcSplitTyConApp_maybe res_ty-        typeMismatchError :: SDoc-        typeMismatchError =-          text "Pattern synonyms can only be bundled with matching type constructors"-              $$ text "Couldn't match expected type of"-              <+> quotes (ppr expected_res_ty)-              <+> text "with actual type of"-              <+> quotes (ppr res_ty)   {-===========================================================================-}@@ -673,9 +660,7 @@             | greNameMangledName child == greNameMangledName child'   -- Duplicate export             -- But we don't want to warn if the same thing is exported             -- by two different module exports. See ticket #4478.-            -> do { warnIfFlag Opt_WarnDuplicateExports-                               (not (dupExport_ok child ie ie'))-                               (dupExportWarn child ie ie')+            -> do { warnIf (not (dupExport_ok child ie ie')) (TcRnDuplicateExport child ie ie')                   ; return occs }              | otherwise    -- Same occ name but different names: an error@@ -737,35 +722,6 @@     single _               = False  -dupModuleExport :: ModuleName -> SDoc-dupModuleExport mod-  = hsep [text "Duplicate",-          quotes (text "Module" <+> ppr mod),-          text "in export list"]--moduleNotImported :: ModuleName -> SDoc-moduleNotImported mod-  = hsep [text "The export item",-          quotes (text "module" <+> ppr mod),-          text "is not imported"]--nullModuleExport :: ModuleName -> SDoc-nullModuleExport mod-  = hsep [text "The export item",-          quotes (text "module" <+> ppr mod),-          text "exports nothing"]--missingModuleExportWarn :: ModuleName -> SDoc-missingModuleExportWarn mod-  = hsep [text "The export item",-          quotes (text "module" <+> ppr mod),-          text "is missing an export list"]---dodgyExportWarn :: Name -> SDoc-dodgyExportWarn item-  = dodgyMsg (text "export") item (dodgyMsgInsert item :: IE GhcRn)- exportErrCtxt :: Outputable o => String -> o -> SDoc exportErrCtxt herald exp =   text "In the" <+> text (herald ++ ":") <+> ppr exp@@ -777,65 +733,21 @@   where     exportCtxt = text "In the export:" <+> ppr ie -exportItemErr :: IE GhcPs -> SDoc-exportItemErr export_item-  = sep [ text "The export item" <+> quotes (ppr export_item),-          text "attempts to export constructors or class methods that are not visible here" ] --dupExportWarn :: GreName -> IE GhcPs -> IE GhcPs -> SDoc-dupExportWarn child ie1 ie2-  = hsep [quotes (ppr child),-          text "is exported by", quotes (ppr ie1),-          text "and",            quotes (ppr ie2)]--dcErrMsg :: Name -> String -> SDoc -> [SDoc] -> SDoc-dcErrMsg ty_con what_is thing parents =-          text "The type constructor" <+> quotes (ppr ty_con)-                <+> text "is not the parent of the" <+> text what_is-                <+> quotes thing <> char '.'-                $$ text (capitalise what_is)-                   <> text "s can only be exported with their parent type constructor."-                $$ (case parents of-                      [] -> empty-                      [_] -> text "Parent:"-                      _  -> text "Parents:") <+> fsep (punctuate comma parents)- failWithDcErr :: Name -> GreName -> [Name] -> TcM a failWithDcErr parent child parents = do   ty_thing <- tcLookupGlobal (greNameMangledName child)-  failWithTc $ dcErrMsg parent (pp_category ty_thing)-                        (ppr child) (map ppr parents)-  where-    pp_category :: TyThing -> String-    pp_category (AnId i)-      | isRecordSelector i = "record selector"-    pp_category i = tyThingCategory i+  failWithTc $ TcRnExportedParentChildMismatch parent ty_thing child parents   exportClashErr :: GlobalRdrEnv                -> GreName -> GreName                -> IE GhcPs -> IE GhcPs-               -> SDoc+               -> TcRnMessage exportClashErr global_env child1 child2 ie1 ie2-  = vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon-         , ppr_export child1' gre1' ie1'-         , ppr_export child2' gre2' ie2'-         ]+  = TcRnConflictingExports occ child1' gre1' ie1' child2' gre2' ie2'   where     occ = occName child1--    ppr_export child gre ie = nest 3 (hang (quotes (ppr ie) <+> text "exports" <+>-                                            quotes (ppr_name child))-                                        2 (pprNameProvenance gre))--    -- DuplicateRecordFields means that nameOccName might be a mangled-    -- $sel-prefixed thing, in which case show the correct OccName alone-    -- (but otherwise show the Name so it will have a module qualifier)-    ppr_name (FieldGreName fl) | flIsOverloaded fl = ppr fl-                               | otherwise         = ppr (flSelector fl)-    ppr_name (NormalGreName name) = ppr name-     -- get_gre finds a GRE for the Name, so that we can show its provenance     gre1 = get_gre child1     gre2 = get_gre child2
compiler/GHC/Tc/Gen/Expr.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE DataKinds           #-} {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -23,23 +23,24 @@          tcPolyExpr, tcExpr,          tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType,          tcCheckId,-         addAmbiguousNameErr,          getFixedTyVars ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import {-# SOURCE #-}   GHC.Tc.Gen.Splice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket )  import GHC.Hs+import GHC.Hs.Syn.Type import GHC.Rename.Utils import GHC.Tc.Utils.Zonk import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Unify import GHC.Types.Basic+import GHC.Types.Error import GHC.Core.Multiplicity import GHC.Core.UsageEnv+import GHC.Tc.Errors.Types+import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) import GHC.Tc.Utils.Instantiate import GHC.Tc.Gen.App import GHC.Tc.Gen.Head@@ -51,7 +52,6 @@ import GHC.Tc.Gen.Arrow import GHC.Tc.Gen.Match import GHC.Tc.Gen.HsType-import GHC.Tc.Gen.Pat import GHC.Tc.Utils.TcMType import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType as TcType@@ -77,7 +77,7 @@ import GHC.Data.Maybe import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic-import GHC.Data.FastString+import GHC.Utils.Panic.Plain import Control.Monad import GHC.Core.Class(classTyCon) import GHC.Types.Unique.Set ( UniqSet, mkUniqSet, elementOfUniqSet, nonDetEltsUniqSet )@@ -186,7 +186,7 @@ --   - HsApp         value applications --   - HsAppType     type applications --   - ExprWithTySig (e :: type)---   - HsRecFld      overloaded record fields+--   - HsRecSel      overloaded record fields --   - HsExpanded    renamer expansions --   - HsOpApp       operator applications --   - HsOverLit     overloaded literals@@ -199,7 +199,7 @@ tcExpr e@(OpApp {})              res_ty = tcApp e res_ty tcExpr e@(HsAppType {})          res_ty = tcApp e res_ty tcExpr e@(ExprWithTySig {})      res_ty = tcApp e res_ty-tcExpr e@(HsRecFld {})           res_ty = tcApp e res_ty+tcExpr e@(HsRecSel {})           res_ty = tcApp e res_ty tcExpr e@(XExpr (HsExpanded {})) res_ty = tcApp e res_ty  tcExpr e@(HsOverLit _ lit) res_ty@@ -224,9 +224,9 @@   = do { let lit_ty = hsLitType lit        ; tcWrapResult e (HsLit x (convertLit lit)) lit_ty res_ty } -tcExpr (HsPar x expr) res_ty+tcExpr (HsPar x lpar expr rpar) res_ty   = do { expr' <- tcMonoExprNC expr res_ty-       ; return (HsPar x expr') }+       ; return (HsPar x lpar expr' rpar) }  tcExpr (HsPragE x prag expr) res_ty   = do { expr' <- tcMonoExpr expr res_ty@@ -240,11 +240,9 @@         ; return (NegApp x expr' neg_expr') }  tcExpr e@(HsIPVar _ x) res_ty-  = do {   {- Implicit parameters must have a *tau-type* not a-              type scheme.  We enforce this by creating a fresh-              type variable as its type.  (Because res_ty may not-              be a tau-type.) -}-         ip_ty <- newOpenFlexiTyVarTy+  = do { ip_ty <- newFlexiTyVarTy liftedTypeKind+          -- Create a unification type variable of kind 'Type'.+          -- (The type of an implicit parameter must have kind 'Type'.)        ; let ip_name = mkStrLitTy (hsIPNameFS x)        ; ipClass <- tcLookupClass ipClassName        ; ip_var <- emitWantedEvVar origin (mkClassPred ipClass [ip_name, ip_ty])@@ -262,22 +260,15 @@         ; return (mkHsWrap wrap (HsLam noExtField match')) }   where     match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcBody }-    herald = sep [ text "The lambda expression" <+>-                   quotes (pprSetDepth (PartWay 1) $-                           pprMatches match),-                        -- The pprSetDepth makes the abstraction print briefly-                   text "has"]+    herald = ExpectedFunTyLam match -tcExpr e@(HsLamCase x matches) res_ty+tcExpr e@(HsLamCase x lc_variant matches) res_ty   = do { (wrap, matches')-           <- tcMatchLambda msg match_ctxt matches res_ty-           -- The laziness annotation is because we don't want to fail here-           -- if there are multiple arguments-       ; return (mkHsWrap wrap $ HsLamCase x matches') }+           <- tcMatchLambda herald match_ctxt matches res_ty+       ; return (mkHsWrap wrap $ HsLamCase x lc_variant matches') }   where-    msg = sep [ text "The function" <+> quotes (ppr e)-              , text "requires"]-    match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody }+    match_ctxt = MC { mc_what = LamCaseAlt lc_variant, mc_body = tcBody }+    herald = ExpectedFunTyLamCase lc_variant e   @@ -330,10 +321,9 @@        ; let expr'       = ExplicitTuple x tup_args1 boxity              missing_tys = [Scaled mult ty | (Missing (Scaled mult _), ty) <- zip tup_args1 arg_tys] -             -- See Note [Linear fields generalization] in GHC.Tc.Gen.App-             act_res_ty-                 = mkVisFunTys missing_tys (mkTupleTy1 boxity arg_tys)-                   -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make+             -- See Note [Typechecking data constructors] in GHC.Tc.Gen.Head+             -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make+             act_res_ty = mkVisFunTys missing_tys (mkTupleTy1 boxity arg_tys)         ; traceTc "ExplicitTuple" (ppr act_res_ty $$ ppr res_ty) @@ -345,7 +335,16 @@        ; (coi, arg_tys) <- matchExpectedTyConApp sum_tc res_ty        ; -- Drop levity vars, we don't care about them here          let arg_tys' = drop arity arg_tys-       ; expr' <- tcCheckPolyExpr expr (arg_tys' `getNth` (alt - 1))+             arg_ty   = arg_tys' `getNth` (alt - 1)+       ; expr' <- tcCheckPolyExpr expr arg_ty+       -- Check the whole res_ty, not just the arg_ty, to avoid #20277.+       -- Example:+       --   a :: TYPE rep (representation-polymorphic)+       --   (# 17# | #) :: (# Int# | a #)+       -- This should cause an error, even though (17# :: Int#)+       -- is not representation-polymorphic: we don't know how+       -- wide the concrete representation of the sum type will be.+       ; hasFixedRuntimeRep_syntactic FRRUnboxedSum res_ty        ; return $ mkHsWrapCo coi (ExplicitSum arg_tys' alt arity expr' ) }  @@ -357,10 +356,10 @@ ************************************************************************ -} -tcExpr (HsLet x binds expr) res_ty+tcExpr (HsLet x tkLet binds tkIn expr) res_ty   = do  { (binds', expr') <- tcLocalBinds binds $                              tcMonoExpr expr res_ty-        ; return (HsLet x binds' expr') }+        ; return (HsLet x tkLet binds' tkIn expr') }  tcExpr (HsCase x scrut matches) res_ty   = do  {  -- We used to typecheck the case alternatives first.@@ -383,6 +382,7 @@         ; (scrut', scrut_ty) <- tcScalingUsage mult $ tcInferRho scrut          ; traceTc "HsCase" (ppr scrut_ty)+        ; hasFixedRuntimeRep_syntactic FRRCase scrut_ty         ; matches' <- tcMatchesCase match_ctxt (Scaled mult scrut_ty) matches res_ty         ; return (HsCase x scrut' matches') }  where@@ -397,7 +397,7 @@        ; return (HsIf x pred' b1' b2') }  tcExpr (HsMultiIf _ alts) res_ty-  = do { alts' <- mapM (wrapLocM $ tcGRHS match_ctxt res_ty) alts+  = do { alts' <- mapM (wrapLocMA $ tcGRHS match_ctxt res_ty) alts        ; res_ty <- readExpType res_ty        ; return (HsMultiIf res_ty alts') }   where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }@@ -432,11 +432,8 @@         ; mapM_ checkClosedInStaticForm $ nonDetEltsUniqSet fvs          -- Require the type of the argument to be Typeable.-        -- The evidence is not used, but asking the constraint ensures that-        -- the current implementation is as restrictive as future versions-        -- of the StaticPointers extension.         ; typeableClass <- tcLookupClass typeableClassName-        ; _ <- emitWantedEvVar StaticOrigin $+        ; typeable_ev <- emitWantedEvVar StaticOrigin $                   mkTyConApp (classTyCon typeableClass)                              [liftedTypeKind, expr_ty] @@ -447,11 +444,12 @@         -- Wrap the static form with the 'fromStaticPtr' call.         ; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName                                              [p_ty]-        ; let wrap = mkWpTyApps [expr_ty]+        ; let wrap = mkWpEvVarApps [typeable_ev] <.> mkWpTyApps [expr_ty]         ; loc <- getSrcSpanM+        ; static_ptr_ty_con <- tcLookupTyCon staticPtrTyConName         ; return $ mkHsWrapCo co $ HsApp noComments                             (L (noAnnSrcSpan loc) $ mkHsWrap wrap fromStaticPtr)-                            (L (noAnnSrcSpan loc) (HsStatic fvs expr'))+                            (L (noAnnSrcSpan loc) (HsStatic (fvs, mkTyConApp static_ptr_ty_con [expr_ty]) expr'))         }  {-@@ -644,7 +642,7 @@ -- GHC.Hs.Expr. This is why we match on 'rupd_flds = Left rbnds' here -- and panic otherwise. tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = Left rbnds }) res_ty-  = ASSERT( notNull rbnds )+  = assert (notNull rbnds) $     do  { -- STEP -2: typecheck the record_expr, the record to be updated           (record_expr', record_rho) <- tcScalingUsage Many $ tcInferRho record_expr             -- Record update drops some of the content of the record (namely the@@ -664,7 +662,7 @@         -- STEP -1  See Note [Disambiguating record fields] in GHC.Tc.Gen.Head         -- After this we know that rbinds is unambiguous         ; rbinds <- disambiguateRecordBinds record_expr record_rho rbnds res_ty-        ; let upd_flds = map (unLoc . hsRecFieldLbl . unLoc) rbinds+        ; let upd_flds = map (unLoc . hfbLHS . unLoc) rbinds               upd_fld_occs = map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc) upd_flds               sel_ids      = map selectorAmbiguousFieldOcc upd_flds         -- STEP 0@@ -678,10 +676,10 @@                            not (isRecordSelector sel_id),                            let fld_name = idName sel_id ]         ; unless (null bad_guys) (sequence bad_guys >> failM)-        -- See note [Mixed Record Selectors]+        -- See Note [Mixed Record Selectors]         ; let (data_sels, pat_syn_sels) =                 partition isDataConRecordSelector sel_ids-        ; MASSERT( all isPatSynRecordSelector pat_syn_sels )+        ; massert (all isPatSynRecordSelector pat_syn_sels)         ; checkTc ( null data_sels || null pat_syn_sels )                   ( mixedSelectors data_sels pat_syn_sels ) @@ -715,7 +713,7 @@         ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds con_likes)          -- Take apart a representative constructor-        ; let con1 = ASSERT( not (null relevant_cons) ) head relevant_cons+        ; let con1 = assert (not (null relevant_cons) ) head relevant_cons               (con1_tvs, _, _, _prov_theta, req_theta, scaled_con1_arg_tys, _)                  = conLikeFullSig con1               con1_arg_tys = map scaledThing scaled_con1_arg_tys@@ -742,7 +740,7 @@               con1_tv_set  = mkVarSet con1_tvs               bad_fld (fld, ty) = fld `elem` upd_fld_occs &&                                       not (tyCoVarsOfType ty `subVarSet` con1_tv_set)-        ; checkTc (null bad_upd_flds) (badFieldTypes bad_upd_flds)+        ; checkTc (null bad_upd_flds) (TcRnFieldUpdateInvalidType bad_upd_flds)          -- STEP 4  Note [Type of a record update]         -- Figure out types for the scrutinee and result@@ -775,7 +773,7 @@               scrut_ty      = TcType.substTy scrut_subst  con1_res_ty               con1_arg_tys' = map (TcType.substTy result_subst) con1_arg_tys -        ; co_scrut <- unifyType (Just (ppr record_expr)) record_rho scrut_ty+        ; co_scrut <- unifyType (Just . HsExprRnThing $ unLoc record_expr) record_rho scrut_ty                 -- NB: normal unification is OK here (as opposed to subsumption),                 -- because for this to work out, both record_rho and scrut_ty have                 -- to be normal datatypes -- no contravariant stuff can go on@@ -784,7 +782,8 @@         -- Typecheck the bindings         ; rbinds'      <- tcRecordUpd con1 con1_arg_tys' rbinds -        -- STEP 6: Deal with the stupid theta+        -- STEP 6: Deal with the stupid theta.+        -- See Note [The stupid context] in GHC.Core.DataCon.         ; let theta' = substThetaUnchecked scrut_subst (conLikeStupidTheta con1)         ; instStupidTheta RecordUpdOrigin theta' @@ -860,8 +859,8 @@   = do addModFinalizersWithLclEnv mod_finalizers        tcExpr expr res_ty tcExpr (HsSpliceE _ splice)          res_ty = tcSpliceExpr splice res_ty-tcExpr e@(HsBracket _ brack)         res_ty = tcTypedBracket e brack res_ty-tcExpr e@(HsRnBracketOut _ brack ps) res_ty = tcUntypedBracket e brack ps res_ty+tcExpr e@(HsTypedBracket _ body) res_ty = tcTypedBracket e body res_ty+tcExpr e@(HsUntypedBracket ps body) res_ty = tcUntypedBracket e body ps res_ty  {- ************************************************************************@@ -871,13 +870,9 @@ ************************************************************************ -} -tcExpr (HsConLikeOut {})   ty = pprPanic "tcExpr:HsConLikeOut" (ppr ty) tcExpr (HsOverLabel {})    ty = pprPanic "tcExpr:HsOverLabel"  (ppr ty) tcExpr (SectionL {})       ty = pprPanic "tcExpr:SectionL"    (ppr ty) tcExpr (SectionR {})       ty = pprPanic "tcExpr:SectionR"    (ppr ty)-tcExpr (HsTcBracketOut {}) ty = pprPanic "tcExpr:HsTcBracketOut"    (ppr ty)-tcExpr (HsTick {})         ty = pprPanic "tcExpr:HsTick"    (ppr ty)-tcExpr (HsBinTick {})      ty = pprPanic "tcExpr:HsBinTick"    (ppr ty)   {-@@ -941,16 +936,26 @@        ; return (idHsWrapper, elt_mult, elt_ty, Just fl') }  -----------------tcTupArgs :: [HsTupArg GhcRn] -> [TcSigmaType] -> TcM [HsTupArg GhcTc]+tcTupArgs :: [HsTupArg GhcRn]+          -> [TcSigmaType]+              -- ^ Argument types.+              -- This function ensures they all have+              -- a fixed runtime representation.+          -> TcM [HsTupArg GhcTc] tcTupArgs args tys-  = do MASSERT( equalLength args tys )+  = do massert (equalLength args tys)        checkTupSize (length args)-       mapM go (args `zip` tys)+       zipWith3M go [1,2..] args tys   where-    go (Missing {},     arg_ty) = do { mult <- newFlexiTyVarTy multiplicityTy-                                     ; return (Missing (Scaled mult arg_ty)) }-    go (Present x expr, arg_ty) = do { expr' <- tcCheckPolyExpr expr arg_ty-                                     ; return (Present x expr') }+    go :: Int -> HsTupArg GhcRn -> TcType -> TcM (HsTupArg GhcTc)+    go i (Missing {})     arg_ty+      = do { mult <- newFlexiTyVarTy multiplicityTy+           ; hasFixedRuntimeRep_syntactic (FRRTupleSection i) arg_ty+           ; return (Missing (Scaled mult arg_ty)) }+    go i (Present x expr) arg_ty+      = do { expr' <- tcCheckPolyExpr expr arg_ty+           ; hasFixedRuntimeRep_syntactic (FRRTupleArg i) arg_ty+           ; return (Present x expr') }  --------------------------- -- See TcType.SyntaxOpType also for commentary@@ -975,14 +980,14 @@               -> SyntaxExprRn               -> [SyntaxOpType]               -> SyntaxOpType-              -> ([TcSigmaType] -> [Mult] -> TcM a)+              -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a)               -> TcM (a, SyntaxExprTc) tcSyntaxOpGen orig (SyntaxExprRn op) arg_tys res_ty thing_inside-  = do { (expr, sigma) <- tcInferAppHead (op, VACall op 0 noSrcSpan) [] Nothing+  = do { (expr, sigma) <- tcInferAppHead (op, VACall op 0 noSrcSpan) []              -- Ugh!! But all this code is scheduled for demolition anyway        ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma)        ; (result, expr_wrap, arg_wraps, res_wrap)-           <- tcSynArgA orig sigma arg_tys res_ty $+           <- tcSynArgA orig op sigma arg_tys res_ty $               thing_inside        ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma )        ; return (result, SyntaxExprTc { syn_expr = mkHsWrap expr_wrap expr@@ -1003,12 +1008,13 @@ -- works on "expected" types, skolemising where necessary -- See Note [tcSynArg] tcSynArgE :: CtOrigin+          -> HsExpr GhcRn -- ^ the operator to check (for error messages only)           -> TcSigmaType           -> SyntaxOpType                -- ^ shape it is expected to have-          -> ([TcSigmaType] -> [Mult] -> TcM a) -- ^ check the arguments+          -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) -- ^ check the arguments           -> TcM (a, HsWrapper)            -- ^ returns a wrapper :: (type of right shape) "->" (type passed in)-tcSynArgE orig sigma_ty syn_ty thing_inside+tcSynArgE orig op sigma_ty syn_ty thing_inside   = do { (skol_wrap, (result, ty_wrapper))            <- tcTopSkolemise GenSigCtxt sigma_ty                 (\ rho_ty -> go rho_ty syn_ty)@@ -1039,27 +1045,27 @@                           -- another nested arrow is too much for now,                          -- but I bet we'll never need this-                     ; MASSERT2( case arg_shape of+                     ; massertPpr (case arg_shape of                                    SynFun {} -> False;-                                   _         -> True-                               , text "Too many nested arrows in SyntaxOpType" $$-                                 pprCtOrigin orig )+                                   _         -> True)+                                  (text "Too many nested arrows in SyntaxOpType" $$+                                   pprCtOrigin orig)                       ; let arg_mult = scaledMult arg_ty-                     ; tcSynArgA orig arg_tc_ty [] arg_shape $+                     ; tcSynArgA orig op arg_tc_ty [] arg_shape $                        \ arg_results arg_res_mults ->-                       tcSynArgE orig res_tc_ty res_shape $+                       tcSynArgE orig op res_tc_ty res_shape $                        \ res_results res_res_mults ->                        do { result <- thing_inside (arg_results ++ res_results) ([arg_mult] ++ arg_res_mults ++ res_res_mults)                           ; return (result, arg_tc_ty, res_tc_ty, arg_mult) }} -           ; return ( result-                    , match_wrapper <.>-                      mkWpFun (arg_wrapper2 <.> arg_wrapper1) res_wrapper-                              (Scaled op_mult arg_ty) res_ty doc ) }+           ; let fun_wrap = mkWpFun (arg_wrapper2 <.> arg_wrapper1) res_wrapper+                              (Scaled op_mult arg_ty) res_ty+               -- NB: arg_ty comes from matchExpectedFunTys, so it has a+               -- fixed RuntimeRep, as needed to call mkWpFun.+           ; return (result, match_wrapper <.> fun_wrap) }       where-        herald = text "This rebindable syntax expects a function with"-        doc = text "When checking a rebindable syntax operator arising from" <+> ppr orig+        herald = ExpectedFunTySyntaxOp orig op      go rho_ty (SynType the_ty)       = do { wrap   <- tcSubTypePat orig GenSigCtxt the_ty rho_ty@@ -1069,15 +1075,16 @@ -- works on "actual" types, instantiating where necessary -- See Note [tcSynArg] tcSynArgA :: CtOrigin+          -> HsExpr GhcRn -- ^ the operator we are checking (for error messages)           -> TcSigmaType           -> [SyntaxOpType]              -- ^ argument shapes           -> SyntaxOpType                -- ^ result shape-          -> ([TcSigmaType] -> [Mult] -> TcM a) -- ^ check the arguments+          -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) -- ^ check the arguments           -> TcM (a, HsWrapper, [HsWrapper], HsWrapper)             -- ^ returns a wrapper to be applied to the original function,             -- wrappers to be applied to arguments             -- and a wrapper to be applied to the overall expression-tcSynArgA orig sigma_ty arg_shapes res_shape thing_inside+tcSynArgA orig op sigma_ty arg_shapes res_shape thing_inside   = do { (match_wrapper, arg_tys, res_ty)            <- matchActualFunTysRho herald orig Nothing                                    (length arg_shapes) sigma_ty@@ -1088,22 +1095,22 @@               thing_inside (arg_results ++ res_results) (map scaledMult arg_tys ++ arg_res_mults)        ; return (result, match_wrapper, arg_wrappers, res_wrapper) }   where-    herald = text "This rebindable syntax expects a function with"+    herald = ExpectedFunTySyntaxOp orig op -    tc_syn_args_e :: [TcSigmaType] -> [SyntaxOpType]-                  -> ([TcSigmaType] -> [Mult] -> TcM a)+    tc_syn_args_e :: [TcSigmaTypeFRR] -> [SyntaxOpType]+                  -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a)                   -> TcM (a, [HsWrapper])                     -- the wrappers are for arguments     tc_syn_args_e (arg_ty : arg_tys) (arg_shape : arg_shapes) thing_inside       = do { ((result, arg_wraps), arg_wrap)-               <- tcSynArgE     orig arg_ty  arg_shape  $ \ arg1_results arg1_mults ->-                  tc_syn_args_e      arg_tys arg_shapes $ \ args_results args_mults ->+               <- tcSynArgE     orig  op arg_ty  arg_shape  $ \ arg1_results arg1_mults ->+                  tc_syn_args_e          arg_tys arg_shapes $ \ args_results args_mults ->                   thing_inside (arg1_results ++ args_results) (arg1_mults ++ args_mults)            ; return (result, arg_wrap : arg_wraps) }     tc_syn_args_e _ _ thing_inside = (, []) <$> thing_inside [] [] -    tc_syn_arg :: TcSigmaType -> SyntaxOpType-               -> ([TcSigmaType] -> TcM a)+    tc_syn_arg :: TcSigmaTypeFRR -> SyntaxOpType+               -> ([TcSigmaTypeFRR] -> TcM a)                -> TcM (a, HsWrapper)                   -- the wrapper applies to the overall result     tc_syn_arg res_ty SynAny thing_inside@@ -1188,7 +1195,7 @@ -- See Note [Disambiguating record fields] in GHC.Tc.Gen.Head disambiguateRecordBinds :: LHsExpr GhcRn -> TcRhoType                  -> [LHsRecUpdField GhcRn] -> ExpRhoType-                 -> TcM [LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]+                 -> TcM [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] disambiguateRecordBinds record_expr record_rho rbnds res_ty     -- Are all the fields unambiguous?   = case mapM isUnambiguous rbnds of@@ -1207,7 +1214,7 @@   where     -- Extract the selector name of a field update if it is unambiguous     isUnambiguous :: LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn,Name)-    isUnambiguous x = case unLoc (hsRecFieldLbl (unLoc x)) of+    isUnambiguous x = case unLoc (hfbLHS (unLoc x)) of                         Unambiguous sel_name _ -> Just (x, sel_name)                         Ambiguous{}            -> Nothing @@ -1225,7 +1232,7 @@     identifyParent fam_inst_envs possible_parents       = case foldr1 intersect possible_parents of         -- No parents for all fields: record update is ill-typed-        []  -> failWithTc (noPossibleParents rbnds)+        []  -> failWithTc (TcRnNoPossibleParentForFields rbnds)          -- Exactly one datatype with all the fields: use that         [p] -> return p@@ -1244,7 +1251,7 @@                   ; return (RecSelData tc) }          -- Nothing else we can try...-        _ -> failWithTc badOverloadedUpdate+        _ -> failWithTc (TcRnBadOverloadedRecordUpdate rbnds)      -- Make a field unambiguous by choosing the given parent.     -- Emits an error if the field cannot have that parent,@@ -1253,7 +1260,7 @@     -- where T does not have field x.     pickParent :: RecSelParent                -> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])-               -> TcM (LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))+               -> TcM (LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))     pickParent p (upd, xs)       = case lookup p xs of                       -- Phew! The parent is valid for this field.@@ -1262,8 +1269,8 @@                       -- unambiguous ones shouldn't be recorded again                       -- (giving duplicate deprecation warnings).           Just gre -> do { unless (null (tail xs)) $ do-                             let L loc _ = hsRecFieldLbl (unLoc upd)-                             setSrcSpan loc $ addUsedGRE True gre+                             let L loc _ = hfbLHS (unLoc upd)+                             setSrcSpanA loc $ addUsedGRE True gre                          ; lookupSelector (upd, greMangledName gre) }                       -- The field doesn't belong to this parent, so report                       -- an error but keep going through all the fields@@ -1274,31 +1281,24 @@     -- Given a (field update, selector name) pair, look up the     -- selector to give a field update with an unambiguous Id     lookupSelector :: (LHsRecUpdField GhcRn, Name)-                 -> TcM (LHsRecField' GhcRn (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))+                 -> TcM (LHsFieldBind GhcRn (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))     lookupSelector (L l upd, n)       = do { i <- tcLookupId n-           ; let L loc af = hsRecFieldLbl upd+           ; let L loc af = hfbLHS upd                  lbl      = rdrNameAmbiguousFieldOcc af-           -- ; return $ L l upd { hsRecFieldLbl-           --                = L loc (Unambiguous i (L (noAnnSrcSpan loc) lbl)) }-           ; return $ L l HsRecField-               { hsRecFieldAnn = hsRecFieldAnn upd-               , hsRecFieldLbl-                       = L loc (Unambiguous i (L (noAnnSrcSpan loc) lbl))-               , hsRecFieldArg = hsRecFieldArg upd-               , hsRecPun = hsRecPun upd+           ; return $ L l HsFieldBind+               { hfbAnn = hfbAnn upd+               , hfbLHS+                       = L (l2l loc) (Unambiguous i (L (l2l loc) lbl))+               , hfbRHS = hfbRHS upd+               , hfbPun = hfbPun upd                }            }      -- See Note [Deprecating ambiguous fields] in GHC.Tc.Gen.Head     reportAmbiguousField :: TyCon -> TcM ()     reportAmbiguousField parent_type =-        setSrcSpan loc $ warnIfFlag Opt_WarnAmbiguousFields True $-          vcat [ text "The record update" <+> ppr rupd-                   <+> text "with type" <+> ppr parent_type-                   <+> text "is ambiguous."-               , text "This will not be supported by -XDuplicateRecordFields in future releases of GHC."-               ]+        setSrcSpan loc $ addDiagnostic $ TcRnAmbiguousField rupd parent_type       where         rupd = RecordUpd { rupd_expr = record_expr, rupd_flds = Left rbnds, rupd_ext = noExtField }         loc  = getLocA (head rbnds)@@ -1336,24 +1336,24 @@      do_bind :: LHsRecField GhcRn (LHsExpr GhcRn)             -> TcM (Maybe (LHsRecField GhcTc (LHsExpr GhcTc)))-    do_bind (L l fld@(HsRecField { hsRecFieldLbl = f-                                 , hsRecFieldArg = rhs }))+    do_bind (L l fld@(HsFieldBind { hfbLHS = f+                                 , hfbRHS = rhs }))        = do { mb <- tcRecordField con_like flds_w_tys f rhs            ; case mb of                Nothing         -> return Nothing-               -- Just (f', rhs') -> return (Just (L l (fld { hsRecFieldLbl = f'-               --                                            , hsRecFieldArg = rhs' }))) }-               Just (f', rhs') -> return (Just (L l (HsRecField-                                                     { hsRecFieldAnn = hsRecFieldAnn fld-                                                     , hsRecFieldLbl = f'-                                                     , hsRecFieldArg = rhs'-                                                     , hsRecPun = hsRecPun fld}))) }+               -- Just (f', rhs') -> return (Just (L l (fld { hfbLHS = f'+               --                                            , hfbRHS = rhs' }))) }+               Just (f', rhs') -> return (Just (L l (HsFieldBind+                                                     { hfbAnn = hfbAnn fld+                                                     , hfbLHS = f'+                                                     , hfbRHS = rhs'+                                                     , hfbPun = hfbPun fld}))) }  tcRecordUpd         :: ConLike         -> [TcType]     -- Expected type for each field-        -> [LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]+        -> [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]         -> TcM [LHsRecUpdField GhcTc]  tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds@@ -1361,23 +1361,23 @@     fields = map flSelector $ conLikeFieldLabels con_like     flds_w_tys = zipEqual "tcRecordUpd" fields arg_tys -    do_bind :: LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)+    do_bind :: LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)             -> TcM (Maybe (LHsRecUpdField GhcTc))-    do_bind (L l fld@(HsRecField { hsRecFieldLbl = L loc af-                                 , hsRecFieldArg = rhs }))+    do_bind (L l fld@(HsFieldBind { hfbLHS = L loc af+                                 , hfbRHS = rhs }))       = do { let lbl = rdrNameAmbiguousFieldOcc af                  sel_id = selectorAmbiguousFieldOcc af-                 f = L loc (FieldOcc (idName sel_id) (L (noAnnSrcSpan loc) lbl))+                 f = L loc (FieldOcc (idName sel_id) (L (l2l loc) lbl))            ; mb <- tcRecordField con_like flds_w_tys f rhs            ; case mb of                Nothing         -> return Nothing                Just (f', rhs') ->                  return (Just-                         (L l (fld { hsRecFieldLbl+                         (L l (fld { hfbLHS                                       = L loc (Unambiguous-                                               (extFieldOcc (unLoc f'))-                                               (L (noAnnSrcSpan loc) lbl))-                                   , hsRecFieldArg = rhs' }))) }+                                               (foExt (unLoc f'))+                                               (L (l2l loc) lbl))+                                   , hfbRHS = rhs' }))) }  tcRecordField :: ConLike -> Assoc Name Type               -> LFieldOcc GhcRn -> LHsExpr GhcRn@@ -1386,16 +1386,18 @@   | Just field_ty <- assocMaybe flds_w_tys sel_name       = addErrCtxt (fieldCtxt field_lbl) $         do { rhs' <- tcCheckPolyExprNC rhs field_ty+           ; hasFixedRuntimeRep_syntactic (FRRRecordUpdate (unLoc lbl) (unLoc rhs'))+                field_ty            ; let field_id = mkUserLocal (nameOccName sel_name)                                         (nameUnique sel_name)-                                        Many field_ty loc+                                        Many field_ty (locA loc)                 -- Yuk: the field_id has the *unique* of the selector Id                 --          (so we can find it easily)                 --      but is a LocalId with the appropriate type of the RHS                 --          (so the desugarer knows the type of local binder to make)            ; return (Just (L loc (FieldOcc field_id lbl), rhs')) }       | otherwise-      = do { addErrTc (badFieldCon con_like field_lbl)+      = do { addErrTc (badFieldConErr (getName con_like) field_lbl)            ; return Nothing }   where         field_lbl = occNameFS $ rdrNameOcc (unLoc lbl)@@ -1407,19 +1409,18 @@                         -- But C{} is still valid if no strict fields   = if any isBanged field_strs then         -- Illegal if any arg is strict-        addErrTc (missingStrictFields con_like [])+        addErrTc (TcRnMissingStrictFields con_like [])     else do-        warn <- woptM Opt_WarnMissingFields-        when (warn && notNull field_strs && null field_labels)-             (warnTc (Reason Opt_WarnMissingFields) True-                 (missingFields con_like []))+        when (notNull field_strs && null field_labels) $ do+          let msg = TcRnMissingFields con_like []+          (diagnosticTc True msg)    | otherwise = do              -- A record     unless (null missing_s_fields) $ do         fs <- zonk_fields missing_s_fields         -- It is an error to omit a strict field, because         -- we can't substitute it with (error "Missing field f")-        addErrTc (missingStrictFields con_like fs)+        addErrTc (TcRnMissingStrictFields con_like fs)      warn <- woptM Opt_WarnMissingFields     when (warn && notNull missing_ns_fields) $ do@@ -1427,8 +1428,8 @@         -- It is not an error (though we may want) to omit a         -- lazy field, because we can always use         -- (error "Missing field f") instead.-        warnTc (Reason Opt_WarnMissingFields) True-             (missingFields con_like fs)+        let msg = TcRnMissingFields con_like fs+        diagnosticTc True msg    where     -- we zonk the fields to get better types in error messages (#18869)@@ -1467,22 +1468,15 @@  fieldCtxt :: FieldLabelString -> SDoc fieldCtxt field_name-  = text "In the" <+> quotes (ppr field_name) <+> ptext (sLit "field of a record")--badFieldTypes :: [(FieldLabelString,TcType)] -> SDoc-badFieldTypes prs-  = hang (text "Record update for insufficiently polymorphic field"-                         <> plural prs <> colon)-       2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ])+  = text "In the" <+> quotes (ppr field_name) <+> text "field of a record"  badFieldsUpd-  :: [LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]+  :: [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]                -- Field names that don't belong to a single datacon   -> [ConLike] -- Data cons of the type which the first field name belongs to-  -> SDoc+  -> TcRnMessage badFieldsUpd rbinds data_cons-  = hang (text "No constructor has all these fields:")-       2 (pprQuotedList conflictingFields)+  = TcRnNoConstructorHasAllFields conflictingFields           -- See Note [Finding the conflicting fields]   where     -- A (preferably small) set of fields such that no constructor contains@@ -1505,14 +1499,14 @@             -- are redundant and can be dropped.             map (fst . head) $ groupBy ((==) `on` snd) growingSets -    aMember = ASSERT( not (null members) ) fst (head members)+    aMember = assert (not (null members) ) fst (head members)     (members, nonMembers) = partition (or . snd) membership      -- For each field, which constructors contain the field?     membership :: [(FieldLabelString, [Bool])]     membership = sortMembership $         map (\fld -> (fld, map (fld `elementOfUniqSet`) fieldLabelSets)) $-          map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) rbinds+          map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc . unLoc . hfbLHS . unLoc) rbinds      fieldLabelSets :: [UniqSet FieldLabelString]     fieldLabelSets = map (mkUniqSet . map flLabel . conLikeFieldLabels) data_cons@@ -1551,60 +1545,14 @@ a decent stab, no more.  See #7989. -} -mixedSelectors :: [Id] -> [Id] -> SDoc+mixedSelectors :: [Id] -> [Id] -> TcRnMessage mixedSelectors data_sels@(dc_rep_id:_) pat_syn_sels@(ps_rep_id:_)-  = ptext-      (sLit "Cannot use a mixture of pattern synonym and record selectors") $$-    text "Record selectors defined by"-      <+> quotes (ppr (tyConName rep_dc))-      <> text ":"-      <+> pprWithCommas ppr data_sels $$-    text "Pattern synonym selectors defined by"-      <+> quotes (ppr (patSynName rep_ps))-      <> text ":"-      <+> pprWithCommas ppr pat_syn_sels+  = TcRnMixedSelectors (tyConName rep_dc) data_sels (patSynName rep_ps) pat_syn_sels   where     RecSelPatSyn rep_ps = recordSelectorTyCon ps_rep_id     RecSelData rep_dc = recordSelectorTyCon dc_rep_id mixedSelectors _ _ = panic "GHC.Tc.Gen.Expr: mixedSelectors emptylists" --missingStrictFields :: ConLike -> [(FieldLabelString, TcType)] -> SDoc-missingStrictFields con fields-  = vcat [header, nest 2 rest]-  where-    pprField (f,ty) = ppr f <+> dcolon <+> ppr ty-    rest | null fields = Outputable.empty  -- Happens for non-record constructors-                                           -- with strict fields-         | otherwise   = vcat (fmap pprField fields)--    header = text "Constructor" <+> quotes (ppr con) <+>-             text "does not have the required strict field(s)" <>-             if null fields then Outputable.empty else colon--missingFields :: ConLike -> [(FieldLabelString, TcType)] -> SDoc-missingFields con fields-  = vcat [header, nest 2 rest]-  where-    pprField (f,ty) = ppr f <+> text "::" <+> ppr ty-    rest | null fields = Outputable.empty-         | otherwise   = vcat (fmap pprField fields)-    header = text "Fields of" <+> quotes (ppr con) <+>-             text "not initialised" <>-             if null fields then Outputable.empty else colon---- callCtxt fun args = text "In the call" <+> parens (ppr (foldl' mkHsApp fun args))--noPossibleParents :: [LHsRecUpdField GhcRn] -> SDoc-noPossibleParents rbinds-  = hang (text "No type has all these fields:")-       2 (pprQuotedList fields)-  where-    fields = map (hsRecFieldLbl . unLoc) rbinds--badOverloadedUpdate :: SDoc-badOverloadedUpdate = text "Record update is ambiguous, and requires a type signature"- {- ************************************************************************ *                                                                      *@@ -1613,11 +1561,6 @@ ************************************************************************ -} --- | A data type to describe why a variable is not closed.-data NotClosedReason = NotLetBoundReason-                     | NotTypeClosed VarSet-                     | NotClosed Name NotClosedReason- -- | Checks if the given name is closed and emits an error if not. -- -- See Note [Not-closed error messages].@@ -1682,26 +1625,8 @@     --     -- when the final node has a non-closed type.     ---    explain :: Name -> NotClosedReason -> SDoc-    explain name reason =-      quotes (ppr name) <+> text "is used in a static form but it is not closed"-                        <+> text "because it"-                        $$-                        sep (causes reason)--    causes :: NotClosedReason -> [SDoc]-    causes NotLetBoundReason = [text "is not let-bound."]-    causes (NotTypeClosed vs) =-      [ text "has a non-closed type because it contains the"-      , text "type variables:" <+>-        pprVarSet vs (hsep . punctuate comma . map (quotes . ppr))-      ]-    causes (NotClosed n reason) =-      let msg = text "uses" <+> quotes (ppr n) <+> text "which"-       in case reason of-            NotClosed _ _ -> msg : causes reason-            _   -> let (xs0, xs1) = splitAt 1 $ causes reason-                    in fmap (msg <+>) xs0 ++ xs1+    explain :: Name -> NotClosedReason -> TcRnMessage+    explain = TcRnStaticFormNotClosed  -- Note [Not-closed error messages] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Tc/Gen/Expr.hs-boot view
@@ -1,7 +1,8 @@ module GHC.Tc.Gen.Expr where import GHC.Hs              ( HsExpr, LHsExpr, SyntaxExprRn                            , SyntaxExprTc )-import GHC.Tc.Utils.TcType ( TcRhoType, TcSigmaType, SyntaxOpType+import GHC.Tc.Utils.TcType ( TcRhoType, TcSigmaType, TcSigmaTypeFRR+                           , SyntaxOpType                            , ExpType, ExpRhoType, ExpSigmaType ) import GHC.Tc.Types        ( TcM ) import GHC.Tc.Types.Origin ( CtOrigin )@@ -32,13 +33,13 @@            -> SyntaxExprRn            -> [SyntaxOpType]           -- ^ shape of syntax operator arguments            -> ExpType                  -- ^ overall result type-           -> ([TcSigmaType] -> [Mult] -> TcM a) -- ^ Type check any arguments+           -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) -- ^ Type check any arguments            -> TcM (a, SyntaxExprTc)  tcSyntaxOpGen :: CtOrigin               -> SyntaxExprRn               -> [SyntaxOpType]               -> SyntaxOpType-              -> ([TcSigmaType] -> [Mult] -> TcM a)+              -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a)               -> TcM (a, SyntaxExprTc)
compiler/GHC/Tc/Gen/Foreign.hs view
@@ -4,7 +4,7 @@  -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -35,12 +35,11 @@         , tcCheckFEType         ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Hs +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Gen.HsType import GHC.Tc.Gen.Expr@@ -49,6 +48,7 @@ import GHC.Tc.Instance.Family import GHC.Core.FamInstEnv import GHC.Core.Coercion+import GHC.Core.Reduction import GHC.Core.Type import GHC.Core.Multiplicity import GHC.Types.ForeignCall@@ -71,7 +71,11 @@ import GHC.Driver.Hooks import qualified GHC.LanguageExtensions as LangExt -import Control.Monad+import Control.Monad ( zipWithM )+import Control.Monad.Trans.Writer.CPS+  ( WriterT, runWriterT, tell )+import Control.Monad.Trans.Class+  ( lift )  -- Defines a binding isForeignImport :: forall name. UnXRec name => LForeignDecl name -> Bool@@ -108,15 +112,15 @@ -- we are only allowed to look through newtypes if the constructor is -- in scope.  We return a bag of all the newtype constructors thus found. -- Always returns a Representational coercion-normaliseFfiType :: Type -> TcM (Coercion, Type, Bag GlobalRdrElt)+normaliseFfiType :: Type -> TcM (Reduction, Bag GlobalRdrElt) normaliseFfiType ty     = do fam_envs <- tcGetFamInstEnvs          normaliseFfiType' fam_envs ty -normaliseFfiType' :: FamInstEnvs -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt)-normaliseFfiType' env ty0 = go Representational initRecTc ty0+normaliseFfiType' :: FamInstEnvs -> Type -> TcM (Reduction, Bag GlobalRdrElt)+normaliseFfiType' env ty0 = runWriterT $ go Representational initRecTc ty0   where-    go :: Role -> RecTcChecker -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt)+    go :: Role -> RecTcChecker -> Type -> WriterT (Bag GlobalRdrElt) TcM Reduction     go role rec_nts ty       | Just ty' <- tcView ty     -- Expand synonyms       = go role rec_nts ty'@@ -126,15 +130,14 @@        | (bndrs, inner_ty) <- splitForAllTyCoVarBinders ty       , not (null bndrs)-      = do (coi, nty1, gres1) <- go role rec_nts inner_ty-           return ( mkHomoForAllCos (binderVars bndrs) coi-                  , mkForAllTys bndrs nty1, gres1 )+      = do redn <- go role rec_nts inner_ty+           return $ mkHomoForAllRedn bndrs redn        | otherwise -- see Note [Don't recur in normaliseFfiType']-      = return (mkReflCo role ty, ty, emptyBag)+      = return $ mkReflRedn role ty      go_tc_app :: Role -> RecTcChecker -> TyCon -> [Type]-              -> TcM (Coercion, Type, Bag GlobalRdrElt)+              -> WriterT (Bag GlobalRdrElt) TcM Reduction     go_tc_app role rec_nts tc tys         -- We don't want to look through the IO newtype, even if it is         -- in scope, so we have a special case for it:@@ -149,32 +152,34 @@                    --   Here, we don't reject the type for being recursive.                    -- If this is a recursive newtype then it will normally                    -- be rejected later as not being a valid FFI type.-        = do { rdr_env <- getGlobalRdrEnv+        = do { rdr_env <- lift $ getGlobalRdrEnv              ; case checkNewtypeFFI rdr_env tc of                  Nothing  -> nothing-                 Just gre -> do { (co', ty', gres) <- go role rec_nts' nt_rhs-                                ; return (mkTransCo nt_co co', ty', gre `consBag` gres) } }+                 Just gre ->+                   do { redn <- go role rec_nts' nt_rhs+                      ; tell (unitBag gre)+                      ; return $ nt_co `mkTransRedn` redn } }          | isFamilyTyCon tc              -- Expand open tycons-        , (co, ty) <- normaliseTcApp env role tc tys+        , Reduction co ty <- normaliseTcApp env role tc tys         , not (isReflexiveCo co)-        = do (co', ty', gres) <- go role rec_nts ty-             return (mkTransCo co co', ty', gres)+        = do redn <- go role rec_nts ty+             return $ co `mkTransRedn` redn          | otherwise         = nothing -- see Note [Don't recur in normaliseFfiType']         where           tc_key = getUnique tc           children_only-            = do xs <- zipWithM (\ty r -> go r rec_nts ty) tys (tyConRolesX role tc)-                 let (cos, tys', gres) = unzip3 xs-                 return ( mkTyConAppCo role tc cos-                        , mkTyConApp tc tys', unionManyBags gres)+            = do { args <- unzipRedns <$>+                            zipWithM ( \ ty r -> go r rec_nts ty )+                                     tys (tyConRolesX role tc)+                 ; return $ mkTyConAppRedn role tc args }           nt_co  = mkUnbranchedAxInstCo role (newTyConCo tc) tys []           nt_rhs = newTyConInstRhs tc tys            ty      = mkTyConApp tc tys-          nothing = return (mkReflCo role ty, ty, emptyBag)+          nothing = return $ mkReflRedn role ty  checkNewtypeFFI :: GlobalRdrEnv -> TyCon -> Maybe GlobalRdrElt checkNewtypeFFI rdr_env tc@@ -237,7 +242,7 @@                                     , fd_fi = imp_decl }))   = setSrcSpanA dloc $ addErrCtxt (foreignDeclCtxt fo)  $     do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty-       ; (norm_co, norm_sig_ty, gres) <- normaliseFfiType sig_ty+       ; (Reduction norm_co norm_sig_ty, gres) <- normaliseFfiType sig_ty        ; let            -- Drop the foralls before inspecting the            -- structure of the foreign type.@@ -261,22 +266,23 @@  tcCheckFIType :: [Scaled Type] -> Type -> ForeignImport -> TcM ForeignImport -tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh l@(CLabel _) src)+tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) safety mh l@(CLabel _) src)   -- Foreign import label-  = do checkCg checkCOrAsmOrLlvmOrInterp+  = do checkCg (Right idecl) checkCOrAsmOrLlvmOrInterp        -- NB check res_ty not sig_ty!        --    In case sig_ty is (forall a. ForeignPtr a)-       check (isFFILabelTy (mkVisFunTys arg_tys res_ty)) (illegalForeignTyErr Outputable.empty)-       cconv' <- checkCConv cconv+       check (isFFILabelTy (mkVisFunTys arg_tys res_ty))+             (TcRnIllegalForeignType Nothing)+       cconv' <- checkCConv (Right idecl) cconv        return (CImport (L lc cconv') safety mh l src) -tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh CWrapper src) = do+tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) safety mh CWrapper src) = do         -- Foreign wrapper (former f.e.d.)         -- The type must be of the form ft -> IO (FunPtr ft), where ft is a valid         -- foreign type.  For legacy reasons ft -> IO (Ptr ft) is accepted, too.         -- The use of the latter form is DEPRECATED, though.-    checkCg checkCOrAsmOrLlvmOrInterp-    cconv' <- checkCConv cconv+    checkCg (Right idecl) checkCOrAsmOrLlvmOrInterp+    cconv' <- checkCConv (Right idecl) cconv     case arg_tys of         [Scaled arg1_mult arg1_ty] -> do                         checkNoLinearFFI arg1_mult@@ -285,70 +291,66 @@                         checkForeignRes mustBeIO checkSafe (isFFIDynTy arg1_ty) res_ty                   where                      (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty-        _ -> addErrTc (illegalForeignTyErr Outputable.empty (text "One argument expected"))+        _ -> addErrTc (TcRnIllegalForeignType Nothing OneArgExpected)     return (CImport (L lc cconv') safety mh CWrapper src)  tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh                                             (CFunction target) src)   | isDynamicTarget target = do -- Foreign import dynamic-      checkCg checkCOrAsmOrLlvmOrInterp-      cconv' <- checkCConv cconv+      checkCg (Right idecl) checkCOrAsmOrLlvmOrInterp+      cconv' <- checkCConv (Right idecl) cconv       case arg_tys of           -- The first arg must be Ptr or FunPtr         []                ->-          addErrTc (illegalForeignTyErr Outputable.empty (text "At least one argument expected"))+          addErrTc (TcRnIllegalForeignType Nothing AtLeastOneArgExpected)         (Scaled arg1_mult arg1_ty:arg_tys) -> do           dflags <- getDynFlags           let curried_res_ty = mkVisFunTys arg_tys res_ty           checkNoLinearFFI arg1_mult           check (isFFIDynTy curried_res_ty arg1_ty)-                (illegalForeignTyErr argument)+                (TcRnIllegalForeignType (Just Arg))           checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys           checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty       return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src   | cconv == PrimCallConv = do       dflags <- getDynFlags       checkTc (xopt LangExt.GHCForeignImportPrim dflags)-              (text "Use GHCForeignImportPrim to allow `foreign import prim'.")-      checkCg checkCOrAsmOrLlvmOrInterp-      checkCTarget target+              (TcRnForeignImportPrimExtNotSet idecl)+      checkCg (Right idecl) checkCOrAsmOrLlvmOrInterp+      checkCTarget idecl target       checkTc (playSafe safety)-              (text "The safe/unsafe annotation should not be used with `foreign import prim'.")+              (TcRnForeignImportPrimSafeAnn idecl)       checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys       -- prim import result is more liberal, allows (#,,#)       checkForeignRes nonIOok checkSafe (isFFIPrimResultTy dflags) res_ty       return idecl   | otherwise = do              -- Normal foreign import-      checkCg checkCOrAsmOrLlvmOrInterp-      cconv' <- checkCConv cconv-      checkCTarget target+      checkCg (Right idecl) checkCOrAsmOrLlvmOrInterp+      cconv' <- checkCConv (Right idecl) cconv+      checkCTarget idecl target       dflags <- getDynFlags       checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys       checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty-      checkMissingAmpersand dflags (map scaledThing arg_tys) res_ty+      checkMissingAmpersand idecl (map scaledThing arg_tys) res_ty       case target of           StaticTarget _ _ _ False            | not (null arg_tys) ->-              addErrTc (text "`value' imports cannot have function types")+              addErrTc (TcRnForeignFunctionImportAsValue idecl)           _ -> return ()       return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src - -- This makes a convenient place to check -- that the C identifier is valid for C-checkCTarget :: CCallTarget -> TcM ()-checkCTarget (StaticTarget _ str _ _) = do-    checkCg checkCOrAsmOrLlvmOrInterp-    checkTc (isCLabelString str) (badCName str)--checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget"+checkCTarget :: ForeignImport -> CCallTarget -> TcM ()+checkCTarget idecl (StaticTarget _ str _ _) = do+    checkCg (Right idecl) checkCOrAsmOrLlvmOrInterp+    checkTc (isCLabelString str) (TcRnInvalidCIdentifier str) +checkCTarget _ DynamicTarget = panic "checkCTarget DynamicTarget" -checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM ()-checkMissingAmpersand dflags arg_tys res_ty-  | null arg_tys && isFunPtrTy res_ty &&-    wopt Opt_WarnDodgyForeignImports dflags-  = addWarn (Reason Opt_WarnDodgyForeignImports)-        (text "possible missing & in foreign import of FunPtr")+checkMissingAmpersand :: ForeignImport -> [Type] -> Type -> TcM ()+checkMissingAmpersand idecl arg_tys res_ty+  | null arg_tys && isFunPtrTy res_ty+  = addDiagnosticTc $ TcRnFunPtrImportWithoutAmpersand idecl   | otherwise   = return () @@ -387,7 +389,7 @@     sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty     rhs <- tcCheckPolyExpr (nlHsVar nm) sig_ty -    (norm_co, norm_sig_ty, gres) <- normaliseFfiType sig_ty+    (Reduction norm_co norm_sig_ty, gres) <- normaliseFfiType sig_ty      spec' <- tcCheckFEType norm_sig_ty spec @@ -404,17 +406,18 @@     return ( mkVarBind id rhs            , ForeignExport { fd_name = L loc id                            , fd_sig_ty = undefined-                           , fd_e_ext = norm_co, fd_fe = spec' }+                           , fd_e_ext = norm_co+                           , fd_fe = spec' }            , gres) tcFExport d = pprPanic "tcFExport" (ppr d)  -- ------------ Checking argument types for foreign export ----------------------  tcCheckFEType :: Type -> ForeignExport -> TcM ForeignExport-tcCheckFEType sig_ty (CExport (L l (CExportStatic esrc str cconv)) src) = do-    checkCg checkCOrAsmOrLlvm-    checkTc (isCLabelString str) (badCName str)-    cconv' <- checkCConv cconv+tcCheckFEType sig_ty edecl@(CExport (L l (CExportStatic esrc str cconv)) src) = do+    checkCg (Left edecl) checkCOrAsmOrLlvm+    checkTc (isCLabelString str) (TcRnInvalidCIdentifier str)+    cconv' <- checkCConv (Left edecl) cconv     checkForeignArgs isFFIExternalTy arg_tys     checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty     return (CExport (L l (CExportStatic esrc str cconv')) src)@@ -432,16 +435,16 @@ -}  ------------ Checking argument types for foreign import -----------------------checkForeignArgs :: (Type -> Validity) -> [Scaled Type] -> TcM ()+checkForeignArgs :: (Type -> Validity' IllegalForeignTypeReason) -> [Scaled Type] -> TcM () checkForeignArgs pred tys = mapM_ go tys   where     go (Scaled mult ty) = checkNoLinearFFI mult >>-                          check (pred ty) (illegalForeignTyErr argument)+                          check (pred ty) (TcRnIllegalForeignType (Just Arg))  checkNoLinearFFI :: Mult -> TcM ()  -- No linear types in FFI (#18472) checkNoLinearFFI Many = return ()-checkNoLinearFFI _    = addErrTc $ illegalForeignTyErr argument-                                   (text "Linear types are not supported in FFI declarations, see #18472")+checkNoLinearFFI _    = addErrTc $ TcRnIllegalForeignType (Just Arg)+                                   LinearTypesNotAllowed  ------------ Checking result types for foreign calls ---------------------- -- | Check that the type has the form@@ -452,41 +455,39 @@ -- We also check that the Safe Haskell condition of FFI imports having -- results in the IO monad holds. ---checkForeignRes :: Bool -> Bool -> (Type -> Validity) -> Type -> TcM ()+checkForeignRes :: Bool -> Bool -> (Type -> Validity' IllegalForeignTypeReason) -> Type -> TcM () checkForeignRes non_io_result_ok check_safe pred_res_ty ty   | Just (_, res_ty) <- tcSplitIOType_maybe ty   =     -- Got an IO result type, that's always fine!-     check (pred_res_ty res_ty) (illegalForeignTyErr result)+     check (pred_res_ty res_ty)+           (TcRnIllegalForeignType (Just Result))    -- We disallow nested foralls in foreign types   -- (at least, for the time being). See #16702.   | tcIsForAllTy ty-  = addErrTc $ illegalForeignTyErr result (text "Unexpected nested forall")+  = addErrTc $ TcRnIllegalForeignType (Just Result) UnexpectedNestedForall    -- Case for non-IO result type with FFI Import   | not non_io_result_ok-  = addErrTc $ illegalForeignTyErr result (text "IO result type expected")+  = addErrTc $ TcRnIllegalForeignType (Just Result) IOResultExpected    | otherwise   = do { dflags <- getDynFlags        ; case pred_res_ty ty of                 -- Handle normal typecheck fail, we want to handle this first and                 -- only report safe haskell errors if the normal type check is OK.-           NotValid msg -> addErrTc $ illegalForeignTyErr result msg+           NotValid msg -> addErrTc $ TcRnIllegalForeignType (Just Result) msg             -- handle safe infer fail            _ | check_safe && safeInferOn dflags-               -> recordUnsafeInfer emptyBag+               -> recordUnsafeInfer emptyMessages             -- handle safe language typecheck fail            _ | check_safe && safeLanguageOn dflags-               -> addErrTc (illegalForeignTyErr result safeHsErr)+               -> addErrTc (TcRnIllegalForeignType (Just Result) SafeHaskellMustBeInIO)             -- success! non-IO return is fine            _ -> return () }-  where-    safeHsErr =-      text "Safe Haskell is on, all FFI imports must be in the IO monad"  nonIOok, mustBeIO :: Bool nonIOok  = True@@ -497,76 +498,64 @@ noCheckSafe = False  -- | Checking a supported backend is in use-checkCOrAsmOrLlvm :: Backend -> Validity+checkCOrAsmOrLlvm :: Backend -> Validity' ExpectedBackends checkCOrAsmOrLlvm ViaC = IsValid checkCOrAsmOrLlvm NCG  = IsValid checkCOrAsmOrLlvm LLVM = IsValid-checkCOrAsmOrLlvm _-  = NotValid (text "requires unregisterised, llvm (-fllvm) or native code generation (-fasm)")+checkCOrAsmOrLlvm _    = NotValid COrAsmOrLlvm  -- | Checking a supported backend is in use-checkCOrAsmOrLlvmOrInterp :: Backend -> Validity+checkCOrAsmOrLlvmOrInterp :: Backend -> Validity' ExpectedBackends checkCOrAsmOrLlvmOrInterp ViaC        = IsValid checkCOrAsmOrLlvmOrInterp NCG         = IsValid checkCOrAsmOrLlvmOrInterp LLVM        = IsValid checkCOrAsmOrLlvmOrInterp Interpreter = IsValid-checkCOrAsmOrLlvmOrInterp _-  = NotValid (text "requires interpreted, unregisterised, llvm or native code generation")+checkCOrAsmOrLlvmOrInterp _           = NotValid COrAsmOrLlvmOrInterp -checkCg :: (Backend -> Validity) -> TcM ()-checkCg check = do+checkCg :: Either ForeignExport ForeignImport -> (Backend -> Validity' ExpectedBackends) -> TcM ()+checkCg decl check = do     dflags <- getDynFlags     let bcknd = backend dflags     case bcknd of       NoBackend -> return ()       _ ->         case check bcknd of-          IsValid      -> return ()-          NotValid err -> addErrTc (text "Illegal foreign declaration:" <+> err)+          IsValid -> return ()+          NotValid expectedBcknd ->+            addErrTc $ TcRnIllegalForeignDeclBackend decl bcknd expectedBcknd  -- Calling conventions -checkCConv :: CCallConv -> TcM CCallConv-checkCConv CCallConv    = return CCallConv-checkCConv CApiConv     = return CApiConv-checkCConv StdCallConv  = do dflags <- getDynFlags-                             let platform = targetPlatform dflags-                             if platformArch platform == ArchX86-                                 then return StdCallConv-                                 else do -- This is a warning, not an error. see #3336-                                         when (wopt Opt_WarnUnsupportedCallingConventions dflags) $-                                             addWarnTc (Reason Opt_WarnUnsupportedCallingConventions)-                                                 (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall")-                                         return CCallConv-checkCConv PrimCallConv = do addErrTc (text "The `prim' calling convention can only be used with `foreign import'")-                             return PrimCallConv-checkCConv JavaScriptCallConv = do dflags <- getDynFlags-                                   if platformArch (targetPlatform dflags) == ArchJavaScript-                                       then return JavaScriptCallConv-                                       else do addErrTc (text "The `javascript' calling convention is unsupported on this platform")-                                               return JavaScriptCallConv+checkCConv :: Either ForeignExport ForeignImport -> CCallConv -> TcM CCallConv+checkCConv _ CCallConv    = return CCallConv+checkCConv _ CApiConv     = return CApiConv+checkCConv decl StdCallConv = do+  dflags <- getDynFlags+  let platform = targetPlatform dflags+  if platformArch platform == ArchX86+      then return StdCallConv+      else do -- This is a warning, not an error. see #3336+              let msg = TcRnUnsupportedCallConv decl StdCallConvUnsupported+              addDiagnosticTc msg+              return CCallConv+checkCConv decl PrimCallConv = do+  addErrTc $ TcRnUnsupportedCallConv decl PrimCallConvUnsupported+  return PrimCallConv+checkCConv decl JavaScriptCallConv = do+  dflags <- getDynFlags+  if platformArch (targetPlatform dflags) == ArchJavaScript+      then return JavaScriptCallConv+      else do+        addErrTc $ TcRnUnsupportedCallConv decl JavaScriptCallConvUnsupported+        return JavaScriptCallConv  -- Warnings -check :: Validity -> (SDoc -> SDoc) -> TcM ()-check IsValid _             = return ()-check (NotValid doc) err_fn = addErrTc (err_fn doc)--illegalForeignTyErr :: SDoc -> SDoc -> SDoc-illegalForeignTyErr arg_or_res extra-  = hang msg 2 extra-  where-    msg = hsep [ text "Unacceptable", arg_or_res-               , text "type in foreign declaration:"]---- Used for 'arg_or_res' argument to illegalForeignTyErr-argument, result :: SDoc-argument = text "argument"-result   = text "result"--badCName :: CLabelString -> SDoc-badCName target-  = sep [quotes (ppr target) <+> text "is not a valid C identifier"]+check :: Validity' IllegalForeignTypeReason+      -> (IllegalForeignTypeReason -> TcRnMessage)+      -> TcM ()+check IsValid _                   = return ()+check (NotValid reason) mkMessage = addErrTc (mkMessage reason)  foreignDeclCtxt :: ForeignDecl GhcRn -> SDoc foreignDeclCtxt fo
compiler/GHC/Tc/Gen/Head.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE DataKinds           #-} {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE GADTs               #-}@@ -6,6 +6,8 @@ {-# LANGUAGE TupleSections       #-} {-# LANGUAGE TypeFamilies        #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]+{-# LANGUAGE ViewPatterns        #-}+{-# LANGUAGE DisambiguateRecordFields #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-} @@ -21,10 +23,11 @@        , splitHsApps, rebuildHsApps        , addArgWrap, isHsValArg        , countLeadingValArgs, isVisibleArg, pprHsExprArgTc+       , countVisAndInvisValArgs, countHsWrapperInvisArgs         , tcInferAppHead, tcInferAppHead_maybe        , tcInferId, tcCheckId-       , obviousSig, addAmbiguousNameErr+       , obviousSig        , tyConOf, tyConOfET, lookupParents, fieldNotInType        , notSelector, nonBidirectionalErr @@ -33,29 +36,31 @@ import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckMonoExprNC, tcCheckPolyExprNC )  import GHC.Tc.Gen.HsType-import GHC.Tc.Gen.Pat import GHC.Tc.Gen.Bind( chooseInferredQuantifiers )-import GHC.Tc.Gen.Sig( tcUserTypeSig, tcInstSig )+import GHC.Tc.Gen.Sig( tcUserTypeSig, tcInstSig, lhsSigWcTypeContextSpan ) import GHC.Tc.TyCl.PatSyn( patSynBuilderOcc ) import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Unify import GHC.Types.Basic+import GHC.Types.Error import GHC.Tc.Utils.Instantiate-import GHC.Tc.Instance.Family ( tcGetFamInstEnvs, tcLookupDataFamInst )+import GHC.Tc.Instance.Family ( tcLookupDataFamInst ) import GHC.Core.FamInstEnv    ( FamInstEnvs ) import GHC.Core.UsageEnv      ( unitUE )-import GHC.Rename.Env         ( addUsedGRE )-import GHC.Rename.Utils       ( addNameClashErrRn, unknownSubordinateErr )+import GHC.Rename.Unbound     ( unknownNameSuggestions, WhatLooking(..) )+import GHC.Unit.Module        ( getModule )+import GHC.Tc.Errors.Types import GHC.Tc.Solver          ( InferMode(..), simplifyInfer ) import GHC.Tc.Utils.Env-import GHC.Tc.Utils.Zonk      ( hsLitType ) import GHC.Tc.Utils.TcMType import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType as TcType import GHC.Hs+import GHC.Hs.Syn.Type import GHC.Types.Id import GHC.Types.Id.Info-import GHC.Core.ConLike+import GHC.Core.PatSyn( PatSyn )+import GHC.Core.ConLike( ConLike(..) ) import GHC.Core.DataCon import GHC.Types.Name import GHC.Types.Name.Reader@@ -66,19 +71,18 @@ import GHC.Builtin.Types( multiplicityTy ) import GHC.Builtin.Names import GHC.Builtin.Names.TH( liftStringName, liftName )+import GHC.Driver.Env import GHC.Driver.Session import GHC.Types.SrcLoc import GHC.Utils.Misc import GHC.Data.Maybe import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import Control.Monad  import Data.Function-import qualified Data.List.NonEmpty as NE -#include "GhclibHsVersions.h"- import GHC.Prelude  @@ -245,7 +249,7 @@ -- See Note [splitHsApps] splitHsApps e = go e (top_ctxt 0 e) []   where-    top_ctxt n (HsPar _ fun)               = top_lctxt n fun+    top_ctxt n (HsPar _ _ fun _)           = top_lctxt n fun     top_ctxt n (HsPragE _ _ fun)           = top_lctxt n fun     top_ctxt n (HsAppType _ fun _)         = top_lctxt (n+1) fun     top_ctxt n (HsApp _ fun _)             = top_lctxt (n+1) fun@@ -256,7 +260,7 @@      go :: HsExpr GhcRn -> AppCtxt -> [HsExprArg 'TcpRn]        -> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn])-    go (HsPar _     (L l fun))    ctxt args = go fun (set l ctxt) (EWrap (EPar ctxt)   : args)+    go (HsPar _ _ (L l fun) _)    ctxt args = go fun (set l ctxt) (EWrap (EPar ctxt)   : args)     go (HsPragE _ p (L l fun))    ctxt args = go fun (set l ctxt) (EPrag      ctxt p   : args)     go (HsAppType _ (L l fun) ty) ctxt args = go fun (dec l ctxt) (mkETypeArg ctxt ty  : args)     go (HsApp _ (L l fun) arg)    ctxt args = go fun (dec l ctxt) (mkEValArg  ctxt arg : args)@@ -294,7 +298,7 @@       EPrag ctxt' p         -> rebuildHsApps (HsPragE noExtField p lfun) ctxt' args       EWrap (EPar ctxt')-        -> rebuildHsApps (HsPar noAnn lfun) ctxt' args+        -> rebuildHsApps (gHsPar lfun) ctxt' args       EWrap (EExpand orig)         -> rebuildHsApps (XExpr (ExpansionExpr (HsExpanded orig fun))) ctxt args       EWrap (EHsWrap wrap)@@ -322,6 +326,36 @@ isVisibleArg (ETypeArg {}) = True isVisibleArg _             = False +-- | Count visible and invisible value arguments in a list+-- of 'HsExprArg' arguments.+countVisAndInvisValArgs :: [HsExprArg id] -> Arity+countVisAndInvisValArgs []                  = 0+countVisAndInvisValArgs (EValArg {} : args) = 1 + countVisAndInvisValArgs args+countVisAndInvisValArgs (EWrap wrap : args) =+  case wrap of { EHsWrap hsWrap            -> countHsWrapperInvisArgs hsWrap + countVisAndInvisValArgs args+               ; EPar   {}                 -> countVisAndInvisValArgs args+               ; EExpand {}                -> countVisAndInvisValArgs args }+countVisAndInvisValArgs (EPrag {}   : args) = countVisAndInvisValArgs args+countVisAndInvisValArgs (ETypeArg {}: args) = countVisAndInvisValArgs args++-- | Counts the number of invisible term-level arguments applied by an 'HsWrapper'.+-- Precondition: this wrapper contains no abstractions.+countHsWrapperInvisArgs :: HsWrapper -> Arity+countHsWrapperInvisArgs = go+  where+    go WpHole = 0+    go (WpCompose wrap1 wrap2) = go wrap1 + go wrap2+    go fun@(WpFun {}) = nope fun+    go (WpCast {}) = 0+    go evLam@(WpEvLam {}) = nope evLam+    go (WpEvApp _) = 1+    go tyLam@(WpTyLam {}) = nope tyLam+    go (WpTyApp _) = 0+    go (WpLet _) = 0+    go (WpMultCoercion {}) = 0++    nope x = pprPanic "countHsWrapperInvisApps" (ppr x)+ instance OutputableBndrId (XPass p) => Outputable (HsExprArg p) where   ppr (EValArg { eva_arg = arg })      = text "EValArg" <+> ppr arg   ppr (EPrag _ p)                      = text "EPrag" <+> ppr p@@ -373,22 +407,21 @@ ********************************************************************* -}  tcInferAppHead :: (HsExpr GhcRn, AppCtxt)-               -> [HsExprArg 'TcpRn] -> Maybe TcRhoType-               -- These two args are solely for tcInferRecSelId+               -> [HsExprArg 'TcpRn]                -> TcM (HsExpr GhcTc, TcSigmaType) -- Infer type of the head of an application --   i.e. the 'f' in (f e1 ... en) -- See Note [Application chains and heads] in GHC.Tc.Gen.App -- We get back a /SigmaType/ because we have special cases for --   * A bare identifier (just look it up)---     This case also covers a record selector HsRecFld+--     This case also covers a record selector HsRecSel --   * An expression with a type signature (e :: ty) -- See Note [Application chains and heads] in GHC.Tc.Gen.App ----- Why do we need the arguments to infer the type of the head of--- the application?  For two reasons:---   * (Legitimate) The first arg has the source location of the head---   * (Disgusting) Needed for record disambiguation; see tcInferRecSelId+-- Why do we need the arguments to infer the type of the head of the+-- application? Simply to inform add_head_ctxt about whether or not+-- to put push a new "In the expression..." context. (We don't push a+-- new one if there are no arguments, because we already have.) -- -- Note that [] and (,,) are both HsVar: --   see Note [Empty lists] and [ExplicitTuple] in GHC.Hs.Expr@@ -397,29 +430,28 @@ --     cases are dealt with by splitHsApps. -- -- See Note [tcApp: typechecking applications] in GHC.Tc.Gen.App-tcInferAppHead (fun,ctxt) args mb_res_ty+tcInferAppHead (fun,ctxt) args   = setSrcSpan (appCtxtLoc ctxt) $-    do { mb_tc_fun <- tcInferAppHead_maybe fun args mb_res_ty+    do { mb_tc_fun <- tcInferAppHead_maybe fun args        ; case mb_tc_fun of             Just (fun', fun_sigma) -> return (fun', fun_sigma)             Nothing -> add_head_ctxt fun args $                        tcInfer (tcExpr fun) }  tcInferAppHead_maybe :: HsExpr GhcRn-                     -> [HsExprArg 'TcpRn] -> Maybe TcRhoType-                        -- These two args are solely for tcInferRecSelId+                     -> [HsExprArg 'TcpRn]                      -> TcM (Maybe (HsExpr GhcTc, TcSigmaType)) -- See Note [Application chains and heads] in GHC.Tc.Gen.App -- Returns Nothing for a complicated head-tcInferAppHead_maybe fun args mb_res_ty+tcInferAppHead_maybe fun args   = case fun of       HsVar _ (L _ nm)          -> Just <$> tcInferId nm-      HsRecFld _ f              -> Just <$> tcInferRecSelId f args mb_res_ty+      HsRecSel _ f              -> Just <$> tcInferRecSelId f       ExprWithTySig _ e hs_ty   -> add_head_ctxt fun args $                                    Just <$> tcExprWithSig e hs_ty       HsOverLit _ lit           -> Just <$> tcInferOverLit lit       HsSpliceE _ (HsSpliced _ _ (HsSplicedExpr e))-                                -> tcInferAppHead_maybe e args mb_res_ty+                                -> tcInferAppHead_maybe e args       _                         -> return Nothing  add_head_ctxt :: HsExpr GhcRn -> [HsExprArg 'TcpRn] -> TcM a -> TcM a@@ -436,224 +468,46 @@ *                                                                      * ********************************************************************* -} -{--Note [Deprecating ambiguous fields]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In the future, the -XDuplicateRecordFields extension will no longer support-disambiguating record fields during type-checking (as described in Note-[Disambiguating record fields]).  For now, the -Wambiguous-fields option will-emit a warning whenever an ambiguous field is resolved using type information.-In a subsequent GHC release, this functionality will be removed and the warning-will turn into an ambiguity error in the renamer.--For background information, see GHC proposal #366-(https://github.com/ghc-proposals/ghc-proposals/pull/366).---Note [Disambiguating record fields]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-NB. The following is going to be removed: see-Note [Deprecating ambiguous fields].--When the -XDuplicateRecordFields extension is used, and the renamer-encounters a record selector or update that it cannot immediately-disambiguate (because it involves fields that belong to multiple-datatypes), it will defer resolution of the ambiguity to the-typechecker.  In this case, the `Ambiguous` constructor of-`AmbiguousFieldOcc` is used.--Consider the following definitions:--        data S = MkS { foo :: Int }-        data T = MkT { foo :: Int, bar :: Int }-        data U = MkU { bar :: Int, baz :: Int }--When the renamer sees `foo` as a selector or an update, it will not-know which parent datatype is in use.--For selectors, there are two possible ways to disambiguate:--1. Check if the pushed-in type is a function whose domain is a-   datatype, for example:--       f s = (foo :: S -> Int) s--       g :: T -> Int-       g = foo--    This is checked by `tcCheckRecSelId` when checking `HsRecFld foo`.--2. Check if the selector is applied to an argument that has a type-   signature, for example:--       h = foo (s :: S)--    This is checked by `tcInferRecSelId`.---Updates are slightly more complex.  The `disambiguateRecordBinds`-function tries to determine the parent datatype in three ways:--1. Check for types that have all the fields being updated. For example:--        f x = x { foo = 3, bar = 2 }--   Here `f` must be updating `T` because neither `S` nor `U` have-   both fields. This may also discover that no possible type exists.-   For example the following will be rejected:--        f' x = x { foo = 3, baz = 3 }--2. Use the type being pushed in, if it is already a TyConApp. The-   following are valid updates to `T`:--        g :: T -> T-        g x = x { foo = 3 }--        g' x = x { foo = 3 } :: T--3. Use the type signature of the record expression, if it exists and-   is a TyConApp. Thus this is valid update to `T`:--        h x = (x :: T) { foo = 3 }---Note that we do not look up the types of variables being updated, and-no constraint-solving is performed, so for example the following will-be rejected as ambiguous:--     let bad (s :: S) = foo s--     let r :: T-         r = blah-     in r { foo = 3 }--     \r. (r { foo = 3 },  r :: T )--We could add further tests, of a more heuristic nature. For example,-rather than looking for an explicit signature, we could try to infer-the type of the argument to a selector or the record expression being-updated, in case we are lucky enough to get a TyConApp straight-away. However, it might be hard for programmers to predict whether a-particular update is sufficiently obvious for the signature to be-omitted. Moreover, this might change the behaviour of typechecker in-non-obvious ways.--See also Note [HsRecField and HsRecUpdField] in GHC.Hs.Pat.--}--tcInferRecSelId :: AmbiguousFieldOcc GhcRn-                -> [HsExprArg 'TcpRn] -> Maybe TcRhoType+tcInferRecSelId :: FieldOcc GhcRn                 -> TcM (HsExpr GhcTc, TcSigmaType)-tcInferRecSelId (Unambiguous sel_name lbl) _args _mb_res_ty-   = do { sel_id <- tc_rec_sel_id lbl sel_name-        ; let expr = HsRecFld noExtField (Unambiguous sel_id lbl)-        ; return (expr, idType sel_id) }--tcInferRecSelId (Ambiguous _ lbl) args mb_res_ty-   = do { sel_name <- tcInferAmbiguousRecSelId lbl args mb_res_ty-        ; sel_id   <- tc_rec_sel_id lbl sel_name-        ; let expr = HsRecFld noExtField (Ambiguous sel_id lbl)-        ; return (expr, idType sel_id) }+tcInferRecSelId (FieldOcc sel_name lbl)+   = do { sel_id <- tc_rec_sel_id+        ; let expr = HsRecSel noExtField (FieldOcc sel_id lbl)+        ; return (expr, idType sel_id)+        }+     where+       occ :: OccName+       occ = rdrNameOcc (unLoc lbl) --------------------------tc_rec_sel_id :: LocatedN RdrName -> Name -> TcM TcId--- Like tc_infer_id, but returns an Id not a HsExpr,--- so we can wrap it back up into a HsRecFld-tc_rec_sel_id lbl sel_name-  = do { thing <- tcLookup sel_name-       ; case thing of-             ATcId { tct_id = id }-               -> do { check_naughty occ id-                     ; check_local_id id-                     ; return id }+       tc_rec_sel_id :: TcM TcId+       -- Like tc_infer_id, but returns an Id not a HsExpr,+       -- so we can wrap it back up into a HsRecSel+       tc_rec_sel_id+         = do { thing <- tcLookup sel_name+              ; case thing of+                    ATcId { tct_id = id }+                      -> do { check_naughty occ id  -- See Note [Local record selectors]+                            ; check_local_id id+                            ; return id } -             AGlobal (AnId id)-               -> do { check_naughty occ id-                     ; return id }-                    -- A global cannot possibly be ill-staged-                    -- nor does it need the 'lifting' treatment-                    -- hence no checkTh stuff here+                    AGlobal (AnId id)+                      -> do { check_naughty occ id+                            ; return id }+                           -- A global cannot possibly be ill-staged+                           -- nor does it need the 'lifting' treatment+                           -- hence no checkTh stuff here -             _ -> failWithTc $-                  ppr thing <+> text "used where a value identifier was expected" }-  where-    occ = rdrNameOcc (unLoc lbl)+                    _ -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $+                         ppr thing <+> text "used where a value identifier was expected" }  -------------------------tcInferAmbiguousRecSelId :: LocatedN RdrName-                         -> [HsExprArg 'TcpRn] -> Maybe TcRhoType-                         -> TcM Name--- Disgusting special case for ambiguous record selectors--- Given a RdrName that refers to multiple record fields, and the type--- of its argument, try to determine the name of the selector that is--- meant.--- See Note [Disambiguating record fields]-tcInferAmbiguousRecSelId lbl args mb_res_ty-  | arg1 : _ <- dropWhile (not . isVisibleArg) args -- A value arg is first-  , EValArg { eva_arg = ValArg (L _ arg) } <- arg1-  , Just sig_ty <- obviousSig arg  -- A type sig on the arg disambiguates-  = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty-       ; finish_ambiguous_selector lbl sig_tc_ty } -  | Just res_ty <- mb_res_ty-  , Just (arg_ty,_) <- tcSplitFunTy_maybe res_ty-  = finish_ambiguous_selector lbl (scaledThing arg_ty)--  | otherwise-  = ambiguousSelector lbl--finish_ambiguous_selector :: LocatedN RdrName -> Type -> TcM Name-finish_ambiguous_selector lr@(L _ rdr) parent_type- = do { fam_inst_envs <- tcGetFamInstEnvs-      ; case tyConOf fam_inst_envs parent_type of {-          Nothing -> ambiguousSelector lr ;-          Just p  ->--    do { xs <- lookupParents True rdr-       ; let parent = RecSelData p-       ; case lookup parent xs of {-           Nothing  -> failWithTc (fieldNotInType parent rdr) ;-           Just gre ->--    -- See Note [Unused name reporting and HasField] in GHC.Tc.Instance.Class-    do { addUsedGRE True gre-       ; keepAlive (greMangledName gre)-         -- See Note [Deprecating ambiguous fields]-       ; warnIfFlag Opt_WarnAmbiguousFields True $-          vcat [ text "The field" <+> quotes (ppr rdr)-                   <+> text "belonging to type" <+> ppr parent_type-                   <+> text "is ambiguous."-               , text "This will not be supported by -XDuplicateRecordFields in future releases of GHC."-               , if isLocalGRE gre-                 then text "You can use explicit case analysis to resolve the ambiguity."-                 else text "You can use a qualified import or explicit case analysis to resolve the ambiguity."-               ]-       ; return (greMangledName gre) } } } } }---- This field name really is ambiguous, so add a suitable "ambiguous--- occurrence" error, then give up.-ambiguousSelector :: LocatedN RdrName -> TcM a-ambiguousSelector (L _ rdr)-  = do { addAmbiguousNameErr rdr-       ; failM }---- | This name really is ambiguous, so add a suitable "ambiguous--- occurrence" error, then continue-addAmbiguousNameErr :: RdrName -> TcM ()-addAmbiguousNameErr rdr-  = do { env <- getGlobalRdrEnv-       ; let gres = lookupGRE_RdrName rdr env-       ; case gres of-         [] -> panic "addAmbiguousNameErr: not found"-         gre : gres -> setErrCtxt [] $ addNameClashErrRn rdr $ gre NE.:| gres}- -- A type signature on the argument of an ambiguous record selector or -- the record expression in an update must be "obvious", i.e. the -- outermost constructor ignoring parentheses. obviousSig :: HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn) obviousSig (ExprWithTySig _ _ ty) = Just ty-obviousSig (HsPar _ p)            = obviousSig (unLoc p)+obviousSig (HsPar _ _ p _)        = obviousSig (unLoc p) obviousSig (HsPragE _ _ p)        = obviousSig (unLoc p) obviousSig _                      = Nothing @@ -693,17 +547,20 @@                               Nothing -> failWithTc (notSelector (greMangledName gre)) }  -fieldNotInType :: RecSelParent -> RdrName -> SDoc+fieldNotInType :: RecSelParent -> RdrName -> TcRnMessage fieldNotInType p rdr-  = unknownSubordinateErr (text "field of type" <+> quotes (ppr p)) rdr+  = mkTcRnNotInScope rdr $+    UnknownSubordinate (text "field of type" <+> quotes (ppr p)) -notSelector :: Name -> SDoc+notSelector :: Name -> TcRnMessage notSelector field-  = hsep [quotes (ppr field), text "is not a record selector"]+  = TcRnUnknownMessage $ mkPlainError noHints $+  hsep [quotes (ppr field), text "is not a record selector"] -naughtyRecordSel :: OccName -> SDoc+naughtyRecordSel :: OccName -> TcRnMessage naughtyRecordSel lbl-  = text "Cannot use record selector" <+> quotes (ppr lbl) <+>+  = TcRnUnknownMessage $ mkPlainError noHints $+    text "Cannot use record selector" <+> quotes (ppr lbl) <+>     text "as a function due to escaped type variables" $$     text "Probable fix: use pattern-matching syntax instead" @@ -720,20 +577,21 @@ tcExprWithSig expr hs_ty   = do { sig_info <- checkNoErrs $  -- Avoid error cascade                      tcUserTypeSig loc hs_ty Nothing-       ; (expr', poly_ty) <- tcExprSig expr sig_info+       ; (expr', poly_ty) <- tcExprSig ctxt expr sig_info        ; return (ExprWithTySig noExtField expr' hs_ty, poly_ty) }   where     loc = getLocA (dropWildCards hs_ty)+    ctxt = ExprSigCtxt (lhsSigWcTypeContextSpan hs_ty) -tcExprSig :: LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcType)-tcExprSig expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc })+tcExprSig :: UserTypeCtxt -> LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcType)+tcExprSig ctxt expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc })   = setSrcSpan loc $   -- Sets the location for the implication constraint     do { let poly_ty = idType poly_id-       ; (wrap, expr') <- tcSkolemiseScoped ExprSigCtxt poly_ty $ \rho_ty ->+       ; (wrap, expr') <- tcSkolemiseScoped ctxt poly_ty $ \rho_ty ->                           tcCheckMonoExprNC expr rho_ty        ; return (mkLHsWrap wrap expr', poly_ty) } -tcExprSig expr sig@(PartialSig { psig_name = name, sig_loc = loc })+tcExprSig _ expr sig@(PartialSig { psig_name = name, sig_loc = loc })   = setSrcSpan loc $   -- Sets the location for the implication constraint     do { (tclvl, wanted, (expr', sig_inst))              <- pushLevelAndCaptureConstraints  $@@ -749,13 +607,14 @@                         = ApplyMR                         | otherwise                         = NoRestrictions-       ; (qtvs, givens, ev_binds, _)-                 <- simplifyInfer tclvl infer_mode [sig_inst] [(name, tau)] wanted+       ; ((qtvs, givens, ev_binds, _), residual)+           <- captureConstraints $ simplifyInfer tclvl infer_mode [sig_inst] [(name, tau)] wanted+       ; emitConstraints residual         ; tau <- zonkTcType tau        ; let inferred_theta = map evVarPred givens              tau_tvs        = tyCoVarsOfType tau-       ; (binders, my_theta) <- chooseInferredQuantifiers inferred_theta+       ; (binders, my_theta) <- chooseInferredQuantifiers residual inferred_theta                                    tau_tvs qtvs (Just sig_inst)        ; let inferred_sigma = mkInfSigmaTy qtvs inferred_theta tau              my_sigma       = mkInvisForAllTys binders (mkPhiTy  my_theta tau)@@ -763,7 +622,7 @@                  then return idHsWrapper  -- Fast path; also avoids complaint when we infer                                           -- an ambiguous type and have AllowAmbiguousType                                           -- e..g infer  x :: forall a. F a -> Int-                 else tcSubTypeSigma ExprSigOrigin ExprSigCtxt inferred_sigma my_sigma+                 else tcSubTypeSigma ExprSigOrigin (ExprSigCtxt NoRRC) inferred_sigma my_sigma         ; traceTc "tcExpSig" (ppr qtvs $$ ppr givens $$ ppr inferred_sigma $$ ppr my_sigma)        ; let poly_wrap = wrap@@ -810,37 +669,33 @@  tcInferOverLit :: HsOverLit GhcRn -> TcM (HsExpr GhcTc, TcSigmaType) tcInferOverLit lit@(OverLit { ol_val = val-                            , ol_witness = HsVar _ (L loc from_name)-                            , ol_ext = rebindable })+                            , ol_ext = OverLitRn { ol_rebindable = rebindable+                                                 , ol_from_fun = L loc from_name } })   = -- Desugar "3" to (fromInteger (3 :: Integer))     --   where fromInteger is gotten by looking up from_name, and     --   the (3 :: Integer) is returned by mkOverLit     -- Ditto the string literal "foo" to (fromString ("foo" :: String))-    do { from_id <- tcLookupId from_name-       ; (wrap1, from_ty) <- topInstantiate orig (idType from_id)--       ; (wrap2, sarg_ty, res_ty) <- matchActualFunTySigma herald mb_doc+    do { hs_lit <- mkOverLit val+       ; from_id <- tcLookupId from_name+       ; (wrap1, from_ty) <- topInstantiate (LiteralOrigin lit) (idType from_id)+       ; let+           thing    = NameThing from_name+           mb_thing = Just thing+           herald   = ExpectedFunTyArg thing (HsLit noAnn hs_lit)+       ; (wrap2, sarg_ty, res_ty) <- matchActualFunTySigma herald mb_thing                                                            (1, []) from_ty-       ; hs_lit <- mkOverLit val-       ; co <- unifyType mb_doc (hsLitType hs_lit) (scaledThing sarg_ty) +       ; co <- unifyType mb_thing (hsLitType hs_lit) (scaledThing sarg_ty)        ; let lit_expr = L (l2l loc) $ mkHsWrapCo co $                         HsLit noAnn hs_lit              from_expr = mkHsWrap (wrap2 <.> wrap1) $                          HsVar noExtField (L loc from_id)-             lit' = lit { ol_witness = HsApp noAnn (L (l2l loc) from_expr) lit_expr-                        , ol_ext = OverLitTc rebindable res_ty }+             witness = HsApp noAnn (L (l2l loc) from_expr) lit_expr+             lit' = lit { ol_ext = OverLitTc { ol_rebindable = rebindable+                                             , ol_witness = witness+                                             , ol_type = res_ty } }        ; return (HsOverLit noAnn lit', res_ty) }-  where-    orig   = LiteralOrigin lit-    mb_doc = Just (ppr from_name)-    herald = sep [ text "The function" <+> quotes (ppr from_name)-                 , text "is applied to"] -tcInferOverLit lit-  = pprPanic "tcInferOverLit" (ppr lit)-- {- ********************************************************************* *                                                                      *                  tcInferId, tcCheckId@@ -885,95 +740,61 @@ tc_infer_id :: Name -> TcM (HsExpr GhcTc, TcSigmaType) tc_infer_id id_name  = do { thing <- tcLookup id_name-      ; global_env <- getGlobalRdrEnv       ; case thing of              ATcId { tct_id = id }                -> do { check_local_id id                      ; return_id id } -             AGlobal (AnId id)-               -> return_id id+             AGlobal (AnId id) -> return_id id                -- A global cannot possibly be ill-staged                -- nor does it need the 'lifting' treatment                -- Hence no checkTh stuff here -             AGlobal (AConLike cl) -> case cl of-                 RealDataCon con -> return_data_con con-                 PatSynCon ps-                   | Just (expr, ty) <- patSynBuilderOcc ps-                   -> return (expr, ty)-                   | otherwise-                   -> failWithTc (nonBidirectionalErr id_name)--             AGlobal (ATyCon ty_con)-               -> fail_tycon global_env ty_con--             ATyVar name _-                -> failWithTc $-                     text "Illegal term-level use of the type variable"-                       <+> quotes (ppr name)-                       $$ nest 2 (text "bound at" <+> ppr (getSrcLoc name))--             ATcTyCon ty_con-               -> fail_tycon global_env ty_con+             AGlobal (AConLike (RealDataCon con)) -> tcInferDataCon con+             AGlobal (AConLike (PatSynCon ps)) -> tcInferPatSyn id_name ps+             (tcTyThingTyCon_maybe -> Just tc) -> fail_tycon tc -- TyCon or TcTyCon+             ATyVar name _ -> fail_tyvar name -             _ -> failWithTc $+             _ -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $                   ppr thing <+> text "used where a value identifier was expected" }   where-    fail_tycon global_env ty_con =-      let pprov = case lookupGRE_Name global_env (tyConName ty_con) of-            Just gre -> nest 2 (pprNameProvenance gre)-            Nothing  -> empty-      in failWithTc (term_level_tycons ty_con $$ pprov)--    term_level_tycons ty_con-      = text "Illegal term-level use of the type constructor"-          <+> quotes (ppr (tyConName ty_con))--    return_id id = return (HsVar noExtField (noLocA id), idType id)+    fail_tycon tc = do+      gre <- getGlobalRdrEnv+      let nm = tyConName tc+          pprov = case lookupGRE_Name gre nm of+                      Just gre -> nest 2 (pprNameProvenance gre)+                      Nothing  -> empty+      fail_with_msg dataName nm pprov -    return_data_con con-      = do { let tvs = dataConUserTyVarBinders con-                 theta = dataConOtherTheta con-                 args = dataConOrigArgTys con-                 res = dataConOrigResTy con+    fail_tyvar nm =+      let pprov = nest 2 (text "bound at" <+> ppr (getSrcLoc nm))+      in fail_with_msg varName nm pprov -           -- See Note [Linear fields generalization]-           ; mul_vars <- newFlexiTyVarTys (length args) multiplicityTy-           ; let scaleArgs args' = zipWithEqual "return_data_con" combine mul_vars args'-                 combine var (Scaled One ty) = Scaled var ty-                 combine _   scaled_ty       = scaled_ty-                   -- The combine function implements the fact that, as-                   -- described in Note [Linear fields generalization], if a-                   -- field is not linear (last line) it isn't made polymorphic.+    fail_with_msg whatName nm pprov = do+      (import_errs, hints) <- get_suggestions whatName+      unit_state <- hsc_units <$> getTopEnv+      let+        -- TODO: unfortunate to have to convert to SDoc here.+        -- This should go away once we refactor ErrInfo.+        hint_msg = vcat $ map ppr hints+        import_err_msg = vcat $ map ppr import_errs+        info = ErrInfo { errInfoContext = pprov, errInfoSupplementary = import_err_msg $$ hint_msg }+        msg = TcRnMessageWithInfo unit_state+            $ TcRnMessageDetailed info (TcRnIncorrectNameSpace nm False)+      failWithTc msg -                 etaWrapper arg_tys = foldr (\scaled_ty wr -> WpFun WpHole wr scaled_ty empty) WpHole arg_tys+    get_suggestions ns = do+       let occ = mkOccNameFS ns (occNameFS (occName id_name))+       dflags  <- getDynFlags+       rdr_env <- getGlobalRdrEnv+       lcl_env <- getLocalRdrEnv+       imp_info <- getImports+       curr_mod <- getModule+       hpt <- getHpt+       return $ unknownNameSuggestions WL_Anything dflags hpt curr_mod rdr_env+         lcl_env imp_info (mkRdrUnqual occ) -           -- See Note [Instantiating stupid theta]-           ; let shouldInstantiate = (not (null (dataConStupidTheta con)) ||-                                      isKindLevPoly (tyConResKind (dataConTyCon con)))-           ; case shouldInstantiate of-               True -> do { (subst, tvs') <- newMetaTyVars (binderVars tvs)-                           ; let tys'   = mkTyVarTys tvs'-                                 theta' = substTheta subst theta-                                 args'  = substScaledTys subst args-                                 res'   = substTy subst res-                           ; wrap <- instCall (OccurrenceOf id_name) tys' theta'-                           ; let scaled_arg_tys = scaleArgs args'-                                 eta_wrap = etaWrapper scaled_arg_tys-                           ; addDataConStupidTheta con tys'-                           ; return ( mkHsWrap (eta_wrap <.> wrap)-                                               (HsConLikeOut noExtField (RealDataCon con))-                                    , mkVisFunTys scaled_arg_tys res')-                           }-               False -> let scaled_arg_tys = scaleArgs args-                            wrap1 = mkWpTyApps (mkTyVarTys $ binderVars tvs)-                            eta_wrap = etaWrapper (map unrestricted theta ++ scaled_arg_tys)-                            wrap2 = mkWpTyLams $ binderVars tvs-                        in return ( mkHsWrap (wrap2 <.> eta_wrap <.> wrap1)-                                             (HsConLikeOut noExtField (RealDataCon con))-                                  , mkInvisForAllTys tvs $ mkInvisFunTysMany theta $ mkVisFunTys scaled_arg_tys res)-           }+    return_id id = return (HsVar noExtField (noLocA id), idType id)  check_local_id :: Id -> TcM () check_local_id id@@ -985,48 +806,119 @@   | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel lbl)   | otherwise                  = return () -nonBidirectionalErr :: Outputable name => name -> SDoc-nonBidirectionalErr name = text "non-bidirectional pattern synonym"-                           <+> quotes (ppr name) <+> text "used in an expression"+tcInferDataCon :: DataCon -> TcM (HsExpr GhcTc, TcSigmaType)+-- See Note [Typechecking data constructors]+tcInferDataCon con+  = do { let tvbs  = dataConUserTyVarBinders con+             tvs   = binderVars tvbs+             theta = dataConOtherTheta con+             args  = dataConOrigArgTys con+             res   = dataConOrigResTy con+             stupid_theta = dataConStupidTheta con -{--Note [Linear fields generalization]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-As per Note [Polymorphisation of linear fields], linear field of data-constructors get a polymorphic type when the data constructor is used as a term.+       ; scaled_arg_tys <- mapM linear_to_poly args -    Just :: forall {p} a. a #p-> Maybe a+       ; let full_theta  = stupid_theta ++ theta+             all_arg_tys = map unrestricted full_theta ++ scaled_arg_tys+                -- stupid-theta must come first+                -- See Note [Instantiating stupid theta] -This rule is known only to the typechecker: Just keeps its linear type in Core.+       ; return ( XExpr (ConLikeTc (RealDataCon con) tvs all_arg_tys)+                , mkInvisForAllTys tvbs $ mkPhiTy full_theta $+                  mkVisFunTys scaled_arg_tys res ) }+  where+    linear_to_poly :: Scaled Type -> TcM (Scaled Type)+    -- linear_to_poly implements point (3,4)+    -- of Note [Typechecking data constructors]+    linear_to_poly (Scaled One ty) = do { mul_var <- newFlexiTyVarTy multiplicityTy+                                        ; return (Scaled mul_var ty) }+    linear_to_poly scaled_ty       = return scaled_ty -In order to desugar this generalised typing rule, we simply eta-expand:+tcInferPatSyn :: Name -> PatSyn -> TcM (HsExpr GhcTc, TcSigmaType)+tcInferPatSyn id_name ps+  = case patSynBuilderOcc ps of+       Just (expr,ty) -> return (expr,ty)+       Nothing        -> failWithTc (nonBidirectionalErr id_name) -    \a (x # p :: a) -> Just @a x+nonBidirectionalErr :: Outputable name => name -> TcRnMessage+nonBidirectionalErr name = TcRnUnknownMessage $ mkPlainError noHints $+  text "non-bidirectional pattern synonym"+  <+> quotes (ppr name) <+> text "used in an expression" -has the appropriate type. We insert these eta-expansion with WpFun wrappers.+{- Note [Typechecking data constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As per Note [Polymorphisation of linear fields] in+GHC.Core.Multiplicity, linear fields of data constructors get a+polymorphic multiplicity when the data constructor is used as a term: -A small hitch: if the constructor is levity-polymorphic (unboxed tuples, sums,-certain newtypes with -XUnliftedNewtypes) then this strategy produces+    Just :: forall {p} a. a %p -> Maybe a -    \r1 r2 a b (x # p :: a) (y # q :: b) -> (# a, b #)+So at an occurrence of a data constructor we do the following,+mostly in tcInferDataCon: -Which has type+1. Get its type, say+    K :: forall (r :: RuntimeRep) (a :: TYPE r). a %1 -> T r a+   Note the %1: it is linear -    forall r1 r2 a b. a #p-> b #q-> (# a, b #)+2. We are going to return a ConLikeTc, thus:+     XExpr (ConLikeTc K [r,a] [Scaled p a])+      :: forall (r :: RuntimeRep) (a :: TYPE r). a %p -> T r a+   where 'p' is a fresh multiplicity unification variable. -Which violates the levity-polymorphism restriction see Note [Levity polymorphism-checking] in DsMonad.+   To get the returned ConLikeTc, we allocate a fresh multiplicity+   variable for each linear argument, and store the type, scaled by+   the fresh multiplicity variable in the ConLikeTc; along with+   the type of the ConLikeTc. This is done by linear_to_poly. -So we really must instantiate r1 and r2 rather than quantify over them.  For-simplicity, we just instantiate the entire type, as described in Note-[Instantiating stupid theta]. It breaks visible type application with unboxed-tuples, sums and levity-polymorphic newtypes, but this doesn't appear to be used-anywhere.+3. If the argument is not linear (perhaps explicitly declared as+   non-linear by the user), don't bother with this. -A better plan: let's force all representation variable to be *inferred*, so that-they are not subject to visible type applications. Then we can instantiate-inferred argument eagerly.+4. The (ConLikeTc K [r,a] [Scaled p a]) is later desugared by+   GHC.HsToCore.Expr.dsConLike to:+     (/\r (a :: TYPE r). \(x %p :: a). K @r @a x)+   which has the desired type given in the previous bullet.+   The 'p' is the multiplicity unification variable, which+   will by now have been unified to something, or defaulted in+   `GHC.Tc.Utils.Zonk.commitFlexi`. So it won't just be an+   (unbound) variable. +Wrinkles++* Note that the [TcType] is strictly redundant anyway; those are the+  type variables from the dataConUserTyVarBinders of the data constructor.+  Similarly in the [Scaled TcType] field of ConLikeTc, the types come directly+  from the data constructor.  The only bit that /isn't/ redundant is the+  fresh multiplicity variables!++  So an alternative would be to define ConLikeTc like this:+      | ConLikeTc [TcType]    -- Just the multiplicity variables+  But then the desugarer would need to repeat some of the work done here.+  So for now at least ConLikeTc records this strictly-redundant info.++* The lambda expression we produce in (4) can have representation-polymorphic+  arguments, as indeed in (/\r (a :: TYPE r). \(x %p :: a). K @r @a x),+  we have a lambda-bound variable x :: (a :: TYPE r).+  This goes against the representation polymorphism invariants given in+  Note [Representation polymorphism invariants] in GHC.Core. The trick is that+  this this lambda will always be instantiated in a way that upholds the invariants.+  This is achieved as follows:++    A. Any arguments to such lambda abstractions are guaranteed to have+       a fixed runtime representation. This is enforced in 'tcApp' by+       'matchActualFunTySigma'.++    B. If there are fewer arguments than there are bound term variables,+       hasFixedRuntimeRep_remainingValArgs will ensure that we are still+       instantiating at a representation-monomorphic type, e.g.++       ( /\r (a :: TYPE r). \ (x %p :: a). K @r @a x) @IntRep @Int#+         :: Int# -> T IntRep Int#++  We then rely on the simple optimiser to beta reduce the lambda.++* See Note [Instantiating stupid theta] for an extra wrinkle++ Note [Adding the implicit parameter to 'assert'] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The typechecker transforms (assert e1 e2) to (assertError e1 e2).@@ -1038,15 +930,33 @@  Note [Instantiating stupid theta] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Normally, when we infer the type of an Id, we don't instantiate,-because we wish to allow for visible type application later on.-But if a datacon has a stupid theta, we're a bit stuck. We need-to emit the stupid theta constraints with instantiated types. It's-difficult to defer this to the lazy instantiation, because a stupid-theta has no spot to put it in a type. So we just instantiate eagerly-in this case. Thus, users cannot use visible type application with-a data constructor sporting a stupid theta. I won't feel so bad for-the users that complain.+Consider a data type with a "stupid theta" (see+Note [The stupid context] in GHC.Core.DataCon):++  data Ord a => T a = MkT (Maybe a)++We want to generate an Ord constraint for every use of MkT; but+we also want to allow visible type application, such as+   MkT @Int++So we generate (ConLikeTc MkT [a] [Ord a, Maybe a]), with type+   forall a. Ord a => Maybe a -> T a++Now visible type application will work fine. But we desugar the+ConLikeTc to+   /\a \(d:Ord a) (x:Maybe a). MkT x+Notice that 'd' is dropped in this desugaring. We don't need it;+it was only there to generate a Wanted constraint. (That is why+it is stupid.)  To achieve this:++* We put the stupid-thata at the front of the list of argument+  types in ConLikeTc++* GHC.HsToCore.Expr.dsConLike generates /lambdas/ for all the+  arguments, but drops the stupid-theta arguments when building the+  /application/.++Nice. -}  {-@@ -1116,10 +1026,7 @@                                        [getRuntimeRep id_ty, id_ty]                     -- Warning for implicit lift (#17804)-        ; whenWOptM Opt_WarnImplicitLift $-            addWarnTc (Reason Opt_WarnImplicitLift)-                       (text "The variable" <+> quotes (ppr id) <+>-                        text "is implicitly lifted in the TH quotation")+        ; addDetailedDiagnostic (TcRnImplicitLift id)                     -- Update the pending splices         ; ps <- readMutVar ps_var@@ -1134,9 +1041,10 @@  checkCrossStageLifting _ _ _ = return () -polySpliceErr :: Id -> SDoc+polySpliceErr :: Id -> TcRnMessage polySpliceErr id-  = text "Can't splice the polymorphic local variable" <+> quotes (ppr id)+  = TcRnUnknownMessage $ mkPlainError noHints $+  text "Can't splice the polymorphic local variable" <+> quotes (ppr id)  {- Note [Lifting strings]@@ -1151,11 +1059,11 @@ If this check fails (which isn't impossible) we get another chance; see Note [Converting strings] in Convert.hs -Local record selectors-~~~~~~~~~~~~~~~~~~~~~~+Note [Local record selectors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Record selectors for TyCons in this module are ordinary local bindings, which show up as ATcIds rather than AGlobals.  So we need to check for-naughtiness in both branches.  c.f. TcTyClsBindings.mkAuxBinds.+naughtiness in both branches.  c.f. GHC.Tc.TyCl.Utils.mkRecSelBinds. -}  @@ -1186,7 +1094,7 @@                            Just env_ty -> zonkTcType env_ty                            Nothing     ->                              do { dumping <- doptM Opt_D_dump_tc_trace-                                ; MASSERT( dumping )+                                ; massert dumping                                 ; newFlexiTyVarTy liftedTypeKind }            ; let -- See Note [Splitting nested sigma types in mismatched                  --           function types]
compiler/GHC/Tc/Gen/HsType.hs view
@@ -1,4231 +1,4414 @@-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE DataKinds           #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE RankNTypes          #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies        #-}-{-# LANGUAGE ViewPatterns        #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}--{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998---}---- | Typechecking user-specified @MonoTypes@-module GHC.Tc.Gen.HsType (-        -- Type signatures-        kcClassSigType, tcClassSigType,-        tcHsSigType, tcHsSigWcType,-        tcHsPartialSigType,-        tcStandaloneKindSig,-        funsSigCtxt, addSigCtxt, pprSigCtxt,--        tcHsClsInstType,-        tcHsDeriv, tcDerivStrategy,-        tcHsTypeApp,-        UserTypeCtxt(..),-        bindImplicitTKBndrs_Tv, bindImplicitTKBndrs_Skol,-            bindImplicitTKBndrs_Q_Tv, bindImplicitTKBndrs_Q_Skol,-        bindExplicitTKBndrs_Tv, bindExplicitTKBndrs_Skol,-            bindExplicitTKBndrs_Q_Tv, bindExplicitTKBndrs_Q_Skol,--        bindOuterFamEqnTKBndrs, bindOuterFamEqnTKBndrs_Q_Tv,-        tcOuterTKBndrs, scopedSortOuter,-        bindOuterSigTKBndrs_Tv,-        tcExplicitTKBndrs,-        bindNamedWildCardBinders,--        -- Type checking type and class decls, and instances thereof-        bindTyClTyVars, tcFamTyPats,-        etaExpandAlgTyCon, tcbVisibilities,--          -- tyvars-        zonkAndScopedSort,--        -- Kind-checking types-        -- No kind generalisation, no checkValidType-        InitialKindStrategy(..),-        SAKS_or_CUSK(..),-        ContextKind(..),-        kcDeclHeader,-        tcHsLiftedType,   tcHsOpenType,-        tcHsLiftedTypeNC, tcHsOpenTypeNC,-        tcInferLHsType, tcInferLHsTypeKind, tcInferLHsTypeUnsaturated,-        tcCheckLHsType,-        tcHsContext, tcLHsPredType,--        kindGeneralizeAll, kindGeneralizeSome, kindGeneralizeNone,--        -- Sort-checking kinds-        tcLHsKindSig, checkDataKindSig, DataSort(..),-        checkClassKindSig,--        -- Multiplicity-        tcMult,--        -- Pattern type signatures-        tcHsPatSigType,-        HoleMode(..),--        -- Error messages-        funAppCtxt, addTyConFlavCtxt-   ) where--#include "GhclibHsVersions.h"--import GHC.Prelude--import GHC.Hs-import GHC.Rename.Utils-import GHC.Tc.Utils.Monad-import GHC.Tc.Types.Origin-import GHC.Core.Predicate-import GHC.Tc.Types.Constraint-import GHC.Tc.Utils.Env-import GHC.Tc.Utils.TcMType-import GHC.Tc.Validity-import GHC.Tc.Utils.Unify-import GHC.IfaceToCore-import GHC.Tc.Solver-import GHC.Tc.Utils.Zonk-import GHC.Core.TyCo.Rep-import GHC.Core.TyCo.Ppr-import GHC.Tc.Utils.TcType-import GHC.Tc.Utils.Instantiate ( tcInstInvisibleTyBinders, tcInstInvisibleTyBindersN,-                                  tcInstInvisibleTyBinder )-import GHC.Core.Type-import GHC.Builtin.Types.Prim-import GHC.Types.Name.Env-import GHC.Types.Name.Reader( lookupLocalRdrOcc )-import GHC.Types.Var-import GHC.Types.Var.Set-import GHC.Core.TyCon-import GHC.Core.ConLike-import GHC.Core.DataCon-import GHC.Core.Class-import GHC.Types.Name--- import GHC.Types.Name.Set-import GHC.Types.Var.Env-import GHC.Builtin.Types-import GHC.Types.Basic-import GHC.Types.SrcLoc-import GHC.Types.Unique-import GHC.Types.Unique.FM-import GHC.Types.Unique.Set-import GHC.Utils.Misc-import GHC.Types.Unique.Supply-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Data.FastString-import GHC.Builtin.Names hiding ( wildCardName )-import GHC.Driver.Session-import qualified GHC.LanguageExtensions as LangExt--import GHC.Data.Maybe-import GHC.Data.Bag( unitBag )-import Data.List ( find )-import Control.Monad--{--        -----------------------------                General notes-        ------------------------------Unlike with expressions, type-checking types both does some checking and-desugars at the same time. This is necessary because we often want to perform-equality checks on the types right away, and it would be incredibly painful-to do this on un-desugared types. Luckily, desugared types are close enough-to HsTypes to make the error messages sane.--During type-checking, we perform as little validity checking as possible.-Generally, after type-checking, you will want to do validity checking, say-with GHC.Tc.Validity.checkValidType.--Validity checking-~~~~~~~~~~~~~~~~~-Some of the validity check could in principle be done by the kind checker,-but not all:--- During desugaring, we normalise by expanding type synonyms.  Only-  after this step can we check things like type-synonym saturation-  e.g.  type T k = k Int-        type S a = a-  Then (T S) is ok, because T is saturated; (T S) expands to (S Int);-  and then S is saturated.  This is a GHC extension.--- Similarly, also a GHC extension, we look through synonyms before complaining-  about the form of a class or instance declaration--- Ambiguity checks involve functional dependencies--Also, in a mutually recursive group of types, we can't look at the TyCon until we've-finished building the loop.  So to keep things simple, we postpone most validity-checking until step (3).--%************************************************************************-%*                                                                      *-              Check types AND do validity checking-*                                                                      *-************************************************************************--Note [Keeping implicitly quantified variables in order]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When the user implicitly quantifies over variables (say, in a type-signature), we need to come up with some ordering on these variables.-This is done by bumping the TcLevel, bringing the tyvars into scope,-and then type-checking the thing_inside. The constraints are all-wrapped in an implication, which is then solved. Finally, we can-zonk all the binders and then order them with scopedSort.--It's critical to solve before zonking and ordering in order to uncover-any unifications. You might worry that this eager solving could cause-trouble elsewhere. I don't think it will. Because it will solve only-in an increased TcLevel, it can't unify anything that was mentioned-elsewhere. Additionally, we require that the order of implicitly-quantified variables is manifest by the scope of these variables, so-we're not going to learn more information later that will help order-these variables.--Note [Recipe for checking a signature]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Kind-checking a user-written signature requires several steps:-- 0. Bump the TcLevel- 1.   Bind any lexically-scoped type variables.- 2.   Generate constraints.- 3. Solve constraints.- 4. Sort any implicitly-bound variables into dependency order- 5. Promote tyvars and/or kind-generalize.- 6. Zonk.- 7. Check validity.--Very similar steps also apply when kind-checking a type or class-declaration.--The general pattern looks something like this.  (But NB every-specific instance varies in one way or another!)--    do { (tclvl, wanted, (spec_tkvs, ty))-              <- pushLevelAndSolveEqualitiesX "tc_top_lhs_type" $-                 bindImplicitTKBndrs_Skol sig_vars              $-                 <kind-check the type>--       ; spec_tkvs <- zonkAndScopedSort spec_tkvs--       ; reportUnsolvedEqualities skol_info spec_tkvs tclvl wanted--       ; let ty1 = mkSpecForAllTys spec_tkvs ty-       ; kvs <- kindGeneralizeAll ty1--       ; final_ty <- zonkTcTypeToType (mkInfForAllTys kvs ty1)--       ; checkValidType final_ty--This pattern is repeated many times in GHC.Tc.Gen.HsType,-GHC.Tc.Gen.Sig, and GHC.Tc.TyCl, with variations.  In more detail:--* pushLevelAndSolveEqualitiesX (Step 0, step 3) bumps the TcLevel,-  calls the thing inside to generate constraints, solves those-  constraints as much as possible, returning the residual unsolved-  constraints in 'wanted'.--* bindImplicitTKBndrs_Skol (Step 1) binds the user-specified type-  variables E.g.  when kind-checking f :: forall a. F a -> a we must-  bring 'a' into scope before kind-checking (F a -> a)--* zonkAndScopedSort (Step 4) puts those user-specified variables in-  the dependency order.  (For "implicit" variables the order is no-  user-specified.  E.g.  forall (a::k1) (b::k2). blah k1 and k2 are-  implicitly brought into scope.--* reportUnsolvedEqualities (Step 3 continued) reports any unsolved-  equalities, carefully wrapping them in an implication that binds the-  skolems.  We can't do that in pushLevelAndSolveEqualitiesX because-  that function doesn't have access to the skolems.--* kindGeneralize (Step 5). See Note [Kind generalisation]--* The final zonkTcTypeToType must happen after promoting/generalizing,-  because promoting and generalizing fill in metavariables.---Doing Step 3 (constraint solving) eagerly (rather than building an-implication constraint and solving later) is necessary for several-reasons:--* Exactly as for Solver.simplifyInfer: when generalising, we solve all-  the constraints we can so that we don't have to quantify over them-  or, since we don't quantify over constraints in kinds, float them-  and inhibit generalisation.--* Most signatures also bring implicitly quantified variables into-  scope, and solving is necessary to get these in the right order-  (Step 4) see Note [Keeping implicitly quantified variables in-  order]).--Note [Kind generalisation]-~~~~~~~~~~~~~~~~~~~~~~~~~~-Step 5 of Note [Recipe for checking a signature], namely-kind-generalisation, is done by-    kindGeneraliseAll-    kindGeneraliseSome-    kindGeneraliseNone--Here, we have to deal with the fact that metatyvars generated in the-type will have a bumped TcLevel, because explicit foralls raise the-TcLevel. To avoid these variables from ever being visible in the-surrounding context, we must obey the following dictum:--  Every metavariable in a type must either be-    (A) generalized, or-    (B) promoted, or        See Note [Promotion in signatures]-    (C) a cause to error    See Note [Naughty quantification candidates]-                            in GHC.Tc.Utils.TcMType--There are three steps (look at kindGeneraliseSome):--1. candidateQTyVarsOfType finds the free variables of the type or kind,-   to generalise--2. filterConstrainedCandidates filters out candidates that appear-   in the unsolved 'wanteds', and promotes the ones that get filtered out-   thereby.--3. quantifyTyVars quantifies the remaining type variables--The kindGeneralize functions do not require pre-zonking; they zonk as they-go.--kindGeneraliseAll specialises for the case where step (2) is vacuous.-kindGeneraliseNone specialises for the case where we do no quantification,-but we must still promote.--If you are actually doing kind-generalization, you need to bump the-level before generating constraints, as we will only generalize-variables with a TcLevel higher than the ambient one.-Hence the "pushLevel" in pushLevelAndSolveEqualities.--Note [Promotion in signatures]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If an unsolved metavariable in a signature is not generalized-(because we're not generalizing the construct -- e.g., pattern-sig -- or because the metavars are constrained -- see kindGeneralizeSome)-we need to promote to maintain (WantedTvInv) of Note [TcLevel invariants]-in GHC.Tc.Utils.TcType. Note that promotion is identical in effect to generalizing-and the reinstantiating with a fresh metavariable at the current level.-So in some sense, we generalize *all* variables, but then re-instantiate-some of them.--Here is an example of why we must promote:-  foo (x :: forall a. a -> Proxy b) = ...--In the pattern signature, `b` is unbound, and will thus be brought into-scope. We do not know its kind: it will be assigned kappa[2]. Note that-kappa is at TcLevel 2, because it is invented under a forall. (A priori,-the kind kappa might depend on `a`, so kappa rightly has a higher TcLevel-than the surrounding context.) This kappa cannot be solved for while checking-the pattern signature (which is not kind-generalized). When we are checking-the *body* of foo, though, we need to unify the type of x with the argument-type of bar. At this point, the ambient TcLevel is 1, and spotting a-matavariable with level 2 would violate the (WantedTvInv) invariant of-Note [TcLevel invariants]. So, instead of kind-generalizing,-we promote the metavariable to level 1. This is all done in kindGeneralizeNone.---}--funsSigCtxt :: [LocatedN Name] -> UserTypeCtxt--- Returns FunSigCtxt, with no redundant-context-reporting,--- form a list of located names-funsSigCtxt (L _ name1 : _) = FunSigCtxt name1 False-funsSigCtxt []              = panic "funSigCtxt"--addSigCtxt :: Outputable hs_ty => UserTypeCtxt -> LocatedA hs_ty -> TcM a -> TcM a-addSigCtxt ctxt hs_ty thing_inside-  = setSrcSpan (getLocA hs_ty) $-    addErrCtxt (pprSigCtxt ctxt hs_ty) $-    thing_inside--pprSigCtxt :: Outputable hs_ty => UserTypeCtxt -> LocatedA hs_ty -> SDoc--- (pprSigCtxt ctxt <extra> <type>)--- prints    In the type signature for 'f':---              f :: <type>--- The <extra> is either empty or "the ambiguity check for"-pprSigCtxt ctxt hs_ty-  | Just n <- isSigMaybe ctxt-  = hang (text "In the type signature:")-       2 (pprPrefixOcc n <+> dcolon <+> ppr hs_ty)--  | otherwise-  = hang (text "In" <+> pprUserTypeCtxt ctxt <> colon)-       2 (ppr hs_ty)--tcHsSigWcType :: UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Type--- This one is used when we have a LHsSigWcType, but in--- a place where wildcards aren't allowed. The renamer has--- already checked this, so we can simply ignore it.-tcHsSigWcType ctxt sig_ty = tcHsSigType ctxt (dropWildCards sig_ty)--kcClassSigType :: [LocatedN Name] -> LHsSigType GhcRn -> TcM ()--- This is a special form of tcClassSigType that is used during the--- kind-checking phase to infer the kind of class variables. Cf. tc_lhs_sig_type.--- Importantly, this does *not* kind-generalize. Consider---   class SC f where---     meth :: forall a (x :: f a). Proxy x -> ()--- When instantiating Proxy with kappa, we must unify kappa := f a. But we're--- still working out the kind of f, and thus f a will have a coercion in it.--- Coercions block unification (Note [Equalities with incompatible kinds] in--- TcCanonical) and so we fail to unify. If we try to kind-generalize, we'll--- end up promoting kappa to the top level (because kind-generalization is--- normally done right before adding a binding to the context), and then we--- can't set kappa := f a, because a is local.-kcClassSigType names-    sig_ty@(L _ (HsSig { sig_bndrs = hs_outer_bndrs, sig_body = hs_ty }))-  = addSigCtxt (funsSigCtxt names) sig_ty $-    do { _ <- bindOuterSigTKBndrs_Tv hs_outer_bndrs    $-              tcLHsType hs_ty liftedTypeKind-       ; return () }--tcClassSigType :: [LocatedN Name] -> LHsSigType GhcRn -> TcM Type--- Does not do validity checking-tcClassSigType names sig_ty-  = addSigCtxt sig_ctxt sig_ty $-    do { (implic, ty) <- tc_lhs_sig_type skol_info sig_ty (TheKind liftedTypeKind)-       ; emitImplication implic-       ; return ty }-       -- Do not zonk-to-Type, nor perform a validity check-       -- We are in a knot with the class and associated types-       -- Zonking and validity checking is done by tcClassDecl-       ---       -- No need to fail here if the type has an error:-       --   If we're in the kind-checking phase, the solveEqualities-       --     in kcTyClGroup catches the error-       --   If we're in the type-checking phase, the solveEqualities-       --     in tcClassDecl1 gets it-       -- Failing fast here degrades the error message in, e.g., tcfail135:-       --   class Foo f where-       --     baa :: f a -> f-       -- If we fail fast, we're told that f has kind `k1` when we wanted `*`.-       -- It should be that f has kind `k2 -> *`, but we never get a chance-       -- to run the solver where the kind of f is touchable. This is-       -- painfully delicate.-  where-    sig_ctxt = funsSigCtxt names-    skol_info = SigTypeSkol sig_ctxt--tcHsSigType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type--- Does validity checking--- See Note [Recipe for checking a signature]-tcHsSigType ctxt sig_ty-  = addSigCtxt ctxt sig_ty $-    do { traceTc "tcHsSigType {" (ppr sig_ty)--          -- Generalise here: see Note [Kind generalisation]-       ; (implic, ty) <- tc_lhs_sig_type skol_info sig_ty  (expectedKindInCtxt ctxt)--       -- Float out constraints, failing fast if not possible-       -- See Note [Failure in local type signatures] in GHC.Tc.Solver-       ; traceTc "tcHsSigType 2" (ppr implic)-       ; simplifyAndEmitFlatConstraints (mkImplicWC (unitBag implic))--       ; ty <- zonkTcType ty-       ; checkValidType ctxt ty-       ; traceTc "end tcHsSigType }" (ppr ty)-       ; return ty }-  where-    skol_info = SigTypeSkol ctxt--tc_lhs_sig_type :: SkolemInfo -> LHsSigType GhcRn-               -> ContextKind -> TcM (Implication, TcType)--- Kind-checks/desugars an 'LHsSigType',---   solve equalities,---   and then kind-generalizes.--- This will never emit constraints, as it uses solveEqualities internally.--- No validity checking or zonking--- Returns also an implication for the unsolved constraints-tc_lhs_sig_type skol_info (L loc (HsSig { sig_bndrs = hs_outer_bndrs-                                       , sig_body = hs_ty })) ctxt_kind-  = setSrcSpanA loc $-    do { (tc_lvl, wanted, (outer_bndrs, ty))-              <- pushLevelAndSolveEqualitiesX "tc_lhs_sig_type" $-                 -- See Note [Failure in local type signatures]-                 tcOuterTKBndrs skol_info hs_outer_bndrs $-                 do { kind <- newExpectedKind ctxt_kind-                    ; tcLHsType hs_ty kind }-       -- Any remaining variables (unsolved in the solveEqualities)-       -- should be in the global tyvars, and therefore won't be quantified--       ; traceTc "tc_lhs_sig_type" (ppr hs_outer_bndrs $$ ppr outer_bndrs)-       ; (outer_tv_bndrs :: [InvisTVBinder]) <- scopedSortOuter outer_bndrs--       ; let ty1 = mkInvisForAllTys outer_tv_bndrs ty--       ; kvs <- kindGeneralizeSome wanted ty1--       -- Build an implication for any as-yet-unsolved kind equalities-       -- See Note [Skolem escape in type signatures]-       ; implic <- buildTvImplication skol_info kvs tc_lvl wanted--       ; return (implic, mkInfForAllTys kvs ty1) }--{- Note [Skolem escape in type signatures]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-tcHsSigType is tricky.  Consider (T11142)-  foo :: forall b. (forall k (a :: k). SameKind a b) -> ()-This is ill-kinded because of a nested skolem-escape.--That will show up as an un-solvable constraint in the implication-returned by buildTvImplication in tc_lhs_sig_type.  See Note [Skolem-escape prevention] in GHC.Tc.Utils.TcType for why it is unsolvable-(the unification variable for b's kind is untouchable).--Then, in GHC.Tc.Solver.simplifyAndEmitFlatConstraints (called from tcHsSigType)-we'll try to float out the constraint, be unable to do so, and fail.-See GHC.Tc.Solver Note [Failure in local type signatures] for more-detail on this.--The separation between tcHsSigType and tc_lhs_sig_type is because-tcClassSigType wants to use the latter, but *not* fail fast, because-there are skolems from the class decl which are in scope; but it's fine-not to because tcClassDecl1 has a solveEqualities wrapped around all-the tcClassSigType calls.--That's why tcHsSigType does simplifyAndEmitFlatConstraints (which-fails fast) but tcClassSigType just does emitImplication (which does-not).  Ugh.--c.f. see also Note [Skolem escape and forall-types]. The difference-is that we don't need to simplify at a forall type, only at the-top level of a signature.--}---- Does validity checking and zonking.-tcStandaloneKindSig :: LStandaloneKindSig GhcRn -> TcM (Name, Kind)-tcStandaloneKindSig (L _ (StandaloneKindSig _ (L _ name) ksig))-  = addSigCtxt ctxt ksig $-    do { kind <- tc_top_lhs_type KindLevel ctxt ksig-       ; checkValidType ctxt kind-       ; return (name, kind) }-  where-   ctxt = StandaloneKindSigCtxt name--tcTopLHsType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type-tcTopLHsType ctxt lsig_ty-  = tc_top_lhs_type TypeLevel ctxt lsig_ty--tc_top_lhs_type :: TypeOrKind -> UserTypeCtxt -> LHsSigType GhcRn -> TcM Type--- tc_top_lhs_type is used for kind-checking top-level LHsSigTypes where---   we want to fully solve /all/ equalities, and report errors--- Does zonking, but not validity checking because it's used---   for things (like deriving and instances) that aren't---   ordinary types--- Used for both types and kinds-tc_top_lhs_type tyki ctxt (L loc sig_ty@(HsSig { sig_bndrs = hs_outer_bndrs-                                               , sig_body = body }))-  = setSrcSpanA loc $-    do { traceTc "tc_top_lhs_type {" (ppr sig_ty)-       ; (tclvl, wanted, (outer_bndrs, ty))-              <- pushLevelAndSolveEqualitiesX "tc_top_lhs_type"    $-                 tcOuterTKBndrs skol_info hs_outer_bndrs $-                 do { kind <- newExpectedKind (expectedKindInCtxt ctxt)-                    ; tc_lhs_type (mkMode tyki) body kind }--       ; outer_tv_bndrs <- scopedSortOuter outer_bndrs-       ; let ty1 = mkInvisForAllTys outer_tv_bndrs ty--       ; kvs <- kindGeneralizeAll ty1  -- "All" because it's a top-level type-       ; reportUnsolvedEqualities skol_info kvs tclvl wanted--       ; ze       <- mkEmptyZonkEnv NoFlexi-       ; final_ty <- zonkTcTypeToTypeX ze (mkInfForAllTys kvs ty1)-       ; traceTc "tc_top_lhs_type }" (vcat [ppr sig_ty, ppr final_ty])-       ; return final_ty }-  where-    skol_info = SigTypeSkol ctxt--------------------tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], Class, [Type], [Kind])--- Like tcHsSigType, but for the ...deriving( C t1 ty2 ) clause--- Returns the C, [ty1, ty2, and the kinds of C's remaining arguments--- E.g.    class C (a::*) (b::k->k)---         data T a b = ... deriving( C Int )---    returns ([k], C, [k, Int], [k->k])--- Return values are fully zonked-tcHsDeriv hs_ty-  = do { ty <- checkNoErrs $  -- Avoid redundant error report-                              -- with "illegal deriving", below-               tcTopLHsType DerivClauseCtxt hs_ty-       ; let (tvs, pred)    = splitForAllTyCoVars ty-             (kind_args, _) = splitFunTys (tcTypeKind pred)-       ; case getClassPredTys_maybe pred of-           Just (cls, tys) -> return (tvs, cls, tys, map scaledThing kind_args)-           Nothing -> failWithTc (text "Illegal deriving item" <+> quotes (ppr hs_ty)) }---- | Typecheck a deriving strategy. For most deriving strategies, this is a--- no-op, but for the @via@ strategy, this requires typechecking the @via@ type.-tcDerivStrategy ::-     Maybe (LDerivStrategy GhcRn)-     -- ^ The deriving strategy-  -> TcM (Maybe (LDerivStrategy GhcTc), [TyVar])-     -- ^ The typechecked deriving strategy and the tyvars that it binds-     -- (if using 'ViaStrategy').-tcDerivStrategy mb_lds-  = case mb_lds of-      Nothing -> boring_case Nothing-      Just (L loc ds) ->-        setSrcSpan loc $ do-          (ds', tvs) <- tc_deriv_strategy ds-          pure (Just (L loc ds'), tvs)-  where-    tc_deriv_strategy :: DerivStrategy GhcRn-                      -> TcM (DerivStrategy GhcTc, [TyVar])-    tc_deriv_strategy (StockStrategy    _)-                                     = boring_case (StockStrategy noExtField)-    tc_deriv_strategy (AnyclassStrategy _)-                                     = boring_case (AnyclassStrategy noExtField)-    tc_deriv_strategy (NewtypeStrategy  _)-                                     = boring_case (NewtypeStrategy noExtField)-    tc_deriv_strategy (ViaStrategy ty) = do-      ty' <- checkNoErrs $ tcTopLHsType DerivClauseCtxt ty-      let (via_tvs, via_pred) = splitForAllTyCoVars ty'-      pure (ViaStrategy via_pred, via_tvs)--    boring_case :: ds -> TcM (ds, [TyVar])-    boring_case ds = pure (ds, [])--tcHsClsInstType :: UserTypeCtxt    -- InstDeclCtxt or SpecInstCtxt-                -> LHsSigType GhcRn-                -> TcM Type--- Like tcHsSigType, but for a class instance declaration-tcHsClsInstType user_ctxt hs_inst_ty-  = setSrcSpan (getLocA hs_inst_ty) $-    do { -- Fail eagerly if tcTopLHsType fails.  We are at top level so-         -- these constraints will never be solved later. And failing-         -- eagerly avoids follow-on errors when checkValidInstance-         -- sees an unsolved coercion hole-         inst_ty <- checkNoErrs $-                    tcTopLHsType user_ctxt hs_inst_ty-       ; checkValidInstance user_ctxt hs_inst_ty inst_ty-       ; return inst_ty }--------------------------------------------------- | Type-check a visible type application-tcHsTypeApp :: LHsWcType GhcRn -> Kind -> TcM Type--- See Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType-tcHsTypeApp wc_ty kind-  | HsWC { hswc_ext = sig_wcs, hswc_body = hs_ty } <- wc_ty-  = do { mode <- mkHoleMode TypeLevel HM_VTA-                 -- HM_VTA: See Note [Wildcards in visible type application]-       ; ty <- addTypeCtxt hs_ty                  $-               solveEqualities "tcHsTypeApp" $-               -- We are looking at a user-written type, very like a-               -- signature so we want to solve its equalities right now-               bindNamedWildCardBinders sig_wcs $ \ _ ->-               tc_lhs_type mode hs_ty kind--       -- We do not kind-generalize type applications: we just-       -- instantiate with exactly what the user says.-       -- See Note [No generalization in type application]-       -- We still must call kindGeneralizeNone, though, according-       -- to Note [Recipe for checking a signature]-       ; kindGeneralizeNone ty-       ; ty <- zonkTcType ty-       ; checkValidType TypeAppCtxt ty-       ; return ty }--{- Note [Wildcards in visible type application]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A HsWildCardBndrs's hswc_ext now only includes /named/ wildcards, so-any unnamed wildcards stay unchanged in hswc_body.  When called in-tcHsTypeApp, tcCheckLHsType will call emitAnonTypeHole-on these anonymous wildcards. However, this would trigger-error/warning when an anonymous wildcard is passed in as a visible type-argument, which we do not want because users should be able to write-@_ to skip a instantiating a type variable variable without fuss. The-solution is to switch the PartialTypeSignatures flags here to let the-typechecker know that it's checking a '@_' and do not emit hole-constraints on it.  See related Note [Wildcards in visible kind-application] and Note [The wildcard story for types] in GHC.Hs.Type--Ugh!--Note [No generalization in type application]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We do not kind-generalize type applications. Imagine--  id @(Proxy Nothing)--If we kind-generalized, we would get--  id @(forall {k}. Proxy @(Maybe k) (Nothing @k))--which is very sneakily impredicative instantiation.--There is also the possibility of mentioning a wildcard-(`id @(Proxy _)`), which definitely should not be kind-generalized.---}--tcFamTyPats :: TyCon-            -> HsTyPats GhcRn                -- Patterns-            -> TcM (TcType, TcKind)          -- (lhs_type, lhs_kind)--- Check the LHS of a type/data family instance--- e.g.   type instance F ty1 .. tyn = ...--- Used for both type and data families-tcFamTyPats fam_tc hs_pats-  = do { traceTc "tcFamTyPats {" $-         vcat [ ppr fam_tc, text "arity:" <+> ppr fam_arity ]--       ; mode <- mkHoleMode TypeLevel HM_FamPat-                 -- HM_FamPat: See Note [Wildcards in family instances] in-                 -- GHC.Rename.Module-       ; let fun_ty = mkTyConApp fam_tc []-       ; (fam_app, res_kind) <- tcInferTyApps mode lhs_fun fun_ty hs_pats--       -- Hack alert: see Note [tcFamTyPats: zonking the result kind]-       ; res_kind <- zonkTcType res_kind--       ; traceTc "End tcFamTyPats }" $-         vcat [ ppr fam_tc, text "res_kind:" <+> ppr res_kind ]--       ; return (fam_app, res_kind) }-  where-    fam_name  = tyConName fam_tc-    fam_arity = tyConArity fam_tc-    lhs_fun   = noLocA (HsTyVar noAnn NotPromoted (noLocA fam_name))--{- Note [tcFamTyPats: zonking the result kind]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider (#19250)-    F :: forall k. k -> k-    type instance F (x :: Constraint) = ()--The tricky point is this:-  is that () an empty type tuple (() :: Type), or-  an empty constraint tuple (() :: Constraint)?-We work this out in a hacky way, by looking at the expected kind:-see Note [Inferring tuple kinds].--In this case, we kind-check the RHS using the kind gotten from the LHS:-see the call to tcCheckLHsType in tcTyFamInstEqnGuts in GHC.Tc.Tycl.--But we want the kind from the LHS to be /zonked/, so that when-kind-checking the RHS (tcCheckLHsType) we can "see" what we learned-from kind-checking the LHS (tcFamTyPats).  In our example above, the-type of the LHS is just `kappa` (by instantiating the forall k), but-then we learn (from x::Constraint) that kappa ~ Constraint.  We want-that info when kind-checking the RHS.--Easy solution: just zonk that return kind.  Of course this won't help-if there is lots of type-family reduction to do, but it works fine in-common cases.--}---{--************************************************************************-*                                                                      *-            The main kind checker: no validity checks here-*                                                                      *-************************************************************************--}------------------------------tcHsOpenType, tcHsLiftedType,-  tcHsOpenTypeNC, tcHsLiftedTypeNC :: LHsType GhcRn -> TcM TcType--- Used for type signatures--- Do not do validity checking-tcHsOpenType   hs_ty = addTypeCtxt hs_ty $ tcHsOpenTypeNC hs_ty-tcHsLiftedType hs_ty = addTypeCtxt hs_ty $ tcHsLiftedTypeNC hs_ty--tcHsOpenTypeNC   hs_ty = do { ek <- newOpenTypeKind; tcLHsType hs_ty ek }-tcHsLiftedTypeNC hs_ty = tcLHsType hs_ty liftedTypeKind---- Like tcHsType, but takes an expected kind-tcCheckLHsType :: LHsType GhcRn -> ContextKind -> TcM TcType-tcCheckLHsType hs_ty exp_kind-  = addTypeCtxt hs_ty $-    do { ek <- newExpectedKind exp_kind-       ; tcLHsType hs_ty ek }--tcInferLHsType :: LHsType GhcRn -> TcM TcType-tcInferLHsType hs_ty-  = do { (ty,_kind) <- tcInferLHsTypeKind hs_ty-       ; return ty }--tcInferLHsTypeKind :: LHsType GhcRn -> TcM (TcType, TcKind)--- Called from outside: set the context--- Eagerly instantiate any trailing invisible binders-tcInferLHsTypeKind lhs_ty@(L loc hs_ty)-  = addTypeCtxt lhs_ty $-    setSrcSpanA loc    $  -- Cover the tcInstInvisibleTyBinders-    do { (res_ty, res_kind) <- tc_infer_hs_type typeLevelMode hs_ty-       ; tcInstInvisibleTyBinders res_ty res_kind }-  -- See Note [Do not always instantiate eagerly in types]---- Used to check the argument of GHCi :kind--- Allow and report wildcards, e.g. :kind T _--- Do not saturate family applications: see Note [Dealing with :kind]--- Does not instantiate eagerly; See Note [Do not always instantiate eagerly in types]-tcInferLHsTypeUnsaturated :: LHsType GhcRn -> TcM (TcType, TcKind)-tcInferLHsTypeUnsaturated hs_ty-  = addTypeCtxt hs_ty $-    do { mode <- mkHoleMode TypeLevel HM_Sig  -- Allow and report holes-       ; case splitHsAppTys (unLoc hs_ty) of-           Just (hs_fun_ty, hs_args)-              -> do { (fun_ty, _ki) <- tcInferTyAppHead mode hs_fun_ty-                    ; tcInferTyApps_nosat mode hs_fun_ty fun_ty hs_args }-                      -- Notice the 'nosat'; do not instantiate trailing-                      -- invisible arguments of a type family.-                      -- See Note [Dealing with :kind]-           Nothing -> tc_infer_lhs_type mode hs_ty }--{- Note [Dealing with :kind]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this GHCi command-  ghci> type family F :: Either j k-  ghci> :kind F-  F :: forall {j,k}. Either j k--We will only get the 'forall' if we /refrain/ from saturating those-invisible binders. But generally we /do/ saturate those invisible-binders (see tcInferTyApps), and we want to do so for nested application-even in GHCi.  Consider for example (#16287)-  ghci> type family F :: k-  ghci> data T :: (forall k. k) -> Type-  ghci> :kind T F-We want to reject this. It's just at the very top level that we want-to switch off saturation.--So tcInferLHsTypeUnsaturated does a little special case for top level-applications.  Actually the common case is a bare variable, as above.--Note [Do not always instantiate eagerly in types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Terms are eagerly instantiated. This means that if you say--  x = id--then `id` gets instantiated to have type alpha -> alpha. The variable-alpha is then unconstrained and regeneralized. But we cannot do this-in types, as we have no type-level lambda. So, when we are sure-that we will not want to regeneralize later -- because we are done-checking a type, for example -- we can instantiate. But we do not-instantiate at variables, nor do we in tcInferLHsTypeUnsaturated,-which is used by :kind in GHCi.--************************************************************************-*                                                                      *-      Type-checking modes-*                                                                      *-************************************************************************--The kind-checker is parameterised by a TcTyMode, which contains some-information about where we're checking a type.--The renamer issues errors about what it can. All errors issued here must-concern things that the renamer can't handle.---}--tcMult :: HsArrow GhcRn -> TcM Mult-tcMult hc = tc_mult typeLevelMode hc---- | Info about the context in which we're checking a type. Currently,--- differentiates only between types and kinds, but this will likely--- grow, at least to include the distinction between patterns and--- not-patterns.------ To find out where the mode is used, search for 'mode_tyki'------ This data type is purely local, not exported from this module-data TcTyMode-  = TcTyMode { mode_tyki :: TypeOrKind-             , mode_holes :: HoleInfo   }---- See Note [Levels for wildcards]--- Nothing <=> no wildcards expected-type HoleInfo = Maybe (TcLevel, HoleMode)---- HoleMode says how to treat the occurrences--- of anonymous wildcards; see tcAnonWildCardOcc-data HoleMode = HM_Sig      -- Partial type signatures: f :: _ -> Int-              | HM_FamPat   -- Family instances: F _ Int = Bool-              | HM_VTA      -- Visible type and kind application:-                            --   f @(Maybe _)-                            --   Maybe @(_ -> _)-              | HM_TyAppPat -- Visible type applications in patterns:-                            --   foo (Con @_ @t x) = ...-                            --   case x of Con @_ @t v -> ...--mkMode :: TypeOrKind -> TcTyMode-mkMode tyki = TcTyMode { mode_tyki = tyki, mode_holes = Nothing }--typeLevelMode, kindLevelMode :: TcTyMode--- These modes expect no wildcards (holes) in the type-kindLevelMode = mkMode KindLevel-typeLevelMode = mkMode TypeLevel--mkHoleMode :: TypeOrKind -> HoleMode -> TcM TcTyMode-mkHoleMode tyki hm-  = do { lvl <- getTcLevel-       ; return (TcTyMode { mode_tyki  = tyki-                          , mode_holes = Just (lvl,hm) }) }--instance Outputable HoleMode where-  ppr HM_Sig      = text "HM_Sig"-  ppr HM_FamPat   = text "HM_FamPat"-  ppr HM_VTA      = text "HM_VTA"-  ppr HM_TyAppPat = text "HM_TyAppPat"--instance Outputable TcTyMode where-  ppr (TcTyMode { mode_tyki = tyki, mode_holes = hm })-    = text "TcTyMode" <+> braces (sep [ ppr tyki <> comma-                                      , ppr hm ])--{--Note [Bidirectional type checking]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In expressions, whenever we see a polymorphic identifier, say `id`, we are-free to instantiate it with metavariables, knowing that we can always-re-generalize with type-lambdas when necessary. For example:--  rank2 :: (forall a. a -> a) -> ()-  x = rank2 id--When checking the body of `x`, we can instantiate `id` with a metavariable.-Then, when we're checking the application of `rank2`, we notice that we really-need a polymorphic `id`, and then re-generalize over the unconstrained-metavariable.--In types, however, we're not so lucky, because *we cannot re-generalize*!-There is no lambda. So, we must be careful only to instantiate at the last-possible moment, when we're sure we're never going to want the lost polymorphism-again. This is done in calls to tcInstInvisibleTyBinders.--To implement this behavior, we use bidirectional type checking, where we-explicitly think about whether we know the kind of the type we're checking-or not. Note that there is a difference between not knowing a kind and-knowing a metavariable kind: the metavariables are TauTvs, and cannot become-forall-quantified kinds. Previously (before dependent types), there were-no higher-rank kinds, and so we could instantiate early and be sure that-no types would have polymorphic kinds, and so we could always assume that-the kind of a type was a fresh metavariable. Not so anymore, thus the-need for two algorithms.--For HsType forms that can never be kind-polymorphic, we implement only the-"down" direction, where we safely assume a metavariable kind. For HsType forms-that *can* be kind-polymorphic, we implement just the "up" (functions with-"infer" in their name) version, as we gain nothing by also implementing the-"down" version.--Note [Future-proofing the type checker]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-As discussed in Note [Bidirectional type checking], each HsType form is-handled in *either* tc_infer_hs_type *or* tc_hs_type. These functions-are mutually recursive, so that either one can work for any type former.-But, we want to make sure that our pattern-matches are complete. So,-we have a bunch of repetitive code just so that we get warnings if we're-missing any patterns.---}----------------------------------------------- | Check and desugar a type, returning the core type and its--- possibly-polymorphic kind. Much like 'tcInferRho' at the expression--- level.-tc_infer_lhs_type :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind)-tc_infer_lhs_type mode (L span ty)-  = setSrcSpanA span $-    tc_infer_hs_type mode ty-------------------------------- | Call 'tc_infer_hs_type' and check its result against an expected kind.-tc_infer_hs_type_ek :: HasDebugCallStack => TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType-tc_infer_hs_type_ek mode hs_ty ek-  = do { (ty, k) <- tc_infer_hs_type mode hs_ty-       ; checkExpectedKind hs_ty ty k ek }-------------------------------- | Infer the kind of a type and desugar. This is the "up" type-checker,--- as described in Note [Bidirectional type checking]-tc_infer_hs_type :: TcTyMode -> HsType GhcRn -> TcM (TcType, TcKind)--tc_infer_hs_type mode (HsParTy _ t)-  = tc_infer_lhs_type mode t--tc_infer_hs_type mode ty-  | Just (hs_fun_ty, hs_args) <- splitHsAppTys ty-  = do { (fun_ty, _ki) <- tcInferTyAppHead mode hs_fun_ty-       ; tcInferTyApps mode hs_fun_ty fun_ty hs_args }--tc_infer_hs_type mode (HsKindSig _ ty sig)-  = do { let mode' = mode { mode_tyki = KindLevel }-       ; sig' <- tc_lhs_kind_sig mode' KindSigCtxt sig-                 -- We must typecheck the kind signature, and solve all-                 -- its equalities etc; from this point on we may do-                 -- things like instantiate its foralls, so it needs-                 -- to be fully determined (#14904)-       ; traceTc "tc_infer_hs_type:sig" (ppr ty $$ ppr sig')-       ; ty' <- tc_lhs_type mode ty sig'-       ; return (ty', sig') }---- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceType' to communicate--- the splice location to the typechecker. Here we skip over it in order to have--- the same kind inferred for a given expression whether it was produced from--- splices or not.------ See Note [Delaying modFinalizers in untyped splices].-tc_infer_hs_type mode (HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)))-  = tc_infer_hs_type mode ty--tc_infer_hs_type mode (HsDocTy _ ty _) = tc_infer_lhs_type mode ty---- See Note [Typechecking HsCoreTys]-tc_infer_hs_type _ (XHsType ty)-  = do env <- getLclEnv-       -- Raw uniques since we go from NameEnv to TvSubstEnv.-       let subst_prs :: [(Unique, TcTyVar)]-           subst_prs = [ (getUnique nm, tv)-                       | ATyVar nm tv <- nameEnvElts (tcl_env env) ]-           subst = mkTvSubst-                     (mkInScopeSet $ mkVarSet $ map snd subst_prs)-                     (listToUFM_Directly $ map (liftSnd mkTyVarTy) subst_prs)-           ty' = substTy subst ty-       return (ty', tcTypeKind ty')--tc_infer_hs_type _ (HsExplicitListTy _ _ tys)-  | null tys  -- this is so that we can use visible kind application with '[]-              -- e.g ... '[] @Bool-  = return (mkTyConTy promotedNilDataCon,-            mkSpecForAllTys [alphaTyVar] $ mkListTy alphaTy)--tc_infer_hs_type mode other_ty-  = do { kv <- newMetaKindVar-       ; ty' <- tc_hs_type mode other_ty kv-       ; return (ty', kv) }--{--Note [Typechecking HsCoreTys]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-HsCoreTy is an escape hatch that allows embedding Core Types in HsTypes.-As such, there's not much to be done in order to typecheck an HsCoreTy,-since it's already been typechecked to some extent. There is one thing that-we must do, however: we must substitute the type variables from the tcl_env.-To see why, consider GeneralizedNewtypeDeriving, which is one of the main-clients of HsCoreTy (example adapted from #14579):--  newtype T a = MkT a deriving newtype Eq--This will produce an InstInfo GhcPs that looks roughly like this:--  instance forall a_1. Eq a_1 => Eq (T a_1) where-    (==) = coerce @(  a_1 ->   a_1 -> Bool) -- The type within @(...) is an HsCoreTy-                  @(T a_1 -> T a_1 -> Bool) -- So is this-                  (==)--This is then fed into the renamer. Since all of the type variables in this-InstInfo use Exact RdrNames, the resulting InstInfo GhcRn looks basically-identical. Things get more interesting when the InstInfo is fed into the-typechecker, however. GHC will first generate fresh skolems to instantiate-the instance-bound type variables with. In the example above, we might generate-the skolem a_2 and use that to instantiate a_1, which extends the local type-environment (tcl_env) with [a_1 :-> a_2]. This gives us:--  instance forall a_2. Eq a_2 => Eq (T a_2) where ...--To ensure that the body of this instance is well scoped, every occurrence of-the `a` type variable should refer to a_2, the new skolem. However, the-HsCoreTys mention a_1, not a_2. Luckily, the tcl_env provides exactly the-substitution we need ([a_1 :-> a_2]) to fix up the scoping. We apply this-substitution to each HsCoreTy and all is well:--  instance forall a_2. Eq a_2 => Eq (T a_2) where-    (==) = coerce @(  a_2 ->   a_2 -> Bool)-                  @(T a_2 -> T a_2 -> Bool)-                  (==)--}---------------------------------------------tcLHsType :: LHsType GhcRn -> TcKind -> TcM TcType-tcLHsType hs_ty exp_kind-  = tc_lhs_type typeLevelMode hs_ty exp_kind--tc_lhs_type :: TcTyMode -> LHsType GhcRn -> TcKind -> TcM TcType-tc_lhs_type mode (L span ty) exp_kind-  = setSrcSpanA span $-    tc_hs_type mode ty exp_kind--tc_hs_type :: TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType--- See Note [Bidirectional type checking]--tc_hs_type mode (HsParTy _ ty)   exp_kind = tc_lhs_type mode ty exp_kind-tc_hs_type mode (HsDocTy _ ty _) exp_kind = tc_lhs_type mode ty exp_kind-tc_hs_type _ ty@(HsBangTy _ bang _) _-    -- While top-level bangs at this point are eliminated (eg !(Maybe Int)),-    -- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of-    -- bangs are invalid, so fail. (#7210, #14761)-    = do { let bangError err = failWith $-                 text "Unexpected" <+> text err <+> text "annotation:" <+> ppr ty $$-                 text err <+> text "annotation cannot appear nested inside a type"-         ; case bang of-             HsSrcBang _ SrcUnpack _           -> bangError "UNPACK"-             HsSrcBang _ SrcNoUnpack _         -> bangError "NOUNPACK"-             HsSrcBang _ NoSrcUnpack SrcLazy   -> bangError "laziness"-             HsSrcBang _ _ _                   -> bangError "strictness" }-tc_hs_type _ ty@(HsRecTy {})      _-      -- Record types (which only show up temporarily in constructor-      -- signatures) should have been removed by now-    = failWithTc (text "Record syntax is illegal here:" <+> ppr ty)---- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceType'.--- Here we get rid of it and add the finalizers to the global environment--- while capturing the local environment.------ See Note [Delaying modFinalizers in untyped splices].-tc_hs_type mode (HsSpliceTy _ (HsSpliced _ mod_finalizers (HsSplicedTy ty)))-           exp_kind-  = do addModFinalizersWithLclEnv mod_finalizers-       tc_hs_type mode ty exp_kind---- This should never happen; type splices are expanded by the renamer-tc_hs_type _ ty@(HsSpliceTy {}) _exp_kind-  = failWithTc (text "Unexpected type splice:" <+> ppr ty)------------ Functions and applications-tc_hs_type mode (HsFunTy _ mult ty1 ty2) exp_kind-  = tc_fun_type mode mult ty1 ty2 exp_kind--tc_hs_type mode (HsOpTy _ ty1 (L _ op) ty2) exp_kind-  | op `hasKey` funTyConKey-  = tc_fun_type mode (HsUnrestrictedArrow NormalSyntax) ty1 ty2 exp_kind----------- Foralls-tc_hs_type mode (HsForAllTy { hst_tele = tele, hst_body = ty }) exp_kind-  = do { (tv_bndrs, ty') <- tcTKTelescope mode tele $-                            tc_lhs_type mode ty exp_kind-                 -- Pass on the mode from the type, to any wildcards-                 -- in kind signatures on the forall'd variables-                 -- e.g.      f :: _ -> Int -> forall (a :: _). blah-                 -- Why exp_kind?  See Note [Body kind of HsForAllTy]--       -- Do not kind-generalise here!  See Note [Kind generalisation]--       ; return (mkForAllTys tv_bndrs ty') }--tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = rn_ty }) exp_kind-  | null (fromMaybeContext ctxt)-  = tc_lhs_type mode rn_ty exp_kind--  -- See Note [Body kind of a HsQualTy]-  | tcIsConstraintKind exp_kind-  = do { ctxt' <- tc_hs_context mode ctxt-       ; ty'   <- tc_lhs_type mode rn_ty constraintKind-       ; return (mkPhiTy ctxt' ty') }--  | otherwise-  = do { ctxt' <- tc_hs_context mode ctxt--       ; ek <- newOpenTypeKind  -- The body kind (result of the function) can-                                -- be TYPE r, for any r, hence newOpenTypeKind-       ; ty' <- tc_lhs_type mode rn_ty ek-       ; checkExpectedKind (unLoc rn_ty) (mkPhiTy ctxt' ty')-                           liftedTypeKind exp_kind }----------- Lists, arrays, and tuples-tc_hs_type mode rn_ty@(HsListTy _ elt_ty) exp_kind-  = do { tau_ty <- tc_lhs_type mode elt_ty liftedTypeKind-       ; checkWiredInTyCon listTyCon-       ; checkExpectedKind rn_ty (mkListTy tau_ty) liftedTypeKind exp_kind }---- See Note [Distinguishing tuple kinds] in GHC.Hs.Type--- See Note [Inferring tuple kinds]-tc_hs_type mode rn_ty@(HsTupleTy _ HsBoxedOrConstraintTuple hs_tys) exp_kind-     -- (NB: not zonking before looking at exp_k, to avoid left-right bias)-  | Just tup_sort <- tupKindSort_maybe exp_kind-  = traceTc "tc_hs_type tuple" (ppr hs_tys) >>-    tc_tuple rn_ty mode tup_sort hs_tys exp_kind-  | otherwise-  = do { traceTc "tc_hs_type tuple 2" (ppr hs_tys)-       ; (tys, kinds) <- mapAndUnzipM (tc_infer_lhs_type mode) hs_tys-       ; kinds <- mapM zonkTcType kinds-           -- Infer each arg type separately, because errors can be-           -- confusing if we give them a shared kind.  Eg #7410-           -- (Either Int, Int), we do not want to get an error saying-           -- "the second argument of a tuple should have kind *->*"--       ; let (arg_kind, tup_sort)-               = case [ (k,s) | k <- kinds-                              , Just s <- [tupKindSort_maybe k] ] of-                    ((k,s) : _) -> (k,s)-                    [] -> (liftedTypeKind, BoxedTuple)-         -- In the [] case, it's not clear what the kind is, so guess *--       ; tys' <- sequence [ setSrcSpanA loc $-                            checkExpectedKind hs_ty ty kind arg_kind-                          | ((L loc hs_ty),ty,kind) <- zip3 hs_tys tys kinds ]--       ; finish_tuple rn_ty tup_sort tys' (map (const arg_kind) tys') exp_kind }---tc_hs_type mode rn_ty@(HsTupleTy _ HsUnboxedTuple tys) exp_kind-  = tc_tuple rn_ty mode UnboxedTuple tys exp_kind--tc_hs_type mode rn_ty@(HsSumTy _ hs_tys) exp_kind-  = do { let arity = length hs_tys-       ; arg_kinds <- mapM (\_ -> newOpenTypeKind) hs_tys-       ; tau_tys   <- zipWithM (tc_lhs_type mode) hs_tys arg_kinds-       ; let arg_reps = map kindRep arg_kinds-             arg_tys  = arg_reps ++ tau_tys-             sum_ty   = mkTyConApp (sumTyCon arity) arg_tys-             sum_kind = unboxedSumKind arg_reps-       ; checkExpectedKind rn_ty sum_ty sum_kind exp_kind-       }----------- Promoted lists and tuples-tc_hs_type mode rn_ty@(HsExplicitListTy _ _ tys) exp_kind-  = do { tks <- mapM (tc_infer_lhs_type mode) tys-       ; (taus', kind) <- unifyKinds tys tks-       ; let ty = (foldr (mk_cons kind) (mk_nil kind) taus')-       ; checkExpectedKind rn_ty ty (mkListTy kind) exp_kind }-  where-    mk_cons k a b = mkTyConApp (promoteDataCon consDataCon) [k, a, b]-    mk_nil  k     = mkTyConApp (promoteDataCon nilDataCon) [k]--tc_hs_type mode rn_ty@(HsExplicitTupleTy _ tys) exp_kind-  -- using newMetaKindVar means that we force instantiations of any polykinded-  -- types. At first, I just used tc_infer_lhs_type, but that led to #11255.-  = do { ks   <- replicateM arity newMetaKindVar-       ; taus <- zipWithM (tc_lhs_type mode) tys ks-       ; let kind_con   = tupleTyCon           Boxed arity-             ty_con     = promotedTupleDataCon Boxed arity-             tup_k      = mkTyConApp kind_con ks-       ; checkTupSize arity-       ; checkExpectedKind rn_ty (mkTyConApp ty_con (ks ++ taus)) tup_k exp_kind }-  where-    arity = length tys----------- Constraint types-tc_hs_type mode rn_ty@(HsIParamTy _ (L _ n) ty) exp_kind-  = do { MASSERT( isTypeLevel (mode_tyki mode) )-       ; ty' <- tc_lhs_type mode ty liftedTypeKind-       ; let n' = mkStrLitTy $ hsIPNameFS n-       ; ipClass <- tcLookupClass ipClassName-       ; checkExpectedKind rn_ty (mkClassPred ipClass [n',ty'])-                           constraintKind exp_kind }--tc_hs_type _ rn_ty@(HsStarTy _ _) exp_kind-  -- Desugaring 'HsStarTy' to 'Data.Kind.Type' here means that we don't have to-  -- handle it in 'coreView' and 'tcView'.-  = checkExpectedKind rn_ty liftedTypeKind liftedTypeKind exp_kind----------- Literals-tc_hs_type _ rn_ty@(HsTyLit _ (HsNumTy _ n)) exp_kind-  = do { checkWiredInTyCon naturalTyCon-       ; checkExpectedKind rn_ty (mkNumLitTy n) naturalTy exp_kind }--tc_hs_type _ rn_ty@(HsTyLit _ (HsStrTy _ s)) exp_kind-  = do { checkWiredInTyCon typeSymbolKindCon-       ; checkExpectedKind rn_ty (mkStrLitTy s) typeSymbolKind exp_kind }-tc_hs_type _ rn_ty@(HsTyLit _ (HsCharTy _ c)) exp_kind-  = do { checkWiredInTyCon charTyCon-       ; checkExpectedKind rn_ty (mkCharLitTy c) charTy exp_kind }----------- Wildcards--tc_hs_type mode ty@(HsWildCardTy _)        ek-  = tcAnonWildCardOcc NoExtraConstraint mode ty ek----------- Potentially kind-polymorphic types: call the "up" checker--- See Note [Future-proofing the type checker]-tc_hs_type mode ty@(HsTyVar {})            ek = tc_infer_hs_type_ek mode ty ek-tc_hs_type mode ty@(HsAppTy {})            ek = tc_infer_hs_type_ek mode ty ek-tc_hs_type mode ty@(HsAppKindTy{})         ek = tc_infer_hs_type_ek mode ty ek-tc_hs_type mode ty@(HsOpTy {})             ek = tc_infer_hs_type_ek mode ty ek-tc_hs_type mode ty@(HsKindSig {})          ek = tc_infer_hs_type_ek mode ty ek-tc_hs_type mode ty@(XHsType {})            ek = tc_infer_hs_type_ek mode ty ek--{--Note [Variable Specificity and Forall Visibility]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A HsForAllTy contains an HsForAllTelescope to denote the visibility of the forall-binder. Furthermore, each invisible type variable binder also has a-Specificity. Together, these determine the variable binders (ArgFlag) for each-variable in the generated ForAllTy type.--This table summarises this relation:------------------------------------------------------------------------------| User-written type         HsForAllTelescope   Specificity        ArgFlag-|----------------------------------------------------------------------------| f :: forall a. type       HsForAllInvis       SpecifiedSpec      Specified-| f :: forall {a}. type     HsForAllInvis       InferredSpec       Inferred-| f :: forall a -> type     HsForAllVis         SpecifiedSpec      Required-| f :: forall {a} -> type   HsForAllVis         InferredSpec       /-|   This last form is non-sensical and is thus rejected.-------------------------------------------------------------------------------For more information regarding the interpretation of the resulting ArgFlag, see-Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in "GHC.Core.TyCo.Rep".--}---------------------------------------------tc_mult :: TcTyMode -> HsArrow GhcRn -> TcM Mult-tc_mult mode ty = tc_lhs_type mode (arrowToHsType ty) multiplicityTy--------------------------------------------tc_fun_type :: TcTyMode -> HsArrow GhcRn -> LHsType GhcRn -> LHsType GhcRn -> TcKind-            -> TcM TcType-tc_fun_type mode mult ty1 ty2 exp_kind = case mode_tyki mode of-  TypeLevel ->-    do { arg_k <- newOpenTypeKind-       ; res_k <- newOpenTypeKind-       ; ty1' <- tc_lhs_type mode ty1 arg_k-       ; ty2' <- tc_lhs_type mode ty2 res_k-       ; mult' <- tc_mult mode mult-       ; checkExpectedKind (HsFunTy noAnn mult ty1 ty2) (mkVisFunTy mult' ty1' ty2')-                           liftedTypeKind exp_kind }-  KindLevel ->  -- no representation polymorphism in kinds. yet.-    do { ty1' <- tc_lhs_type mode ty1 liftedTypeKind-       ; ty2' <- tc_lhs_type mode ty2 liftedTypeKind-       ; mult' <- tc_mult mode mult-       ; checkExpectedKind (HsFunTy noAnn mult ty1 ty2) (mkVisFunTy mult' ty1' ty2')-                           liftedTypeKind exp_kind }--{- Note [Skolem escape and forall-types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-See also Note [Checking telescopes].--Consider-  f :: forall a. (forall kb (b :: kb). Proxy '[a, b]) -> ()--The Proxy '[a,b] forces a and b to have the same kind.  But a's-kind must be bound outside the 'forall a', and hence escapes.-We discover this by building an implication constraint for-each forall.  So the inner implication constraint will look like-    forall kb (b::kb).  kb ~ ka-where ka is a's kind.  We can't unify these two, /even/ if ka is-unification variable, because it would be untouchable inside-this inner implication.--That's what the pushLevelAndCaptureConstraints, plus subsequent-buildTvImplication/emitImplication is all about, when kind-checking-HsForAllTy.--Note that--* We don't need to /simplify/ the constraints here-  because we aren't generalising. We just capture them.--* We can't use emitResidualTvConstraint, because that has a fast-path-  for empty constraints.  We can't take that fast path here, because-  we must do the bad-telescope check even if there are no inner wanted-  constraints. See Note [Checking telescopes] in-  GHC.Tc.Types.Constraint.  Lacking this check led to #16247.--}--{- *********************************************************************-*                                                                      *-                Tuples-*                                                                      *-********************************************************************* -}------------------------------tupKindSort_maybe :: TcKind -> Maybe TupleSort-tupKindSort_maybe k-  | Just (k', _) <- splitCastTy_maybe k = tupKindSort_maybe k'-  | Just k'      <- tcView k            = tupKindSort_maybe k'-  | tcIsConstraintKind k = Just ConstraintTuple-  | tcIsLiftedTypeKind k   = Just BoxedTuple-  | otherwise            = Nothing--tc_tuple :: HsType GhcRn -> TcTyMode -> TupleSort -> [LHsType GhcRn] -> TcKind -> TcM TcType-tc_tuple rn_ty mode tup_sort tys exp_kind-  = do { arg_kinds <- case tup_sort of-           BoxedTuple      -> return (replicate arity liftedTypeKind)-           UnboxedTuple    -> replicateM arity newOpenTypeKind-           ConstraintTuple -> return (replicate arity constraintKind)-       ; tau_tys <- zipWithM (tc_lhs_type mode) tys arg_kinds-       ; finish_tuple rn_ty tup_sort tau_tys arg_kinds exp_kind }-  where-    arity   = length tys--finish_tuple :: HsType GhcRn-             -> TupleSort-             -> [TcType]    -- ^ argument types-             -> [TcKind]    -- ^ of these kinds-             -> TcKind      -- ^ expected kind of the whole tuple-             -> TcM TcType-finish_tuple rn_ty tup_sort tau_tys tau_kinds exp_kind = do-  traceTc "finish_tuple" (ppr tup_sort $$ ppr tau_kinds $$ ppr exp_kind)-  case tup_sort of-    ConstraintTuple-      |  [tau_ty] <- tau_tys-         -- Drop any uses of 1-tuple constraints here.-         -- See Note [Ignore unary constraint tuples]-      -> check_expected_kind tau_ty constraintKind-      |  otherwise-      -> do let tycon = cTupleTyCon arity-            checkCTupSize arity-            check_expected_kind (mkTyConApp tycon tau_tys) constraintKind-    BoxedTuple -> do-      let tycon = tupleTyCon Boxed arity-      checkTupSize arity-      checkWiredInTyCon tycon-      check_expected_kind (mkTyConApp tycon tau_tys) liftedTypeKind-    UnboxedTuple -> do-      let tycon    = tupleTyCon Unboxed arity-          tau_reps = map kindRep tau_kinds-          -- See also Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon-          arg_tys  = tau_reps ++ tau_tys-          res_kind = unboxedTupleKind tau_reps-      checkTupSize arity-      check_expected_kind (mkTyConApp tycon arg_tys) res_kind-  where-    arity = length tau_tys-    check_expected_kind ty act_kind =-      checkExpectedKind rn_ty ty act_kind exp_kind--{--Note [Ignore unary constraint tuples]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-GHC provides unary tuples and unboxed tuples (see Note [One-tuples] in-GHC.Builtin.Types) but does *not* provide unary constraint tuples. Why? First,-recall the definition of a unary tuple data type:--  data Solo a = Solo a--Note that `Solo a` is *not* the same thing as `a`, since Solo is boxed and-lazy. Therefore, the presence of `Solo` matters semantically. On the other-hand, suppose we had a unary constraint tuple:--  class a => Solo% a--This compiles down a newtype (i.e., a cast) in Core, so `Solo% a` is-semantically equivalent to `a`. Therefore, a 1-tuple constraint would have-no user-visible impact, nor would it allow you to express anything that-you couldn't otherwise.--We could simply add Solo% for consistency with tuples (Solo) and unboxed-tuples (Solo#), but that would require even more magic to wire in another-magical class, so we opt not to do so. We must be careful, however, since-one can try to sneak in uses of unary constraint tuples through Template-Haskell, such as in this program (from #17511):--  f :: $(pure (ForallT [] [TupleT 1 `AppT` (ConT ''Show `AppT` ConT ''Int)]-                       (ConT ''String)))-  -- f :: Solo% (Show Int) => String-  f = "abc"--This use of `TupleT 1` will produce an HsBoxedOrConstraintTuple of arity 1,-and since it is used in a Constraint position, GHC will attempt to treat-it as thought it were a constraint tuple, which can potentially lead to-trouble if one attempts to look up the name of a constraint tuple of arity-1 (as it won't exist). To avoid this trouble, we simply take any unary-constraint tuples discovered when typechecking and drop them—i.e., treat-"Solo% a" as though the user had written "a". This is always safe to do-since the two constraints should be semantically equivalent.--}--{- *********************************************************************-*                                                                      *-                Type applications-*                                                                      *-********************************************************************* -}--splitHsAppTys :: HsType GhcRn -> Maybe (LHsType GhcRn, [LHsTypeArg GhcRn])-splitHsAppTys hs_ty-  | is_app hs_ty = Just (go (noLocA hs_ty) [])-  | otherwise    = Nothing-  where-    is_app :: HsType GhcRn -> Bool-    is_app (HsAppKindTy {})        = True-    is_app (HsAppTy {})            = True-    is_app (HsOpTy _ _ (L _ op) _) = not (op `hasKey` funTyConKey)-      -- I'm not sure why this funTyConKey test is necessary-      -- Can it even happen?  Perhaps for   t1 `(->)` t2-      -- but then maybe it's ok to treat that like a normal-      -- application rather than using the special rule for HsFunTy-    is_app (HsTyVar {})            = True-    is_app (HsParTy _ (L _ ty))    = is_app ty-    is_app _                       = False--    go :: LHsType GhcRn-       -> [HsArg (LHsType GhcRn) (LHsKind GhcRn)]-       -> (LHsType GhcRn,-           [HsArg (LHsType GhcRn) (LHsKind GhcRn)]) -- AZ temp-    go (L _  (HsAppTy _ f a))      as = go f (HsValArg a : as)-    go (L _  (HsAppKindTy l ty k)) as = go ty (HsTypeArg l k : as)-    go (L sp (HsParTy _ f))        as = go f (HsArgPar (locA sp) : as)-    go (L _  (HsOpTy _ l op@(L sp _) r)) as-      = ( L (na2la sp) (HsTyVar noAnn NotPromoted op)-        , HsValArg l : HsValArg r : as )-    go f as = (f, as)------------------------------tcInferTyAppHead :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind)--- Version of tc_infer_lhs_type specialised for the head of an--- application. In particular, for a HsTyVar (which includes type--- constructors, it does not zoom off into tcInferTyApps and family--- saturation-tcInferTyAppHead mode (L _ (HsTyVar _ _ (L _ tv)))-  = tcTyVar mode tv-tcInferTyAppHead mode ty-  = tc_infer_lhs_type mode ty-------------------------------- | Apply a type of a given kind to a list of arguments. This instantiates--- invisible parameters as necessary. Always consumes all the arguments,--- using matchExpectedFunKind as necessary.--- This takes an optional @VarEnv Kind@ which maps kind variables to kinds.---- These kinds should be used to instantiate invisible kind variables;--- they come from an enclosing class for an associated type/data family.------ tcInferTyApps also arranges to saturate any trailing invisible arguments---   of a type-family application, which is usually the right thing to do--- tcInferTyApps_nosat does not do this saturation; it is used only---   by ":kind" in GHCi-tcInferTyApps, tcInferTyApps_nosat-    :: TcTyMode-    -> LHsType GhcRn        -- ^ Function (for printing only)-    -> TcType               -- ^ Function-    -> [LHsTypeArg GhcRn]   -- ^ Args-    -> TcM (TcType, TcKind) -- ^ (f args, args, result kind)-tcInferTyApps mode hs_ty fun hs_args-  = do { (f_args, res_k) <- tcInferTyApps_nosat mode hs_ty fun hs_args-       ; saturateFamApp f_args res_k }--tcInferTyApps_nosat mode orig_hs_ty fun orig_hs_args-  = do { traceTc "tcInferTyApps {" (ppr orig_hs_ty $$ ppr orig_hs_args)-       ; (f_args, res_k) <- go_init 1 fun orig_hs_args-       ; traceTc "tcInferTyApps }" (ppr f_args <+> dcolon <+> ppr res_k)-       ; return (f_args, res_k) }-  where--    -- go_init just initialises the auxiliary-    -- arguments of the 'go' loop-    go_init n fun all_args-      = go n fun empty_subst fun_ki all_args-      where-        fun_ki = tcTypeKind fun-           -- We do (tcTypeKind fun) here, even though the caller-           -- knows the function kind, to absolutely guarantee-           -- INVARIANT for 'go'-           -- Note that in a typical application (F t1 t2 t3),-           -- the 'fun' is just a TyCon, so tcTypeKind is fast--        empty_subst = mkEmptyTCvSubst $ mkInScopeSet $-                      tyCoVarsOfType fun_ki--    go :: Int             -- The # of the next argument-       -> TcType          -- Function applied to some args-       -> TCvSubst        -- Applies to function kind-       -> TcKind          -- Function kind-       -> [LHsTypeArg GhcRn]    -- Un-type-checked args-       -> TcM (TcType, TcKind)  -- Result type and its kind-    -- INVARIANT: in any call (go n fun subst fun_ki args)-    --               tcTypeKind fun  =  subst(fun_ki)-    -- So the 'subst' and 'fun_ki' arguments are simply-    -- there to avoid repeatedly calling tcTypeKind.-    ---    -- Reason for INVARIANT: to support the Purely Kinded Type Invariant-    -- it's important that if fun_ki has a forall, then so does-    -- (tcTypeKind fun), because the next thing we are going to do-    -- is apply 'fun' to an argument type.--    -- Dispatch on all_args first, for performance reasons-    go n fun subst fun_ki all_args = case (all_args, tcSplitPiTy_maybe fun_ki) of--      ---------------- No user-written args left. We're done!-      ([], _) -> return (fun, substTy subst fun_ki)--      ---------------- HsArgPar: We don't care about parens here-      (HsArgPar _ : args, _) -> go n fun subst fun_ki args--      ---------------- HsTypeArg: a kind application (fun @ki)-      (HsTypeArg _ hs_ki_arg : hs_args, Just (ki_binder, inner_ki)) ->-        case ki_binder of--        -- FunTy with PredTy on LHS, or ForAllTy with Inferred-        Named (Bndr _ Inferred) -> instantiate ki_binder inner_ki-        Anon InvisArg _         -> instantiate ki_binder inner_ki--        Named (Bndr _ Specified) ->  -- Visible kind application-          do { traceTc "tcInferTyApps (vis kind app)"-                       (vcat [ ppr ki_binder, ppr hs_ki_arg-                             , ppr (tyBinderType ki_binder)-                             , ppr subst ])--             ; let exp_kind = substTy subst $ tyBinderType ki_binder-             ; arg_mode <- mkHoleMode KindLevel HM_VTA-                   -- HM_VKA: see Note [Wildcards in visible kind application]-             ; ki_arg <- addErrCtxt (funAppCtxt orig_hs_ty hs_ki_arg n) $-                         tc_lhs_type arg_mode hs_ki_arg exp_kind--             ; traceTc "tcInferTyApps (vis kind app)" (ppr exp_kind)-             ; (subst', fun') <- mkAppTyM subst fun ki_binder ki_arg-             ; go (n+1) fun' subst' inner_ki hs_args }--        -- Attempted visible kind application (fun @ki), but fun_ki is-        --   forall k -> blah   or   k1 -> k2-        -- So we need a normal application.  Error.-        _ -> ty_app_err hs_ki_arg $ substTy subst fun_ki--      -- No binder; try applying the substitution, or fail if that's not possible-      (HsTypeArg _ ki_arg : _, Nothing) -> try_again_after_substing_or $-                                           ty_app_err ki_arg substed_fun_ki--      ---------------- HsValArg: a normal argument (fun ty)-      (HsValArg arg : args, Just (ki_binder, inner_ki))-        -- next binder is invisible; need to instantiate it-        | isInvisibleBinder ki_binder   -- FunTy with InvisArg on LHS;-                                        -- or ForAllTy with Inferred or Specified-         -> instantiate ki_binder inner_ki--        -- "normal" case-        | otherwise-         -> do { traceTc "tcInferTyApps (vis normal app)"-                          (vcat [ ppr ki_binder-                                , ppr arg-                                , ppr (tyBinderType ki_binder)-                                , ppr subst ])-                ; let exp_kind = substTy subst $ tyBinderType ki_binder-                ; arg' <- addErrCtxt (funAppCtxt orig_hs_ty arg n) $-                          tc_lhs_type mode arg exp_kind-                ; traceTc "tcInferTyApps (vis normal app) 2" (ppr exp_kind)-                ; (subst', fun') <- mkAppTyM subst fun ki_binder arg'-                ; go (n+1) fun' subst' inner_ki args }--          -- no binder; try applying the substitution, or infer another arrow in fun kind-      (HsValArg _ : _, Nothing)-        -> try_again_after_substing_or $-           do { let arrows_needed = n_initial_val_args all_args-              ; co <- matchExpectedFunKind hs_ty arrows_needed substed_fun_ki--              ; fun' <- zonkTcType (fun `mkTcCastTy` co)-                     -- This zonk is essential, to expose the fruits-                     -- of matchExpectedFunKind to the 'go' loop--              ; traceTc "tcInferTyApps (no binder)" $-                   vcat [ ppr fun <+> dcolon <+> ppr fun_ki-                        , ppr arrows_needed-                        , ppr co-                        , ppr fun' <+> dcolon <+> ppr (tcTypeKind fun')]-              ; go_init n fun' all_args }-                -- Use go_init to establish go's INVARIANT-      where-        instantiate ki_binder inner_ki-          = do { traceTc "tcInferTyApps (need to instantiate)"-                         (vcat [ ppr ki_binder, ppr subst])-               ; (subst', arg') <- tcInstInvisibleTyBinder subst ki_binder-               ; go n (mkAppTy fun arg') subst' inner_ki all_args }-                 -- Because tcInvisibleTyBinder instantiate ki_binder,-                 -- the kind of arg' will have the same shape as the kind-                 -- of ki_binder.  So we don't need mkAppTyM here.--        try_again_after_substing_or fallthrough-          | not (isEmptyTCvSubst subst)-          = go n fun zapped_subst substed_fun_ki all_args-          | otherwise-          = fallthrough--        zapped_subst   = zapTCvSubst subst-        substed_fun_ki = substTy subst fun_ki-        hs_ty          = appTypeToArg orig_hs_ty (take (n-1) orig_hs_args)--    n_initial_val_args :: [HsArg tm ty] -> Arity-    -- Count how many leading HsValArgs we have-    n_initial_val_args (HsValArg {} : args) = 1 + n_initial_val_args args-    n_initial_val_args (HsArgPar {} : args) = n_initial_val_args args-    n_initial_val_args _                    = 0--    ty_app_err arg ty-      = failWith $ text "Cannot apply function of kind" <+> quotes (ppr ty)-                $$ text "to visible kind argument" <+> quotes (ppr arg)---mkAppTyM :: TCvSubst-         -> TcType -> TyCoBinder    -- fun, plus its top-level binder-         -> TcType                  -- arg-         -> TcM (TCvSubst, TcType)  -- Extended subst, plus (fun arg)--- Precondition: the application (fun arg) is well-kinded after zonking---               That is, the application makes sense------ Precondition: for (mkAppTyM subst fun bndr arg)---       tcTypeKind fun  =  Pi bndr. body---  That is, fun always has a ForAllTy or FunTy at the top---           and 'bndr' is fun's pi-binder------ Postcondition: if fun and arg satisfy (PKTI), the purely-kinded type---                invariant, then so does the result type (fun arg)------ We do not require that---    tcTypeKind arg = tyVarKind (binderVar bndr)--- This must be true after zonking (precondition 1), but it's not--- required for the (PKTI).-mkAppTyM subst fun ki_binder arg-  | -- See Note [mkAppTyM]: Nasty case 2-    TyConApp tc args <- fun-  , isTypeSynonymTyCon tc-  , args `lengthIs` (tyConArity tc - 1)-  , any isTrickyTvBinder (tyConTyVars tc) -- We could cache this in the synonym-  = do { arg'  <- zonkTcType  arg-       ; args' <- zonkTcTypes args-       ; let subst' = case ki_binder of-                        Anon {}           -> subst-                        Named (Bndr tv _) -> extendTvSubstAndInScope subst tv arg'-       ; return (subst', mkTyConApp tc (args' ++ [arg'])) }---mkAppTyM subst fun (Anon {}) arg-   = return (subst, mk_app_ty fun arg)--mkAppTyM subst fun (Named (Bndr tv _)) arg-  = do { arg' <- if isTrickyTvBinder tv-                 then -- See Note [mkAppTyM]: Nasty case 1-                      zonkTcType arg-                 else return     arg-       ; return ( extendTvSubstAndInScope subst tv arg'-                , mk_app_ty fun arg' ) }--mk_app_ty :: TcType -> TcType -> TcType--- This function just adds an ASSERT for mkAppTyM's precondition-mk_app_ty fun arg-  = ASSERT2( isPiTy fun_kind-           ,  ppr fun <+> dcolon <+> ppr fun_kind $$ ppr arg )-    mkAppTy fun arg-  where-    fun_kind = tcTypeKind fun--isTrickyTvBinder :: TcTyVar -> Bool--- NB: isTrickyTvBinder is just an optimisation--- It would be absolutely sound to return True always-isTrickyTvBinder tv = isPiTy (tyVarKind tv)--{- Note [The Purely Kinded Type Invariant (PKTI)]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-During type inference, we maintain this invariant-- (PKTI) It is legal to call 'tcTypeKind' on any Type ty,-        on any sub-term of ty, /without/ zonking ty--        Moreover, any such returned kind-        will itself satisfy (PKTI)--By "legal to call tcTypeKind" we mean "tcTypeKind will not crash".-The way in which tcTypeKind can crash is in applications-    (a t1 t2 .. tn)-if 'a' is a type variable whose kind doesn't have enough arrows-or foralls.  (The crash is in piResultTys.)--The loop in tcInferTyApps has to be very careful to maintain the (PKTI).-For example, suppose-    kappa is a unification variable-    We have already unified kappa := Type-      yielding    co :: Refl (Type -> Type)-    a :: kappa-then consider the type-    (a Int)-If we call tcTypeKind on that, we'll crash, because the (un-zonked)-kind of 'a' is just kappa, not an arrow kind.  So we must zonk first.--So the type inference engine is very careful when building applications.-This happens in tcInferTyApps. Suppose we are kind-checking the type (a Int),-where (a :: kappa).  Then in tcInferApps we'll run out of binders on-a's kind, so we'll call matchExpectedFunKind, and unify-   kappa := kappa1 -> kappa2,  with evidence co :: kappa ~ (kappa1 ~ kappa2)-At this point we must zonk the function type to expose the arrrow, so-that (a Int) will satisfy (PKTI).--The absence of this caused #14174 and #14520.--The calls to mkAppTyM is the other place we are very careful; see Note [mkAppTyM].--Wrinkle around FunTy:-Note that the PKTI does *not* guarantee anything about the shape of FunTys.-Specifically, when we have (FunTy vis mult arg res), it should be the case-that arg :: TYPE rr1 and res :: TYPE rr2, for some rr1 and rr2. However, we-might not have this. Example: if the user writes (a -> b), then we might-invent a :: kappa1 and b :: kappa2. We soon will check whether kappa1 ~ TYPE rho1-(for some rho1), and that will lead to kappa1 := TYPE rho1 (ditto for kappa2).-However, when we build the FunTy, we might not have zonked `a`, and so the-FunTy will be built without being able to purely extract the RuntimeReps.--Because the PKTI does not guarantee that the RuntimeReps are available in a FunTy,-we must be aware of this when splitting: splitTyConApp and splitAppTy will *not*-split a FunTy if the RuntimeReps are not available. See also Note [Decomposing FunTy]-in GHC.Tc.Solver.Canonical.--Note [mkAppTyM]-~~~~~~~~~~~~~~~-mkAppTyM is trying to guarantee the Purely Kinded Type Invariant-(PKTI) for its result type (fun arg).  There are two ways it can go wrong:--* Nasty case 1: forall types (polykinds/T14174a)-    T :: forall (p :: *->*). p Int -> p Bool-  Now kind-check (T x), where x::kappa.-  Well, T and x both satisfy the PKTI, but-     T x :: x Int -> x Bool-  and (x Int) does /not/ satisfy the PKTI.--* Nasty case 2: type synonyms-    type S f a = f a-  Even though (S ff aa) would satisfy the (PKTI) if S was a data type-  (i.e. nasty case 1 is dealt with), it might still not satisfy (PKTI)-  if S is a type synonym, because the /expansion/ of (S ff aa) is-  (ff aa), and /that/ does not satisfy (PKTI).  E.g. perhaps-  (ff :: kappa), where 'kappa' has already been unified with (*->*).--  We check for nasty case 2 on the final argument of a type synonym.--Notice that in both cases the trickiness only happens if the-bound variable has a pi-type.  Hence isTrickyTvBinder.--}---saturateFamApp :: TcType -> TcKind -> TcM (TcType, TcKind)--- Precondition for (saturateFamApp ty kind):---     tcTypeKind ty = kind------ If 'ty' is an unsaturated family application with trailing--- invisible arguments, instantiate them.--- See Note [saturateFamApp]--saturateFamApp ty kind-  | Just (tc, args) <- tcSplitTyConApp_maybe ty-  , mustBeSaturated tc-  , let n_to_inst = tyConArity tc - length args-  = do { (extra_args, ki') <- tcInstInvisibleTyBindersN n_to_inst kind-       ; return (ty `mkTcAppTys` extra_args, ki') }-  | otherwise-  = return (ty, kind)--{- Note [saturateFamApp]-~~~~~~~~~~~~~~~~~~~~~~~~-Consider-   type family F :: Either j k-   type instance F @Type = Right Maybe-   type instance F @Type = Right Either```--Then F :: forall {j,k}. Either j k--The two type instances do a visible kind application that instantiates-'j' but not 'k'.  But we want to end up with instances that look like-  type instance F @Type @(*->*) = Right @Type @(*->*) Maybe--so that F has arity 2.  We must instantiate that trailing invisible-binder. In general, Invisible binders precede Specified and Required,-so this is only going to bite for apparently-nullary families.--Note that-  type family F2 :: forall k. k -> *-is quite different and really does have arity 0.--It's not just type instances where we need to saturate those-unsaturated arguments: see #11246.  Hence doing this in tcInferApps.--}--appTypeToArg :: LHsType GhcRn -> [LHsTypeArg GhcRn] -> LHsType GhcRn-appTypeToArg f []                       = f-appTypeToArg f (HsValArg arg    : args) = appTypeToArg (mkHsAppTy f arg) args-appTypeToArg f (HsArgPar _      : args) = appTypeToArg f                 args-appTypeToArg f (HsTypeArg l arg : args)-  = appTypeToArg (mkHsAppKindTy l f arg) args---{- *********************************************************************-*                                                                      *-                checkExpectedKind-*                                                                      *-********************************************************************* -}---- | This instantiates invisible arguments for the type being checked if it must--- be saturated and is not yet saturated. It then calls and uses the result--- from checkExpectedKindX to build the final type-checkExpectedKind :: HasDebugCallStack-                  => HsType GhcRn       -- ^ type we're checking (for printing)-                  -> TcType             -- ^ type we're checking-                  -> TcKind             -- ^ the known kind of that type-                  -> TcKind             -- ^ the expected kind-                  -> TcM TcType--- Just a convenience wrapper to save calls to 'ppr'-checkExpectedKind hs_ty ty act_kind exp_kind-  = do { traceTc "checkExpectedKind" (ppr ty $$ ppr act_kind)--       ; (new_args, act_kind') <- tcInstInvisibleTyBindersN n_to_inst act_kind--       ; let origin = TypeEqOrigin { uo_actual   = act_kind'-                                   , uo_expected = exp_kind-                                   , uo_thing    = Just (ppr hs_ty)-                                   , uo_visible  = True } -- the hs_ty is visible--       ; traceTc "checkExpectedKindX" $-         vcat [ ppr hs_ty-              , text "act_kind':" <+> ppr act_kind'-              , text "exp_kind:" <+> ppr exp_kind ]--       ; let res_ty = ty `mkTcAppTys` new_args--       ; if act_kind' `tcEqType` exp_kind-         then return res_ty  -- This is very common-         else do { co_k <- uType KindLevel origin act_kind' exp_kind-                 ; traceTc "checkExpectedKind" (vcat [ ppr act_kind-                                                     , ppr exp_kind-                                                     , ppr co_k ])-                ; return (res_ty `mkTcCastTy` co_k) } }-    where-      -- We need to make sure that both kinds have the same number of implicit-      -- foralls out front. If the actual kind has more, instantiate accordingly.-      -- Otherwise, just pass the type & kind through: the errors are caught-      -- in unifyType.-      n_exp_invis_bndrs = invisibleTyBndrCount exp_kind-      n_act_invis_bndrs = invisibleTyBndrCount act_kind-      n_to_inst         = n_act_invis_bndrs - n_exp_invis_bndrs-------------------------------tcHsContext :: Maybe (LHsContext GhcRn) -> TcM [PredType]-tcHsContext cxt = tc_hs_context typeLevelMode cxt--tcLHsPredType :: LHsType GhcRn -> TcM PredType-tcLHsPredType pred = tc_lhs_pred typeLevelMode pred--tc_hs_context :: TcTyMode -> Maybe (LHsContext GhcRn) -> TcM [PredType]-tc_hs_context _ Nothing = return []-tc_hs_context mode (Just ctxt) = mapM (tc_lhs_pred mode) (unLoc ctxt)--tc_lhs_pred :: TcTyMode -> LHsType GhcRn -> TcM PredType-tc_lhs_pred mode pred = tc_lhs_type mode pred constraintKind------------------------------tcTyVar :: TcTyMode -> Name -> TcM (TcType, TcKind)--- See Note [Type checking recursive type and class declarations]--- in GHC.Tc.TyCl--- This does not instantiate. See Note [Do not always instantiate eagerly in types]-tcTyVar mode name         -- Could be a tyvar, a tycon, or a datacon-  = do { traceTc "lk1" (ppr name)-       ; thing <- tcLookup name-       ; case thing of-           ATyVar _ tv -> return (mkTyVarTy tv, tyVarKind tv)--           -- See Note [Recursion through the kinds]-           ATcTyCon tc_tc-             -> do { check_tc tc_tc-                   ; return (mkTyConTy tc_tc, tyConKind tc_tc) }--           AGlobal (ATyCon tc)-             -> do { check_tc tc-                   ; return (mkTyConTy tc, tyConKind tc) }--           AGlobal (AConLike (RealDataCon dc))-             -> do { data_kinds <- xoptM LangExt.DataKinds-                   ; unless (data_kinds || specialPromotedDc dc) $-                       promotionErr name NoDataKindsDC-                   ; when (isFamInstTyCon (dataConTyCon dc)) $-                       -- see #15245-                       promotionErr name FamDataConPE-                   ; let (_, _, _, theta, _, _) = dataConFullSig dc-                   ; traceTc "tcTyVar" (ppr dc <+> ppr theta $$ ppr (dc_theta_illegal_constraint theta))-                   ; case dc_theta_illegal_constraint theta of-                       Just pred -> promotionErr name $-                                    ConstrainedDataConPE pred-                       Nothing   -> pure ()-                   ; let tc = promoteDataCon dc-                   ; return (mkTyConApp tc [], tyConKind tc) }--           APromotionErr err -> promotionErr name err--           _  -> wrongThingErr "type" thing name }-  where-    check_tc :: TyCon -> TcM ()-    check_tc tc = do { data_kinds   <- xoptM LangExt.DataKinds-                     ; unless (isTypeLevel (mode_tyki mode) ||-                               data_kinds ||-                               isKindTyCon tc) $-                       promotionErr name NoDataKindsTC }--    -- We cannot promote a data constructor with a context that contains-    -- constraints other than equalities, so error if we find one.-    -- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep-    dc_theta_illegal_constraint :: ThetaType -> Maybe PredType-    dc_theta_illegal_constraint = find (not . isEqPred)--{--Note [Recursion through the kinds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider these examples--Ticket #11554:-  data P (x :: k) = Q-  data A :: Type where-    MkA :: forall (a :: A). P a -> A--Ticket #12174-  data V a-  data T = forall (a :: T). MkT (V a)--The type is recursive (which is fine) but it is recursive /through the-kinds/.  In earlier versions of GHC this caused a loop in the compiler-(to do with knot-tying) but there is nothing fundamentally wrong with-the code (kinds are types, and the recursive declarations are OK). But-it's hard to distinguish "recursion through the kinds" from "recursion-through the types". Consider this (also #11554):--  data PB k (x :: k) = Q-  data B :: Type where-    MkB :: P B a -> B--Here the occurrence of B is not obviously in a kind position.--So now GHC allows all these programs.  #12081 and #15942 are other-examples.--Note [Body kind of a HsForAllTy]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The body of a forall is usually a type, but in principle-there's no reason to prohibit *unlifted* types.-In fact, GHC can itself construct a function with an-unboxed tuple inside a for-all (via CPR analysis; see-typecheck/should_compile/tc170).--Moreover in instance heads we get forall-types with-kind Constraint.--It's tempting to check that the body kind is either * or #. But this is-wrong. For example:--  class C a b-  newtype N = Mk Foo deriving (C a)--We're doing newtype-deriving for C. But notice how `a` isn't in scope in-the predicate `C a`. So we quantify, yielding `forall a. C a` even though-`C a` has kind `* -> Constraint`. The `forall a. C a` is a bit cheeky, but-convenient. Bottom line: don't check for * or # here.--Note [Body kind of a HsQualTy]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If ctxt is non-empty, the HsQualTy really is a /function/, so the-kind of the result really is '*', and in that case the kind of the-body-type can be lifted or unlifted.--However, consider-    instance Eq a => Eq [a] where ...-or-    f :: (Eq a => Eq [a]) => blah-Here both body-kind of the HsQualTy is Constraint rather than *.-Rather crudely we tell the difference by looking at exp_kind. It's-very convenient to typecheck instance types like any other HsSigType.--Admittedly the '(Eq a => Eq [a]) => blah' case is erroneous, but it's-better to reject in checkValidType.  If we say that the body kind-should be '*' we risk getting TWO error messages, one saying that Eq-[a] doesn't have kind '*', and one saying that we need a Constraint to-the left of the outer (=>).--How do we figure out the right body kind?  Well, it's a bit of a-kludge: I just look at the expected kind.  If it's Constraint, we-must be in this instance situation context. It's a kludge because it-wouldn't work if any unification was involved to compute that result-kind -- but it isn't.  (The true way might be to use the 'mode'-parameter, but that seemed like a sledgehammer to crack a nut.)--Note [Inferring tuple kinds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Give a tuple type (a,b,c), which the parser labels as HsBoxedOrConstraintTuple,-we try to figure out whether it's a tuple of kind * or Constraint.-  Step 1: look at the expected kind-  Step 2: infer argument kinds--If after Step 2 it's not clear from the arguments that it's-Constraint, then it must be *.  Once having decided that we re-check-the arguments to give good error messages in-  e.g.  (Maybe, Maybe)--Note that we will still fail to infer the correct kind in this case:--  type T a = ((a,a), D a)-  type family D :: Constraint -> Constraint--While kind checking T, we do not yet know the kind of D, so we will default the-kind of T to * -> *. It works if we annotate `a` with kind `Constraint`.--Note [Desugaring types]-~~~~~~~~~~~~~~~~~~~~~~~-The type desugarer is phase 2 of dealing with HsTypes.  Specifically:--  * It transforms from HsType to Type--  * It zonks any kinds.  The returned type should have no mutable kind-    or type variables (hence returning Type not TcType):-      - any unconstrained kind variables are defaulted to (Any *) just-        as in GHC.Tc.Utils.Zonk.-      - there are no mutable type variables because we are-        kind-checking a type-    Reason: the returned type may be put in a TyCon or DataCon where-    it will never subsequently be zonked.--You might worry about nested scopes:-        ..a:kappa in scope..-            let f :: forall b. T '[a,b] -> Int-In this case, f's type could have a mutable kind variable kappa in it;-and we might then default it to (Any *) when dealing with f's type-signature.  But we don't expect this to happen because we can't get a-lexically scoped type variable with a mutable kind variable in it.  A-delicate point, this.  If it becomes an issue we might need to-distinguish top-level from nested uses.--Moreover-  * it cannot fail,-  * it does no unifications-  * it does no validity checking, except for structural matters, such as-        (a) spurious ! annotations.-        (b) a class used as a type--Note [Kind of a type splice]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider these terms, each with TH type splice inside:-     [| e1 :: Maybe $(..blah..) |]-     [| e2 :: $(..blah..) |]-When kind-checking the type signature, we'll kind-check the splice-$(..blah..); we want to give it a kind that can fit in any context,-as if $(..blah..) :: forall k. k.--In the e1 example, the context of the splice fixes kappa to *.  But-in the e2 example, we'll desugar the type, zonking the kind unification-variables as we go.  When we encounter the unconstrained kappa, we-want to default it to '*', not to (Any *).---}--addTypeCtxt :: LHsType GhcRn -> TcM a -> TcM a-        -- Wrap a context around only if we want to show that contexts.-        -- Omit invisible ones and ones user's won't grok-addTypeCtxt (L _ (HsWildCardTy _)) thing = thing   -- "In the type '_'" just isn't helpful.-addTypeCtxt (L _ ty) thing-  = addErrCtxt doc thing-  where-    doc = text "In the type" <+> quotes (ppr ty)---{- *********************************************************************-*                                                                      *-                Type-variable binders-*                                                                      *-********************************************************************* -}--bindNamedWildCardBinders :: [Name]-                         -> ([(Name, TcTyVar)] -> TcM a)-                         -> TcM a--- Bring into scope the /named/ wildcard binders.  Remember that--- plain wildcards _ are anonymous and dealt with by HsWildCardTy--- Soe Note [The wildcard story for types] in GHC.Hs.Type-bindNamedWildCardBinders wc_names thing_inside-  = do { wcs <- mapM newNamedWildTyVar wc_names-       ; let wc_prs = wc_names `zip` wcs-       ; tcExtendNameTyVarEnv wc_prs $-         thing_inside wc_prs }--newNamedWildTyVar :: Name -> TcM TcTyVar--- ^ New unification variable '_' for a wildcard-newNamedWildTyVar _name   -- Currently ignoring the "_x" wildcard name used in the type-  = do { kind <- newMetaKindVar-       ; details <- newMetaDetails TauTv-       ; wc_name <- newMetaTyVarName (fsLit "w")   -- See Note [Wildcard names]-       ; let tyvar = mkTcTyVar wc_name kind details-       ; traceTc "newWildTyVar" (ppr tyvar)-       ; return tyvar }------------------------------tcAnonWildCardOcc :: IsExtraConstraint-                  -> TcTyMode -> HsType GhcRn -> Kind -> TcM TcType-tcAnonWildCardOcc is_extra (TcTyMode { mode_holes = Just (hole_lvl, hole_mode) })-                  ty exp_kind-    -- hole_lvl: see Note [Checking partial type signatures]-    --           esp the bullet on nested forall types-  = do { kv_details <- newTauTvDetailsAtLevel hole_lvl-       ; kv_name    <- newMetaTyVarName (fsLit "k")-       ; wc_details <- newTauTvDetailsAtLevel hole_lvl-       ; wc_name    <- newMetaTyVarName (fsLit wc_nm)-       ; let kv      = mkTcTyVar kv_name liftedTypeKind kv_details-             wc_kind = mkTyVarTy kv-             wc_tv   = mkTcTyVar wc_name wc_kind wc_details--       ; traceTc "tcAnonWildCardOcc" (ppr hole_lvl <+> ppr emit_holes)-       ; when emit_holes $-         emitAnonTypeHole is_extra wc_tv-         -- Why the 'when' guard?-         -- See Note [Wildcards in visible kind application]--       -- You might think that this would always just unify-       -- wc_kind with exp_kind, so we could avoid even creating kv-       -- But the level numbers might not allow that unification,-       -- so we have to do it properly (T14140a)-       ; checkExpectedKind ty (mkTyVarTy wc_tv) wc_kind exp_kind }-  where-     -- See Note [Wildcard names]-     wc_nm = case hole_mode of-               HM_Sig      -> "w"-               HM_FamPat   -> "_"-               HM_VTA      -> "w"-               HM_TyAppPat -> "_"--     emit_holes = case hole_mode of-                     HM_Sig     -> True-                     HM_FamPat  -> False-                     HM_VTA     -> False-                     HM_TyAppPat -> False--tcAnonWildCardOcc _ mode ty _--- mode_holes is Nothing.  Should not happen, because renamer--- should already have rejected holes in unexpected places-  = pprPanic "tcWildCardOcc" (ppr mode $$ ppr ty)--{- Note [Wildcard names]-~~~~~~~~~~~~~~~~~~~~~~~~-So we hackily use the mode_holes flag to control the name used-for wildcards:--* For proper holes (whether in a visible type application (VTA) or no),-  we rename the '_' to 'w'. This is so that we see variables like 'w0'-  or 'w1' in error messages, a vast improvement upon '_0' and '_1'. For-  example, we prefer-       Found type wildcard ‘_’ standing for ‘w0’-  over-       Found type wildcard ‘_’ standing for ‘_1’--  Even in the VTA case, where we do not emit an error to be printed, we-  want to do the renaming, as the variables may appear in other,-  non-wildcard error messages.--* However, holes in the left-hand sides of type families ("type-  patterns") stand for type variables which we do not care to name ---  much like the use of an underscore in an ordinary term-level-  pattern. When we spot these, we neither wish to generate an error-  message nor to rename the variable.  We don't rename the variable so-  that we can pretty-print a type family LHS as, e.g.,-    F _ Int _ = ...-  and not-     F w1 Int w2 = ...--  See also Note [Wildcards in family instances] in-  GHC.Rename.Module. The choice of HM_FamPat is made in-  tcFamTyPats. There is also some unsavory magic, relying on that-  underscore, in GHC.Core.Coercion.tidyCoAxBndrsForUser.--Note [Wildcards in visible kind application]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-There are cases where users might want to pass in a wildcard as a visible kind-argument, for instance:--data T :: forall k1 k2. k1 → k2 → Type where-  MkT :: T a b-x :: T @_ @Nat False n-x = MkT--So we should allow '@_' without emitting any hole constraints, and-regardless of whether PartialTypeSignatures is enabled or not. But how-would the typechecker know which '_' is being used in VKA and which is-not when it calls emitNamedTypeHole in-tcHsPartialSigType on all HsWildCardBndrs?  The solution is to neither-rename nor include unnamed wildcards in HsWildCardBndrs, but instead-give every anonymous wildcard a fresh wild tyvar in tcAnonWildCardOcc.--And whenever we see a '@', we set mode_holes to HM_VKA, so that-we do not call emitAnonTypeHole in tcAnonWildCardOcc.-See related Note [Wildcards in visible type application] here and-Note [The wildcard story for types] in GHC.Hs.Type--}--{- *********************************************************************-*                                                                      *-             Kind inference for type declarations-*                                                                      *-********************************************************************* -}---- See Note [kcCheckDeclHeader vs kcInferDeclHeader]-data InitialKindStrategy-  = InitialKindCheck SAKS_or_CUSK-  | InitialKindInfer---- Does the declaration have a standalone kind signature (SAKS) or a complete--- user-specified kind (CUSK)?-data SAKS_or_CUSK-  = SAKS Kind  -- Standalone kind signature, fully zonked! (zonkTcTypeToType)-  | CUSK       -- Complete user-specified kind (CUSK)--instance Outputable SAKS_or_CUSK where-  ppr (SAKS k) = text "SAKS" <+> ppr k-  ppr CUSK = text "CUSK"---- See Note [kcCheckDeclHeader vs kcInferDeclHeader]-kcDeclHeader-  :: InitialKindStrategy-  -> Name              -- ^ of the thing being checked-  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked-  -> LHsQTyVars GhcRn  -- ^ Binders in the header-  -> TcM ContextKind   -- ^ The result kind-  -> TcM TcTyCon       -- ^ A suitably-kinded TcTyCon-kcDeclHeader (InitialKindCheck msig) = kcCheckDeclHeader msig-kcDeclHeader InitialKindInfer = kcInferDeclHeader--{- Note [kcCheckDeclHeader vs kcInferDeclHeader]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-kcCheckDeclHeader and kcInferDeclHeader are responsible for getting the initial kind-of a type constructor.--* kcCheckDeclHeader: the TyCon has a standalone kind signature or a CUSK. In that-  case, find the full, final, poly-kinded kind of the TyCon.  It's very like a-  term-level binding where we have a complete type signature for the function.--* kcInferDeclHeader: the TyCon has neither a standalone kind signature nor a-  CUSK. Find a monomorphic kind, with unification variables in it; they will be-  generalised later.  It's very like a term-level binding where we do not have a-  type signature (or, more accurately, where we have a partial type signature),-  so we infer the type and generalise.--}---------------------------------kcCheckDeclHeader-  :: SAKS_or_CUSK-  -> Name              -- ^ of the thing being checked-  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked-  -> LHsQTyVars GhcRn  -- ^ Binders in the header-  -> TcM ContextKind   -- ^ The result kind. AnyKind == no result signature-  -> TcM TcTyCon       -- ^ A suitably-kinded generalized TcTyCon-kcCheckDeclHeader (SAKS sig) = kcCheckDeclHeader_sig sig-kcCheckDeclHeader CUSK       = kcCheckDeclHeader_cusk--kcCheckDeclHeader_cusk-  :: Name              -- ^ of the thing being checked-  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked-  -> LHsQTyVars GhcRn  -- ^ Binders in the header-  -> TcM ContextKind   -- ^ The result kind-  -> TcM TcTyCon       -- ^ A suitably-kinded generalized TcTyCon-kcCheckDeclHeader_cusk name flav-              (HsQTvs { hsq_ext = kv_ns-                      , hsq_explicit = hs_tvs }) kc_res_ki-  -- CUSK case-  -- See note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl-  = addTyConFlavCtxt name flav $-    do { (tclvl, wanted, (scoped_kvs, (tc_tvs, res_kind)))-           <- pushLevelAndSolveEqualitiesX "kcCheckDeclHeader_cusk" $-              bindImplicitTKBndrs_Q_Skol kv_ns                      $-              bindExplicitTKBndrs_Q_Skol ctxt_kind hs_tvs           $-              newExpectedKind =<< kc_res_ki--           -- Now, because we're in a CUSK,-           -- we quantify over the mentioned kind vars-       ; let spec_req_tkvs = scoped_kvs ++ tc_tvs-             all_kinds     = res_kind : map tyVarKind spec_req_tkvs--       ; candidates' <- candidateQTyVarsOfKinds all_kinds-             -- 'candidates' are all the variables that we are going to-             -- skolemise and then quantify over.  We do not include spec_req_tvs-             -- because they are /already/ skolems--       ; let non_tc_candidates = filter (not . isTcTyVar) (nonDetEltsUniqSet (tyCoVarsOfTypes all_kinds))-             candidates = candidates' { dv_kvs = dv_kvs candidates' `extendDVarSetList` non_tc_candidates }-             inf_candidates = candidates `delCandidates` spec_req_tkvs--       ; inferred <- quantifyTyVars inf_candidates-                     -- NB: 'inferred' comes back sorted in dependency order--       ; scoped_kvs <- mapM zonkTyCoVarKind scoped_kvs-       ; tc_tvs     <- mapM zonkTyCoVarKind tc_tvs-       ; res_kind   <- zonkTcType           res_kind--       ; let mentioned_kv_set = candidateKindVars candidates-             specified        = scopedSort scoped_kvs-                                -- NB: maintain the L-R order of scoped_kvs--             final_tc_binders =  mkNamedTyConBinders Inferred  inferred-                              ++ mkNamedTyConBinders Specified specified-                              ++ map (mkRequiredTyConBinder mentioned_kv_set) tc_tvs--             all_tv_prs =  mkTyVarNamePairs (scoped_kvs ++ tc_tvs)-             tycon = mkTcTyCon name final_tc_binders res_kind all_tv_prs-                               True -- it is generalised-                               flav--       ; reportUnsolvedEqualities skol_info (binderVars final_tc_binders)-                                  tclvl wanted--         -- If the ordering from-         -- Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl-         -- doesn't work, we catch it here, before an error cascade-       ; checkTyConTelescope tycon--       ; traceTc "kcCheckDeclHeader_cusk " $-         vcat [ text "name" <+> ppr name-              , text "kv_ns" <+> ppr kv_ns-              , text "hs_tvs" <+> ppr hs_tvs-              , text "scoped_kvs" <+> ppr scoped_kvs-              , text "tc_tvs" <+> ppr tc_tvs-              , text "res_kind" <+> ppr res_kind-              , text "candidates" <+> ppr candidates-              , text "inferred" <+> ppr inferred-              , text "specified" <+> ppr specified-              , text "final_tc_binders" <+> ppr final_tc_binders-              , text "mkTyConKind final_tc_bndrs res_kind"-                <+> ppr (mkTyConKind final_tc_binders res_kind)-              , text "all_tv_prs" <+> ppr all_tv_prs ]--       ; return tycon }-  where-    skol_info = TyConSkol flav name-    ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind-              | otherwise            = AnyKind---- | Kind-check a 'LHsQTyVars'. Used in 'inferInitialKind' (for tycon kinds and--- other kinds).------ This function does not do telescope checking.-kcInferDeclHeader-  :: Name              -- ^ of the thing being checked-  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked-  -> LHsQTyVars GhcRn-  -> TcM ContextKind   -- ^ The result kind-  -> TcM TcTyCon       -- ^ A suitably-kinded non-generalized TcTyCon-kcInferDeclHeader name flav-              (HsQTvs { hsq_ext = kv_ns-                      , hsq_explicit = hs_tvs }) kc_res_ki-  -- No standalane kind signature and no CUSK.-  -- See note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl-  = addTyConFlavCtxt name flav $-    do { (scoped_kvs, (tc_tvs, res_kind))-           -- Why bindImplicitTKBndrs_Q_Tv which uses newTyVarTyVar?-           -- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl-           <- bindImplicitTKBndrs_Q_Tv kv_ns            $-              bindExplicitTKBndrs_Q_Tv ctxt_kind hs_tvs $-              newExpectedKind =<< kc_res_ki-              -- Why "_Tv" not "_Skol"? See third wrinkle in-              -- Note [Inferring kinds for type declarations] in GHC.Tc.TyCl,--       ; let   -- NB: Don't add scoped_kvs to tyConTyVars, because they-               -- might unify with kind vars in other types in a mutually-               -- recursive group.-               -- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl--             tc_binders = mkAnonTyConBinders VisArg tc_tvs-               -- Also, note that tc_binders has the tyvars from only the-               -- user-written tyvarbinders. See S1 in Note [How TcTyCons work]-               -- in GHC.Tc.TyCl-               ---               -- mkAnonTyConBinder: see Note [No polymorphic recursion]--             all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs)-               -- NB: bindExplicitTKBndrs_Q_Tv does not clone;-               --     ditto Implicit-               -- See Note [Cloning for type variable binders]--             tycon = mkTcTyCon name tc_binders res_kind all_tv_prs-                               False -- not yet generalised-                               flav--       ; traceTc "kcInferDeclHeader: not-cusk" $-         vcat [ ppr name, ppr kv_ns, ppr hs_tvs-              , ppr scoped_kvs-              , ppr tc_tvs, ppr (mkTyConKind tc_binders res_kind) ]-       ; return tycon }-  where-    ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind-              | otherwise            = AnyKind---- | Kind-check a declaration header against a standalone kind signature.--- See Note [Arity inference in kcCheckDeclHeader_sig]-kcCheckDeclHeader_sig-  :: Kind              -- ^ Standalone kind signature, fully zonked! (zonkTcTypeToType)-  -> Name              -- ^ of the thing being checked-  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked-  -> LHsQTyVars GhcRn  -- ^ Binders in the header-  -> TcM ContextKind   -- ^ The result kind. AnyKind == no result signature-  -> TcM TcTyCon       -- ^ A suitably-kinded TcTyCon-kcCheckDeclHeader_sig kisig name flav-          (HsQTvs { hsq_ext      = implicit_nms-                  , hsq_explicit = explicit_nms }) kc_res_ki-  = addTyConFlavCtxt name flav $-    do {  -- Step 1: zip user-written binders with quantifiers from the kind signature.-          -- For example:-          ---          --   type F :: forall k -> k -> forall j. j -> Type-          --   data F i a b = ...-          ---          -- Results in the following 'zipped_binders':-          ---          --                   TyBinder      LHsTyVarBndr-          --    ----------------------------------------          --    ZippedBinder   forall k ->   i-          --    ZippedBinder   k ->          a-          --    ZippedBinder   forall j.-          --    ZippedBinder   j ->          b-          ---          let (zipped_binders, excess_bndrs, kisig') = zipBinders kisig explicit_nms--          -- Report binders that don't have a corresponding quantifier.-          -- For example:-          ---          --   type T :: Type -> Type-          --   data T b1 b2 b3 = ...-          ---          -- Here, b1 is zipped with Type->, while b2 and b3 are excess binders.-          ---        ; unless (null excess_bndrs) $ failWithTc (tooManyBindersErr kisig' excess_bndrs)--          -- Convert each ZippedBinder to TyConBinder        for  tyConBinders-          --                       and to [(Name, TcTyVar)]  for  tcTyConScopedTyVars-        ; (vis_tcbs, concat -> explicit_tv_prs) <- mapAndUnzipM zipped_to_tcb zipped_binders--        ; (tclvl, wanted, (implicit_tvs, (invis_binders, r_ki)))-             <- pushLevelAndSolveEqualitiesX "kcCheckDeclHeader_sig" $  -- #16687-                bindImplicitTKBndrs_Tv implicit_nms                  $-                tcExtendNameTyVarEnv explicit_tv_prs                 $-                do { -- Check that inline kind annotations on binders are valid.-                     -- For example:-                     ---                     --   type T :: Maybe k -> Type-                     --   data T (a :: Maybe j) = ...-                     ---                     -- Here we unify   Maybe k ~ Maybe j-                     mapM_ check_zipped_binder zipped_binders--                     -- Kind-check the result kind annotation, if present:-                     ---                     --    data T a b :: res_ki where-                     --               ^^^^^^^^^-                     -- We do it here because at this point the environment has been-                     -- extended with both 'implicit_tcv_prs' and 'explicit_tv_prs'.-                   ; ctx_k    <- kc_res_ki-                   ; m_res_ki <- case ctx_k of-                                  AnyKind -> return Nothing-                                  _ -> Just <$> newExpectedKind ctx_k--                     -- Step 2: split off invisible binders.-                     -- For example:-                     ---                     --   type F :: forall k1 k2. (k1, k2) -> Type-                     --   type family F-                     ---                     -- Does 'forall k1 k2' become a part of 'tyConBinders' or 'tyConResKind'?-                     -- See Note [Arity inference in kcCheckDeclHeader_sig]-                   ; let (invis_binders, r_ki) = split_invis kisig' m_res_ki--                     -- Check that the inline result kind annotation is valid.-                     -- For example:-                     ---                     --   type T :: Type -> Maybe k-                     --   type family T a :: Maybe j where-                     ---                     -- Here we unify   Maybe k ~ Maybe j-                   ; whenIsJust m_res_ki $ \res_ki ->-                      discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig]-                      unifyKind Nothing r_ki res_ki--                   ; return (invis_binders, r_ki) }--        -- Convert each invisible TyCoBinder to TyConBinder for tyConBinders.-        ; invis_tcbs <- mapM invis_to_tcb invis_binders--        -- Zonk the implicitly quantified variables.-        ; implicit_tvs <- mapM zonkTcTyVarToTyVar implicit_tvs--        -- Build the final, generalized TcTyCon-        ; let tcbs            = vis_tcbs ++ invis_tcbs-              implicit_tv_prs = implicit_nms `zip` implicit_tvs-              all_tv_prs      = implicit_tv_prs ++ explicit_tv_prs-              tc              = mkTcTyCon name tcbs r_ki all_tv_prs True flav-              skol_info       = TyConSkol flav name--        -- Check that there are no unsolved equalities-        ; reportUnsolvedEqualities skol_info (binderVars tcbs) tclvl wanted--        ; traceTc "kcCheckDeclHeader_sig done:" $ vcat-          [ text "tyConName = " <+> ppr (tyConName tc)-          , text "kisig =" <+> debugPprType kisig-          , text "tyConKind =" <+> debugPprType (tyConKind tc)-          , text "tyConBinders = " <+> ppr (tyConBinders tc)-          , text "tcTyConScopedTyVars" <+> ppr (tcTyConScopedTyVars tc)-          , text "tyConResKind" <+> debugPprType (tyConResKind tc)-          ]-        ; return tc }-  where-    -- Consider this declaration:-    ---    --    type T :: forall a. forall b -> (a~b) => Proxy a -> Type-    --    data T x p = MkT-    ---    -- Here, we have every possible variant of ZippedBinder:-    ---    --                   TyBinder           LHsTyVarBndr-    --    -----------------------------------------------    --    ZippedBinder   forall {k}.-    --    ZippedBinder   forall (a::k).-    --    ZippedBinder   forall (b::k) ->   x-    --    ZippedBinder   (a~b) =>-    --    ZippedBinder   Proxy a ->         p-    ---    -- Given a ZippedBinder zipped_to_tcb produces:-    ---    --  * TyConBinder      for  tyConBinders-    --  * (Name, TcTyVar)  for  tcTyConScopedTyVars, if there's a user-written LHsTyVarBndr-    ---    zipped_to_tcb :: ZippedBinder -> TcM (TyConBinder, [(Name, TcTyVar)])-    zipped_to_tcb zb = case zb of--      -- Inferred variable, no user-written binder.-      -- Example:   forall {k}.-      ZippedBinder (Named (Bndr v Specified)) Nothing ->-        return (mkNamedTyConBinder Specified v, [])--      -- Specified variable, no user-written binder.-      -- Example:   forall (a::k).-      ZippedBinder (Named (Bndr v Inferred)) Nothing ->-        return (mkNamedTyConBinder Inferred v, [])--      -- Constraint, no user-written binder.-      -- Example:   (a~b) =>-      ZippedBinder (Anon InvisArg bndr_ki) Nothing -> do-        name <- newSysName (mkTyVarOccFS (fsLit "ev"))-        let tv = mkTyVar name (scaledThing bndr_ki)-        return (mkAnonTyConBinder InvisArg tv, [])--      -- Non-dependent visible argument with a user-written binder.-      -- Example:   Proxy a ->-      ZippedBinder (Anon VisArg bndr_ki) (Just b) ->-        return $-          let v_name = getName b-              tv = mkTyVar v_name (scaledThing bndr_ki)-              tcb = mkAnonTyConBinder VisArg tv-          in (tcb, [(v_name, tv)])--      -- Dependent visible argument with a user-written binder.-      -- Example:   forall (b::k) ->-      ZippedBinder (Named (Bndr v Required)) (Just b) ->-        return $-          let v_name = getName b-              tcb = mkNamedTyConBinder Required v-          in (tcb, [(v_name, v)])--      -- 'zipBinders' does not produce any other variants of ZippedBinder.-      _ -> panic "goVis: invalid ZippedBinder"--    -- Given an invisible binder that comes from 'split_invis',-    -- convert it to TyConBinder.-    invis_to_tcb :: TyCoBinder -> TcM TyConBinder-    invis_to_tcb tb = do-      (tcb, stv) <- zipped_to_tcb (ZippedBinder tb Nothing)-      MASSERT(null stv)-      return tcb--    -- Check that the inline kind annotation on a binder is valid-    -- by unifying it with the kind of the quantifier.-    check_zipped_binder :: ZippedBinder -> TcM ()-    check_zipped_binder (ZippedBinder _ Nothing) = return ()-    check_zipped_binder (ZippedBinder tb (Just b)) =-      case unLoc b of-        UserTyVar _ _ _ -> return ()-        KindedTyVar _ _ v v_hs_ki -> do-          v_ki <- tcLHsKindSig (TyVarBndrKindCtxt (unLoc v)) v_hs_ki-          discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig]-            unifyKind (Just (ppr v))-                      (tyBinderType tb)-                      v_ki--    -- Split the invisible binders that should become a part of 'tyConBinders'-    -- rather than 'tyConResKind'.-    -- See Note [Arity inference in kcCheckDeclHeader_sig]-    split_invis :: Kind -> Maybe Kind -> ([TyCoBinder], Kind)-    split_invis sig_ki Nothing =-      -- instantiate all invisible binders-      splitInvisPiTys sig_ki-    split_invis sig_ki (Just res_ki) =-      -- subtraction a la checkExpectedKind-      let n_res_invis_bndrs = invisibleTyBndrCount res_ki-          n_sig_invis_bndrs = invisibleTyBndrCount sig_ki-          n_inst = n_sig_invis_bndrs - n_res_invis_bndrs-      in splitInvisPiTysN n_inst sig_ki---- A quantifier from a kind signature zipped with a user-written binder for it.-data ZippedBinder = ZippedBinder TyBinder (Maybe (LHsTyVarBndr () GhcRn))---- See Note [Arity inference in kcCheckDeclHeader_sig]-zipBinders-  :: Kind                      -- Kind signature-  -> [LHsTyVarBndr () GhcRn]   -- User-written binders-  -> ( [ZippedBinder]          -- Zipped binders-     , [LHsTyVarBndr () GhcRn] -- Leftover user-written binders-     , Kind )                  -- Remainder of the kind signature-zipBinders = zip_binders [] emptyTCvSubst-  where-    -- subst: we substitute as we go, to ensure that the resulting-    -- binders in the [ZippedBndr] all have distinct uniques.-    -- If not, the TyCon may get multiple binders with the same unique,-    -- which results in chaos (see #19092,3,4)-    -- (The incoming kind might be forall k. k -> forall k. k -> Type-    --  where those two k's have the same unique. Without the substitution-    --  we'd get a repeated 'k'.)-    zip_binders acc subst ki bs-      | (b:bs') <- bs  -- Stop as soon as 'bs' becomes empty-      , Just (tb,ki') <- tcSplitPiTy_maybe ki-      , let (subst', tb') = substTyCoBndr subst tb-      = if isInvisibleBinder tb-        then zip_binders (ZippedBinder tb' Nothing  : acc) subst' ki' bs-        else zip_binders (ZippedBinder tb' (Just b) : acc) subst' ki' bs'--      | otherwise-      = (reverse acc, bs, substTy subst ki)--tooManyBindersErr :: Kind -> [LHsTyVarBndr () GhcRn] -> SDoc-tooManyBindersErr ki bndrs =-   hang (text "Not a function kind:")-      4 (ppr ki) $$-   hang (text "but extra binders found:")-      4 (fsep (map ppr bndrs))--{- Note [Arity inference in kcCheckDeclHeader_sig]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Given a kind signature 'kisig' and a declaration header, kcCheckDeclHeader_sig-verifies that the declaration conforms to the signature. The end result is a-TcTyCon 'tc' such that:--  tyConKind tc == kisig--This TcTyCon would be rather easy to produce if we didn't have to worry about-arity. Consider these declarations:--  type family S1 :: forall k. k -> Type-  type family S2 (a :: k) :: Type--Both S1 and S2 can be given the same standalone kind signature:--  type S2 :: forall k. k -> Type--And, indeed, tyConKind S1 == tyConKind S2. However, tyConKind is built from-tyConBinders and tyConResKind, such that--  tyConKind tc == mkTyConKind (tyConBinders tc) (tyConResKind tc)--For S1 and S2, tyConBinders and tyConResKind are different:--  tyConBinders S1  ==  []-  tyConResKind S1  ==  forall k. k -> Type-  tyConKind    S1  ==  forall k. k -> Type--  tyConBinders S2  ==  [spec k, anon-vis (a :: k)]-  tyConResKind S2  ==  Type-  tyConKind    S1  ==  forall k. k -> Type--This difference determines the arity:--  tyConArity tc == length (tyConBinders tc)--That is, the arity of S1 is 0, while the arity of S2 is 2.--'kcCheckDeclHeader_sig' needs to infer the desired arity to split the standalone-kind signature into binders and the result kind. It does so in two rounds:--1. zip user-written binders (vis_tcbs)-2. split off invisible binders (invis_tcbs)--Consider the following declarations:--    type F :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type-    type family F a b--    type G :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type-    type family G a b :: forall r2. (r1, r2) -> Type--In step 1 (zip user-written binders), we zip the quantifiers in the signature-with the binders in the header using 'zipBinders'. In both F and G, this results in-the following zipped binders:--                   TyBinder     LHsTyVarBndr-    ----------------------------------------    ZippedBinder   Type ->      a-    ZippedBinder   forall j.-    ZippedBinder   j ->         b---At this point, we have accumulated three zipped binders which correspond to a-prefix of the standalone kind signature:--  Type -> forall j. j -> ...--In step 2 (split off invisible binders), we have to decide how much remaining-invisible binders of the standalone kind signature to split off:--    forall k1 k2. (k1, k2) -> Type-    ^^^^^^^^^^^^^-    split off or not?--This decision is made in 'split_invis':--* If a user-written result kind signature is not provided, as in F,-  then split off all invisible binders. This is why we need special treatment-  for AnyKind.-* If a user-written result kind signature is provided, as in G,-  then do as checkExpectedKind does and split off (n_sig - n_res) binders.-  That is, split off such an amount of binders that the remainder of the-  standalone kind signature and the user-written result kind signature have the-  same amount of invisible quantifiers.--For F, split_invis splits away all invisible binders, and we have 2:--    forall k1 k2. (k1, k2) -> Type-    ^^^^^^^^^^^^^-    split away both binders--The resulting arity of F is 3+2=5.  (length vis_tcbs = 3,-                                     length invis_tcbs = 2,-                                     length tcbs = 5)--For G, split_invis decides to split off 1 invisible binder, so that we have the-same amount of invisible quantifiers left:--    res_ki  =  forall    r2. (r1, r2) -> Type-    kisig   =  forall k1 k2. (k1, k2) -> Type-                     ^^^-                     split off this one.--The resulting arity of G is 3+1=4. (length vis_tcbs = 3,-                                    length invis_tcbs = 1,-                                    length tcbs = 4)---}--{- Note [discardResult in kcCheckDeclHeader_sig]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We use 'unifyKind' to check inline kind annotations in declaration headers-against the signature.--  type T :: [i] -> Maybe j -> Type-  data T (a :: [k1]) (b :: Maybe k2) :: Type where ...--Here, we will unify:--       [k1] ~ [i]-  Maybe k2  ~ Maybe j-      Type  ~ Type--The end result is that we fill in unification variables k1, k2:--    k1  :=  i-    k2  :=  j--We also validate that the user isn't confused:--  type T :: Type -> Type-  data T (a :: Bool) = ...--This will report that (Type ~ Bool) failed to unify.--Now, consider the following example:--  type family Id a where Id x = x-  type T :: Bool -> Type-  type T (a :: Id Bool) = ...--We will unify (Bool ~ Id Bool), and this will produce a non-reflexive coercion.-However, we are free to discard it, as the kind of 'T' is determined by the-signature, not by the inline kind annotation:--      we have   T ::    Bool -> Type-  rather than   T :: Id Bool -> Type--This (Id Bool) will not show up anywhere after we're done validating it, so we-have no use for the produced coercion.--}--{- Note [No polymorphic recursion]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Should this kind-check?-  data T ka (a::ka) b  = MkT (T Type           Int   Bool)-                             (T (Type -> Type) Maybe Bool)--Notice that T is used at two different kinds in its RHS.  No!-This should not kind-check.  Polymorphic recursion is known to-be a tough nut.--Previously, we laboriously (with help from the renamer)-tried to give T the polymorphic kind-   T :: forall ka -> ka -> kappa -> Type-where kappa is a unification variable, even in the inferInitialKinds-phase (which is what kcInferDeclHeader is all about).  But-that is dangerously fragile (see the ticket).--Solution: make kcInferDeclHeader give T a straightforward-monomorphic kind, with no quantification whatsoever. That's why-we use mkAnonTyConBinder for all arguments when figuring out-tc_binders.--But notice that (#16322 comment:3)--* The algorithm successfully kind-checks this declaration:-    data T2 ka (a::ka) = MkT2 (T2 Type a)--  Starting with (inferInitialKinds)-    T2 :: (kappa1 :: kappa2 :: *) -> (kappa3 :: kappa4 :: *) -> *-  we get-    kappa4 := kappa1   -- from the (a:ka) kind signature-    kappa1 := Type     -- From application T2 Type--  These constraints are soluble so generaliseTcTyCon gives-    T2 :: forall (k::Type) -> k -> *--  But now the /typechecking/ (aka desugaring, tcTyClDecl) phase-  fails, because the call (T2 Type a) in the RHS is ill-kinded.--  We'd really prefer all errors to show up in the kind checking-  phase.--* This algorithm still accepts (in all phases)-     data T3 ka (a::ka) = forall b. MkT3 (T3 Type b)-  although T3 is really polymorphic-recursive too.-  Perhaps we should somehow reject that.--Note [Kind variable ordering for associated types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-What should be the kind of `T` in the following example? (#15591)--  class C (a :: Type) where-    type T (x :: f a)--As per Note [Ordering of implicit variables] in GHC.Rename.HsType, we want to quantify-the kind variables in left-to-right order of first occurrence in order to-support visible kind application. But we cannot perform this analysis on just-T alone, since its variable `a` actually occurs /before/ `f` if you consider-the fact that `a` was previously bound by the parent class `C`. That is to say,-the kind of `T` should end up being:--  T :: forall a f. f a -> Type--(It wouldn't necessarily be /wrong/ if the kind ended up being, say,-forall f a. f a -> Type, but that would not be as predictable for users of-visible kind application.)--In contrast, if `T` were redefined to be a top-level type family, like `T2`-below:--  type family T2 (x :: f (a :: Type))--Then `a` first appears /after/ `f`, so the kind of `T2` should be:--  T2 :: forall f a. f a -> Type--In order to make this distinction, we need to know (in kcCheckDeclHeader) which-type variables have been bound by the parent class (if there is one). With-the class-bound variables in hand, we can ensure that we always quantify-these first.--}---{- *********************************************************************-*                                                                      *-             Expected kinds-*                                                                      *-********************************************************************* -}---- | Describes the kind expected in a certain context.-data ContextKind = TheKind Kind   -- ^ a specific kind-                 | AnyKind        -- ^ any kind will do-                 | OpenKind       -- ^ something of the form @TYPE _@--------------------------newExpectedKind :: ContextKind -> TcM Kind-newExpectedKind (TheKind k)   = return k-newExpectedKind AnyKind       = newMetaKindVar-newExpectedKind OpenKind      = newOpenTypeKind--------------------------expectedKindInCtxt :: UserTypeCtxt -> ContextKind--- Depending on the context, we might accept any kind (for instance, in a TH--- splice), or only certain kinds (like in type signatures).-expectedKindInCtxt (TySynCtxt _)   = AnyKind-expectedKindInCtxt (GhciCtxt {})   = AnyKind--- The types in a 'default' decl can have varying kinds--- See Note [Extended defaults]" in GHC.Tc.Utils.Env-expectedKindInCtxt DefaultDeclCtxt     = AnyKind-expectedKindInCtxt DerivClauseCtxt     = AnyKind-expectedKindInCtxt TypeAppCtxt         = AnyKind-expectedKindInCtxt (ForSigCtxt _)      = TheKind liftedTypeKind-expectedKindInCtxt (InstDeclCtxt {})   = TheKind constraintKind-expectedKindInCtxt SpecInstCtxt        = TheKind constraintKind-expectedKindInCtxt _                   = OpenKind---{- *********************************************************************-*                                                                      *-             Bringing type variables into scope-*                                                                      *-********************************************************************* -}-------------------------------------------    HsForAllTelescope-----------------------------------------tcTKTelescope :: TcTyMode-              -> HsForAllTelescope GhcRn-              -> TcM a-              -> TcM ([TcTyVarBinder], a)-tcTKTelescope mode tele thing_inside = case tele of-  HsForAllVis { hsf_vis_bndrs = bndrs }-    -> do { (req_tv_bndrs, thing) <- tcExplicitTKBndrsX skol_mode bndrs thing_inside-            -- req_tv_bndrs :: [VarBndr TyVar ()],-            -- but we want [VarBndr TyVar ArgFlag]-          ; return (tyVarReqToBinders req_tv_bndrs, thing) }--  HsForAllInvis { hsf_invis_bndrs = bndrs }-    -> do { (inv_tv_bndrs, thing) <- tcExplicitTKBndrsX skol_mode bndrs thing_inside-            -- inv_tv_bndrs :: [VarBndr TyVar Specificity],-            -- but we want [VarBndr TyVar ArgFlag]-          ; return (tyVarSpecToBinders inv_tv_bndrs, thing) }-  where-    skol_mode = smVanilla { sm_clone = False, sm_holes = mode_holes mode }-------------------------------------------    HsOuterTyVarBndrs-----------------------------------------bindOuterTKBndrsX :: OutputableBndrFlag flag 'Renamed-                  => SkolemMode-                  -> HsOuterTyVarBndrs flag GhcRn-                  -> TcM a-                  -> TcM (HsOuterTyVarBndrs flag GhcTc, a)-bindOuterTKBndrsX skol_mode outer_bndrs thing_inside-  = case outer_bndrs of-      HsOuterImplicit{hso_ximplicit = imp_tvs} ->-        do { (imp_tvs', thing) <- bindImplicitTKBndrsX skol_mode imp_tvs thing_inside-           ; return ( HsOuterImplicit{hso_ximplicit = imp_tvs'}-                    , thing) }-      HsOuterExplicit{hso_bndrs = exp_bndrs} ->-        do { (exp_tvs', thing) <- bindExplicitTKBndrsX skol_mode exp_bndrs thing_inside-           ; return ( HsOuterExplicit { hso_xexplicit = exp_tvs'-                                      , hso_bndrs     = exp_bndrs }-                    , thing) }--getOuterTyVars :: HsOuterTyVarBndrs flag GhcTc -> [TcTyVar]--- The returned [TcTyVar] is not necessarily in dependency order--- at least for the HsOuterImplicit case-getOuterTyVars (HsOuterImplicit { hso_ximplicit = tvs })  = tvs-getOuterTyVars (HsOuterExplicit { hso_xexplicit = tvbs }) = binderVars tvbs------------------scopedSortOuter :: HsOuterTyVarBndrs Specificity GhcTc -> TcM [InvisTVBinder]--- Sort any /implicit/ binders into dependency order---     (zonking first so we can see the dependencies)--- /Explicit/ ones are already in the right order-scopedSortOuter (HsOuterImplicit{hso_ximplicit = imp_tvs})-  = do { imp_tvs <- zonkAndScopedSort imp_tvs-       ; return [Bndr tv SpecifiedSpec | tv <- imp_tvs] }-scopedSortOuter (HsOuterExplicit{hso_xexplicit = exp_tvs})-  = -- No need to dependency-sort (or zonk) explicit quantifiers-    return exp_tvs------------------bindOuterSigTKBndrs_Tv :: HsOuterSigTyVarBndrs GhcRn-                       -> TcM a -> TcM (HsOuterSigTyVarBndrs GhcTc, a)-bindOuterSigTKBndrs_Tv-  = bindOuterTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = True })--bindOuterSigTKBndrs_Tv_M :: TcTyMode-                         -> HsOuterSigTyVarBndrs GhcRn-                         -> TcM a -> TcM (HsOuterSigTyVarBndrs GhcTc, a)--- Do not push level; do not make implication constraint; use Tvs--- Two major clients of this "bind-only" path are:---    Note [Using TyVarTvs for kind-checking GADTs] in GHC.Tc.TyCl---    Note [Checking partial type signatures]-bindOuterSigTKBndrs_Tv_M mode-  = bindOuterTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = True-                                 , sm_holes = mode_holes mode })--bindOuterFamEqnTKBndrs_Q_Tv :: HsOuterFamEqnTyVarBndrs GhcRn-                            -> TcM a-                            -> TcM ([TcTyVar], a)-bindOuterFamEqnTKBndrs_Q_Tv hs_bndrs thing_inside-  = liftFstM getOuterTyVars $-    bindOuterTKBndrsX (smVanilla { sm_clone = False, sm_parent = True-                                 , sm_tvtv = True })-                      hs_bndrs thing_inside-    -- sm_clone=False: see Note [Cloning for type variable binders]--bindOuterFamEqnTKBndrs :: HsOuterFamEqnTyVarBndrs GhcRn-                       -> TcM a-                       -> TcM ([TcTyVar], a)-bindOuterFamEqnTKBndrs hs_bndrs thing_inside-  = liftFstM getOuterTyVars $-    bindOuterTKBndrsX (smVanilla { sm_clone = False, sm_parent = True })-                      hs_bndrs thing_inside-    -- sm_clone=False: see Note [Cloning for type variable binders]------------------tcOuterTKBndrs :: OutputableBndrFlag flag 'Renamed-               => SkolemInfo-               -> HsOuterTyVarBndrs flag GhcRn-               -> TcM a -> TcM (HsOuterTyVarBndrs flag GhcTc, a)-tcOuterTKBndrs = tcOuterTKBndrsX (smVanilla { sm_clone = False })-  -- Do not clone the outer binders-  -- See Note [Cloning for type variable binder] under "must not"--tcOuterTKBndrsX :: OutputableBndrFlag flag 'Renamed-                => SkolemMode -> SkolemInfo-                -> HsOuterTyVarBndrs flag GhcRn-                -> TcM a -> TcM (HsOuterTyVarBndrs flag GhcTc, a)--- Push level, capture constraints, make implication-tcOuterTKBndrsX skol_mode skol_info outer_bndrs thing_inside-  = case outer_bndrs of-      HsOuterImplicit{hso_ximplicit = imp_tvs} ->-        do { (imp_tvs', thing) <- tcImplicitTKBndrsX skol_mode skol_info imp_tvs thing_inside-           ; return ( HsOuterImplicit{hso_ximplicit = imp_tvs'}-                    , thing) }-      HsOuterExplicit{hso_bndrs = exp_bndrs} ->-        do { (exp_tvs', thing) <- tcExplicitTKBndrsX skol_mode exp_bndrs thing_inside-           ; return ( HsOuterExplicit { hso_xexplicit = exp_tvs'-                                      , hso_bndrs     = exp_bndrs }-                    , thing) }-------------------------------------------    Explicit tyvar binders-----------------------------------------tcExplicitTKBndrs :: OutputableBndrFlag flag 'Renamed-                  => [LHsTyVarBndr flag GhcRn]-                  -> TcM a-                  -> TcM ([VarBndr TyVar flag], a)-tcExplicitTKBndrs = tcExplicitTKBndrsX (smVanilla { sm_clone = True })--tcExplicitTKBndrsX :: OutputableBndrFlag flag 'Renamed-                   => SkolemMode-                   -> [LHsTyVarBndr flag GhcRn]-                   -> TcM a-                   -> TcM ([VarBndr TyVar flag], a)--- Push level, capture constraints,--- and emit an implication constraint with a ForAllSkol ic_info,--- so that it is subject to a telescope test.-tcExplicitTKBndrsX skol_mode bndrs thing_inside-  = do { (tclvl, wanted, (skol_tvs, res))-             <- pushLevelAndCaptureConstraints $-                bindExplicitTKBndrsX skol_mode bndrs $-                thing_inside--       ; let skol_info = ForAllSkol (fsep (map ppr bndrs))-             -- Notice that we use ForAllSkol here, ignoring the enclosing-             -- skol_info unlike tc_implicit_tk_bndrs, because the bad-telescope-             -- test applies only to ForAllSkol-       ; emitResidualTvConstraint skol_info (binderVars skol_tvs) tclvl wanted--       ; return (skol_tvs, res) }--------------------- | Skolemise the 'HsTyVarBndr's in an 'HsForAllTelescope' with the supplied--- 'TcTyMode'.-bindExplicitTKBndrs_Skol, bindExplicitTKBndrs_Tv-    :: (OutputableBndrFlag flag 'Renamed)-    => [LHsTyVarBndr flag GhcRn]-    -> TcM a-    -> TcM ([VarBndr TyVar flag], a)--bindExplicitTKBndrs_Skol = bindExplicitTKBndrsX (smVanilla { sm_clone = False })-bindExplicitTKBndrs_Tv   = bindExplicitTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = True })-   -- sm_clone: see Note [Cloning for type variable binders]--bindExplicitTKBndrs_Q_Skol, bindExplicitTKBndrs_Q_Tv-    :: ContextKind-    -> [LHsTyVarBndr () GhcRn]-    -> TcM a-    -> TcM ([TcTyVar], a)--- These do not clone: see Note [Cloning for type variable binders]-bindExplicitTKBndrs_Q_Skol ctxt_kind hs_bndrs thing_inside-  = liftFstM binderVars $-    bindExplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True-                                    , sm_kind = ctxt_kind })-                         hs_bndrs thing_inside-    -- sm_clone=False: see Note [Cloning for type variable binders]--bindExplicitTKBndrs_Q_Tv ctxt_kind hs_bndrs thing_inside-  = liftFstM binderVars $-    bindExplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True-                                    , sm_tvtv = True, sm_kind = ctxt_kind })-                         hs_bndrs thing_inside-    -- sm_clone=False: see Note [Cloning for type variable binders]--bindExplicitTKBndrsX :: (OutputableBndrFlag flag 'Renamed)-    => SkolemMode-    -> [LHsTyVarBndr flag GhcRn]-    -> TcM a-    -> TcM ([VarBndr TyVar flag], a)  -- Returned [TcTyVar] are in 1-1 correspondence-                                      -- with the passed-in [LHsTyVarBndr]-bindExplicitTKBndrsX skol_mode@(SM { sm_parent = check_parent, sm_kind = ctxt_kind-                                   , sm_holes = hole_info })-                     hs_tvs thing_inside-  = do { traceTc "bindExplicitTKBndrs" (ppr hs_tvs)-       ; go hs_tvs }-  where-    tc_ki_mode = TcTyMode { mode_tyki = KindLevel, mode_holes = hole_info }-                 -- Inherit the HoleInfo from the context--    go [] = do { res <- thing_inside-               ; return ([], res) }-    go (L _ hs_tv : hs_tvs)-       = do { lcl_env <- getLclTypeEnv-            ; tv <- tc_hs_bndr lcl_env hs_tv-            -- Extend the environment as we go, in case a binder-            -- is mentioned in the kind of a later binder-            --   e.g. forall k (a::k). blah-            -- NB: tv's Name may differ from hs_tv's-            -- See Note [Cloning for type variable binders]-            ; (tvs,res) <- tcExtendNameTyVarEnv [(hsTyVarName hs_tv, tv)] $-                           go hs_tvs-            ; return (Bndr tv (hsTyVarBndrFlag hs_tv):tvs, res) }---    tc_hs_bndr lcl_env (UserTyVar _ _ (L _ name))-      | check_parent-      , Just (ATyVar _ tv) <- lookupNameEnv lcl_env name-      = return tv-      | otherwise-      = do { kind <- newExpectedKind ctxt_kind-           ; newTyVarBndr skol_mode name kind }--    tc_hs_bndr lcl_env (KindedTyVar _ _ (L _ name) lhs_kind)-      | check_parent-      , Just (ATyVar _ tv) <- lookupNameEnv lcl_env name-      = do { kind <- tc_lhs_kind_sig tc_ki_mode (TyVarBndrKindCtxt name) lhs_kind-           ; discardResult $-             unifyKind (Just (ppr name)) kind (tyVarKind tv)-                          -- This unify rejects:-                          --    class C (m :: * -> *) where-                          --      type F (m :: *) = ...-           ; return tv }--      | otherwise-      = do { kind <- tc_lhs_kind_sig tc_ki_mode (TyVarBndrKindCtxt name) lhs_kind-           ; newTyVarBndr skol_mode name kind }--newTyVarBndr :: SkolemMode -> Name -> Kind -> TcM TcTyVar-newTyVarBndr (SM { sm_clone = clone, sm_tvtv = tvtv }) name kind-  = do { name <- case clone of-              True -> do { uniq <- newUnique-                         ; return (setNameUnique name uniq) }-              False -> return name-       ; details <- case tvtv of-                 True  -> newMetaDetails TyVarTv-                 False -> do { lvl <- getTcLevel-                             ; return (SkolemTv lvl False) }-       ; return (mkTcTyVar name kind details) }-------------------------------------------    Implicit tyvar binders-----------------------------------------tcImplicitTKBndrsX :: SkolemMode -> SkolemInfo-                   -> [Name]-                   -> TcM a-                   -> TcM ([TcTyVar], a)--- The workhorse:---    push level, capture constraints,---    and emit an implication constraint with a ForAllSkol ic_info,---    so that it is subject to a telescope test.-tcImplicitTKBndrsX skol_mode skol_info bndrs thing_inside-  = do { (tclvl, wanted, (skol_tvs, res))-             <- pushLevelAndCaptureConstraints       $-                bindImplicitTKBndrsX skol_mode bndrs $-                thing_inside--       ; emitResidualTvConstraint skol_info skol_tvs tclvl wanted--       ; return (skol_tvs, res) }---------------------bindImplicitTKBndrs_Skol, bindImplicitTKBndrs_Tv,-  bindImplicitTKBndrs_Q_Skol, bindImplicitTKBndrs_Q_Tv-  :: [Name] -> TcM a -> TcM ([TcTyVar], a)-bindImplicitTKBndrs_Skol   = bindImplicitTKBndrsX (smVanilla { sm_clone = True })-bindImplicitTKBndrs_Tv     = bindImplicitTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = True })-bindImplicitTKBndrs_Q_Skol = bindImplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True })-bindImplicitTKBndrs_Q_Tv   = bindImplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True, sm_tvtv = True })--bindImplicitTKBndrsX-   :: SkolemMode-   -> [Name]-   -> TcM a-   -> TcM ([TcTyVar], a)   -- Returned [TcTyVar] are in 1-1 correspondence-                           -- with the passed in [Name]-bindImplicitTKBndrsX skol_mode@(SM { sm_parent = check_parent, sm_kind = ctxt_kind })-                     tv_names thing_inside-  = do { lcl_env <- getLclTypeEnv-       ; tkvs <- mapM (new_tv lcl_env) tv_names-       ; traceTc "bindImplicitTKBndrsX" (ppr tv_names $$ ppr tkvs)-       ; res <- tcExtendNameTyVarEnv (tv_names `zip` tkvs)-                thing_inside-       ; return (tkvs, res) }-  where-    new_tv lcl_env name-      | check_parent-      , Just (ATyVar _ tv) <- lookupNameEnv lcl_env name-      = return tv-      | otherwise-      = do { kind <- newExpectedKind ctxt_kind-           ; newTyVarBndr skol_mode name kind }-------------------------------------------           SkolemMode------------------------------------------- | 'SkolemMode' describes how to typecheck an explicit ('HsTyVarBndr') or--- implicit ('Name') binder in a type. It is just a record of flags--- that describe what sort of 'TcTyVar' to create.-data SkolemMode-  = SM { sm_parent :: Bool    -- True <=> check the in-scope parent type variable-                              -- Used only for asssociated types--       , sm_clone  :: Bool    -- True <=> fresh unique-                              -- See Note [Cloning for type variable binders]--       , sm_tvtv   :: Bool    -- True <=> use a TyVarTv, rather than SkolemTv-                              -- Why?  See Note [Inferring kinds for type declarations]-                              -- in GHC.Tc.TyCl, and (in this module)-                              -- Note [Checking partial type signatures]--       , sm_kind   :: ContextKind  -- Use this for the kind of any new binders--       , sm_holes  :: HoleInfo     -- What to do for wildcards in the kind-       }--smVanilla :: SkolemMode-smVanilla = SM { sm_clone  = panic "sm_clone"  -- We always override this-               , sm_parent = False-               , sm_tvtv   = False-               , sm_kind   = AnyKind-               , sm_holes  = Nothing }--{- Note [Cloning for type variable binders]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Sometimes we must clone the Name of a type variable binder (written in-the source program); and sometimes we must not. This is controlled by-the sm_clone field of SkolemMode.--In some cases it doesn't matter whether or not we clone. Perhaps-it'd be better to use MustClone/MayClone/MustNotClone.--When we /must not/ clone-* In the binders of a type signature (tcOuterTKBndrs)-      f :: forall a{27}. blah-      f = rhs-  Then 'a' scopes over 'rhs'. When we kind-check the signature (tcHsSigType),-  we must get the type (forall a{27}. blah) for the Id f, because-  we bring that type variable into scope when we typecheck 'rhs'.--* In the binders of a data family instance (bindOuterFamEqnTKBndrs)-     data instance-       forall p q. D (p,q) = D1 p | D2 q-  We kind-check the LHS in tcDataFamInstHeader, and then separately-  (in tcDataFamInstDecl) bring p,q into scope before looking at the-  the constructor decls.--* bindExplicitTKBndrs_Q_Tv/bindImplicitTKBndrs_Q_Tv do not clone-  We take advantage of this in kcInferDeclHeader:-     all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs)-  If we cloned, we'd need to take a bit more care here; not hard.--* bindExplicitTKBndrs_Q_Skol, bindExplicitTKBndrs_Skol, do not clone.-  There is no need, I think.--  The payoff here is that avoiding gratuitous cloning means that we can-  almost always take the fast path in swizzleTcTyConBndrs.--When we /must/ clone.-* bindOuterSigTKBndrs_Tv, bindExplicitTKBndrs_Tv do cloning--  This for a narrow and tricky reason which, alas, I couldn't find a-  simpler way round.  #16221 is the poster child:--     data SameKind :: k -> k -> *-     data T a = forall k2 (b :: k2). MkT (SameKind a b) !Int--  When kind-checking T, we give (a :: kappa1). Then:--  - In kcConDecl we make a TyVarTv unification variable kappa2 for k2-    (as described in Note [Using TyVarTvs for kind-checking GADTs],-    even though this example is an existential)-  - So we get (b :: kappa2) via bindExplicitTKBndrs_Tv-  - We end up unifying kappa1 := kappa2, because of the (SameKind a b)--  Now we generalise over kappa2. But if kappa2's Name is precisely k2-  (i.e. we did not clone) we'll end up giving T the utterly final kind-    T :: forall k2. k2 -> *-  Nothing directly wrong with that but when we typecheck the data constructor-  we have k2 in scope; but then it's brought into scope /again/ when we find-  the forall k2.  This is chaotic, and we end up giving it the type-    MkT :: forall k2 (a :: k2) k2 (b :: k2).-           SameKind @k2 a b -> Int -> T @{k2} a-  which is bogus -- because of the shadowing of k2, we can't-  apply T to the kind or a!--  And there no reason /not/ to clone the Name when making a unification-  variable.  So that's what we do.--}------------------------------------------- Binding type/class variables in the--- kind-checking and typechecking phases-----------------------------------------bindTyClTyVars :: Name-               -> (TcTyCon -> [TyConBinder] -> Kind -> TcM a) -> TcM a--- ^ Used for the type variables of a type or class decl--- in the "kind checking" and "type checking" pass,--- but not in the initial-kind run.-bindTyClTyVars tycon_name thing_inside-  = do { tycon <- tcLookupTcTyCon tycon_name-       ; let scoped_prs = tcTyConScopedTyVars tycon-             res_kind   = tyConResKind tycon-             binders    = tyConBinders tycon-       ; traceTc "bindTyClTyVars" (ppr tycon_name <+> ppr binders $$ ppr scoped_prs)-       ; tcExtendNameTyVarEnv scoped_prs $-         thing_inside tycon binders res_kind }---{- *********************************************************************-*                                                                      *-             Kind generalisation-*                                                                      *-********************************************************************* -}--zonkAndScopedSort :: [TcTyVar] -> TcM [TcTyVar]-zonkAndScopedSort spec_tkvs-  = do { spec_tkvs <- mapM zonkTcTyVarToTyVar spec_tkvs-         -- Zonk the kinds, to we can do the dependency analayis--       -- Do a stable topological sort, following-       -- Note [Ordering of implicit variables] in GHC.Rename.HsType-       ; return (scopedSort spec_tkvs) }---- | Generalize some of the free variables in the given type.--- All such variables should be *kind* variables; any type variables--- should be explicitly quantified (with a `forall`) before now.------ The WantedConstraints are un-solved kind constraints. Generally--- they'll be reported as errors later, but meanwhile we refrain--- from quantifying over any variable free in these unsolved--- constraints. See Note [Failure in local type signatures].------ But in all cases, generalize only those variables whose TcLevel is--- strictly greater than the ambient level. This "strictly greater--- than" means that you likely need to push the level before creating--- whatever type gets passed here.------ Any variable whose level is greater than the ambient level but is--- not selected to be generalized will be promoted. (See [Promoting--- unification variables] in "GHC.Tc.Solver" and Note [Recipe for--- checking a signature].)------ The resulting KindVar are the variables to quantify over, in the--- correct, well-scoped order. They should generally be Inferred, not--- Specified, but that's really up to the caller of this function.-kindGeneralizeSome :: WantedConstraints-                   -> TcType    -- ^ needn't be zonked-                   -> TcM [KindVar]-kindGeneralizeSome wanted kind_or_type-  = do { -- Use the "Kind" variant here, as any types we see-         -- here will already have all type variables quantified;-         -- thus, every free variable is really a kv, never a tv.-       ; dvs <- candidateQTyVarsOfKind kind_or_type-       ; dvs <- filterConstrainedCandidates wanted dvs-       ; quantifyTyVars dvs }--filterConstrainedCandidates-  :: WantedConstraints    -- Don't quantify over variables free in these-                          --   Not necessarily fully zonked-  -> CandidatesQTvs       -- Candidates for quantification-  -> TcM CandidatesQTvs--- filterConstrainedCandidates removes any candidates that are free in--- 'wanted'; instead, it promotes them.  This bit is very much like--- decideMonoTyVars in GHC.Tc.Solver, but constraints are so much--- simpler in kinds, it is much easier here. (In particular, we never--- quantify over a constraint in a type.)-filterConstrainedCandidates wanted dvs-  | isEmptyWC wanted   -- Fast path for a common case-  = return dvs-  | otherwise-  = do { wc_tvs <- zonkTyCoVarsAndFV (tyCoVarsOfWC wanted)-       ; let (to_promote, dvs') = partitionCandidates dvs (`elemVarSet` wc_tvs)-       ; _ <- promoteTyVarSet to_promote-       ; return dvs' }---- |- Specialised version of 'kindGeneralizeSome', but with empty--- WantedConstraints, so no filtering is needed--- i.e.   kindGeneraliseAll = kindGeneralizeSome emptyWC-kindGeneralizeAll :: TcType -> TcM [KindVar]-kindGeneralizeAll kind_or_type-  = do { traceTc "kindGeneralizeAll" (ppr kind_or_type)-       ; dvs <- candidateQTyVarsOfKind kind_or_type-       ; quantifyTyVars dvs }---- | Specialized version of 'kindGeneralizeSome', but where no variables--- can be generalized, but perhaps some may need to be promoted.--- Use this variant when it is unknowable whether metavariables might--- later be constrained.------ To see why this promotion is needed, see--- Note [Recipe for checking a signature], and especially--- Note [Promotion in signatures].-kindGeneralizeNone :: TcType  -- needn't be zonked-                   -> TcM ()-kindGeneralizeNone kind_or_type-  = do { traceTc "kindGeneralizeNone" (ppr kind_or_type)-       ; dvs <- candidateQTyVarsOfKind kind_or_type-       ; _ <- promoteTyVarSet (candidateKindVars dvs)-       ; return () }--{- Note [Levels and generalisation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-  f x = e-with no type signature. We are currently at level i.-We must-  * Push the level to level (i+1)-  * Allocate a fresh alpha[i+1] for the result type-  * Check that e :: alpha[i+1], gathering constraint WC-  * Solve WC as far as possible-  * Zonking the result type alpha[i+1], say to beta[i-1] -> gamma[i]-  * Find the free variables with level > i, in this case gamma[i]-  * Skolemise those free variables and quantify over them, giving-       f :: forall g. beta[i-1] -> g-  * Emit the residiual constraint wrapped in an implication for g,-    thus   forall g. WC--All of this happens for types too.  Consider-  f :: Int -> (forall a. Proxy a -> Int)--Note [Kind generalisation]-~~~~~~~~~~~~~~~~~~~~~~~~~~-We do kind generalisation only at the outer level of a type signature.-For example, consider-  T :: forall k. k -> *-  f :: (forall a. T a -> Int) -> Int-When kind-checking f's type signature we generalise the kind at-the outermost level, thus:-  f1 :: forall k. (forall (a:k). T k a -> Int) -> Int  -- YES!-and *not* at the inner forall:-  f2 :: (forall k. forall (a:k). T k a -> Int) -> Int  -- NO!-Reason: same as for HM inference on value level declarations,-we want to infer the most general type.  The f2 type signature-would be *less applicable* than f1, because it requires a more-polymorphic argument.--NB: There are no explicit kind variables written in f's signature.-When there are, the renamer adds these kind variables to the list of-variables bound by the forall, so you can indeed have a type that's-higher-rank in its kind. But only by explicit request.--Note [Kinds of quantified type variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-tcTyVarBndrsGen quantifies over a specified list of type variables,-*and* over the kind variables mentioned in the kinds of those tyvars.--Note that we must zonk those kinds (obviously) but less obviously, we-must return type variables whose kinds are zonked too. Example-    (a :: k7)  where  k7 := k9 -> k9-We must return-    [k9, a:k9->k9]-and NOT-    [k9, a:k7]-Reason: we're going to turn this into a for-all type,-   forall k9. forall (a:k7). blah-which the type checker will then instantiate, and instantiate does not-look through unification variables!--Hence using zonked_kinds when forming tvs'.---}--------------------------------------etaExpandAlgTyCon :: [TyConBinder]-                  -> Kind   -- must be zonked-                  -> TcM ([TyConBinder], Kind)--- GADT decls can have a (perhaps partial) kind signature---      e.g.  data T a :: * -> * -> * where ...--- This function makes up suitable (kinded) TyConBinders for the--- argument kinds.  E.g. in this case it might return---   ([b::*, c::*], *)--- Never emits constraints.--- It's a little trickier than you might think: see--- Note [TyConBinders for the result kind signature of a data type]--- See Note [Datatype return kinds] in GHC.Tc.TyCl-etaExpandAlgTyCon tc_bndrs kind-  = do  { loc     <- getSrcSpanM-        ; uniqs   <- newUniqueSupply-        ; !rdr_env <- getLocalRdrEnv-        ; let new_occs = [ occ-                         | str <- allNameStrings-                         , let occ = mkOccName tvName str-                         , isNothing (lookupLocalRdrOcc rdr_env occ)-                         -- Note [Avoid name clashes for associated data types]-                         , not (occ `elem` lhs_occs) ]-              new_uniqs = uniqsFromSupply uniqs-              subst = mkEmptyTCvSubst (mkInScopeSet (mkVarSet lhs_tvs))-        ; return (go loc new_occs new_uniqs subst [] kind) }-  where-    lhs_tvs  = map binderVar tc_bndrs-    lhs_occs = map getOccName lhs_tvs--    go loc occs uniqs subst acc kind-      = case splitPiTy_maybe kind of-          Nothing -> (reverse acc, substTy subst kind)--          Just (Anon af arg, kind')-            -> go loc occs' uniqs' subst' (tcb : acc) kind'-            where-              arg'   = substTy subst (scaledThing arg)-              -- Force the occ before making the TyVar as otherwise it retains the TcLclEnv-              tv     = occ `seq` mkTyVar (mkInternalName uniq occ loc) arg'-              subst' = extendTCvInScope subst tv-              tcb    = Bndr tv (AnonTCB af)-              (uniq:uniqs') = uniqs-              (!occ:occs')   = occs--          Just (Named (Bndr tv vis), kind')-            -> go loc occs uniqs subst' (tcb : acc) kind'-            where-              (subst', tv') = substTyVarBndr subst tv-              tcb = Bndr tv' (NamedTCB vis)---- | A description of whether something is a------ * @data@ or @newtype@ ('DataDeclSort')------ * @data instance@ or @newtype instance@ ('DataInstanceSort')------ * @data family@ ('DataFamilySort')------ At present, this data type is only consumed by 'checkDataKindSig'.-data DataSort-  = DataDeclSort     NewOrData-  | DataInstanceSort NewOrData-  | DataFamilySort---- | Local helper type used in 'checkDataKindSig'.------ Superficially similar to 'ContextKind', but it lacks 'AnyKind'--- and 'AnyBoxedKind', and instead of @'TheKind' liftedTypeKind@--- provides 'LiftedKind', which is much simpler to match on and--- handle in 'isAllowedDataResKind'.-data AllowedDataResKind-  = AnyTYPEKind-  | AnyBoxedKind-  | LiftedKind--isAllowedDataResKind :: AllowedDataResKind -> Kind -> Bool-isAllowedDataResKind AnyTYPEKind  kind = tcIsRuntimeTypeKind kind-isAllowedDataResKind AnyBoxedKind kind = tcIsBoxedTypeKind kind-isAllowedDataResKind LiftedKind   kind = tcIsLiftedTypeKind kind---- | Checks that the return kind in a data declaration's kind signature is--- permissible. There are three cases:------ If dealing with a @data@, @newtype@, @data instance@, or @newtype instance@--- declaration, check that the return kind is @Type@.------ If the declaration is a @newtype@ or @newtype instance@ and the--- @UnliftedNewtypes@ extension is enabled, this check is slightly relaxed so--- that a return kind of the form @TYPE r@ (for some @r@) is permitted.--- See @Note [Implementation of UnliftedNewtypes]@ in "GHC.Tc.TyCl".------ If dealing with a @data family@ declaration, check that the return kind is--- either of the form:------ 1. @TYPE r@ (for some @r@), or------ 2. @k@ (where @k@ is a bare kind variable; see #12369)------ See also Note [Datatype return kinds] in "GHC.Tc.TyCl"-checkDataKindSig :: DataSort -> Kind  -- any arguments in the kind are stripped off-                 -> TcM ()-checkDataKindSig data_sort kind-  = do { dflags <- getDynFlags-       ; traceTc "checkDataKindSig" (ppr kind)-       ; checkTc (tYPE_ok dflags || is_kind_var)-                 (err_msg dflags) }-  where-    res_kind = snd (tcSplitPiTys kind)-       -- Look for the result kind after-       -- peeling off any foralls and arrows--    pp_dec :: SDoc-    pp_dec = text $-      case data_sort of-        DataDeclSort     DataType -> "Data type"-        DataDeclSort     NewType  -> "Newtype"-        DataInstanceSort DataType -> "Data instance"-        DataInstanceSort NewType  -> "Newtype instance"-        DataFamilySort            -> "Data family"--    is_newtype :: Bool-    is_newtype =-      case data_sort of-        DataDeclSort     new_or_data -> new_or_data == NewType-        DataInstanceSort new_or_data -> new_or_data == NewType-        DataFamilySort               -> False--    is_datatype :: Bool-    is_datatype =-      case data_sort of-        DataDeclSort     DataType -> True-        DataInstanceSort DataType -> True-        _                         -> False--    is_data_family :: Bool-    is_data_family =-      case data_sort of-        DataDeclSort{}     -> False-        DataInstanceSort{} -> False-        DataFamilySort     -> True--    allowed_kind :: DynFlags -> AllowedDataResKind-    allowed_kind dflags-      | is_newtype && xopt LangExt.UnliftedNewtypes dflags-        -- With UnliftedNewtypes, we allow kinds other than Type, but they-        -- must still be of the form `TYPE r` since we don't want to accept-        -- Constraint or Nat.-        -- See Note [Implementation of UnliftedNewtypes] in GHC.Tc.TyCl.-      = AnyTYPEKind-      | is_data_family-        -- If this is a `data family` declaration, we don't need to check if-        -- UnliftedNewtypes is enabled, since data family declarations can-        -- have return kind `TYPE r` unconditionally (#16827).-      = AnyTYPEKind-      | is_datatype && xopt LangExt.UnliftedDatatypes dflags-        -- With UnliftedDatatypes, we allow kinds other than Type, but they-        -- must still be of the form `TYPE (BoxedRep l)`, so that we don't-        -- accept result kinds like `TYPE IntRep`.-        -- See Note [Implementation of UnliftedDatatypes] in GHC.Tc.TyCl.-      = AnyBoxedKind-      | otherwise-      = LiftedKind--    tYPE_ok :: DynFlags -> Bool-    tYPE_ok dflags = isAllowedDataResKind (allowed_kind dflags) res_kind--    -- In the particular case of a data family, permit a return kind of the-    -- form `:: k` (where `k` is a bare kind variable).-    is_kind_var :: Bool-    is_kind_var | is_data_family = isJust (tcGetCastedTyVar_maybe res_kind)-                | otherwise      = False--    pp_allowed_kind dflags =-      case allowed_kind dflags of-        AnyTYPEKind  -> ppr tYPETyCon-        AnyBoxedKind -> ppr boxedRepDataConTyCon-        LiftedKind   -> ppr liftedTypeKind--    err_msg :: DynFlags -> SDoc-    err_msg dflags =-      sep [ sep [ pp_dec <+>-                  text "has non-" <>-                  pp_allowed_kind dflags-                , (if is_data_family then text "and non-variable" else empty) <+>-                  text "return kind" <+> quotes (ppr kind) ]-          , ext_hint dflags ]--    ext_hint dflags-      | tcIsRuntimeTypeKind kind-      , is_newtype-      , not (xopt LangExt.UnliftedNewtypes dflags)-      = text "Perhaps you intended to use UnliftedNewtypes"-      | tcIsBoxedTypeKind kind-      , is_datatype-      , not (xopt LangExt.UnliftedDatatypes dflags)-      = text "Perhaps you intended to use UnliftedDatatypes"-      | otherwise-      = empty---- | Checks that the result kind of a class is exactly `Constraint`, rejecting--- type synonyms and type families that reduce to `Constraint`. See #16826.-checkClassKindSig :: Kind -> TcM ()-checkClassKindSig kind = checkTc (tcIsConstraintKind kind) err_msg-  where-    err_msg :: SDoc-    err_msg =-      text "Kind signature on a class must end with" <+> ppr constraintKind $$-      text "unobscured by type families"--tcbVisibilities :: TyCon -> [Type] -> [TyConBndrVis]--- Result is in 1-1 correspondence with orig_args-tcbVisibilities tc orig_args-  = go (tyConKind tc) init_subst orig_args-  where-    init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfTypes orig_args))-    go _ _ []-      = []--    go fun_kind subst all_args@(arg : args)-      | Just (tcb, inner_kind) <- splitPiTy_maybe fun_kind-      = case tcb of-          Anon af _           -> AnonTCB af   : go inner_kind subst  args-          Named (Bndr tv vis) -> NamedTCB vis : go inner_kind subst' args-                 where-                    subst' = extendTCvSubst subst tv arg--      | not (isEmptyTCvSubst subst)-      = go (substTy subst fun_kind) init_subst all_args--      | otherwise-      = pprPanic "addTcbVisibilities" (ppr tc <+> ppr orig_args)---{- Note [TyConBinders for the result kind signature of a data type]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Given-  data T (a::*) :: * -> forall k. k -> *-we want to generate the extra TyConBinders for T, so we finally get-  (a::*) (b::*) (k::*) (c::k)-The function etaExpandAlgTyCon generates these extra TyConBinders from-the result kind signature.--We need to take care to give the TyConBinders-  (a) OccNames that are fresh (because the TyConBinders of a TyCon-      must have distinct OccNames--  (b) Uniques that are fresh (obviously)--For (a) we need to avoid clashes with the tyvars declared by-the user before the "::"; in the above example that is 'a'.-And also see Note [Avoid name clashes for associated data types].--For (b) suppose we have-   data T :: forall k. k -> forall k. k -> *-where the two k's are identical even up to their uniques.  Surprisingly,-this can happen: see #14515.--It's reasonably easy to solve all this; just run down the list with a-substitution; hence the recursive 'go' function.  But it has to be-done.--Note [Avoid name clashes for associated data types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider    class C a b where-               data D b :: * -> *-When typechecking the decl for D, we'll invent an extra type variable-for D, to fill out its kind.  Ideally we don't want this type variable-to be 'a', because when pretty printing we'll get-            class C a b where-               data D b a0-(NB: the tidying happens in the conversion to Iface syntax, which happens-as part of pretty-printing a TyThing.)--That's why we look in the LocalRdrEnv to see what's in scope. This is-important only to get nice-looking output when doing ":info C" in GHCi.-It isn't essential for correctness.---************************************************************************-*                                                                      *-             Partial signatures-*                                                                      *-************************************************************************---}--tcHsPartialSigType-  :: UserTypeCtxt-  -> LHsSigWcType GhcRn       -- The type signature-  -> TcM ( [(Name, TcTyVar)]  -- Wildcards-         , Maybe TcType       -- Extra-constraints wildcard-         , [(Name,InvisTVBinder)] -- Original tyvar names, in correspondence with-                              --   the implicitly and explicitly bound type variables-         , TcThetaType        -- Theta part-         , TcType )           -- Tau part--- See Note [Checking partial type signatures]-tcHsPartialSigType ctxt sig_ty-  | HsWC { hswc_ext  = sig_wcs, hswc_body = sig_ty } <- sig_ty-  , L _ (HsSig{sig_bndrs = hs_outer_bndrs, sig_body = body_ty}) <- sig_ty-  , (hs_ctxt, hs_tau) <- splitLHsQualTy body_ty-  = addSigCtxt ctxt sig_ty $-    do { mode <- mkHoleMode TypeLevel HM_Sig-       ; (outer_bndrs, (wcs, wcx, theta, tau))-            <- solveEqualities "tcHsPartialSigType" $-               -- See Note [Failure in local type signatures]-               bindNamedWildCardBinders sig_wcs             $ \ wcs ->-               bindOuterSigTKBndrs_Tv_M mode hs_outer_bndrs $-               do {   -- Instantiate the type-class context; but if there-                      -- is an extra-constraints wildcard, just discard it here-                    (theta, wcx) <- tcPartialContext mode hs_ctxt--                  ; ek <- newOpenTypeKind-                  ; tau <- addTypeCtxt hs_tau $-                           tc_lhs_type mode hs_tau ek--                  ; return (wcs, wcx, theta, tau) }--       ; traceTc "tcHsPartialSigType 2" empty-       ; outer_tv_bndrs <- scopedSortOuter outer_bndrs-       ; traceTc "tcHsPartialSigType 3" empty--         -- No kind-generalization here:-       ; kindGeneralizeNone (mkInvisForAllTys outer_tv_bndrs $-                             mkPhiTy theta $-                             tau)--       -- Spit out the wildcards (including the extra-constraints one)-       -- as "hole" constraints, so that they'll be reported if necessary-       -- See Note [Extra-constraint holes in partial type signatures]-       ; mapM_ emitNamedTypeHole wcs--       -- Zonk, so that any nested foralls can "see" their occurrences-       -- See Note [Checking partial type signatures], and in particular-       -- Note [Levels for wildcards]-       ; outer_tv_bndrs <- mapM zonkInvisTVBinder outer_tv_bndrs-       ; theta          <- mapM zonkTcType theta-       ; tau            <- zonkTcType tau--         -- We return a proper (Name,InvisTVBinder) environment, to be sure that-         -- we bring the right name into scope in the function body.-         -- Test case: partial-sigs/should_compile/LocalDefinitionBug-       ; let outer_bndr_names :: [Name]-             outer_bndr_names = hsOuterTyVarNames hs_outer_bndrs-             tv_prs :: [(Name,InvisTVBinder)]-             tv_prs = outer_bndr_names `zip` outer_tv_bndrs--      -- NB: checkValidType on the final inferred type will be-      --     done later by checkInferredPolyId.  We can't do it-      --     here because we don't have a complete type to check--       ; traceTc "tcHsPartialSigType" (ppr tv_prs)-       ; return (wcs, wcx, tv_prs, theta, tau) }--tcPartialContext :: TcTyMode -> Maybe (LHsContext GhcRn) -> TcM (TcThetaType, Maybe TcType)-tcPartialContext _ Nothing = return ([], Nothing)-tcPartialContext mode (Just (L _ hs_theta))-  | Just (hs_theta1, hs_ctxt_last) <- snocView hs_theta-  , L wc_loc ty@(HsWildCardTy _) <- ignoreParens hs_ctxt_last-  = do { wc_tv_ty <- setSrcSpanA wc_loc $-                     tcAnonWildCardOcc YesExtraConstraint mode ty constraintKind-       ; theta <- mapM (tc_lhs_pred mode) hs_theta1-       ; return (theta, Just wc_tv_ty) }-  | otherwise-  = do { theta <- mapM (tc_lhs_pred mode) hs_theta-       ; return (theta, Nothing) }--{- Note [Checking partial type signatures]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-This Note is about tcHsPartialSigType.  See also-Note [Recipe for checking a signature]--When we have a partial signature like-   f :: forall a. a -> _-we do the following--* tcHsPartialSigType does not make quantified type (forall a. blah)-  and then instantiate it -- it makes no sense to instantiate a type-  with wildcards in it.  Rather, tcHsPartialSigType just returns the-  'a' and the 'blah' separately.--  Nor, for the same reason, do we push a level in tcHsPartialSigType.--* We instantiate 'a' to a unification variable, a TyVarTv, and /not/-  a skolem; hence the "_Tv" in bindExplicitTKBndrs_Tv.  Consider-    f :: forall a. a -> _-    g :: forall b. _ -> b-    f = g-    g = f-  They are typechecked as a recursive group, with monomorphic types,-  so 'a' and 'b' will get unified together.  Very like kind inference-  for mutually recursive data types (sans CUSKs or SAKS); see-  Note [Cloning for type variable binders]--* In GHC.Tc.Gen.Sig.tcUserSigType we return a PartialSig, which (unlike-  the companion CompleteSig) contains the original, as-yet-unchecked-  source-code LHsSigWcType--* Then, for f and g /separately/, we call tcInstSig, which in turn-  call tchsPartialSig (defined near this Note).  It kind-checks the-  LHsSigWcType, creating fresh unification variables for each "_"-  wildcard.  It's important that the wildcards for f and g are distinct-  because they might get instantiated completely differently.  E.g.-     f,g :: forall a. a -> _-     f x = a-     g x = True-  It's really as if we'd written two distinct signatures.--* Nested foralls. See Note [Levels for wildcards]--* Just as for ordinary signatures, we must solve local equalities and-  zonk the type after kind-checking it, to ensure that all the nested-  forall binders can "see" their occurrenceds--  Just as for ordinary signatures, this zonk also gets any Refl casts-  out of the way of instantiation.  Example: #18008 had-       foo :: (forall a. (Show a => blah) |> Refl) -> _-  and that Refl cast messed things up.  See #18062.--Note [Levels for wildcards]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-     f :: forall b. (forall a. a -> _) -> b-We do /not/ allow the "_" to be instantiated to 'a'; although we do-(as before) allow it to be instantiated to the (top level) 'b'.-Why not?  Suppose-   f x = (x True, x 'c')--During typecking the RHS we must instantiate that (forall a. a -> _),-so we must know /precisely/ where all the a's are; they must not be-hidden under (possibly-not-yet-filled-in) unification variables!--We achieve this as follows:--- For /named/ wildcards such sas-     g :: forall b. (forall la. a -> _x) -> b-  there is no problem: we create them at the outer level (ie the-  ambient level of the signature itself), and push the level when we-  go inside a forall.  So now the unification variable for the "_x"-  can't unify with skolem 'a'.--- For /anonymous/ wildcards, such as 'f' above, we carry the ambient-  level of the signature to the hole in the TcLevel part of the-  mode_holes field of TcTyMode.  Then, in tcAnonWildCardOcc we us that-  level (and /not/ the level ambient at the occurrence of "_") to-  create the unification variable for the wildcard.  That is the sole-  purpose of the TcLevel in the mode_holes field: to transport the-  ambient level of the signature down to the anonymous wildcard-  occurrences.--Note [Extra-constraint holes in partial type signatures]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-  f :: (_) => a -> a-  f x = ...--* The renamer leaves '_' untouched.--* Then, in tcHsPartialSigType, we make a new hole TcTyVar, in-  tcWildCardBinders.--* GHC.Tc.Gen.Bind.chooseInferredQuantifiers fills in that hole TcTyVar-  with the inferred constraints, e.g. (Eq a, Show a)--* GHC.Tc.Errors.mkHoleError finally reports the error.--An annoying difficulty happens if there are more than 64 inferred-constraints. Then we need to fill in the TcTyVar with (say) a 70-tuple.-Where do we find the TyCon?  For good reasons we only have constraint-tuples up to 62 (see Note [How tuples work] in GHC.Builtin.Types).  So how-can we make a 70-tuple?  This was the root cause of #14217.--It's incredibly tiresome, because we only need this type to fill-in the hole, to communicate to the error reporting machinery.  Nothing-more.  So I use a HACK:--* I make an /ordinary/ tuple of the constraints, in-  GHC.Tc.Gen.Bind.chooseInferredQuantifiers. This is ill-kinded because-  ordinary tuples can't contain constraints, but it works fine. And for-  ordinary tuples we don't have the same limit as for constraint-  tuples (which need selectors and an associated class).--* Because it is ill-kinded, it trips an assert in writeMetaTyVar,-  so now I disable the assertion if we are writing a type of-  kind Constraint.  (That seldom/never normally happens so we aren't-  losing much.)--Result works fine, but it may eventually bite us.--See also Note [Do not simplify ConstraintHoles] in GHC.Tc.Solver for-information about how these are printed.--************************************************************************-*                                                                      *-      Pattern signatures (i.e signatures that occur in patterns)-*                                                                      *-********************************************************************* -}--tcHsPatSigType :: UserTypeCtxt-               -> HoleMode -- HM_Sig when in a SigPat, HM_TyAppPat when in a ConPat checking type applications.-               -> HsPatSigType GhcRn          -- The type signature-               -> ContextKind                -- What kind is expected-               -> TcM ( [(Name, TcTyVar)]     -- Wildcards-                      , [(Name, TcTyVar)]     -- The new bit of type environment, binding-                                              -- the scoped type variables-                      , TcType)       -- The type--- Used for type-checking type signatures in--- (a) patterns           e.g  f (x::Int) = e--- (b) RULE forall bndrs  e.g. forall (x::Int). f x = x--- See Note [Pattern signature binders and scoping] in GHC.Hs.Type------ This may emit constraints--- See Note [Recipe for checking a signature]-tcHsPatSigType ctxt hole_mode-  (HsPS { hsps_ext  = HsPSRn { hsps_nwcs = sig_wcs, hsps_imp_tvs = sig_ns }-        , hsps_body = hs_ty })-  ctxt_kind-  = addSigCtxt ctxt hs_ty $-    do { sig_tkv_prs <- mapM new_implicit_tv sig_ns-       ; mode <- mkHoleMode TypeLevel hole_mode-       ; (wcs, sig_ty)-            <- addTypeCtxt hs_ty                     $-               solveEqualities "tcHsPatSigType" $-                 -- See Note [Failure in local type signatures]-                 -- and c.f #16033-               bindNamedWildCardBinders sig_wcs $ \ wcs ->-               tcExtendNameTyVarEnv sig_tkv_prs $-               do { ek     <- newExpectedKind ctxt_kind-                  ; sig_ty <- tc_lhs_type mode hs_ty ek-                  ; return (wcs, sig_ty) }--        ; mapM_ emitNamedTypeHole wcs--          -- sig_ty might have tyvars that are at a higher TcLevel (if hs_ty-          -- contains a forall). Promote these.-          -- Ex: f (x :: forall a. Proxy a -> ()) = ... x ...-          -- When we instantiate x, we have to compare the kind of the argument-          -- to a's kind, which will be a metavariable.-          -- kindGeneralizeNone does this:-        ; kindGeneralizeNone sig_ty-        ; sig_ty <- zonkTcType sig_ty-        ; checkValidType ctxt sig_ty--        ; traceTc "tcHsPatSigType" (ppr sig_tkv_prs)-        ; return (wcs, sig_tkv_prs, sig_ty) }-  where-    new_implicit_tv name-      = do { kind <- newMetaKindVar-           ; tv   <- case ctxt of-                       RuleSigCtxt {} -> newSkolemTyVar name kind-                       _              -> newPatSigTyVar name kind-                       -- See Note [Typechecking pattern signature binders]-             -- NB: tv's Name may be fresh (in the case of newPatSigTyVar)-           ; return (name, tv) }--{- Note [Typechecking pattern signature binders]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-See also Note [Type variables in the type environment] in GHC.Tc.Utils.-Consider--  data T where-    MkT :: forall a. a -> (a -> Int) -> T--  f :: T -> ...-  f (MkT x (f :: b -> c)) = <blah>--Here- * The pattern (MkT p1 p2) creates a *skolem* type variable 'a_sk',-   It must be a skolem so that it retains its identity, and-   GHC.Tc.Errors.getSkolemInfo can thereby find the binding site for the skolem.-- * The type signature pattern (f :: b -> c) makes fresh meta-tyvars-   beta and gamma (TauTvs), and binds "b" :-> beta, "c" :-> gamma in the-   environment-- * Then unification makes beta := a_sk, gamma := Int-   That's why we must make beta and gamma a MetaTv,-   not a SkolemTv, so that it can unify to a_sk (or Int, respectively).-- * Finally, in '<blah>' we have the envt "b" :-> beta, "c" :-> gamma,-   so we return the pairs ("b" :-> beta, "c" :-> gamma) from tcHsPatSigType,--Another example (#13881):-   fl :: forall (l :: [a]). Sing l -> Sing l-   fl (SNil :: Sing (l :: [y])) = SNil-When we reach the pattern signature, 'l' is in scope from the-outer 'forall':-   "a" :-> a_sk :: *-   "l" :-> l_sk :: [a_sk]-We make up a fresh meta-TauTv, y_sig, for 'y', and kind-check-the pattern signature-   Sing (l :: [y])-That unifies y_sig := a_sk.  We return from tcHsPatSigType with-the pair ("y" :-> y_sig).--For RULE binders, though, things are a bit different (yuk).-  RULE "foo" forall (x::a) (y::[a]).  f x y = ...-Here this really is the binding site of the type variable so we'd like-to use a skolem, so that we get a complaint if we unify two of them-together.  Hence the new_implicit_tv function in tcHsPatSigType.---************************************************************************-*                                                                      *-        Checking kinds-*                                                                      *-************************************************************************---}--unifyKinds :: [LHsType GhcRn] -> [(TcType, TcKind)] -> TcM ([TcType], TcKind)-unifyKinds rn_tys act_kinds-  = do { kind <- newMetaKindVar-       ; let check rn_ty (ty, act_kind)-               = checkExpectedKind (unLoc rn_ty) ty act_kind kind-       ; tys' <- zipWithM check rn_tys act_kinds-       ; return (tys', kind) }--{--************************************************************************-*                                                                      *-        Sort checking kinds-*                                                                      *-************************************************************************--tcLHsKindSig converts a user-written kind to an internal, sort-checked kind.-It does sort checking and desugaring at the same time, in one single pass.--}--tcLHsKindSig :: UserTypeCtxt -> LHsKind GhcRn -> TcM Kind-tcLHsKindSig ctxt hs_kind-  = tc_lhs_kind_sig kindLevelMode ctxt hs_kind--tc_lhs_kind_sig :: TcTyMode -> UserTypeCtxt -> LHsKind GhcRn -> TcM Kind-tc_lhs_kind_sig mode ctxt hs_kind--- See  Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType--- Result is zonked-  = do { kind <- addErrCtxt (text "In the kind" <+> quotes (ppr hs_kind)) $-                 solveEqualities "tcLHsKindSig" $-                 tc_lhs_type mode hs_kind liftedTypeKind-       ; traceTc "tcLHsKindSig" (ppr hs_kind $$ ppr kind)-       -- No generalization:-       ; kindGeneralizeNone kind-       ; kind <- zonkTcType kind-         -- This zonk is very important in the case of higher rank kinds-         -- E.g. #13879    f :: forall (p :: forall z (y::z). <blah>).-         --                          <more blah>-         --      When instantiating p's kind at occurrences of p in <more blah>-         --      it's crucial that the kind we instantiate is fully zonked,-         --      else we may fail to substitute properly--       ; checkValidType ctxt kind-       ; traceTc "tcLHsKindSig2" (ppr kind)-       ; return kind }--promotionErr :: Name -> PromotionErr -> TcM a-promotionErr name err-  = failWithTc (hang (pprPECategory err <+> quotes (ppr name) <+> text "cannot be used here")-                   2 (parens reason))-  where-    reason = case err of-               ConstrainedDataConPE pred-                              -> text "it has an unpromotable context"-                                 <+> quotes (ppr pred)-               FamDataConPE   -> text "it comes from a data family instance"-               NoDataKindsTC  -> text "perhaps you intended to use DataKinds"-               NoDataKindsDC  -> text "perhaps you intended to use DataKinds"-               PatSynPE       -> text "pattern synonyms cannot be promoted"-               RecDataConPE   -> same_rec_group_msg-               ClassPE        -> same_rec_group_msg-               TyConPE        -> same_rec_group_msg--    same_rec_group_msg = text "it is defined and used in the same recursive group"--{--************************************************************************-*                                                                      *-          Error messages and such-*                                                                      *-************************************************************************--}----- | Make an appropriate message for an error in a function argument.--- Used for both expressions and types.-funAppCtxt :: (Outputable fun, Outputable arg) => fun -> arg -> Int -> SDoc-funAppCtxt fun arg arg_no-  = hang (hsep [ text "In the", speakNth arg_no, ptext (sLit "argument of"),++{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies        #-}+{-# LANGUAGE ViewPatterns        #-}+{-# LANGUAGE RecursiveDo        #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++-}++-- | Typechecking user-specified @MonoTypes@+module GHC.Tc.Gen.HsType (+        -- Type signatures+        kcClassSigType, tcClassSigType,+        tcHsSigType, tcHsSigWcType,+        tcHsPartialSigType,+        tcStandaloneKindSig,+        funsSigCtxt, addSigCtxt, pprSigCtxt,++        tcHsClsInstType,+        tcHsDeriv, tcDerivStrategy,+        tcHsTypeApp,+        UserTypeCtxt(..),+        bindImplicitTKBndrs_Tv, bindImplicitTKBndrs_Skol,+            bindImplicitTKBndrs_Q_Tv, bindImplicitTKBndrs_Q_Skol,+        bindExplicitTKBndrs_Tv, bindExplicitTKBndrs_Skol,+            bindExplicitTKBndrs_Q_Tv, bindExplicitTKBndrs_Q_Skol,++        bindOuterFamEqnTKBndrs_Q_Tv, bindOuterFamEqnTKBndrs,+        tcOuterTKBndrs, scopedSortOuter, outerTyVars, outerTyVarBndrs,+        bindOuterSigTKBndrs_Tv,+        tcExplicitTKBndrs,+        bindNamedWildCardBinders,++        -- Type checking type and class decls, and instances thereof+        bindTyClTyVars, bindTyClTyVarsAndZonk,+        tcFamTyPats,+        etaExpandAlgTyCon, tcbVisibilities,++          -- tyvars+        zonkAndScopedSort,++        -- Kind-checking types+        -- No kind generalisation, no checkValidType+        InitialKindStrategy(..),+        SAKS_or_CUSK(..),+        ContextKind(..),+        kcDeclHeader, checkForDuplicateScopedTyVars,+        tcHsLiftedType,   tcHsOpenType,+        tcHsLiftedTypeNC, tcHsOpenTypeNC,+        tcInferLHsType, tcInferLHsTypeKind, tcInferLHsTypeUnsaturated,+        tcCheckLHsType,+        tcHsContext, tcLHsPredType,++        kindGeneralizeAll,++        -- Sort-checking kinds+        tcLHsKindSig, checkDataKindSig, DataSort(..),+        checkClassKindSig,++        -- Multiplicity+        tcMult,++        -- Pattern type signatures+        tcHsPatSigType,+        HoleMode(..),++        -- Error messages+        funAppCtxt, addTyConFlavCtxt+   ) where++import GHC.Prelude++import GHC.Hs+import GHC.Rename.Utils+import GHC.Tc.Errors.Types+import GHC.Tc.Utils.Monad+import GHC.Tc.Types.Origin+import GHC.Core.Predicate+import GHC.Tc.Types.Constraint+import GHC.Tc.Utils.Env+import GHC.Tc.Utils.TcMType+import GHC.Tc.Validity+import GHC.Tc.Utils.Unify+import GHC.IfaceToCore+import GHC.Tc.Solver+import GHC.Tc.Utils.Zonk+import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.Ppr+import GHC.Tc.Utils.TcType+import GHC.Tc.Utils.Instantiate ( tcInstInvisibleTyBinders, tcInstInvisibleTyBindersN,+                                  tcInstInvisibleTyBinder, tcSkolemiseInvisibleBndrs )+import GHC.Core.Type+import GHC.Builtin.Types.Prim+import GHC.Types.Error+import GHC.Types.Name.Env+import GHC.Types.Name.Reader( lookupLocalRdrOcc )+import GHC.Types.Var+import GHC.Types.Var.Set+import GHC.Core.TyCon+import GHC.Core.ConLike+import GHC.Core.DataCon+import GHC.Core.Class+import GHC.Types.Name+import GHC.Types.Var.Env+import GHC.Builtin.Types+import GHC.Types.Basic+import GHC.Types.SrcLoc+import GHC.Types.Unique+import GHC.Types.Unique.FM+import GHC.Utils.Misc+import GHC.Types.Unique.Supply+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Builtin.Names hiding ( wildCardName )+import GHC.Driver.Session+import qualified GHC.LanguageExtensions as LangExt++import GHC.Data.FastString+import GHC.Data.List.SetOps+import GHC.Data.Maybe+import GHC.Data.Bag( unitBag )++import Data.Function ( on )+import Data.List.NonEmpty as NE( NonEmpty(..), nubBy )+import Data.List ( find, mapAccumL )+import Control.Monad+import Data.Tuple( swap )++{-+        ----------------------------+                General notes+        ----------------------------++Unlike with expressions, type-checking types both does some checking and+desugars at the same time. This is necessary because we often want to perform+equality checks on the types right away, and it would be incredibly painful+to do this on un-desugared types. Luckily, desugared types are close enough+to HsTypes to make the error messages sane.++During type-checking, we perform as little validity checking as possible.+Generally, after type-checking, you will want to do validity checking, say+with GHC.Tc.Validity.checkValidType.++Validity checking+~~~~~~~~~~~~~~~~~+Some of the validity check could in principle be done by the kind checker,+but not all:++- During desugaring, we normalise by expanding type synonyms.  Only+  after this step can we check things like type-synonym saturation+  e.g.  type T k = k Int+        type S a = a+  Then (T S) is ok, because T is saturated; (T S) expands to (S Int);+  and then S is saturated.  This is a GHC extension.++- Similarly, also a GHC extension, we look through synonyms before complaining+  about the form of a class or instance declaration++- Ambiguity checks involve functional dependencies++Also, in a mutually recursive group of types, we can't look at the TyCon until we've+finished building the loop.  So to keep things simple, we postpone most validity+checking until step (3).++%************************************************************************+%*                                                                      *+              Check types AND do validity checking+*                                                                      *+************************************************************************++Note [Keeping implicitly quantified variables in order]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When the user implicitly quantifies over variables (say, in a type+signature), we need to come up with some ordering on these variables.+This is done by bumping the TcLevel, bringing the tyvars into scope,+and then type-checking the thing_inside. The constraints are all+wrapped in an implication, which is then solved. Finally, we can+zonk all the binders and then order them with scopedSort.++It's critical to solve before zonking and ordering in order to uncover+any unifications. You might worry that this eager solving could cause+trouble elsewhere. I don't think it will. Because it will solve only+in an increased TcLevel, it can't unify anything that was mentioned+elsewhere. Additionally, we require that the order of implicitly+quantified variables is manifest by the scope of these variables, so+we're not going to learn more information later that will help order+these variables.++Note [Recipe for checking a signature]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Kind-checking a user-written signature requires several steps:++ 0. Bump the TcLevel+ 1.   Bind any lexically-scoped type variables.+ 2.   Generate constraints.+ 3. Solve constraints.+ 4. Sort any implicitly-bound variables into dependency order+ 5. Promote tyvars and/or kind-generalize.+ 6. Zonk.+ 7. Check validity.++Very similar steps also apply when kind-checking a type or class+declaration.++The general pattern looks something like this.  (But NB every+specific instance varies in one way or another!)++    do { (tclvl, wanted, (spec_tkvs, ty))+              <- pushLevelAndSolveEqualitiesX "tc_top_lhs_type" $+                 bindImplicitTKBndrs_Skol sig_vars              $+                 <kind-check the type>++       ; spec_tkvs <- zonkAndScopedSort spec_tkvs++       ; reportUnsolvedEqualities skol_info spec_tkvs tclvl wanted++       ; let ty1 = mkSpecForAllTys spec_tkvs ty+       ; kvs <- kindGeneralizeAll ty1++       ; final_ty <- zonkTcTypeToType (mkInfForAllTys kvs ty1)++       ; checkValidType final_ty++This pattern is repeated many times in GHC.Tc.Gen.HsType,+GHC.Tc.Gen.Sig, and GHC.Tc.TyCl, with variations.  In more detail:++* pushLevelAndSolveEqualitiesX (Step 0, step 3) bumps the TcLevel,+  calls the thing inside to generate constraints, solves those+  constraints as much as possible, returning the residual unsolved+  constraints in 'wanted'.++* bindImplicitTKBndrs_Skol (Step 1) binds the user-specified type+  variables E.g.  when kind-checking f :: forall a. F a -> a we must+  bring 'a' into scope before kind-checking (F a -> a)++* zonkAndScopedSort (Step 4) puts those user-specified variables in+  the dependency order.  (For "implicit" variables the order is no+  user-specified.  E.g.  forall (a::k1) (b::k2). blah k1 and k2 are+  implicitly brought into scope.++* reportUnsolvedEqualities (Step 3 continued) reports any unsolved+  equalities, carefully wrapping them in an implication that binds the+  skolems.  We can't do that in pushLevelAndSolveEqualitiesX because+  that function doesn't have access to the skolems.++* kindGeneralize (Step 5). See Note [Kind generalisation]++* The final zonkTcTypeToType must happen after promoting/generalizing,+  because promoting and generalizing fill in metavariables.+++Doing Step 3 (constraint solving) eagerly (rather than building an+implication constraint and solving later) is necessary for several+reasons:++* Exactly as for Solver.simplifyInfer: when generalising, we solve all+  the constraints we can so that we don't have to quantify over them+  or, since we don't quantify over constraints in kinds, float them+  and inhibit generalisation.++* Most signatures also bring implicitly quantified variables into+  scope, and solving is necessary to get these in the right order+  (Step 4) see Note [Keeping implicitly quantified variables in+  order]).++Note [Kind generalisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Step 5 of Note [Recipe for checking a signature], namely+kind-generalisation, is done by+    kindGeneraliseAll+    kindGeneraliseSome+    kindGeneraliseNone++Here, we have to deal with the fact that metatyvars generated in the+type will have a bumped TcLevel, because explicit foralls raise the+TcLevel. To avoid these variables from ever being visible in the+surrounding context, we must obey the following dictum:++  Every metavariable in a type must either be+    (A) generalized, or+    (B) promoted, or        See Note [Promotion in signatures]+    (C) a cause to error    See Note [Naughty quantification candidates]+                            in GHC.Tc.Utils.TcMType++There are three steps (look at kindGeneraliseSome):++1. candidateQTyVarsOfType finds the free variables of the type or kind,+   to generalise++2. filterConstrainedCandidates filters out candidates that appear+   in the unsolved 'wanteds', and promotes the ones that get filtered out+   thereby.++3. quantifyTyVars quantifies the remaining type variables++The kindGeneralize functions do not require pre-zonking; they zonk as they+go.++kindGeneraliseAll specialises for the case where step (2) is vacuous.+kindGeneraliseNone specialises for the case where we do no quantification,+but we must still promote.++If you are actually doing kind-generalization, you need to bump the+level before generating constraints, as we will only generalize+variables with a TcLevel higher than the ambient one.+Hence the "pushLevel" in pushLevelAndSolveEqualities.++Note [Promotion in signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If an unsolved metavariable in a signature is not generalized+(because we're not generalizing the construct -- e.g., pattern+sig -- or because the metavars are constrained -- see kindGeneralizeSome)+we need to promote to maintain (WantedInv) of Note [TcLevel invariants]+in GHC.Tc.Utils.TcType. Note that promotion is identical in effect to generalizing+and the reinstantiating with a fresh metavariable at the current level.+So in some sense, we generalize *all* variables, but then re-instantiate+some of them.++Here is an example of why we must promote:+  foo (x :: forall a. a -> Proxy b) = ...++In the pattern signature, `b` is unbound, and will thus be brought into+scope. We do not know its kind: it will be assigned kappa[2]. Note that+kappa is at TcLevel 2, because it is invented under a forall. (A priori,+the kind kappa might depend on `a`, so kappa rightly has a higher TcLevel+than the surrounding context.) This kappa cannot be solved for while checking+the pattern signature (which is not kind-generalized). When we are checking+the *body* of foo, though, we need to unify the type of x with the argument+type of bar. At this point, the ambient TcLevel is 1, and spotting a+matavariable with level 2 would violate the (WantedInv) invariant of+Note [TcLevel invariants]. So, instead of kind-generalizing,+we promote the metavariable to level 1. This is all done in kindGeneralizeNone.++-}++funsSigCtxt :: [LocatedN Name] -> UserTypeCtxt+-- Returns FunSigCtxt, with no redundant-context-reporting,+-- form a list of located names+funsSigCtxt (L _ name1 : _) = FunSigCtxt name1 NoRRC+funsSigCtxt []              = panic "funSigCtxt"++addSigCtxt :: Outputable hs_ty => UserTypeCtxt -> LocatedA hs_ty -> TcM a -> TcM a+addSigCtxt ctxt hs_ty thing_inside+  = setSrcSpan (getLocA hs_ty) $+    addErrCtxt (pprSigCtxt ctxt hs_ty) $+    thing_inside++pprSigCtxt :: Outputable hs_ty => UserTypeCtxt -> LocatedA hs_ty -> SDoc+-- (pprSigCtxt ctxt <extra> <type>)+-- prints    In the type signature for 'f':+--              f :: <type>+-- The <extra> is either empty or "the ambiguity check for"+pprSigCtxt ctxt hs_ty+  | Just n <- isSigMaybe ctxt+  = hang (text "In the type signature:")+       2 (pprPrefixOcc n <+> dcolon <+> ppr hs_ty)++  | otherwise+  = hang (text "In" <+> pprUserTypeCtxt ctxt <> colon)+       2 (ppr hs_ty)++tcHsSigWcType :: UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Type+-- This one is used when we have a LHsSigWcType, but in+-- a place where wildcards aren't allowed. The renamer has+-- already checked this, so we can simply ignore it.+tcHsSigWcType ctxt sig_ty = tcHsSigType ctxt (dropWildCards sig_ty)++kcClassSigType :: [LocatedN Name] -> LHsSigType GhcRn -> TcM ()+-- This is a special form of tcClassSigType that is used during the+-- kind-checking phase to infer the kind of class variables. Cf. tc_lhs_sig_type.+-- Importantly, this does *not* kind-generalize. Consider+--   class SC f where+--     meth :: forall a (x :: f a). Proxy x -> ()+-- When instantiating Proxy with kappa, we must unify kappa := f a. But we're+-- still working out the kind of f, and thus f a will have a coercion in it.+-- Coercions block unification (Note [Equalities with incompatible kinds] in+-- TcCanonical) and so we fail to unify. If we try to kind-generalize, we'll+-- end up promoting kappa to the top level (because kind-generalization is+-- normally done right before adding a binding to the context), and then we+-- can't set kappa := f a, because a is local.+kcClassSigType names+    sig_ty@(L _ (HsSig { sig_bndrs = hs_outer_bndrs, sig_body = hs_ty }))+  = addSigCtxt (funsSigCtxt names) sig_ty $+    do { _ <- bindOuterSigTKBndrs_Tv hs_outer_bndrs    $+              tcLHsType hs_ty liftedTypeKind+       ; return () }++tcClassSigType :: [LocatedN Name] -> LHsSigType GhcRn -> TcM Type+-- Does not do validity checking+tcClassSigType names sig_ty+  = addSigCtxt sig_ctxt sig_ty $+    do { skol_info <- mkSkolemInfo skol_info_anon+       ; (implic, ty) <- tc_lhs_sig_type skol_info sig_ty (TheKind liftedTypeKind)+       ; emitImplication implic+       ; return ty }+       -- Do not zonk-to-Type, nor perform a validity check+       -- We are in a knot with the class and associated types+       -- Zonking and validity checking is done by tcClassDecl+       --+       -- No need to fail here if the type has an error:+       --   If we're in the kind-checking phase, the solveEqualities+       --     in kcTyClGroup catches the error+       --   If we're in the type-checking phase, the solveEqualities+       --     in tcClassDecl1 gets it+       -- Failing fast here degrades the error message in, e.g., tcfail135:+       --   class Foo f where+       --     baa :: f a -> f+       -- If we fail fast, we're told that f has kind `k1` when we wanted `*`.+       -- It should be that f has kind `k2 -> *`, but we never get a chance+       -- to run the solver where the kind of f is touchable. This is+       -- painfully delicate.+  where+    sig_ctxt = funsSigCtxt names+    skol_info_anon = SigTypeSkol sig_ctxt++tcHsSigType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type+-- Does validity checking+-- See Note [Recipe for checking a signature]+tcHsSigType ctxt sig_ty+  = addSigCtxt ctxt sig_ty $+    do { traceTc "tcHsSigType {" (ppr sig_ty)+       ; skol_info <- mkSkolemInfo skol_info+          -- Generalise here: see Note [Kind generalisation]+       ; (implic, ty) <- tc_lhs_sig_type skol_info sig_ty  (expectedKindInCtxt ctxt)++       -- Float out constraints, failing fast if not possible+       -- See Note [Failure in local type signatures] in GHC.Tc.Solver+       ; traceTc "tcHsSigType 2" (ppr implic)+       ; simplifyAndEmitFlatConstraints (mkImplicWC (unitBag implic))++       ; ty <- zonkTcType ty+       ; checkValidType ctxt ty+       ; traceTc "end tcHsSigType }" (ppr ty)+       ; return ty }+  where+    skol_info = SigTypeSkol ctxt++tc_lhs_sig_type :: SkolemInfo -> LHsSigType GhcRn+               -> ContextKind -> TcM (Implication, TcType)+-- Kind-checks/desugars an 'LHsSigType',+--   solve equalities,+--   and then kind-generalizes.+-- This will never emit constraints, as it uses solveEqualities internally.+-- No validity checking or zonking+-- Returns also an implication for the unsolved constraints+tc_lhs_sig_type skol_info full_hs_ty@(L loc (HsSig { sig_bndrs = hs_outer_bndrs+                                                   , sig_body = hs_ty })) ctxt_kind+  = setSrcSpanA loc $+    do { (tc_lvl, wanted, (exp_kind, (outer_bndrs, ty)))+              <- pushLevelAndSolveEqualitiesX "tc_lhs_sig_type" $+                 -- See Note [Failure in local type signatures]+                 do { exp_kind <- newExpectedKind ctxt_kind+                          -- See Note [Escaping kind in type signatures]+                    ; stuff <- tcOuterTKBndrs skol_info hs_outer_bndrs $+                               tcLHsType hs_ty exp_kind+                    ; return (exp_kind, stuff) }++       -- Default any unconstrained variables free in the kind+       -- See Note [Escaping kind in type signatures]+       ; exp_kind_dvs <- candidateQTyVarsOfType exp_kind+       ; doNotQuantifyTyVars exp_kind_dvs (mk_doc exp_kind)++       ; traceTc "tc_lhs_sig_type" (ppr hs_outer_bndrs $$ ppr outer_bndrs)+       ; outer_bndrs <- scopedSortOuter outer_bndrs++       ; let outer_tv_bndrs :: [InvisTVBinder] = outerTyVarBndrs outer_bndrs+             ty1 = mkInvisForAllTys outer_tv_bndrs ty+       ; kvs <- kindGeneralizeSome skol_info wanted ty1++       -- Build an implication for any as-yet-unsolved kind equalities+       -- See Note [Skolem escape in type signatures]+       ; implic <- buildTvImplication (getSkolemInfo skol_info) kvs tc_lvl wanted++       ; return (implic, mkInfForAllTys kvs ty1) }+  where+    mk_doc exp_kind tidy_env+      = do { (tidy_env2, exp_kind) <- zonkTidyTcType tidy_env exp_kind+           ; return (tidy_env2, hang (text "The kind" <+> ppr exp_kind)+                                   2 (text "of type signature:" <+> ppr full_hs_ty)) }++++{- Note [Escaping kind in type signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider kind-checking the signature for `foo` (#19495):+  type family T (r :: RuntimeRep) :: TYPE r++  foo :: forall (r :: RuntimeRep). T r+  foo = ...++We kind-check the type with expected kind `TYPE delta` (see newExpectedKind),+where `delta :: RuntimeRep` is as-yet unknown. (We can't use `TYPE LiftedRep`+because we allow signatures like `foo :: Int#`.)++Suppose we are at level L currently.  We do this+  * pushLevelAndSolveEqualitiesX: moves to level L+1+  * newExpectedKind: allocates delta{L+1}+  * tcOuterTKBndrs: pushes the level again to L+2, binds skolem r{L+2}+  * kind-check the body (T r) :: TYPE delta{L+1}++Then+* We can't unify delta{L+1} with r{L+2}.+  And rightly so: skolem would escape.++* If delta{L+1} is unified with some-kind{L}, that is fine.+  This can happen+      \(x::a) -> let y :: a; y = x in ...(x :: Int#)...+  Here (x :: a :: TYPE gamma) is in the environment when we check+  the signature y::a.  We unify delta := gamma, and all is well.++* If delta{L+1} is unconstrained, we /must not/ quantify over it!+  E.g. Consider f :: Any   where Any :: forall k. k+  We kind-check this with expected kind TYPE kappa. We get+      Any @(TYPE kappa) :: TYPE kappa+  We don't want to generalise to     forall k. Any @k+  because that is ill-kinded: the kind of the body of the forall,+  (Any @k :: k) mentions the bound variable k.++  Instead we want to default it to LiftedRep.++  An alternative would be to promote it, similar to the monomorphism+  restriction, but the MR is pretty confusing.  Defaulting seems better++How does that defaulting happen?  Well, since we /currently/ default+RuntimeRep variables during generalisation, it'll happen in+kindGeneralize. But in principle we might allow generalisation over+RuntimeRep variables in future.  Moreover, what if we had+   kappa{L+1} := F alpha{L+1}+where F :: Type -> RuntimeRep.   Now it's alpha that is free in the kind+and it /won't/ be defaulted.++So we use doNotQuantifyTyVars to either default the free vars of+exp_kind (if possible), or error (if not).++Note [Skolem escape in type signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+tcHsSigType is tricky.  Consider (T11142)+  foo :: forall b. (forall k (a :: k). SameKind a b) -> ()+This is ill-kinded because of a nested skolem-escape.++That will show up as an un-solvable constraint in the implication+returned by buildTvImplication in tc_lhs_sig_type.  See Note [Skolem+escape prevention] in GHC.Tc.Utils.TcType for why it is unsolvable+(the unification variable for b's kind is untouchable).++Then, in GHC.Tc.Solver.simplifyAndEmitFlatConstraints (called from tcHsSigType)+we'll try to float out the constraint, be unable to do so, and fail.+See GHC.Tc.Solver Note [Failure in local type signatures] for more+detail on this.++The separation between tcHsSigType and tc_lhs_sig_type is because+tcClassSigType wants to use the latter, but *not* fail fast, because+there are skolems from the class decl which are in scope; but it's fine+not to because tcClassDecl1 has a solveEqualities wrapped around all+the tcClassSigType calls.++That's why tcHsSigType does simplifyAndEmitFlatConstraints (which+fails fast) but tcClassSigType just does emitImplication (which does+not).  Ugh.++c.f. see also Note [Skolem escape and forall-types]. The difference+is that we don't need to simplify at a forall type, only at the+top level of a signature.+-}++-- Does validity checking and zonking.+tcStandaloneKindSig :: LStandaloneKindSig GhcRn -> TcM (Name, Kind)+tcStandaloneKindSig (L _ (StandaloneKindSig _ (L _ name) ksig))+  = addSigCtxt ctxt ksig $+    do { kind <- tc_top_lhs_type KindLevel ctxt ksig+       ; checkValidType ctxt kind+       ; return (name, kind) }+  where+   ctxt = StandaloneKindSigCtxt name++tcTopLHsType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type+tcTopLHsType ctxt lsig_ty+  = checkNoErrs $  -- Fail eagerly to avoid follow-on errors.  We are at+                   -- top level so these constraints will never be solved later.+    tc_top_lhs_type TypeLevel ctxt lsig_ty++tc_top_lhs_type :: TypeOrKind -> UserTypeCtxt -> LHsSigType GhcRn -> TcM Type+-- tc_top_lhs_type is used for kind-checking top-level LHsSigTypes where+--   we want to fully solve /all/ equalities, and report errors+-- Does zonking, but not validity checking because it's used+--   for things (like deriving and instances) that aren't+--   ordinary types+-- Used for both types and kinds+tc_top_lhs_type tyki ctxt (L loc sig_ty@(HsSig { sig_bndrs = hs_outer_bndrs+                                               , sig_body = body }))+  = setSrcSpanA loc $+    do { traceTc "tc_top_lhs_type {" (ppr sig_ty)+       ; skol_info <- mkSkolemInfo skol_info_anon+       ; (tclvl, wanted, (outer_bndrs, ty))+              <- pushLevelAndSolveEqualitiesX "tc_top_lhs_type"    $+                 tcOuterTKBndrs skol_info hs_outer_bndrs $+                 do { kind <- newExpectedKind (expectedKindInCtxt ctxt)+                    ; tc_lhs_type (mkMode tyki) body kind }++       ; outer_bndrs <- scopedSortOuter outer_bndrs+       ; let outer_tv_bndrs = outerTyVarBndrs outer_bndrs+             ty1 = mkInvisForAllTys outer_tv_bndrs ty++       ; kvs <- kindGeneralizeAll skol_info ty1  -- "All" because it's a top-level type+       ; reportUnsolvedEqualities skol_info kvs tclvl wanted++       ; ze       <- mkEmptyZonkEnv NoFlexi+       ; final_ty <- zonkTcTypeToTypeX ze (mkInfForAllTys kvs ty1)+       ; traceTc "tc_top_lhs_type }" (vcat [ppr sig_ty, ppr final_ty])+       ; return final_ty }+  where+    skol_info_anon = SigTypeSkol ctxt++-----------------+tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], Class, [Type], [Kind])+-- Like tcHsSigType, but for the ...deriving( C t1 ty2 ) clause+-- Returns the C, [ty1, ty2, and the kinds of C's remaining arguments+-- E.g.    class C (a::*) (b::k->k)+--         data T a b = ... deriving( C Int )+--    returns ([k], C, [k, Int], [k->k])+-- Return values are fully zonked+tcHsDeriv hs_ty+  = do { ty <- tcTopLHsType DerivClauseCtxt hs_ty+       ; let (tvs, pred)    = splitForAllTyCoVars ty+             (kind_args, _) = splitFunTys (tcTypeKind pred)+       ; case getClassPredTys_maybe pred of+           Just (cls, tys) -> return (tvs, cls, tys, map scaledThing kind_args)+           Nothing -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $+             (text "Illegal deriving item" <+> quotes (ppr hs_ty)) }++-- | Typecheck a deriving strategy. For most deriving strategies, this is a+-- no-op, but for the @via@ strategy, this requires typechecking the @via@ type.+tcDerivStrategy :: Maybe (LDerivStrategy GhcRn)+                   -- ^ The deriving strategy+                -> TcM (Maybe (LDerivStrategy GhcTc), [TcTyVar])+                   -- ^ The typechecked deriving strategy and the tyvars that it binds+                   -- (if using 'ViaStrategy').+tcDerivStrategy mb_lds+  = case mb_lds of+      Nothing -> boring_case Nothing+      Just (L loc ds) ->+        setSrcSpanA loc $ do+          (ds', tvs) <- tc_deriv_strategy ds+          pure (Just (L loc ds'), tvs)+  where+    tc_deriv_strategy :: DerivStrategy GhcRn+                      -> TcM (DerivStrategy GhcTc, [TyVar])+    tc_deriv_strategy (StockStrategy    _) = boring_case (StockStrategy    noExtField)+    tc_deriv_strategy (AnyclassStrategy _) = boring_case (AnyclassStrategy noExtField)+    tc_deriv_strategy (NewtypeStrategy  _) = boring_case (NewtypeStrategy  noExtField)+    tc_deriv_strategy (ViaStrategy hs_sig)+      = do { ty <- tcTopLHsType DerivClauseCtxt hs_sig+           ; rec { (via_tvs, via_pred) <- tcSkolemiseInvisibleBndrs (DerivSkol via_pred) ty}+           ; pure (ViaStrategy via_pred, via_tvs) }++    boring_case :: ds -> TcM (ds, [a])+    boring_case ds = pure (ds, [])++tcHsClsInstType :: UserTypeCtxt    -- InstDeclCtxt or SpecInstCtxt+                -> LHsSigType GhcRn+                -> TcM Type+-- Like tcHsSigType, but for a class instance declaration+tcHsClsInstType user_ctxt hs_inst_ty+  = setSrcSpan (getLocA hs_inst_ty) $+    do { inst_ty <- tcTopLHsType user_ctxt hs_inst_ty+       ; checkValidInstance user_ctxt hs_inst_ty inst_ty+       ; return inst_ty }++----------------------------------------------+-- | Type-check a visible type application+tcHsTypeApp :: LHsWcType GhcRn -> Kind -> TcM Type+-- See Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType+tcHsTypeApp wc_ty kind+  | HsWC { hswc_ext = sig_wcs, hswc_body = hs_ty } <- wc_ty+  = do { mode <- mkHoleMode TypeLevel HM_VTA+                 -- HM_VTA: See Note [Wildcards in visible type application]+       ; ty <- addTypeCtxt hs_ty                  $+               solveEqualities "tcHsTypeApp" $+               -- We are looking at a user-written type, very like a+               -- signature so we want to solve its equalities right now+               bindNamedWildCardBinders sig_wcs $ \ _ ->+               tc_lhs_type mode hs_ty kind++       -- We do not kind-generalize type applications: we just+       -- instantiate with exactly what the user says.+       -- See Note [No generalization in type application]+       -- We still must call kindGeneralizeNone, though, according+       -- to Note [Recipe for checking a signature]+       ; kindGeneralizeNone ty+       ; ty <- zonkTcType ty+       ; checkValidType TypeAppCtxt ty+       ; return ty }++{- Note [Wildcards in visible type application]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A HsWildCardBndrs's hswc_ext now only includes /named/ wildcards, so+any unnamed wildcards stay unchanged in hswc_body.  When called in+tcHsTypeApp, tcCheckLHsType will call emitAnonTypeHole+on these anonymous wildcards. However, this would trigger+error/warning when an anonymous wildcard is passed in as a visible type+argument, which we do not want because users should be able to write+@_ to skip a instantiating a type variable variable without fuss. The+solution is to switch the PartialTypeSignatures flags here to let the+typechecker know that it's checking a '@_' and do not emit hole+constraints on it.  See related Note [Wildcards in visible kind+application] and Note [The wildcard story for types] in GHC.Hs.Type++Ugh!++Note [No generalization in type application]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We do not kind-generalize type applications. Imagine++  id @(Proxy Nothing)++If we kind-generalized, we would get++  id @(forall {k}. Proxy @(Maybe k) (Nothing @k))++which is very sneakily impredicative instantiation.++There is also the possibility of mentioning a wildcard+(`id @(Proxy _)`), which definitely should not be kind-generalized.++-}++tcFamTyPats :: TyCon+            -> HsTyPats GhcRn                -- Patterns+            -> TcM (TcType, TcKind)          -- (lhs_type, lhs_kind)+-- Check the LHS of a type/data family instance+-- e.g.   type instance F ty1 .. tyn = ...+-- Used for both type and data families+tcFamTyPats fam_tc hs_pats+  = do { traceTc "tcFamTyPats {" $+         vcat [ ppr fam_tc, text "arity:" <+> ppr fam_arity ]++       ; mode <- mkHoleMode TypeLevel HM_FamPat+                 -- HM_FamPat: See Note [Wildcards in family instances] in+                 -- GHC.Rename.Module+       ; let fun_ty = mkTyConApp fam_tc []+       ; (fam_app, res_kind) <- tcInferTyApps mode lhs_fun fun_ty hs_pats++       -- Hack alert: see Note [tcFamTyPats: zonking the result kind]+       ; res_kind <- zonkTcType res_kind++       ; traceTc "End tcFamTyPats }" $+         vcat [ ppr fam_tc, text "res_kind:" <+> ppr res_kind ]++       ; return (fam_app, res_kind) }+  where+    fam_name  = tyConName fam_tc+    fam_arity = tyConArity fam_tc+    lhs_fun   = noLocA (HsTyVar noAnn NotPromoted (noLocA fam_name))++{- Note [tcFamTyPats: zonking the result kind]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (#19250)+    F :: forall k. k -> k+    type instance F (x :: Constraint) = ()++The tricky point is this:+  is that () an empty type tuple (() :: Type), or+  an empty constraint tuple (() :: Constraint)?+We work this out in a hacky way, by looking at the expected kind:+see Note [Inferring tuple kinds].++In this case, we kind-check the RHS using the kind gotten from the LHS:+see the call to tcCheckLHsType in tcTyFamInstEqnGuts in GHC.Tc.Tycl.++But we want the kind from the LHS to be /zonked/, so that when+kind-checking the RHS (tcCheckLHsType) we can "see" what we learned+from kind-checking the LHS (tcFamTyPats).  In our example above, the+type of the LHS is just `kappa` (by instantiating the forall k), but+then we learn (from x::Constraint) that kappa ~ Constraint.  We want+that info when kind-checking the RHS.++Easy solution: just zonk that return kind.  Of course this won't help+if there is lots of type-family reduction to do, but it works fine in+common cases.+-}+++{-+************************************************************************+*                                                                      *+            The main kind checker: no validity checks here+*                                                                      *+************************************************************************+-}++---------------------------+tcHsOpenType, tcHsLiftedType,+  tcHsOpenTypeNC, tcHsLiftedTypeNC :: LHsType GhcRn -> TcM TcType+-- Used for type signatures+-- Do not do validity checking+tcHsOpenType   hs_ty = addTypeCtxt hs_ty $ tcHsOpenTypeNC hs_ty+tcHsLiftedType hs_ty = addTypeCtxt hs_ty $ tcHsLiftedTypeNC hs_ty++tcHsOpenTypeNC   hs_ty = do { ek <- newOpenTypeKind; tcLHsType hs_ty ek }+tcHsLiftedTypeNC hs_ty = tcLHsType hs_ty liftedTypeKind++-- Like tcHsType, but takes an expected kind+tcCheckLHsType :: LHsType GhcRn -> ContextKind -> TcM TcType+tcCheckLHsType hs_ty exp_kind+  = addTypeCtxt hs_ty $+    do { ek <- newExpectedKind exp_kind+       ; tcLHsType hs_ty ek }++tcInferLHsType :: LHsType GhcRn -> TcM TcType+tcInferLHsType hs_ty+  = do { (ty,_kind) <- tcInferLHsTypeKind hs_ty+       ; return ty }++tcInferLHsTypeKind :: LHsType GhcRn -> TcM (TcType, TcKind)+-- Called from outside: set the context+-- Eagerly instantiate any trailing invisible binders+tcInferLHsTypeKind lhs_ty@(L loc hs_ty)+  = addTypeCtxt lhs_ty $+    setSrcSpanA loc    $  -- Cover the tcInstInvisibleTyBinders+    do { (res_ty, res_kind) <- tc_infer_hs_type typeLevelMode hs_ty+       ; tcInstInvisibleTyBinders res_ty res_kind }+  -- See Note [Do not always instantiate eagerly in types]++-- Used to check the argument of GHCi :kind+-- Allow and report wildcards, e.g. :kind T _+-- Do not saturate family applications: see Note [Dealing with :kind]+-- Does not instantiate eagerly; See Note [Do not always instantiate eagerly in types]+tcInferLHsTypeUnsaturated :: LHsType GhcRn -> TcM (TcType, TcKind)+tcInferLHsTypeUnsaturated hs_ty+  = addTypeCtxt hs_ty $+    do { mode <- mkHoleMode TypeLevel HM_Sig  -- Allow and report holes+       ; case splitHsAppTys (unLoc hs_ty) of+           Just (hs_fun_ty, hs_args)+              -> do { (fun_ty, _ki) <- tcInferTyAppHead mode hs_fun_ty+                    ; tcInferTyApps_nosat mode hs_fun_ty fun_ty hs_args }+                      -- Notice the 'nosat'; do not instantiate trailing+                      -- invisible arguments of a type family.+                      -- See Note [Dealing with :kind]+           Nothing -> tc_infer_lhs_type mode hs_ty }++{- Note [Dealing with :kind]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this GHCi command+  ghci> type family F :: Either j k+  ghci> :kind F+  F :: forall {j,k}. Either j k++We will only get the 'forall' if we /refrain/ from saturating those+invisible binders. But generally we /do/ saturate those invisible+binders (see tcInferTyApps), and we want to do so for nested application+even in GHCi.  Consider for example (#16287)+  ghci> type family F :: k+  ghci> data T :: (forall k. k) -> Type+  ghci> :kind T F+We want to reject this. It's just at the very top level that we want+to switch off saturation.++So tcInferLHsTypeUnsaturated does a little special case for top level+applications.  Actually the common case is a bare variable, as above.++Note [Do not always instantiate eagerly in types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Terms are eagerly instantiated. This means that if you say++  x = id++then `id` gets instantiated to have type alpha -> alpha. The variable+alpha is then unconstrained and regeneralized. But we cannot do this+in types, as we have no type-level lambda. So, when we are sure+that we will not want to regeneralize later -- because we are done+checking a type, for example -- we can instantiate. But we do not+instantiate at variables, nor do we in tcInferLHsTypeUnsaturated,+which is used by :kind in GHCi.++************************************************************************+*                                                                      *+      Type-checking modes+*                                                                      *+************************************************************************++The kind-checker is parameterised by a TcTyMode, which contains some+information about where we're checking a type.++The renamer issues errors about what it can. All errors issued here must+concern things that the renamer can't handle.++-}++tcMult :: HsArrow GhcRn -> TcM Mult+tcMult hc = tc_mult typeLevelMode hc++-- | Info about the context in which we're checking a type. Currently,+-- differentiates only between types and kinds, but this will likely+-- grow, at least to include the distinction between patterns and+-- not-patterns.+--+-- To find out where the mode is used, search for 'mode_tyki'+--+-- This data type is purely local, not exported from this module+data TcTyMode+  = TcTyMode { mode_tyki :: TypeOrKind+             , mode_holes :: HoleInfo   }++-- See Note [Levels for wildcards]+-- Nothing <=> no wildcards expected+type HoleInfo = Maybe (TcLevel, HoleMode)++-- HoleMode says how to treat the occurrences+-- of anonymous wildcards; see tcAnonWildCardOcc+data HoleMode = HM_Sig      -- Partial type signatures: f :: _ -> Int+              | HM_FamPat   -- Family instances: F _ Int = Bool+              | HM_VTA      -- Visible type and kind application:+                            --   f @(Maybe _)+                            --   Maybe @(_ -> _)+              | HM_TyAppPat -- Visible type applications in patterns:+                            --   foo (Con @_ @t x) = ...+                            --   case x of Con @_ @t v -> ...++mkMode :: TypeOrKind -> TcTyMode+mkMode tyki = TcTyMode { mode_tyki = tyki, mode_holes = Nothing }++typeLevelMode, kindLevelMode :: TcTyMode+-- These modes expect no wildcards (holes) in the type+kindLevelMode = mkMode KindLevel+typeLevelMode = mkMode TypeLevel++mkHoleMode :: TypeOrKind -> HoleMode -> TcM TcTyMode+mkHoleMode tyki hm+  = do { lvl <- getTcLevel+       ; return (TcTyMode { mode_tyki  = tyki+                          , mode_holes = Just (lvl,hm) }) }++instance Outputable HoleMode where+  ppr HM_Sig      = text "HM_Sig"+  ppr HM_FamPat   = text "HM_FamPat"+  ppr HM_VTA      = text "HM_VTA"+  ppr HM_TyAppPat = text "HM_TyAppPat"++instance Outputable TcTyMode where+  ppr (TcTyMode { mode_tyki = tyki, mode_holes = hm })+    = text "TcTyMode" <+> braces (sep [ ppr tyki <> comma+                                      , ppr hm ])++{-+Note [Bidirectional type checking]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In expressions, whenever we see a polymorphic identifier, say `id`, we are+free to instantiate it with metavariables, knowing that we can always+re-generalize with type-lambdas when necessary. For example:++  rank2 :: (forall a. a -> a) -> ()+  x = rank2 id++When checking the body of `x`, we can instantiate `id` with a metavariable.+Then, when we're checking the application of `rank2`, we notice that we really+need a polymorphic `id`, and then re-generalize over the unconstrained+metavariable.++In types, however, we're not so lucky, because *we cannot re-generalize*!+There is no lambda. So, we must be careful only to instantiate at the last+possible moment, when we're sure we're never going to want the lost polymorphism+again. This is done in calls to tcInstInvisibleTyBinders.++To implement this behavior, we use bidirectional type checking, where we+explicitly think about whether we know the kind of the type we're checking+or not. Note that there is a difference between not knowing a kind and+knowing a metavariable kind: the metavariables are TauTvs, and cannot become+forall-quantified kinds. Previously (before dependent types), there were+no higher-rank kinds, and so we could instantiate early and be sure that+no types would have polymorphic kinds, and so we could always assume that+the kind of a type was a fresh metavariable. Not so anymore, thus the+need for two algorithms.++For HsType forms that can never be kind-polymorphic, we implement only the+"down" direction, where we safely assume a metavariable kind. For HsType forms+that *can* be kind-polymorphic, we implement just the "up" (functions with+"infer" in their name) version, as we gain nothing by also implementing the+"down" version.++Note [Future-proofing the type checker]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As discussed in Note [Bidirectional type checking], each HsType form is+handled in *either* tc_infer_hs_type *or* tc_hs_type. These functions+are mutually recursive, so that either one can work for any type former.+But, we want to make sure that our pattern-matches are complete. So,+we have a bunch of repetitive code just so that we get warnings if we're+missing any patterns.++-}++------------------------------------------+-- | Check and desugar a type, returning the core type and its+-- possibly-polymorphic kind. Much like 'tcInferRho' at the expression+-- level.+tc_infer_lhs_type :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind)+tc_infer_lhs_type mode (L span ty)+  = setSrcSpanA span $+    tc_infer_hs_type mode ty++---------------------------+-- | Call 'tc_infer_hs_type' and check its result against an expected kind.+tc_infer_hs_type_ek :: HasDebugCallStack => TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType+tc_infer_hs_type_ek mode hs_ty ek+  = do { (ty, k) <- tc_infer_hs_type mode hs_ty+       ; checkExpectedKind hs_ty ty k ek }++---------------------------+-- | Infer the kind of a type and desugar. This is the "up" type-checker,+-- as described in Note [Bidirectional type checking]+tc_infer_hs_type :: TcTyMode -> HsType GhcRn -> TcM (TcType, TcKind)++tc_infer_hs_type mode (HsParTy _ t)+  = tc_infer_lhs_type mode t++tc_infer_hs_type mode ty+  | Just (hs_fun_ty, hs_args) <- splitHsAppTys ty+  = do { (fun_ty, _ki) <- tcInferTyAppHead mode hs_fun_ty+       ; tcInferTyApps mode hs_fun_ty fun_ty hs_args }++tc_infer_hs_type mode (HsKindSig _ ty sig)+  = do { let mode' = mode { mode_tyki = KindLevel }+       ; sig' <- tc_lhs_kind_sig mode' KindSigCtxt sig+                 -- We must typecheck the kind signature, and solve all+                 -- its equalities etc; from this point on we may do+                 -- things like instantiate its foralls, so it needs+                 -- to be fully determined (#14904)+       ; traceTc "tc_infer_hs_type:sig" (ppr ty $$ ppr sig')+       ; ty' <- tc_lhs_type mode ty sig'+       ; return (ty', sig') }++-- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceType' to communicate+-- the splice location to the typechecker. Here we skip over it in order to have+-- the same kind inferred for a given expression whether it was produced from+-- splices or not.+--+-- See Note [Delaying modFinalizers in untyped splices].+tc_infer_hs_type mode (HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)))+  = tc_infer_hs_type mode ty++tc_infer_hs_type mode (HsDocTy _ ty _) = tc_infer_lhs_type mode ty++-- See Note [Typechecking HsCoreTys]+tc_infer_hs_type _ (XHsType ty)+  = do env <- getLclEnv+       -- Raw uniques since we go from NameEnv to TvSubstEnv.+       let subst_prs :: [(Unique, TcTyVar)]+           subst_prs = [ (getUnique nm, tv)+                       | ATyVar nm tv <- nonDetNameEnvElts (tcl_env env) ]+           subst = mkTvSubst+                     (mkInScopeSet $ mkVarSet $ map snd subst_prs)+                     (listToUFM_Directly $ map (liftSnd mkTyVarTy) subst_prs)+           ty' = substTy subst ty+       return (ty', tcTypeKind ty')++tc_infer_hs_type _ (HsExplicitListTy _ _ tys)+  | null tys  -- this is so that we can use visible kind application with '[]+              -- e.g ... '[] @Bool+  = return (mkTyConTy promotedNilDataCon,+            mkSpecForAllTys [alphaTyVar] $ mkListTy alphaTy)++tc_infer_hs_type mode other_ty+  = do { kv <- newMetaKindVar+       ; ty' <- tc_hs_type mode other_ty kv+       ; return (ty', kv) }++{-+Note [Typechecking HsCoreTys]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+HsCoreTy is an escape hatch that allows embedding Core Types in HsTypes.+As such, there's not much to be done in order to typecheck an HsCoreTy,+since it's already been typechecked to some extent. There is one thing that+we must do, however: we must substitute the type variables from the tcl_env.+To see why, consider GeneralizedNewtypeDeriving, which is one of the main+clients of HsCoreTy (example adapted from #14579):++  newtype T a = MkT a deriving newtype Eq++This will produce an InstInfo GhcPs that looks roughly like this:++  instance forall a_1. Eq a_1 => Eq (T a_1) where+    (==) = coerce @(  a_1 ->   a_1 -> Bool) -- The type within @(...) is an HsCoreTy+                  @(T a_1 -> T a_1 -> Bool) -- So is this+                  (==)++This is then fed into the renamer. Since all of the type variables in this+InstInfo use Exact RdrNames, the resulting InstInfo GhcRn looks basically+identical. Things get more interesting when the InstInfo is fed into the+typechecker, however. GHC will first generate fresh skolems to instantiate+the instance-bound type variables with. In the example above, we might generate+the skolem a_2 and use that to instantiate a_1, which extends the local type+environment (tcl_env) with [a_1 :-> a_2]. This gives us:++  instance forall a_2. Eq a_2 => Eq (T a_2) where ...++To ensure that the body of this instance is well scoped, every occurrence of+the `a` type variable should refer to a_2, the new skolem. However, the+HsCoreTys mention a_1, not a_2. Luckily, the tcl_env provides exactly the+substitution we need ([a_1 :-> a_2]) to fix up the scoping. We apply this+substitution to each HsCoreTy and all is well:++  instance forall a_2. Eq a_2 => Eq (T a_2) where+    (==) = coerce @(  a_2 ->   a_2 -> Bool)+                  @(T a_2 -> T a_2 -> Bool)+                  (==)+-}++------------------------------------------+tcLHsType :: LHsType GhcRn -> TcKind -> TcM TcType+tcLHsType hs_ty exp_kind+  = tc_lhs_type typeLevelMode hs_ty exp_kind++tc_lhs_type :: TcTyMode -> LHsType GhcRn -> TcKind -> TcM TcType+tc_lhs_type mode (L span ty) exp_kind+  = setSrcSpanA span $+    tc_hs_type mode ty exp_kind++tc_hs_type :: TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType+-- See Note [Bidirectional type checking]++tc_hs_type mode (HsParTy _ ty)   exp_kind = tc_lhs_type mode ty exp_kind+tc_hs_type mode (HsDocTy _ ty _) exp_kind = tc_lhs_type mode ty exp_kind+tc_hs_type _ ty@(HsBangTy _ bang _) _+    -- While top-level bangs at this point are eliminated (eg !(Maybe Int)),+    -- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of+    -- bangs are invalid, so fail. (#7210, #14761)+    = do { let bangError err = failWith $ TcRnUnknownMessage $ mkPlainError noHints $+                 text "Unexpected" <+> text err <+> text "annotation:" <+> ppr ty $$+                 text err <+> text "annotation cannot appear nested inside a type"+         ; case bang of+             HsSrcBang _ SrcUnpack _           -> bangError "UNPACK"+             HsSrcBang _ SrcNoUnpack _         -> bangError "NOUNPACK"+             HsSrcBang _ NoSrcUnpack SrcLazy   -> bangError "laziness"+             HsSrcBang _ _ _                   -> bangError "strictness" }+tc_hs_type _ ty@(HsRecTy {})      _+      -- Record types (which only show up temporarily in constructor+      -- signatures) should have been removed by now+    = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $+       (text "Record syntax is illegal here:" <+> ppr ty)++-- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceType'.+-- Here we get rid of it and add the finalizers to the global environment+-- while capturing the local environment.+--+-- See Note [Delaying modFinalizers in untyped splices].+tc_hs_type mode (HsSpliceTy _ (HsSpliced _ mod_finalizers (HsSplicedTy ty)))+           exp_kind+  = do addModFinalizersWithLclEnv mod_finalizers+       tc_hs_type mode ty exp_kind++-- This should never happen; type splices are expanded by the renamer+tc_hs_type _ ty@(HsSpliceTy {}) _exp_kind+  = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $+     (text "Unexpected type splice:" <+> ppr ty)++---------- Functions and applications+tc_hs_type mode (HsFunTy _ mult ty1 ty2) exp_kind+  = tc_fun_type mode mult ty1 ty2 exp_kind++tc_hs_type mode (HsOpTy _ _ ty1 (L _ op) ty2) exp_kind+  | op `hasKey` funTyConKey+  = tc_fun_type mode (HsUnrestrictedArrow noHsUniTok) ty1 ty2 exp_kind++--------- Foralls+tc_hs_type mode (HsForAllTy { hst_tele = tele, hst_body = ty }) exp_kind+  = do { (tv_bndrs, ty') <- tcTKTelescope mode tele $+                            tc_lhs_type mode ty exp_kind+                 -- Pass on the mode from the type, to any wildcards+                 -- in kind signatures on the forall'd variables+                 -- e.g.      f :: _ -> Int -> forall (a :: _). blah+                 -- Why exp_kind?  See Note [Body kind of a HsForAllTy]++       -- Do not kind-generalise here!  See Note [Kind generalisation]++       ; return (mkForAllTys tv_bndrs ty') }++tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = rn_ty }) exp_kind+  | null (unLoc ctxt)+  = tc_lhs_type mode rn_ty exp_kind++  -- See Note [Body kind of a HsQualTy]+  | tcIsConstraintKind exp_kind+  = do { ctxt' <- tc_hs_context mode ctxt+       ; ty'   <- tc_lhs_type mode rn_ty constraintKind+       ; return (mkPhiTy ctxt' ty') }++  | otherwise+  = do { ctxt' <- tc_hs_context mode ctxt++       ; ek <- newOpenTypeKind  -- The body kind (result of the function) can+                                -- be TYPE r, for any r, hence newOpenTypeKind+       ; ty' <- tc_lhs_type mode rn_ty ek+       ; checkExpectedKind (unLoc rn_ty) (mkPhiTy ctxt' ty')+                           liftedTypeKind exp_kind }++--------- Lists, arrays, and tuples+tc_hs_type mode rn_ty@(HsListTy _ elt_ty) exp_kind+  = do { tau_ty <- tc_lhs_type mode elt_ty liftedTypeKind+       ; checkWiredInTyCon listTyCon+       ; checkExpectedKind rn_ty (mkListTy tau_ty) liftedTypeKind exp_kind }++-- See Note [Distinguishing tuple kinds] in GHC.Hs.Type+-- See Note [Inferring tuple kinds]+tc_hs_type mode rn_ty@(HsTupleTy _ HsBoxedOrConstraintTuple hs_tys) exp_kind+     -- (NB: not zonking before looking at exp_k, to avoid left-right bias)+  | Just tup_sort <- tupKindSort_maybe exp_kind+  = traceTc "tc_hs_type tuple" (ppr hs_tys) >>+    tc_tuple rn_ty mode tup_sort hs_tys exp_kind+  | otherwise+  = do { traceTc "tc_hs_type tuple 2" (ppr hs_tys)+       ; (tys, kinds) <- mapAndUnzipM (tc_infer_lhs_type mode) hs_tys+       ; kinds <- mapM zonkTcType kinds+           -- Infer each arg type separately, because errors can be+           -- confusing if we give them a shared kind.  Eg #7410+           -- (Either Int, Int), we do not want to get an error saying+           -- "the second argument of a tuple should have kind *->*"++       ; let (arg_kind, tup_sort)+               = case [ (k,s) | k <- kinds+                              , Just s <- [tupKindSort_maybe k] ] of+                    ((k,s) : _) -> (k,s)+                    [] -> (liftedTypeKind, BoxedTuple)+         -- In the [] case, it's not clear what the kind is, so guess *++       ; tys' <- sequence [ setSrcSpanA loc $+                            checkExpectedKind hs_ty ty kind arg_kind+                          | ((L loc hs_ty),ty,kind) <- zip3 hs_tys tys kinds ]++       ; finish_tuple rn_ty tup_sort tys' (map (const arg_kind) tys') exp_kind }+++tc_hs_type mode rn_ty@(HsTupleTy _ HsUnboxedTuple tys) exp_kind+  = tc_tuple rn_ty mode UnboxedTuple tys exp_kind++tc_hs_type mode rn_ty@(HsSumTy _ hs_tys) exp_kind+  = do { let arity = length hs_tys+       ; arg_kinds <- mapM (\_ -> newOpenTypeKind) hs_tys+       ; tau_tys   <- zipWithM (tc_lhs_type mode) hs_tys arg_kinds+       ; let arg_reps = map kindRep arg_kinds+             arg_tys  = arg_reps ++ tau_tys+             sum_ty   = mkTyConApp (sumTyCon arity) arg_tys+             sum_kind = unboxedSumKind arg_reps+       ; checkExpectedKind rn_ty sum_ty sum_kind exp_kind+       }++--------- Promoted lists and tuples+tc_hs_type mode rn_ty@(HsExplicitListTy _ _ tys) exp_kind+  = do { tks <- mapM (tc_infer_lhs_type mode) tys+       ; (taus', kind) <- unifyKinds tys tks+       ; let ty = (foldr (mk_cons kind) (mk_nil kind) taus')+       ; checkExpectedKind rn_ty ty (mkListTy kind) exp_kind }+  where+    mk_cons k a b = mkTyConApp (promoteDataCon consDataCon) [k, a, b]+    mk_nil  k     = mkTyConApp (promoteDataCon nilDataCon) [k]++tc_hs_type mode rn_ty@(HsExplicitTupleTy _ tys) exp_kind+  -- using newMetaKindVar means that we force instantiations of any polykinded+  -- types. At first, I just used tc_infer_lhs_type, but that led to #11255.+  = do { ks   <- replicateM arity newMetaKindVar+       ; taus <- zipWithM (tc_lhs_type mode) tys ks+       ; let kind_con   = tupleTyCon           Boxed arity+             ty_con     = promotedTupleDataCon Boxed arity+             tup_k      = mkTyConApp kind_con ks+       ; checkTupSize arity+       ; checkExpectedKind rn_ty (mkTyConApp ty_con (ks ++ taus)) tup_k exp_kind }+  where+    arity = length tys++--------- Constraint types+tc_hs_type mode rn_ty@(HsIParamTy _ (L _ n) ty) exp_kind+  = do { massert (isTypeLevel (mode_tyki mode))+       ; ty' <- tc_lhs_type mode ty liftedTypeKind+       ; let n' = mkStrLitTy $ hsIPNameFS n+       ; ipClass <- tcLookupClass ipClassName+       ; checkExpectedKind rn_ty (mkClassPred ipClass [n',ty'])+                           constraintKind exp_kind }++tc_hs_type _ rn_ty@(HsStarTy _ _) exp_kind+  -- Desugaring 'HsStarTy' to 'Data.Kind.Type' here means that we don't have to+  -- handle it in 'coreView' and 'tcView'.+  = checkExpectedKind rn_ty liftedTypeKind liftedTypeKind exp_kind++--------- Literals+tc_hs_type _ rn_ty@(HsTyLit _ (HsNumTy _ n)) exp_kind+  = do { checkWiredInTyCon naturalTyCon+       ; checkExpectedKind rn_ty (mkNumLitTy n) naturalTy exp_kind }++tc_hs_type _ rn_ty@(HsTyLit _ (HsStrTy _ s)) exp_kind+  = do { checkWiredInTyCon typeSymbolKindCon+       ; checkExpectedKind rn_ty (mkStrLitTy s) typeSymbolKind exp_kind }+tc_hs_type _ rn_ty@(HsTyLit _ (HsCharTy _ c)) exp_kind+  = do { checkWiredInTyCon charTyCon+       ; checkExpectedKind rn_ty (mkCharLitTy c) charTy exp_kind }++--------- Wildcards++tc_hs_type mode ty@(HsWildCardTy _)        ek+  = tcAnonWildCardOcc NoExtraConstraint mode ty ek++--------- Potentially kind-polymorphic types: call the "up" checker+-- See Note [Future-proofing the type checker]+tc_hs_type mode ty@(HsTyVar {})            ek = tc_infer_hs_type_ek mode ty ek+tc_hs_type mode ty@(HsAppTy {})            ek = tc_infer_hs_type_ek mode ty ek+tc_hs_type mode ty@(HsAppKindTy{})         ek = tc_infer_hs_type_ek mode ty ek+tc_hs_type mode ty@(HsOpTy {})             ek = tc_infer_hs_type_ek mode ty ek+tc_hs_type mode ty@(HsKindSig {})          ek = tc_infer_hs_type_ek mode ty ek+tc_hs_type mode ty@(XHsType {})            ek = tc_infer_hs_type_ek mode ty ek++{-+Note [Variable Specificity and Forall Visibility]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A HsForAllTy contains an HsForAllTelescope to denote the visibility of the forall+binder. Furthermore, each invisible type variable binder also has a+Specificity. Together, these determine the variable binders (ArgFlag) for each+variable in the generated ForAllTy type.++This table summarises this relation:+----------------------------------------------------------------------------+| User-written type         HsForAllTelescope   Specificity        ArgFlag+|---------------------------------------------------------------------------+| f :: forall a. type       HsForAllInvis       SpecifiedSpec      Specified+| f :: forall {a}. type     HsForAllInvis       InferredSpec       Inferred+| f :: forall a -> type     HsForAllVis         SpecifiedSpec      Required+| f :: forall {a} -> type   HsForAllVis         InferredSpec       /+|   This last form is non-sensical and is thus rejected.+----------------------------------------------------------------------------++For more information regarding the interpretation of the resulting ArgFlag, see+Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in "GHC.Core.TyCo.Rep".+-}++------------------------------------------+tc_mult :: TcTyMode -> HsArrow GhcRn -> TcM Mult+tc_mult mode ty = tc_lhs_type mode (arrowToHsType ty) multiplicityTy+------------------------------------------+tc_fun_type :: TcTyMode -> HsArrow GhcRn -> LHsType GhcRn -> LHsType GhcRn -> TcKind+            -> TcM TcType+tc_fun_type mode mult ty1 ty2 exp_kind = case mode_tyki mode of+  TypeLevel ->+    do { arg_k <- newOpenTypeKind+       ; res_k <- newOpenTypeKind+       ; ty1' <- tc_lhs_type mode ty1 arg_k+       ; ty2' <- tc_lhs_type mode ty2 res_k+       ; mult' <- tc_mult mode mult+       ; checkExpectedKind (HsFunTy noAnn mult ty1 ty2) (mkVisFunTy mult' ty1' ty2')+                           liftedTypeKind exp_kind }+  KindLevel ->  -- no representation polymorphism in kinds. yet.+    do { ty1' <- tc_lhs_type mode ty1 liftedTypeKind+       ; ty2' <- tc_lhs_type mode ty2 liftedTypeKind+       ; mult' <- tc_mult mode mult+       ; checkExpectedKind (HsFunTy noAnn mult ty1 ty2) (mkVisFunTy mult' ty1' ty2')+                           liftedTypeKind exp_kind }++{- Note [Skolem escape and forall-types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See also Note [Checking telescopes].++Consider+  f :: forall a. (forall kb (b :: kb). Proxy '[a, b]) -> ()++The Proxy '[a,b] forces a and b to have the same kind.  But a's+kind must be bound outside the 'forall a', and hence escapes.+We discover this by building an implication constraint for+each forall.  So the inner implication constraint will look like+    forall kb (b::kb).  kb ~ ka+where ka is a's kind.  We can't unify these two, /even/ if ka is+unification variable, because it would be untouchable inside+this inner implication.++That's what the pushLevelAndCaptureConstraints, plus subsequent+buildTvImplication/emitImplication is all about, when kind-checking+HsForAllTy.++Note that++* We don't need to /simplify/ the constraints here+  because we aren't generalising. We just capture them.++* We can't use emitResidualTvConstraint, because that has a fast-path+  for empty constraints.  We can't take that fast path here, because+  we must do the bad-telescope check even if there are no inner wanted+  constraints. See Note [Checking telescopes] in+  GHC.Tc.Types.Constraint.  Lacking this check led to #16247.+-}++{- *********************************************************************+*                                                                      *+                Tuples+*                                                                      *+********************************************************************* -}++---------------------------+tupKindSort_maybe :: TcKind -> Maybe TupleSort+tupKindSort_maybe k+  | Just (k', _) <- splitCastTy_maybe k = tupKindSort_maybe k'+  | Just k'      <- tcView k            = tupKindSort_maybe k'+  | tcIsConstraintKind k = Just ConstraintTuple+  | tcIsLiftedTypeKind k   = Just BoxedTuple+  | otherwise            = Nothing++tc_tuple :: HsType GhcRn -> TcTyMode -> TupleSort -> [LHsType GhcRn] -> TcKind -> TcM TcType+tc_tuple rn_ty mode tup_sort tys exp_kind+  = do { arg_kinds <- case tup_sort of+           BoxedTuple      -> return (replicate arity liftedTypeKind)+           UnboxedTuple    -> replicateM arity newOpenTypeKind+           ConstraintTuple -> return (replicate arity constraintKind)+       ; tau_tys <- zipWithM (tc_lhs_type mode) tys arg_kinds+       ; finish_tuple rn_ty tup_sort tau_tys arg_kinds exp_kind }+  where+    arity   = length tys++finish_tuple :: HsType GhcRn+             -> TupleSort+             -> [TcType]    -- ^ argument types+             -> [TcKind]    -- ^ of these kinds+             -> TcKind      -- ^ expected kind of the whole tuple+             -> TcM TcType+finish_tuple rn_ty tup_sort tau_tys tau_kinds exp_kind = do+  traceTc "finish_tuple" (ppr tup_sort $$ ppr tau_kinds $$ ppr exp_kind)+  case tup_sort of+    ConstraintTuple+      |  [tau_ty] <- tau_tys+         -- Drop any uses of 1-tuple constraints here.+         -- See Note [Ignore unary constraint tuples]+      -> check_expected_kind tau_ty constraintKind+      |  otherwise+      -> do let tycon = cTupleTyCon arity+            checkCTupSize arity+            check_expected_kind (mkTyConApp tycon tau_tys) constraintKind+    BoxedTuple -> do+      let tycon = tupleTyCon Boxed arity+      checkTupSize arity+      checkWiredInTyCon tycon+      check_expected_kind (mkTyConApp tycon tau_tys) liftedTypeKind+    UnboxedTuple -> do+      let tycon    = tupleTyCon Unboxed arity+          tau_reps = map kindRep tau_kinds+          -- See also Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon+          arg_tys  = tau_reps ++ tau_tys+          res_kind = unboxedTupleKind tau_reps+      checkTupSize arity+      check_expected_kind (mkTyConApp tycon arg_tys) res_kind+  where+    arity = length tau_tys+    check_expected_kind ty act_kind =+      checkExpectedKind rn_ty ty act_kind exp_kind++{-+Note [Ignore unary constraint tuples]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC provides unary tuples and unboxed tuples (see Note [One-tuples] in+GHC.Builtin.Types) but does *not* provide unary constraint tuples. Why? First,+recall the definition of a unary tuple data type:++  data Solo a = Solo a++Note that `Solo a` is *not* the same thing as `a`, since Solo is boxed and+lazy. Therefore, the presence of `Solo` matters semantically. On the other+hand, suppose we had a unary constraint tuple:++  class a => Solo% a++This compiles down a newtype (i.e., a cast) in Core, so `Solo% a` is+semantically equivalent to `a`. Therefore, a 1-tuple constraint would have+no user-visible impact, nor would it allow you to express anything that+you couldn't otherwise.++We could simply add Solo% for consistency with tuples (Solo) and unboxed+tuples (Solo#), but that would require even more magic to wire in another+magical class, so we opt not to do so. We must be careful, however, since+one can try to sneak in uses of unary constraint tuples through Template+Haskell, such as in this program (from #17511):++  f :: $(pure (ForallT [] [TupleT 1 `AppT` (ConT ''Show `AppT` ConT ''Int)]+                       (ConT ''String)))+  -- f :: Solo% (Show Int) => String+  f = "abc"++This use of `TupleT 1` will produce an HsBoxedOrConstraintTuple of arity 1,+and since it is used in a Constraint position, GHC will attempt to treat+it as thought it were a constraint tuple, which can potentially lead to+trouble if one attempts to look up the name of a constraint tuple of arity+1 (as it won't exist). To avoid this trouble, we simply take any unary+constraint tuples discovered when typechecking and drop them—i.e., treat+"Solo% a" as though the user had written "a". This is always safe to do+since the two constraints should be semantically equivalent.+-}++{- *********************************************************************+*                                                                      *+                Type applications+*                                                                      *+********************************************************************* -}++splitHsAppTys :: HsType GhcRn -> Maybe (LHsType GhcRn, [LHsTypeArg GhcRn])+splitHsAppTys hs_ty+  | is_app hs_ty = Just (go (noLocA hs_ty) [])+  | otherwise    = Nothing+  where+    is_app :: HsType GhcRn -> Bool+    is_app (HsAppKindTy {})        = True+    is_app (HsAppTy {})            = True+    is_app (HsOpTy _ _ _ (L _ op) _) = not (op `hasKey` funTyConKey)+      -- I'm not sure why this funTyConKey test is necessary+      -- Can it even happen?  Perhaps for   t1 `(->)` t2+      -- but then maybe it's ok to treat that like a normal+      -- application rather than using the special rule for HsFunTy+    is_app (HsTyVar {})            = True+    is_app (HsParTy _ (L _ ty))    = is_app ty+    is_app _                       = False++    go :: LHsType GhcRn+       -> [HsArg (LHsType GhcRn) (LHsKind GhcRn)]+       -> (LHsType GhcRn,+           [HsArg (LHsType GhcRn) (LHsKind GhcRn)]) -- AZ temp+    go (L _  (HsAppTy _ f a))      as = go f (HsValArg a : as)+    go (L _  (HsAppKindTy l ty k)) as = go ty (HsTypeArg l k : as)+    go (L sp (HsParTy _ f))        as = go f (HsArgPar (locA sp) : as)+    go (L _  (HsOpTy _ prom l op@(L sp _) r)) as+      = ( L (na2la sp) (HsTyVar noAnn prom op)+        , HsValArg l : HsValArg r : as )+    go f as = (f, as)++---------------------------+tcInferTyAppHead :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind)+-- Version of tc_infer_lhs_type specialised for the head of an+-- application. In particular, for a HsTyVar (which includes type+-- constructors, it does not zoom off into tcInferTyApps and family+-- saturation+tcInferTyAppHead _ (L _ (HsTyVar _ _ (L _ tv)))+  = tcTyVar tv+tcInferTyAppHead mode ty+  = tc_infer_lhs_type mode ty++---------------------------+-- | Apply a type of a given kind to a list of arguments. This instantiates+-- invisible parameters as necessary. Always consumes all the arguments,+-- using matchExpectedFunKind as necessary.+-- This takes an optional @VarEnv Kind@ which maps kind variables to kinds.-+-- These kinds should be used to instantiate invisible kind variables;+-- they come from an enclosing class for an associated type/data family.+--+-- tcInferTyApps also arranges to saturate any trailing invisible arguments+--   of a type-family application, which is usually the right thing to do+-- tcInferTyApps_nosat does not do this saturation; it is used only+--   by ":kind" in GHCi+tcInferTyApps, tcInferTyApps_nosat+    :: TcTyMode+    -> LHsType GhcRn        -- ^ Function (for printing only)+    -> TcType               -- ^ Function+    -> [LHsTypeArg GhcRn]   -- ^ Args+    -> TcM (TcType, TcKind) -- ^ (f args, result kind)+tcInferTyApps mode hs_ty fun hs_args+  = do { (f_args, res_k) <- tcInferTyApps_nosat mode hs_ty fun hs_args+       ; saturateFamApp f_args res_k }++tcInferTyApps_nosat mode orig_hs_ty fun orig_hs_args+  = do { traceTc "tcInferTyApps {" (ppr orig_hs_ty $$ ppr orig_hs_args)+       ; (f_args, res_k) <- go_init 1 fun orig_hs_args+       ; traceTc "tcInferTyApps }" (ppr f_args <+> dcolon <+> ppr res_k)+       ; return (f_args, res_k) }+  where++    -- go_init just initialises the auxiliary+    -- arguments of the 'go' loop+    go_init n fun all_args+      = go n fun empty_subst fun_ki all_args+      where+        fun_ki = tcTypeKind fun+           -- We do (tcTypeKind fun) here, even though the caller+           -- knows the function kind, to absolutely guarantee+           -- INVARIANT for 'go'+           -- Note that in a typical application (F t1 t2 t3),+           -- the 'fun' is just a TyCon, so tcTypeKind is fast++        empty_subst = mkEmptyTCvSubst $ mkInScopeSet $+                      tyCoVarsOfType fun_ki++    go :: Int             -- The # of the next argument+       -> TcType          -- Function applied to some args+       -> TCvSubst        -- Applies to function kind+       -> TcKind          -- Function kind+       -> [LHsTypeArg GhcRn]    -- Un-type-checked args+       -> TcM (TcType, TcKind)  -- Result type and its kind+    -- INVARIANT: in any call (go n fun subst fun_ki args)+    --               tcTypeKind fun  =  subst(fun_ki)+    -- So the 'subst' and 'fun_ki' arguments are simply+    -- there to avoid repeatedly calling tcTypeKind.+    --+    -- Reason for INVARIANT: to support the Purely Kinded Type Invariant+    -- it's important that if fun_ki has a forall, then so does+    -- (tcTypeKind fun), because the next thing we are going to do+    -- is apply 'fun' to an argument type.++    -- Dispatch on all_args first, for performance reasons+    go n fun subst fun_ki all_args = case (all_args, tcSplitPiTy_maybe fun_ki) of++      ---------------- No user-written args left. We're done!+      ([], _) -> return (fun, substTy subst fun_ki)++      ---------------- HsArgPar: We don't care about parens here+      (HsArgPar _ : args, _) -> go n fun subst fun_ki args++      ---------------- HsTypeArg: a kind application (fun @ki)+      (HsTypeArg _ hs_ki_arg : hs_args, Just (ki_binder, inner_ki)) ->+        case ki_binder of++        -- FunTy with PredTy on LHS, or ForAllTy with Inferred+        Named (Bndr _ Inferred) -> instantiate ki_binder inner_ki+        Anon InvisArg _         -> instantiate ki_binder inner_ki++        Named (Bndr _ Specified) ->  -- Visible kind application+          do { traceTc "tcInferTyApps (vis kind app)"+                       (vcat [ ppr ki_binder, ppr hs_ki_arg+                             , ppr (tyBinderType ki_binder)+                             , ppr subst ])++             ; let exp_kind = substTy subst $ tyBinderType ki_binder+             ; arg_mode <- mkHoleMode KindLevel HM_VTA+                   -- HM_VKA: see Note [Wildcards in visible kind application]+             ; ki_arg <- addErrCtxt (funAppCtxt orig_hs_ty hs_ki_arg n) $+                         tc_lhs_type arg_mode hs_ki_arg exp_kind++             ; traceTc "tcInferTyApps (vis kind app)" (ppr exp_kind)+             ; (subst', fun') <- mkAppTyM subst fun ki_binder ki_arg+             ; go (n+1) fun' subst' inner_ki hs_args }++        -- Attempted visible kind application (fun @ki), but fun_ki is+        --   forall k -> blah   or   k1 -> k2+        -- So we need a normal application.  Error.+        _ -> ty_app_err hs_ki_arg $ substTy subst fun_ki++      -- No binder; try applying the substitution, or fail if that's not possible+      (HsTypeArg _ ki_arg : _, Nothing) -> try_again_after_substing_or $+                                           ty_app_err ki_arg substed_fun_ki++      ---------------- HsValArg: a normal argument (fun ty)+      (HsValArg arg : args, Just (ki_binder, inner_ki))+        -- next binder is invisible; need to instantiate it+        | isInvisibleBinder ki_binder   -- FunTy with InvisArg on LHS;+                                        -- or ForAllTy with Inferred or Specified+         -> instantiate ki_binder inner_ki++        -- "normal" case+        | otherwise+         -> do { traceTc "tcInferTyApps (vis normal app)"+                          (vcat [ ppr ki_binder+                                , ppr arg+                                , ppr (tyBinderType ki_binder)+                                , ppr subst ])+                ; let exp_kind = substTy subst $ tyBinderType ki_binder+                ; arg' <- addErrCtxt (funAppCtxt orig_hs_ty arg n) $+                          tc_lhs_type mode arg exp_kind+                ; traceTc "tcInferTyApps (vis normal app) 2" (ppr exp_kind)+                ; (subst', fun') <- mkAppTyM subst fun ki_binder arg'+                ; go (n+1) fun' subst' inner_ki args }++          -- no binder; try applying the substitution, or infer another arrow in fun kind+      (HsValArg _ : _, Nothing)+        -> try_again_after_substing_or $+           do { let arrows_needed = n_initial_val_args all_args+              ; co <- matchExpectedFunKind (HsTypeRnThing $ unLoc hs_ty) arrows_needed substed_fun_ki++              ; fun' <- zonkTcType (fun `mkTcCastTy` co)+                     -- This zonk is essential, to expose the fruits+                     -- of matchExpectedFunKind to the 'go' loop++              ; traceTc "tcInferTyApps (no binder)" $+                   vcat [ ppr fun <+> dcolon <+> ppr fun_ki+                        , ppr arrows_needed+                        , ppr co+                        , ppr fun' <+> dcolon <+> ppr (tcTypeKind fun')]+              ; go_init n fun' all_args }+                -- Use go_init to establish go's INVARIANT+      where+        instantiate ki_binder inner_ki+          = do { traceTc "tcInferTyApps (need to instantiate)"+                         (vcat [ ppr ki_binder, ppr subst])+               ; (subst', arg') <- tcInstInvisibleTyBinder subst ki_binder+               ; go n (mkAppTy fun arg') subst' inner_ki all_args }+                 -- Because tcInvisibleTyBinder instantiate ki_binder,+                 -- the kind of arg' will have the same shape as the kind+                 -- of ki_binder.  So we don't need mkAppTyM here.++        try_again_after_substing_or fallthrough+          | not (isEmptyTCvSubst subst)+          = go n fun zapped_subst substed_fun_ki all_args+          | otherwise+          = fallthrough++        zapped_subst   = zapTCvSubst subst+        substed_fun_ki = substTy subst fun_ki+        hs_ty          = appTypeToArg orig_hs_ty (take (n-1) orig_hs_args)++    n_initial_val_args :: [HsArg tm ty] -> Arity+    -- Count how many leading HsValArgs we have+    n_initial_val_args (HsValArg {} : args) = 1 + n_initial_val_args args+    n_initial_val_args (HsArgPar {} : args) = n_initial_val_args args+    n_initial_val_args _                    = 0++    ty_app_err arg ty+      = failWith $ TcRnUnknownMessage $ mkPlainError noHints $+          text "Cannot apply function of kind" <+> quotes (ppr ty)+            $$ text "to visible kind argument" <+> quotes (ppr arg)+++mkAppTyM :: TCvSubst+         -> TcType -> TyCoBinder    -- fun, plus its top-level binder+         -> TcType                  -- arg+         -> TcM (TCvSubst, TcType)  -- Extended subst, plus (fun arg)+-- Precondition: the application (fun arg) is well-kinded after zonking+--               That is, the application makes sense+--+-- Precondition: for (mkAppTyM subst fun bndr arg)+--       tcTypeKind fun  =  Pi bndr. body+--  That is, fun always has a ForAllTy or FunTy at the top+--           and 'bndr' is fun's pi-binder+--+-- Postcondition: if fun and arg satisfy (PKTI), the purely-kinded type+--                invariant, then so does the result type (fun arg)+--+-- We do not require that+--    tcTypeKind arg = tyVarKind (binderVar bndr)+-- This must be true after zonking (precondition 1), but it's not+-- required for the (PKTI).+mkAppTyM subst fun ki_binder arg+  | -- See Note [mkAppTyM]: Nasty case 2+    TyConApp tc args <- fun+  , isTypeSynonymTyCon tc+  , args `lengthIs` (tyConArity tc - 1)+  , any isTrickyTvBinder (tyConTyVars tc) -- We could cache this in the synonym+  = do { arg'  <- zonkTcType  arg+       ; args' <- zonkTcTypes args+       ; let subst' = case ki_binder of+                        Anon {}           -> subst+                        Named (Bndr tv _) -> extendTvSubstAndInScope subst tv arg'+       ; return (subst', mkTyConApp tc (args' ++ [arg'])) }+++mkAppTyM subst fun (Anon {}) arg+   = return (subst, mk_app_ty fun arg)++mkAppTyM subst fun (Named (Bndr tv _)) arg+  = do { arg' <- if isTrickyTvBinder tv+                 then -- See Note [mkAppTyM]: Nasty case 1+                      zonkTcType arg+                 else return     arg+       ; return ( extendTvSubstAndInScope subst tv arg'+                , mk_app_ty fun arg' ) }++mk_app_ty :: TcType -> TcType -> TcType+-- This function just adds an ASSERT for mkAppTyM's precondition+mk_app_ty fun arg+  = assertPpr (isPiTy fun_kind)+              (ppr fun <+> dcolon <+> ppr fun_kind $$ ppr arg) $+    mkAppTy fun arg+  where+    fun_kind = tcTypeKind fun++isTrickyTvBinder :: TcTyVar -> Bool+-- NB: isTrickyTvBinder is just an optimisation+-- It would be absolutely sound to return True always+isTrickyTvBinder tv = isPiTy (tyVarKind tv)++{- Note [The Purely Kinded Type Invariant (PKTI)]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+During type inference, we maintain this invariant++ (PKTI) It is legal to call 'tcTypeKind' on any Type ty,+        on any sub-term of ty, /without/ zonking ty++        Moreover, any such returned kind+        will itself satisfy (PKTI)++By "legal to call tcTypeKind" we mean "tcTypeKind will not crash".+The way in which tcTypeKind can crash is in applications+    (a t1 t2 .. tn)+if 'a' is a type variable whose kind doesn't have enough arrows+or foralls.  (The crash is in piResultTys.)++The loop in tcInferTyApps has to be very careful to maintain the (PKTI).+For example, suppose+    kappa is a unification variable+    We have already unified kappa := Type+      yielding    co :: Refl (Type -> Type)+    a :: kappa+then consider the type+    (a Int)+If we call tcTypeKind on that, we'll crash, because the (un-zonked)+kind of 'a' is just kappa, not an arrow kind.  So we must zonk first.++So the type inference engine is very careful when building applications.+This happens in tcInferTyApps. Suppose we are kind-checking the type (a Int),+where (a :: kappa).  Then in tcInferApps we'll run out of binders on+a's kind, so we'll call matchExpectedFunKind, and unify+   kappa := kappa1 -> kappa2,  with evidence co :: kappa ~ (kappa1 ~ kappa2)+At this point we must zonk the function type to expose the arrrow, so+that (a Int) will satisfy (PKTI).++The absence of this caused #14174 and #14520.++The calls to mkAppTyM is the other place we are very careful; see Note [mkAppTyM].++Wrinkle around FunTy:+Note that the PKTI does *not* guarantee anything about the shape of FunTys.+Specifically, when we have (FunTy vis mult arg res), it should be the case+that arg :: TYPE rr1 and res :: TYPE rr2, for some rr1 and rr2. However, we+might not have this. Example: if the user writes (a -> b), then we might+invent a :: kappa1 and b :: kappa2. We soon will check whether kappa1 ~ TYPE rho1+(for some rho1), and that will lead to kappa1 := TYPE rho1 (ditto for kappa2).+However, when we build the FunTy, we might not have zonked `a`, and so the+FunTy will be built without being able to purely extract the RuntimeReps.++Because the PKTI does not guarantee that the RuntimeReps are available in a FunTy,+we must be aware of this when splitting: splitTyConApp and splitAppTy will *not*+split a FunTy if the RuntimeReps are not available. See also Note [Decomposing FunTy]+in GHC.Tc.Solver.Canonical.++Note [mkAppTyM]+~~~~~~~~~~~~~~~+mkAppTyM is trying to guarantee the Purely Kinded Type Invariant+(PKTI) for its result type (fun arg).  There are two ways it can go wrong:++* Nasty case 1: forall types (polykinds/T14174a)+    T :: forall (p :: *->*). p Int -> p Bool+  Now kind-check (T x), where x::kappa.+  Well, T and x both satisfy the PKTI, but+     T x :: x Int -> x Bool+  and (x Int) does /not/ satisfy the PKTI.++* Nasty case 2: type synonyms+    type S f a = f a+  Even though (S ff aa) would satisfy the (PKTI) if S was a data type+  (i.e. nasty case 1 is dealt with), it might still not satisfy (PKTI)+  if S is a type synonym, because the /expansion/ of (S ff aa) is+  (ff aa), and /that/ does not satisfy (PKTI).  E.g. perhaps+  (ff :: kappa), where 'kappa' has already been unified with (*->*).++  We check for nasty case 2 on the final argument of a type synonym.++Notice that in both cases the trickiness only happens if the+bound variable has a pi-type.  Hence isTrickyTvBinder.+-}+++saturateFamApp :: TcType -> TcKind -> TcM (TcType, TcKind)+-- Precondition for (saturateFamApp ty kind):+--     tcTypeKind ty = kind+--+-- If 'ty' is an unsaturated family application with trailing+-- invisible arguments, instantiate them.+-- See Note [saturateFamApp]++saturateFamApp ty kind+  | Just (tc, args) <- tcSplitTyConApp_maybe ty+  , mustBeSaturated tc+  , let n_to_inst = tyConArity tc - length args+  = do { (extra_args, ki') <- tcInstInvisibleTyBindersN n_to_inst kind+       ; return (ty `mkTcAppTys` extra_args, ki') }+  | otherwise+  = return (ty, kind)++{- Note [saturateFamApp]+~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   type family F :: Either j k+   type instance F @Type = Right Maybe+   type instance F @Type = Right Either```++Then F :: forall {j,k}. Either j k++The two type instances do a visible kind application that instantiates+'j' but not 'k'.  But we want to end up with instances that look like+  type instance F @Type @(*->*) = Right @Type @(*->*) Maybe++so that F has arity 2.  We must instantiate that trailing invisible+binder. In general, Invisible binders precede Specified and Required,+so this is only going to bite for apparently-nullary families.++Note that+  type family F2 :: forall k. k -> *+is quite different and really does have arity 0.++It's not just type instances where we need to saturate those+unsaturated arguments: see #11246.  Hence doing this in tcInferApps.+-}++appTypeToArg :: LHsType GhcRn -> [LHsTypeArg GhcRn] -> LHsType GhcRn+appTypeToArg f []                       = f+appTypeToArg f (HsValArg arg    : args) = appTypeToArg (mkHsAppTy f arg) args+appTypeToArg f (HsArgPar _      : args) = appTypeToArg f                 args+appTypeToArg f (HsTypeArg l arg : args)+  = appTypeToArg (mkHsAppKindTy l f arg) args+++{- *********************************************************************+*                                                                      *+                checkExpectedKind+*                                                                      *+********************************************************************* -}++-- | This instantiates invisible arguments for the type being checked if it must+-- be saturated and is not yet saturated. It then calls and uses the result+-- from checkExpectedKindX to build the final type+checkExpectedKind :: HasDebugCallStack+                  => HsType GhcRn       -- ^ type we're checking (for printing)+                  -> TcType             -- ^ type we're checking+                  -> TcKind             -- ^ the known kind of that type+                  -> TcKind             -- ^ the expected kind+                  -> TcM TcType+-- Just a convenience wrapper to save calls to 'ppr'+checkExpectedKind hs_ty ty act_kind exp_kind+  = do { traceTc "checkExpectedKind" (ppr ty $$ ppr act_kind)++       ; (new_args, act_kind') <- tcInstInvisibleTyBindersN n_to_inst act_kind++       ; let origin = TypeEqOrigin { uo_actual   = act_kind'+                                   , uo_expected = exp_kind+                                   , uo_thing    = Just (HsTypeRnThing hs_ty)+                                   , uo_visible  = True } -- the hs_ty is visible++       ; traceTc "checkExpectedKindX" $+         vcat [ ppr hs_ty+              , text "act_kind':" <+> ppr act_kind'+              , text "exp_kind:" <+> ppr exp_kind ]++       ; let res_ty = ty `mkTcAppTys` new_args++       ; if act_kind' `tcEqType` exp_kind+         then return res_ty  -- This is very common+         else do { co_k <- uType KindLevel origin act_kind' exp_kind+                 ; traceTc "checkExpectedKind" (vcat [ ppr act_kind+                                                     , ppr exp_kind+                                                     , ppr co_k ])+                ; return (res_ty `mkTcCastTy` co_k) } }+    where+      -- We need to make sure that both kinds have the same number of implicit+      -- foralls out front. If the actual kind has more, instantiate accordingly.+      -- Otherwise, just pass the type & kind through: the errors are caught+      -- in unifyType.+      n_exp_invis_bndrs = invisibleTyBndrCount exp_kind+      n_act_invis_bndrs = invisibleTyBndrCount act_kind+      n_to_inst         = n_act_invis_bndrs - n_exp_invis_bndrs++---------------------------++tcHsContext :: Maybe (LHsContext GhcRn) -> TcM [PredType]+tcHsContext Nothing    = return []+tcHsContext (Just cxt) = tc_hs_context typeLevelMode cxt++tcLHsPredType :: LHsType GhcRn -> TcM PredType+tcLHsPredType pred = tc_lhs_pred typeLevelMode pred++tc_hs_context :: TcTyMode -> LHsContext GhcRn -> TcM [PredType]+tc_hs_context mode ctxt = mapM (tc_lhs_pred mode) (unLoc ctxt)++tc_lhs_pred :: TcTyMode -> LHsType GhcRn -> TcM PredType+tc_lhs_pred mode pred = tc_lhs_type mode pred constraintKind++---------------------------+tcTyVar :: Name -> TcM (TcType, TcKind)+-- See Note [Type checking recursive type and class declarations]+-- in GHC.Tc.TyCl+-- This does not instantiate. See Note [Do not always instantiate eagerly in types]+tcTyVar name         -- Could be a tyvar, a tycon, or a datacon+  = do { traceTc "lk1" (ppr name)+       ; thing <- tcLookup name+       ; case thing of+           ATyVar _ tv -> return (mkTyVarTy tv, tyVarKind tv)++           -- See Note [Recursion through the kinds]+           (tcTyThingTyCon_maybe -> Just tc) -- TyCon or TcTyCon+             -> return (mkTyConTy tc, tyConKind tc)++           AGlobal (AConLike (RealDataCon dc))+             -> do { data_kinds <- xoptM LangExt.DataKinds+                   ; unless (data_kinds || specialPromotedDc dc) $+                       promotionErr name NoDataKindsDC+                   ; when (isFamInstTyCon (dataConTyCon dc)) $+                       -- see #15245+                       promotionErr name FamDataConPE+                   ; let (_, _, _, theta, _, _) = dataConFullSig dc+                   ; traceTc "tcTyVar" (ppr dc <+> ppr theta $$ ppr (dc_theta_illegal_constraint theta))+                   ; case dc_theta_illegal_constraint theta of+                       Just pred -> promotionErr name $+                                    ConstrainedDataConPE pred+                       Nothing   -> pure ()+                   ; let tc = promoteDataCon dc+                   ; return (mkTyConApp tc [], tyConKind tc) }++           APromotionErr err -> promotionErr name err++           _  -> wrongThingErr "type" thing name }+  where+    -- We cannot promote a data constructor with a context that contains+    -- constraints other than equalities, so error if we find one.+    -- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep+    dc_theta_illegal_constraint :: ThetaType -> Maybe PredType+    dc_theta_illegal_constraint = find (not . isEqPred)++{-+Note [Recursion through the kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider these examples++Ticket #11554:+  data P (x :: k) = Q+  data A :: Type where+    MkA :: forall (a :: A). P a -> A++Ticket #12174+  data V a+  data T = forall (a :: T). MkT (V a)++The type is recursive (which is fine) but it is recursive /through the+kinds/.  In earlier versions of GHC this caused a loop in the compiler+(to do with knot-tying) but there is nothing fundamentally wrong with+the code (kinds are types, and the recursive declarations are OK). But+it's hard to distinguish "recursion through the kinds" from "recursion+through the types". Consider this (also #11554):++  data PB k (x :: k) = Q+  data B :: Type where+    MkB :: P B a -> B++Here the occurrence of B is not obviously in a kind position.++So now GHC allows all these programs.  #12081 and #15942 are other+examples.++Note [Body kind of a HsForAllTy]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The body of a forall is usually a type, but in principle+there's no reason to prohibit *unlifted* types.+In fact, GHC can itself construct a function with an+unboxed tuple inside a for-all (via CPR analysis; see+typecheck/should_compile/tc170).++Moreover in instance heads we get forall-types with+kind Constraint.++It's tempting to check that the body kind is either * or #. But this is+wrong. For example:++  class C a b+  newtype N = Mk Foo deriving (C a)++We're doing newtype-deriving for C. But notice how `a` isn't in scope in+the predicate `C a`. So we quantify, yielding `forall a. C a` even though+`C a` has kind `* -> Constraint`. The `forall a. C a` is a bit cheeky, but+convenient. Bottom line: don't check for * or # here.++Note [Body kind of a HsQualTy]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If ctxt is non-empty, the HsQualTy really is a /function/, so the+kind of the result really is '*', and in that case the kind of the+body-type can be lifted or unlifted.++However, consider+    instance Eq a => Eq [a] where ...+or+    f :: (Eq a => Eq [a]) => blah+Here both body-kind of the HsQualTy is Constraint rather than *.+Rather crudely we tell the difference by looking at exp_kind. It's+very convenient to typecheck instance types like any other HsSigType.++Admittedly the '(Eq a => Eq [a]) => blah' case is erroneous, but it's+better to reject in checkValidType.  If we say that the body kind+should be '*' we risk getting TWO error messages, one saying that Eq+[a] doesn't have kind '*', and one saying that we need a Constraint to+the left of the outer (=>).++How do we figure out the right body kind?  Well, it's a bit of a+kludge: I just look at the expected kind.  If it's Constraint, we+must be in this instance situation context. It's a kludge because it+wouldn't work if any unification was involved to compute that result+kind -- but it isn't.  (The true way might be to use the 'mode'+parameter, but that seemed like a sledgehammer to crack a nut.)++Note [Inferring tuple kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Give a tuple type (a,b,c), which the parser labels as HsBoxedOrConstraintTuple,+we try to figure out whether it's a tuple of kind * or Constraint.+  Step 1: look at the expected kind+  Step 2: infer argument kinds++If after Step 2 it's not clear from the arguments that it's+Constraint, then it must be *.  Once having decided that we re-check+the arguments to give good error messages in+  e.g.  (Maybe, Maybe)++Note that we will still fail to infer the correct kind in this case:++  type T a = ((a,a), D a)+  type family D :: Constraint -> Constraint++While kind checking T, we do not yet know the kind of D, so we will default the+kind of T to * -> *. It works if we annotate `a` with kind `Constraint`.++Note [Desugaring types]+~~~~~~~~~~~~~~~~~~~~~~~+The type desugarer is phase 2 of dealing with HsTypes.  Specifically:++  * It transforms from HsType to Type++  * It zonks any kinds.  The returned type should have no mutable kind+    or type variables (hence returning Type not TcType):+      - any unconstrained kind variables are defaulted to (Any *) just+        as in GHC.Tc.Utils.Zonk.+      - there are no mutable type variables because we are+        kind-checking a type+    Reason: the returned type may be put in a TyCon or DataCon where+    it will never subsequently be zonked.++You might worry about nested scopes:+        ..a:kappa in scope..+            let f :: forall b. T '[a,b] -> Int+In this case, f's type could have a mutable kind variable kappa in it;+and we might then default it to (Any *) when dealing with f's type+signature.  But we don't expect this to happen because we can't get a+lexically scoped type variable with a mutable kind variable in it.  A+delicate point, this.  If it becomes an issue we might need to+distinguish top-level from nested uses.++Moreover+  * it cannot fail,+  * it does no unifications+  * it does no validity checking, except for structural matters, such as+        (a) spurious ! annotations.+        (b) a class used as a type++Note [Kind of a type splice]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider these terms, each with TH type splice inside:+     [| e1 :: Maybe $(..blah..) |]+     [| e2 :: $(..blah..) |]+When kind-checking the type signature, we'll kind-check the splice+$(..blah..); we want to give it a kind that can fit in any context,+as if $(..blah..) :: forall k. k.++In the e1 example, the context of the splice fixes kappa to *.  But+in the e2 example, we'll desugar the type, zonking the kind unification+variables as we go.  When we encounter the unconstrained kappa, we+want to default it to '*', not to (Any *).++-}++addTypeCtxt :: LHsType GhcRn -> TcM a -> TcM a+        -- Wrap a context around only if we want to show that contexts.+        -- Omit invisible ones and ones user's won't grok+addTypeCtxt (L _ (HsWildCardTy _)) thing = thing   -- "In the type '_'" just isn't helpful.+addTypeCtxt (L _ ty) thing+  = addErrCtxt doc thing+  where+    doc = text "In the type" <+> quotes (ppr ty)+++{- *********************************************************************+*                                                                      *+                Type-variable binders+*                                                                      *+********************************************************************* -}++bindNamedWildCardBinders :: [Name]+                         -> ([(Name, TcTyVar)] -> TcM a)+                         -> TcM a+-- Bring into scope the /named/ wildcard binders.  Remember that+-- plain wildcards _ are anonymous and dealt with by HsWildCardTy+-- Soe Note [The wildcard story for types] in GHC.Hs.Type+bindNamedWildCardBinders wc_names thing_inside+  = do { wcs <- mapM newNamedWildTyVar wc_names+       ; let wc_prs = wc_names `zip` wcs+       ; tcExtendNameTyVarEnv wc_prs $+         thing_inside wc_prs }++newNamedWildTyVar :: Name -> TcM TcTyVar+-- ^ New unification variable '_' for a wildcard+newNamedWildTyVar _name   -- Currently ignoring the "_x" wildcard name used in the type+  = do { kind <- newMetaKindVar+       ; details <- newMetaDetails TauTv+       ; wc_name <- newMetaTyVarName (fsLit "w")   -- See Note [Wildcard names]+       ; let tyvar = mkTcTyVar wc_name kind details+       ; traceTc "newWildTyVar" (ppr tyvar)+       ; return tyvar }++---------------------------+tcAnonWildCardOcc :: IsExtraConstraint+                  -> TcTyMode -> HsType GhcRn -> Kind -> TcM TcType+tcAnonWildCardOcc is_extra (TcTyMode { mode_holes = Just (hole_lvl, hole_mode) })+                  ty exp_kind+    -- hole_lvl: see Note [Checking partial type signatures]+    --           esp the bullet on nested forall types+  = do { kv_details <- newTauTvDetailsAtLevel hole_lvl+       ; kv_name    <- newMetaTyVarName (fsLit "k")+       ; wc_details <- newTauTvDetailsAtLevel hole_lvl+       ; wc_name    <- newMetaTyVarName (fsLit wc_nm)+       ; let kv      = mkTcTyVar kv_name liftedTypeKind kv_details+             wc_kind = mkTyVarTy kv+             wc_tv   = mkTcTyVar wc_name wc_kind wc_details++       ; traceTc "tcAnonWildCardOcc" (ppr hole_lvl <+> ppr emit_holes)+       ; when emit_holes $+         emitAnonTypeHole is_extra wc_tv+         -- Why the 'when' guard?+         -- See Note [Wildcards in visible kind application]++       -- You might think that this would always just unify+       -- wc_kind with exp_kind, so we could avoid even creating kv+       -- But the level numbers might not allow that unification,+       -- so we have to do it properly (T14140a)+       ; checkExpectedKind ty (mkTyVarTy wc_tv) wc_kind exp_kind }+  where+     -- See Note [Wildcard names]+     wc_nm = case hole_mode of+               HM_Sig      -> "w"+               HM_FamPat   -> "_"+               HM_VTA      -> "w"+               HM_TyAppPat -> "_"++     emit_holes = case hole_mode of+                     HM_Sig     -> True+                     HM_FamPat  -> False+                     HM_VTA     -> False+                     HM_TyAppPat -> False++tcAnonWildCardOcc is_extra _ _ _+-- mode_holes is Nothing. This means we have an anonymous wildcard+-- in an unexpected place. The renamer rejects these wildcards in 'checkAnonWildcard',+-- but it is possible for a wildcard to be introduced by a Template Haskell splice,+-- as per #15433. To account for this, we throw a generic catch-all error message.+  = failWith $ TcRnIllegalWildcardInType Nothing reason Nothing+    where+      reason =+        case is_extra of+          YesExtraConstraint ->+            ExtraConstraintWildcardNotAllowed+              SoleExtraConstraintWildcardNotAllowed+          NoExtraConstraint  ->+            WildcardsNotAllowedAtAll++{- Note [Wildcard names]+~~~~~~~~~~~~~~~~~~~~~~~~+So we hackily use the mode_holes flag to control the name used+for wildcards:++* For proper holes (whether in a visible type application (VTA) or no),+  we rename the '_' to 'w'. This is so that we see variables like 'w0'+  or 'w1' in error messages, a vast improvement upon '_0' and '_1'. For+  example, we prefer+       Found type wildcard ‘_’ standing for ‘w0’+  over+       Found type wildcard ‘_’ standing for ‘_1’++  Even in the VTA case, where we do not emit an error to be printed, we+  want to do the renaming, as the variables may appear in other,+  non-wildcard error messages.++* However, holes in the left-hand sides of type families ("type+  patterns") stand for type variables which we do not care to name --+  much like the use of an underscore in an ordinary term-level+  pattern. When we spot these, we neither wish to generate an error+  message nor to rename the variable.  We don't rename the variable so+  that we can pretty-print a type family LHS as, e.g.,+    F _ Int _ = ...+  and not+     F w1 Int w2 = ...++  See also Note [Wildcards in family instances] in+  GHC.Rename.Module. The choice of HM_FamPat is made in+  tcFamTyPats. There is also some unsavory magic, relying on that+  underscore, in GHC.Core.Coercion.tidyCoAxBndrsForUser.++Note [Wildcards in visible kind application]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are cases where users might want to pass in a wildcard as a visible kind+argument, for instance:++data T :: forall k1 k2. k1 → k2 → Type where+  MkT :: T a b+x :: T @_ @Nat False n+x = MkT++So we should allow '@_' without emitting any hole constraints, and+regardless of whether PartialTypeSignatures is enabled or not. But how+would the typechecker know which '_' is being used in VKA and which is+not when it calls emitNamedTypeHole in+tcHsPartialSigType on all HsWildCardBndrs?  The solution is to neither+rename nor include unnamed wildcards in HsWildCardBndrs, but instead+give every anonymous wildcard a fresh wild tyvar in tcAnonWildCardOcc.++And whenever we see a '@', we set mode_holes to HM_VKA, so that+we do not call emitAnonTypeHole in tcAnonWildCardOcc.+See related Note [Wildcards in visible type application] here and+Note [The wildcard story for types] in GHC.Hs.Type+-}++{- *********************************************************************+*                                                                      *+             Kind inference for type declarations+*                                                                      *+********************************************************************* -}++-- See Note [kcCheckDeclHeader vs kcInferDeclHeader]+data InitialKindStrategy+  = InitialKindCheck SAKS_or_CUSK+  | InitialKindInfer++-- Does the declaration have a standalone kind signature (SAKS) or a complete+-- user-specified kind (CUSK)?+data SAKS_or_CUSK+  = SAKS Kind  -- Standalone kind signature, fully zonked! (zonkTcTypeToType)+  | CUSK       -- Complete user-specified kind (CUSK)++instance Outputable SAKS_or_CUSK where+  ppr (SAKS k) = text "SAKS" <+> ppr k+  ppr CUSK = text "CUSK"++-- See Note [kcCheckDeclHeader vs kcInferDeclHeader]+kcDeclHeader+  :: InitialKindStrategy+  -> Name              -- ^ of the thing being checked+  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked+  -> LHsQTyVars GhcRn  -- ^ Binders in the header+  -> TcM ContextKind   -- ^ The result kind+  -> TcM TcTyCon       -- ^ A suitably-kinded TcTyCon+kcDeclHeader (InitialKindCheck msig) = kcCheckDeclHeader msig+kcDeclHeader InitialKindInfer = kcInferDeclHeader++{- Note [kcCheckDeclHeader vs kcInferDeclHeader]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+kcCheckDeclHeader and kcInferDeclHeader are responsible for getting the initial kind+of a type constructor.++* kcCheckDeclHeader: the TyCon has a standalone kind signature or a CUSK. In that+  case, find the full, final, poly-kinded kind of the TyCon.  It's very like a+  term-level binding where we have a complete type signature for the function.++* kcInferDeclHeader: the TyCon has neither a standalone kind signature nor a+  CUSK. Find a monomorphic kind, with unification variables in it; they will be+  generalised later.  It's very like a term-level binding where we do not have a+  type signature (or, more accurately, where we have a partial type signature),+  so we infer the type and generalise.+-}++------------------------------+kcCheckDeclHeader+  :: SAKS_or_CUSK+  -> Name              -- ^ of the thing being checked+  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked+  -> LHsQTyVars GhcRn  -- ^ Binders in the header+  -> TcM ContextKind   -- ^ The result kind. AnyKind == no result signature+  -> TcM PolyTcTyCon   -- ^ A suitably-kinded generalized TcTyCon+kcCheckDeclHeader (SAKS sig) = kcCheckDeclHeader_sig sig+kcCheckDeclHeader CUSK       = kcCheckDeclHeader_cusk++kcCheckDeclHeader_cusk+  :: Name              -- ^ of the thing being checked+  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked+  -> LHsQTyVars GhcRn  -- ^ Binders in the header+  -> TcM ContextKind   -- ^ The result kind+  -> TcM PolyTcTyCon   -- ^ A suitably-kinded generalized TcTyCon+kcCheckDeclHeader_cusk name flav+              (HsQTvs { hsq_ext = kv_ns+                      , hsq_explicit = hs_tvs }) kc_res_ki+  -- CUSK case+  -- See Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl+  = addTyConFlavCtxt name flav $+    do { skol_info <- mkSkolemInfo skol_info_anon+       ; (tclvl, wanted, (scoped_kvs, (tc_tvs, res_kind)))+           <- pushLevelAndSolveEqualitiesX "kcCheckDeclHeader_cusk" $+              bindImplicitTKBndrs_Q_Skol skol_info kv_ns                      $+              bindExplicitTKBndrs_Q_Skol skol_info ctxt_kind hs_tvs           $+              newExpectedKind =<< kc_res_ki++           -- Now, because we're in a CUSK,+           -- we quantify over the mentioned kind vars+       ; let spec_req_tkvs = scoped_kvs ++ tc_tvs+             all_kinds     = res_kind : map tyVarKind spec_req_tkvs++       ; candidates <- candidateQTyVarsOfKinds all_kinds+             -- 'candidates' are all the variables that we are going to+             -- skolemise and then quantify over.  We do not include spec_req_tvs+             -- because they are /already/ skolems++       ; inferred <- quantifyTyVars skol_info DefaultNonStandardTyVars $+                     candidates `delCandidates` spec_req_tkvs+                     -- NB: 'inferred' comes back sorted in dependency order++       ; scoped_kvs <- mapM zonkTyCoVarKind scoped_kvs  -- scoped_kvs and tc_tvs are skolems,+       ; tc_tvs     <- mapM zonkTyCoVarKind tc_tvs      -- so zonkTyCoVarKind suffices+       ; res_kind   <- zonkTcType           res_kind++       ; let mentioned_kv_set = candidateKindVars candidates+             specified        = scopedSort scoped_kvs+                                -- NB: maintain the L-R order of scoped_kvs++             all_tcbs =  mkNamedTyConBinders Inferred  inferred+                      ++ mkNamedTyConBinders Specified specified+                      ++ map (mkRequiredTyConBinder mentioned_kv_set) tc_tvs++       -- Eta expand if necessary; we are building a PolyTyCon+       ; (eta_tcbs, res_kind) <- etaExpandAlgTyCon flav skol_info all_tcbs res_kind++       ; let all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs)+             final_tcbs = all_tcbs `chkAppend` eta_tcbs+             tycon = mkTcTyCon name final_tcbs res_kind all_tv_prs+                               True -- it is generalised+                               flav++       ; reportUnsolvedEqualities skol_info (binderVars final_tcbs)+                                  tclvl wanted++         -- If the ordering from+         -- Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl+         -- doesn't work, we catch it here, before an error cascade+       ; checkTyConTelescope tycon++       ; traceTc "kcCheckDeclHeader_cusk " $+         vcat [ text "name" <+> ppr name+              , text "candidates" <+> ppr candidates+              , text "mentioned_kv_set" <+> ppr mentioned_kv_set+              , text "kv_ns" <+> ppr kv_ns+              , text "hs_tvs" <+> ppr hs_tvs+              , text "scoped_kvs" <+> ppr scoped_kvs+              , text "spec_req_tvs" <+> pprTyVars spec_req_tkvs+              , text "all_kinds" <+> ppr all_kinds+              , text "tc_tvs" <+> pprTyVars tc_tvs+              , text "res_kind" <+> ppr res_kind+              , text "inferred" <+> ppr inferred+              , text "specified" <+> ppr specified+              , text "final_tcbs" <+> ppr final_tcbs+              , text "mkTyConKind final_tc_bndrs res_kind"+                <+> ppr (mkTyConKind final_tcbs res_kind)+              , text "all_tv_prs" <+> ppr all_tv_prs ]++       ; return tycon }+  where+    skol_info_anon = TyConSkol flav name+    ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind+              | otherwise            = AnyKind++-- | Kind-check a 'LHsQTyVars'. Used in 'inferInitialKind' (for tycon kinds and+-- other kinds).+--+-- This function does not do telescope checking.+kcInferDeclHeader+  :: Name              -- ^ of the thing being checked+  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked+  -> LHsQTyVars GhcRn+  -> TcM ContextKind   -- ^ The result kind+  -> TcM MonoTcTyCon   -- ^ A suitably-kinded non-generalized TcTyCon+kcInferDeclHeader name flav+              (HsQTvs { hsq_ext = kv_ns+                      , hsq_explicit = hs_tvs }) kc_res_ki+  -- No standalane kind signature and no CUSK.+  -- See Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl+  = addTyConFlavCtxt name flav $+    do { (scoped_kvs, (tc_tvs, res_kind))+           -- Why bindImplicitTKBndrs_Q_Tv which uses newTyVarTyVar?+           -- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl+           <- bindImplicitTKBndrs_Q_Tv kv_ns            $+              bindExplicitTKBndrs_Q_Tv ctxt_kind hs_tvs $+              newExpectedKind =<< kc_res_ki+              -- Why "_Tv" not "_Skol"? See third wrinkle in+              -- Note [Inferring kinds for type declarations] in GHC.Tc.TyCl,++       ; let   -- NB: Don't add scoped_kvs to tyConTyVars, because they+               -- might unify with kind vars in other types in a mutually+               -- recursive group.+               -- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl++             tc_binders = mkAnonTyConBinders VisArg tc_tvs+               -- Also, note that tc_binders has the tyvars from only the+               -- user-written tyvarbinders. See S1 in Note [How TcTyCons work]+               -- in GHC.Tc.TyCl+               --+               -- mkAnonTyConBinder: see Note [No polymorphic recursion]++             all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs)+               -- NB: bindExplicitTKBndrs_Q_Tv does not clone;+               --     ditto Implicit+               -- See Note [Cloning for type variable binders]++             tycon = mkTcTyCon name tc_binders res_kind all_tv_prs+                               False -- not yet generalised+                               flav++       ; traceTc "kcInferDeclHeader: not-cusk" $+         vcat [ ppr name, ppr kv_ns, ppr hs_tvs+              , ppr scoped_kvs+              , ppr tc_tvs, ppr (mkTyConKind tc_binders res_kind) ]+       ; return tycon }+  where+    ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind+              | otherwise            = AnyKind++-- | Kind-check a declaration header against a standalone kind signature.+-- See Note [kcCheckDeclHeader_sig]+kcCheckDeclHeader_sig+  :: Kind              -- ^ Standalone kind signature, fully zonked! (zonkTcTypeToType)+  -> Name              -- ^ of the thing being checked+  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked+  -> LHsQTyVars GhcRn  -- ^ Binders in the header+  -> TcM ContextKind   -- ^ The result kind. AnyKind == no result signature+  -> TcM PolyTcTyCon   -- ^ A suitably-kinded, fully generalised TcTyCon+-- Postcondition to (kcCheckDeclHeader_sig sig_kind n f hs_tvs kc_res_ki):+--   kind(returned PolyTcTyCon) = sig_kind+--+kcCheckDeclHeader_sig sig_kind name flav+          (HsQTvs { hsq_ext      = implicit_nms+                  , hsq_explicit = hs_tv_bndrs }) kc_res_ki+  = addTyConFlavCtxt name flav $+    do { skol_info <- mkSkolemInfo (TyConSkol flav name)+       ; (sig_tcbs :: [TcTyConBinder], sig_res_kind :: Kind)+             <- splitTyConKind skol_info emptyInScopeSet+                               (map getOccName hs_tv_bndrs) sig_kind++       ; traceTc "kcCheckDeclHeader_sig {" $+           vcat [ text "sig_kind:" <+> ppr sig_kind+                , text "sig_tcbs:" <+> ppr sig_tcbs+                , text "sig_res_kind:" <+> ppr sig_res_kind ]++       ; (tclvl, wanted, (implicit_tvs, (skol_tcbs, (extra_tcbs, tycon_res_kind))))+           <- pushLevelAndSolveEqualitiesX "kcCheckDeclHeader_sig" $  -- #16687+              bindImplicitTKBndrs_Q_Tv implicit_nms                $  -- Q means don't clone+              matchUpSigWithDecl sig_tcbs sig_res_kind hs_tv_bndrs $ \ excess_sig_tcbs sig_res_kind ->+              do { -- Kind-check the result kind annotation, if present:+                   --    data T a b :: res_ki where ...+                   --               ^^^^^^^^^+                   -- We do it here because at this point the environment has been+                   -- extended with both 'implicit_tcv_prs' and 'explicit_tv_prs'.+                 ; ctx_k <- kc_res_ki++                 -- Work out extra_arity, the number of extra invisible binders from+                 -- the kind signature that should be part of the TyCon's arity.+                 -- See Note [Arity inference in kcCheckDeclHeader_sig]+                 ; let n_invis_tcbs = countWhile isInvisibleTyConBinder excess_sig_tcbs+                       invis_arity = case ctx_k of+                          AnyKind    -> n_invis_tcbs -- No kind signature, so make all the invisible binders+                                                     -- the signature into part of the arity of the TyCon+                          OpenKind   -> n_invis_tcbs -- Result kind is (TYPE rr), so again make all the+                                                     -- invisible binders part of the arity of the TyCon+                          TheKind ki -> 0 `max` (n_invis_tcbs - invisibleTyBndrCount ki)++                 ; let (invis_tcbs, resid_tcbs) = splitAt invis_arity excess_sig_tcbs+                 ; let sig_res_kind' = mkTyConKind resid_tcbs sig_res_kind++                 ; traceTc "kcCheckDeclHeader_sig 2" $ vcat [ ppr excess_sig_tcbs+                                                            , ppr invis_arity, ppr invis_tcbs+                                                            , ppr n_invis_tcbs ]++                 -- Unify res_ki (from the type declaration) with the residual kind from+                 -- the kind signature. Don't forget to apply the skolemising 'subst' first.+                 ; case ctx_k of+                      AnyKind -> return ()   -- No signature+                      _ -> do { res_ki <- newExpectedKind ctx_k+                              ; discardResult (unifyKind Nothing sig_res_kind' res_ki) }++                 -- Add more binders for data/newtype, so the result kind has no arrows+                 -- See Note [Datatype return kinds]+                 ; if null resid_tcbs || not (needsEtaExpansion flav)+                   then return (invis_tcbs,      sig_res_kind')+                   else return (excess_sig_tcbs, sig_res_kind)+          }+++        -- Check that there are no unsolved equalities+        ; let all_tcbs = skol_tcbs ++ extra_tcbs+        ; reportUnsolvedEqualities skol_info (binderVars all_tcbs) tclvl wanted++        -- Check that distinct binders map to distinct tyvars (see #20916). For example+        --    type T :: k -> k -> Type+        --    data T (a::p) (b::q) = ...+        -- Here p and q both map to the same kind variable k.  We don't allow this+        -- so we must check that they are distinct.  A similar thing happens+        -- in GHC.Tc.TyCl.swizzleTcTyConBinders during inference.+        ; implicit_tvs <- zonkTcTyVarsToTcTyVars implicit_tvs+        ; let implicit_prs = implicit_nms `zip` implicit_tvs+        ; checkForDuplicateScopedTyVars implicit_prs++        -- Swizzle the Names so that the TyCon uses the user-declared implicit names+        -- E.g  type T :: k -> Type+        --      data T (a :: j) = ....+        -- We want the TyConBinders of T to be [j, a::j], not [k, a::k]+        -- Why? So that the TyConBinders of the TyCon will lexically scope over the+        -- associated types and methods of a class.+        ; let swizzle_env = mkVarEnv (map swap implicit_prs)+              (subst, swizzled_tcbs) = mapAccumL (swizzleTcb swizzle_env) emptyTCvSubst all_tcbs+              swizzled_kind          = substTy subst tycon_res_kind+              all_tv_prs             = mkTyVarNamePairs (binderVars swizzled_tcbs)++        ; traceTc "kcCheckDeclHeader swizzle" $ vcat+          [ text "implicit_prs = "  <+> ppr implicit_prs+          , text "implicit_nms = "  <+> ppr implicit_nms+          , text "hs_tv_bndrs = "  <+> ppr hs_tv_bndrs+          , text "all_tcbs = "      <+> pprTyVars (binderVars all_tcbs)+          , text "swizzled_tcbs = " <+> pprTyVars (binderVars swizzled_tcbs)+          , text "tycon_res_kind =" <+> ppr tycon_res_kind+          , text "swizzled_kind ="  <+> ppr swizzled_kind ]++        -- Build the final, generalized PolyTcTyCon+        -- NB: all_tcbs must bind the tyvars in the range of all_tv_prs+        --     because the tv_prs is used when (say) typechecking the RHS of+        --     a type synonym.+        ; let tc = mkTcTyCon name swizzled_tcbs swizzled_kind all_tv_prs True flav++        ; traceTc "kcCheckDeclHeader_sig }" $ vcat+          [ text "tyConName = " <+> ppr (tyConName tc)+          , text "sig_kind =" <+> debugPprType sig_kind+          , text "tyConKind =" <+> debugPprType (tyConKind tc)+          , text "tyConBinders = " <+> ppr (tyConBinders tc)+          , text "tyConResKind" <+> debugPprType (tyConResKind tc)+          ]+        ; return tc }++matchUpSigWithDecl+  :: [TcTyConBinder]             -- TcTyConBinders (with skolem TcTyVars) from the separate kind signature+  -> TcKind                      -- The tail end of the kind signature+  -> [LHsTyVarBndr () GhcRn]     -- User-written binders in decl+  -> ([TcTyConBinder] -> TcKind -> TcM a)  -- All user-written binders are in scope+                                           --   Argument is excess TyConBinders and tail kind+  -> TcM ( [TcTyConBinder]       -- Skolemised binders, with TcTyVars+         , a )+-- See Note [Matching a kind sigature with a declaration]+-- Invariant: Length of returned TyConBinders + length of excess TyConBinders+--            = length of incoming TyConBinders+matchUpSigWithDecl sig_tcbs sig_res_kind hs_bndrs thing_inside+  = go emptyTCvSubst sig_tcbs hs_bndrs+  where+    go subst tcbs []+      = do { let (subst', tcbs') = substTyConBindersX subst tcbs+           ; res <- thing_inside tcbs' (substTy subst' sig_res_kind)+           ; return ([], res) }++    go _ [] hs_bndrs+      = failWithTc (tooManyBindersErr sig_res_kind hs_bndrs)++    go subst (tcb : tcbs') hs_bndrs+      | Bndr tv vis <- tcb+      , isVisibleTcbVis vis+      , (L _ hs_bndr : hs_bndrs') <- hs_bndrs  -- hs_bndrs is non-empty+      = -- Visible TyConBinder, so match up with the hs_bndrs+        do { let tv' = updateTyVarKind (substTy subst) $+                       setTyVarName tv (getName hs_bndr)+                   -- Give the skolem the Name of the HsTyVarBndr, so that if it+                   -- appears in an error message it has a name and binding site+                   -- that come from the type declaration, not the kind signature+                 subst' = extendTCvSubstWithClone subst tv tv'+           ; tc_hs_bndr hs_bndr (tyVarKind tv')+           ; (tcbs', res) <- tcExtendTyVarEnv [tv'] $+                             go subst' tcbs' hs_bndrs'+           ; return (Bndr tv' vis : tcbs', res) }++      | otherwise+      = -- Invisible TyConBinder, so do not consume one of the hs_bndrs+        do { let (subst', tcb') = substTyConBinderX subst tcb+           ; (tcbs', res) <- go subst' tcbs' hs_bndrs+                   -- NB: pass on hs_bndrs unchanged; we do not consume a+                   --     HsTyVarBndr for an invisible TyConBinder+           ; return (tcb' : tcbs', res) }++    tc_hs_bndr :: HsTyVarBndr () GhcRn -> TcKind -> TcM ()+    tc_hs_bndr (UserTyVar _ _ _) _+      = return ()+    tc_hs_bndr (KindedTyVar _ _ (L _ hs_nm) lhs_kind) expected_kind+      = do { sig_kind <- tcLHsKindSig (TyVarBndrKindCtxt hs_nm) lhs_kind+           ; discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig]+             unifyKind (Just (NameThing hs_nm)) sig_kind expected_kind }++substTyConBinderX :: TCvSubst -> TyConBinder -> (TCvSubst, TyConBinder)+substTyConBinderX subst (Bndr tv vis)+  = (subst', Bndr tv' vis)+  where+    (subst', tv') = substTyVarBndr subst tv++substTyConBindersX :: TCvSubst -> [TyConBinder] -> (TCvSubst, [TyConBinder])+substTyConBindersX = mapAccumL substTyConBinderX++swizzleTcb :: VarEnv Name -> TCvSubst -> TyConBinder -> (TCvSubst, TyConBinder)+swizzleTcb swizzle_env subst (Bndr tv vis)+  = (subst', Bndr tv2 vis)+  where+    subst' = extendTCvSubstWithClone subst tv tv2+    tv1 = updateTyVarKind (substTy subst) tv+    tv2 = case lookupVarEnv swizzle_env tv of+             Just user_name -> setTyVarName tv1 user_name+             Nothing        -> tv1+    -- NB: the SrcSpan on an implicitly-bound name deliberately spans+    -- the whole declaration. e.g.+    --    data T (a :: k) (b :: Type -> k) = ....+    -- There is no single binding site for 'k'.+    -- See Note [Source locations for implicitly bound type variables]+    -- in GHC.Tc.Rename.HsType++tooManyBindersErr :: Kind -> [LHsTyVarBndr () GhcRn] -> TcRnMessage+tooManyBindersErr ki bndrs = TcRnUnknownMessage $ mkPlainError noHints $+   hang (text "Not a function kind:")+      4 (ppr ki) $$+   hang (text "but extra binders found:")+      4 (fsep (map ppr bndrs))++{- See Note [kcCheckDeclHeader_sig]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Given a kind signature 'sig_kind' and a declaration header,+kcCheckDeclHeader_sig verifies that the declaration conforms to the+signature. The end result is a PolyTcTyCon 'tc' such that:+  tyConKind tc == sig_kind++Basic plan is this:+  * splitTyConKind: Take the Kind from the separate kind signature, and+    decompose it all the way to a [TyConBinder] and a Kind in the corner.++    NB: these TyConBinders contain TyVars, not TcTyVars.++  * matchUpSigWithDecl: match the [TyConBinder] from the signature with+    the [LHsTyVarBndr () GhcRn] from the declaration.  The latter are the+    explicit, user-written binders.  e.g.+        data T (a :: k) b = ....+    There may be more of the former than the latter, because the former+    include invisible binders.  matchUpSigWithDecl uses isVisibleTcbVis+    to decide which TyConBinders are visible.++  * matchUpSigWithDecl also skolemises the [TyConBinder] to produce+    a [TyConBinder], corresponding 1-1 with the consumed [TyConBinder].+    Each new TyConBinder+      - Uses the Name from the LHsTyVarBndr, if available, both because that's+        what the user expects, and because the binding site accurately comes+        from the data/type declaration.+      - Uses a skolem TcTyVar.  We need these to allow unification.++  * machUpSigWithDecl also unifies the user-supplied kind signature for each+    LHsTyVarBndr with the kind that comes from the TyConBinder (itself coming+    from the separate kind signature).++  * Finally, kcCheckDeclHeader_sig unifies the return kind of the separate+    signature with the kind signature (if any) in the data/type declaration.+    E.g.+           type S :: forall k. k -> k -> Type+           type family S (a :: j) :: j -> Type+    Here we match up the 'k ->' with (a :: j); and then must unify the leftover+    part of the signature (k -> Type) with the kind signature of the decl,+    (j -> Type).  This unification, done in kcCheckDeclHeader, needs TcTyVars.++  * The tricky extra_arity part is described in+    Note [Arity inference in kcCheckDeclHeader_sig]++Note [Arity inference in kcCheckDeclHeader_sig]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider these declarations:+  type family S1 :: forall k2. k1 -> k2 -> Type+  type family S2 (a :: k1) (b :: k2) :: Type++Both S1 and S2 can be given the same standalone kind signature:+  type S1 :: forall k1 k2. k1 -> k2 -> Type+  type S2 :: forall k1 k2. k1 -> k2 -> Type++And, indeed, tyConKind S1 == tyConKind S2. However,+tyConBinders and tyConResKind for S1 and S2 are different:++  tyConBinders S1  ==  [spec k1]+  tyConResKind S1  ==  forall k2. k1 -> k2 -> Type+  tyConKind    S1  ==  forall k1 k2. k1 -> k2 -> Type++  tyConBinders S2  ==  [spec k1, spec k2, anon-vis (a :: k1), anon-vis (b :: k2)]+  tyConResKind S2  ==  Type+  tyConKind    S1  ==  forall k1 k2. k1 -> k2 -> Type++This difference determines the /arity/:+  tyConArity tc == length (tyConBinders tc)+That is, the arity of S1 is 1, while the arity of S2 is 4.++'kcCheckDeclHeader_sig' needs to infer the desired arity, to split the+standalone kind signature into binders and the result kind. It does so+in two rounds:++1. matchUpSigWithDecl matches up+   - the [TyConBinder] from (applying splitTyConKind to) the kind signature+   - with the [LHsTyVarBndr] from the type declaration.+   That may leave some excess TyConBinder: in the case of S2 there are+   no excess TyConBinders, but in the case of S1 there are two (since+   there are no LHsTYVarBndrs.++2. Split off further TyConBinders (in the case of S1, one more) to+   make it possible to unify the residual return kind with the+   signature in the type declaration.  More precisely, split off such+   enough invisible that the remainder of the standalone kind+   signature and the user-written result kind signature have the same+   number of invisible quantifiers.++As another example consider the following declarations:++    type F :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type+    type family F a b++    type G :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type+    type family G a b :: forall r2. (r1, r2) -> Type++For both F and G, the signature (after splitTyConKind) has+  sig_tcbs :: [TyConBinder]+    = [ anon-vis (@a_aBq), spec (@j_auA), anon-vis (@(b_aBr :: j_auA))+      , spec (@k1_auB), spec (@k2_auC)+      , anon-vis (@(c_aBs :: (k1_auB, k2_auC)))]++matchUpSigWithDecl will consume the first three of these, passing on+  excess_sig_tcbs+    = [ spec (@k1_auB), spec (@k2_auC)+      , anon-vis (@(c_aBs :: (k1_auB, k2_auC)))]++For F, there is no result kind signature in the declaration for F, so+we absorb all invisible binders into F's arity. The resulting arity of+F is 3+2=5.++Now, in the case of G, we have a result kind sig 'forall r2. (r2,r2)->Type'.+This has one invisible binder, so we split of enough extra binders from+our excess_sig_tcbs to leave just one to match 'r2'.++    res_ki  =  forall    r2. (r1, r2) -> Type+    kisig   =  forall k1 k2. (k1, k2) -> Type+                     ^^^+                     split off this one.++The resulting arity of G is 3+1=4.++Note [discardResult in kcCheckDeclHeader_sig]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We use 'unifyKind' to check inline kind annotations in declaration headers+against the signature.++  type T :: [i] -> Maybe j -> Type+  data T (a :: [k1]) (b :: Maybe k2) :: Type where ...++Here, we will unify:++       [k1] ~ [i]+  Maybe k2  ~ Maybe j+      Type  ~ Type++The end result is that we fill in unification variables k1, k2:++    k1  :=  i+    k2  :=  j++We also validate that the user isn't confused:++  type T :: Type -> Type+  data T (a :: Bool) = ...++This will report that (Type ~ Bool) failed to unify.++Now, consider the following example:++  type family Id a where Id x = x+  type T :: Bool -> Type+  type T (a :: Id Bool) = ...++We will unify (Bool ~ Id Bool), and this will produce a non-reflexive coercion.+However, we are free to discard it, as the kind of 'T' is determined by the+signature, not by the inline kind annotation:++      we have   T ::    Bool -> Type+  rather than   T :: Id Bool -> Type++This (Id Bool) will not show up anywhere after we're done validating it, so we+have no use for the produced coercion.+-}++{- Note [No polymorphic recursion]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Should this kind-check?+  data T ka (a::ka) b  = MkT (T Type           Int   Bool)+                             (T (Type -> Type) Maybe Bool)++Notice that T is used at two different kinds in its RHS.  No!+This should not kind-check.  Polymorphic recursion is known to+be a tough nut.++Previously, we laboriously (with help from the renamer)+tried to give T the polymorphic kind+   T :: forall ka -> ka -> kappa -> Type+where kappa is a unification variable, even in the inferInitialKinds+phase (which is what kcInferDeclHeader is all about).  But+that is dangerously fragile (see the ticket).++Solution: make kcInferDeclHeader give T a straightforward+monomorphic kind, with no quantification whatsoever. That's why+we use mkAnonTyConBinder for all arguments when figuring out+tc_binders.++But notice that (#16322 comment:3)++* The algorithm successfully kind-checks this declaration:+    data T2 ka (a::ka) = MkT2 (T2 Type a)++  Starting with (inferInitialKinds)+    T2 :: (kappa1 :: kappa2 :: *) -> (kappa3 :: kappa4 :: *) -> *+  we get+    kappa4 := kappa1   -- from the (a:ka) kind signature+    kappa1 := Type     -- From application T2 Type++  These constraints are soluble so generaliseTcTyCon gives+    T2 :: forall (k::Type) -> k -> *++  But now the /typechecking/ (aka desugaring, tcTyClDecl) phase+  fails, because the call (T2 Type a) in the RHS is ill-kinded.++  We'd really prefer all errors to show up in the kind checking+  phase.++* This algorithm still accepts (in all phases)+     data T3 ka (a::ka) = forall b. MkT3 (T3 Type b)+  although T3 is really polymorphic-recursive too.+  Perhaps we should somehow reject that.++Note [Kind variable ordering for associated types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+What should be the kind of `T` in the following example? (#15591)++  class C (a :: Type) where+    type T (x :: f a)++As per Note [Ordering of implicit variables] in GHC.Rename.HsType, we want to quantify+the kind variables in left-to-right order of first occurrence in order to+support visible kind application. But we cannot perform this analysis on just+T alone, since its variable `a` actually occurs /before/ `f` if you consider+the fact that `a` was previously bound by the parent class `C`. That is to say,+the kind of `T` should end up being:++  T :: forall a f. f a -> Type++(It wouldn't necessarily be /wrong/ if the kind ended up being, say,+forall f a. f a -> Type, but that would not be as predictable for users of+visible kind application.)++In contrast, if `T` were redefined to be a top-level type family, like `T2`+below:++  type family T2 (x :: f (a :: Type))++Then `a` first appears /after/ `f`, so the kind of `T2` should be:++  T2 :: forall f a. f a -> Type++In order to make this distinction, we need to know (in kcCheckDeclHeader) which+type variables have been bound by the parent class (if there is one). With+the class-bound variables in hand, we can ensure that we always quantify+these first.+-}+++{- *********************************************************************+*                                                                      *+             Expected kinds+*                                                                      *+********************************************************************* -}++-- | Describes the kind expected in a certain context.+data ContextKind = TheKind TcKind   -- ^ a specific kind+                 | AnyKind        -- ^ any kind will do+                 | OpenKind       -- ^ something of the form @TYPE _@++-----------------------+newExpectedKind :: ContextKind -> TcM TcKind+newExpectedKind (TheKind k)   = return k+newExpectedKind AnyKind       = newMetaKindVar+newExpectedKind OpenKind      = newOpenTypeKind++-----------------------+expectedKindInCtxt :: UserTypeCtxt -> ContextKind+-- Depending on the context, we might accept any kind (for instance, in a TH+-- splice), or only certain kinds (like in type signatures).+expectedKindInCtxt (TySynCtxt _)   = AnyKind+expectedKindInCtxt (GhciCtxt {})   = AnyKind+-- The types in a 'default' decl can have varying kinds+-- See Note [Extended defaults]" in GHC.Tc.Utils.Env+expectedKindInCtxt DefaultDeclCtxt     = AnyKind+expectedKindInCtxt DerivClauseCtxt     = AnyKind+expectedKindInCtxt TypeAppCtxt         = AnyKind+expectedKindInCtxt (ForSigCtxt _)      = TheKind liftedTypeKind+expectedKindInCtxt (InstDeclCtxt {})   = TheKind constraintKind+expectedKindInCtxt SpecInstCtxt        = TheKind constraintKind+expectedKindInCtxt _                   = OpenKind+++{- *********************************************************************+*                                                                      *+          Scoped tyvars that map to the same thing+*                                                                      *+********************************************************************* -}++checkForDuplicateScopedTyVars :: [(Name,TcTyVar)] -> TcM ()+-- Check for duplicates+-- E.g. data SameKind (a::k) (b::k)+--      data T (a::k1) (b::k2) c = MkT (SameKind a b) c+-- Here k1 and k2 start as TyVarTvs, and get unified with each other+-- If this happens, things get very confused later, so fail fast+--+-- In the CUSK case k1 and k2 are skolems so they won't unify;+-- but in the inference case (see generaliseTcTyCon),+-- and the type-sig case (see kcCheckDeclHeader_sig), they are+-- TcTyVars, so we must check.+checkForDuplicateScopedTyVars scoped_prs+  = unless (null err_prs) $+    do { mapM_ report_dup err_prs; failM }+  where+    -------------- Error reporting ------------+    err_prs :: [(Name,Name)]+    err_prs = [ (n1,n2)+              | prs :: NonEmpty (Name,TyVar) <- findDupsEq ((==) `on` snd) scoped_prs+              , (n1,_) :| ((n2,_) : _) <- [NE.nubBy ((==) `on` fst) prs] ]+              -- This nubBy avoids bogus error reports when we have+              --    [("f", f), ..., ("f",f)....] in swizzle_prs+              -- which happens with  class C f where { type T f }++    report_dup :: (Name,Name) -> TcM ()+    report_dup (n1,n2)+      = setSrcSpan (getSrcSpan n2) $+        addErrTc $ TcRnUnknownMessage $ mkPlainError noHints $+        hang (text "Different names for the same type variable:") 2 info+      where+        info | nameOccName n1 /= nameOccName n2+             = quotes (ppr n1) <+> text "and" <+> quotes (ppr n2)+             | otherwise -- Same OccNames! See C2 in+                         -- Note [Swizzling the tyvars before generaliseTcTyCon]+             = vcat [ quotes (ppr n1) <+> text "bound at" <+> ppr (getSrcLoc n1)+                    , quotes (ppr n2) <+> text "bound at" <+> ppr (getSrcLoc n2) ]+++{- *********************************************************************+*                                                                      *+             Bringing type variables into scope+*                                                                      *+********************************************************************* -}++--------------------------------------+--    HsForAllTelescope+--------------------------------------++tcTKTelescope :: TcTyMode+              -> HsForAllTelescope GhcRn+              -> TcM a+              -> TcM ([TcTyVarBinder], a)+-- A HsForAllTelescope comes only from a HsForAllTy,+-- an explicit, user-written forall type+tcTKTelescope mode tele thing_inside = case tele of+  HsForAllVis { hsf_vis_bndrs = bndrs }+    -> do { skol_info <- mkSkolemInfo (ForAllSkol (HsTyVarBndrsRn (unLoc <$> bndrs)))+          ; let skol_mode = smVanilla { sm_clone = False, sm_holes = mode_holes mode+                                      , sm_tvtv = SMDSkolemTv skol_info }+          ; (req_tv_bndrs, thing) <- tcExplicitTKBndrsX skol_mode bndrs thing_inside+            -- req_tv_bndrs :: [VarBndr TyVar ()],+            -- but we want [VarBndr TyVar ArgFlag]+          ; return (tyVarReqToBinders req_tv_bndrs, thing) }++  HsForAllInvis { hsf_invis_bndrs = bndrs }+    -> do { skol_info <- mkSkolemInfo (ForAllSkol (HsTyVarBndrsRn (unLoc <$> bndrs)))+          ; let skol_mode = smVanilla { sm_clone = False, sm_holes = mode_holes mode+                                      , sm_tvtv = SMDSkolemTv skol_info }+          ; (inv_tv_bndrs, thing) <- tcExplicitTKBndrsX skol_mode bndrs thing_inside+            -- inv_tv_bndrs :: [VarBndr TyVar Specificity],+            -- but we want [VarBndr TyVar ArgFlag]+          ; return (tyVarSpecToBinders inv_tv_bndrs, thing) }++--------------------------------------+--    HsOuterTyVarBndrs+--------------------------------------++bindOuterTKBndrsX :: OutputableBndrFlag flag 'Renamed+                  => SkolemMode+                  -> HsOuterTyVarBndrs flag GhcRn+                  -> TcM a+                  -> TcM (HsOuterTyVarBndrs flag GhcTc, a)+bindOuterTKBndrsX skol_mode outer_bndrs thing_inside+  = case outer_bndrs of+      HsOuterImplicit{hso_ximplicit = imp_tvs} ->+        do { (imp_tvs', thing) <- bindImplicitTKBndrsX skol_mode imp_tvs thing_inside+           ; return ( HsOuterImplicit{hso_ximplicit = imp_tvs'}+                    , thing) }+      HsOuterExplicit{hso_bndrs = exp_bndrs} ->+        do { (exp_tvs', thing) <- bindExplicitTKBndrsX skol_mode exp_bndrs thing_inside+           ; return ( HsOuterExplicit { hso_xexplicit = exp_tvs'+                                      , hso_bndrs     = exp_bndrs }+                    , thing) }++---------------+outerTyVars :: HsOuterTyVarBndrs flag GhcTc -> [TcTyVar]+-- The returned [TcTyVar] is not necessarily in dependency order+-- at least for the HsOuterImplicit case+outerTyVars (HsOuterImplicit { hso_ximplicit = tvs })  = tvs+outerTyVars (HsOuterExplicit { hso_xexplicit = tvbs }) = binderVars tvbs++---------------+outerTyVarBndrs :: HsOuterTyVarBndrs Specificity GhcTc -> [InvisTVBinder]+outerTyVarBndrs (HsOuterImplicit{hso_ximplicit = imp_tvs}) = [Bndr tv SpecifiedSpec | tv <- imp_tvs]+outerTyVarBndrs (HsOuterExplicit{hso_xexplicit = exp_tvs}) = exp_tvs++---------------+scopedSortOuter :: HsOuterTyVarBndrs flag GhcTc -> TcM (HsOuterTyVarBndrs flag GhcTc)+-- Sort any /implicit/ binders into dependency order+--     (zonking first so we can see the dependencies)+-- /Explicit/ ones are already in the right order+scopedSortOuter (HsOuterImplicit{hso_ximplicit = imp_tvs})+  = do { imp_tvs <- zonkAndScopedSort imp_tvs+       ; return (HsOuterImplicit { hso_ximplicit = imp_tvs }) }+scopedSortOuter bndrs@(HsOuterExplicit{})+  = -- No need to dependency-sort (or zonk) explicit quantifiers+    return bndrs++---------------+bindOuterSigTKBndrs_Tv :: HsOuterSigTyVarBndrs GhcRn+                       -> TcM a -> TcM (HsOuterSigTyVarBndrs GhcTc, a)+bindOuterSigTKBndrs_Tv+  = bindOuterTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = SMDTyVarTv })++bindOuterSigTKBndrs_Tv_M :: TcTyMode+                         -> HsOuterSigTyVarBndrs GhcRn+                         -> TcM a -> TcM (HsOuterSigTyVarBndrs GhcTc, a)+-- Do not push level; do not make implication constraint; use Tvs+-- Two major clients of this "bind-only" path are:+--    Note [Using TyVarTvs for kind-checking GADTs] in GHC.Tc.TyCl+--    Note [Checking partial type signatures]+bindOuterSigTKBndrs_Tv_M mode+  = bindOuterTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = SMDTyVarTv+                                 , sm_holes = mode_holes mode })++bindOuterFamEqnTKBndrs_Q_Tv :: HsOuterFamEqnTyVarBndrs GhcRn+                            -> TcM a+                            -> TcM (HsOuterFamEqnTyVarBndrs GhcTc, a)+bindOuterFamEqnTKBndrs_Q_Tv hs_bndrs thing_inside+  = bindOuterTKBndrsX (smVanilla { sm_clone = False, sm_parent = True+                                 , sm_tvtv = SMDTyVarTv })+                      hs_bndrs thing_inside+    -- sm_clone=False: see Note [Cloning for type variable binders]++bindOuterFamEqnTKBndrs :: SkolemInfo+                       -> HsOuterFamEqnTyVarBndrs GhcRn+                       -> TcM a+                       -> TcM (HsOuterFamEqnTyVarBndrs GhcTc, a)+bindOuterFamEqnTKBndrs skol_info+  = bindOuterTKBndrsX (smVanilla { sm_clone = False, sm_parent = True+                                 , sm_tvtv = SMDSkolemTv skol_info })+    -- sm_clone=False: see Note [Cloning for type variable binders]++---------------+tcOuterTKBndrs :: OutputableBndrFlag flag 'Renamed+               => SkolemInfo+               -> HsOuterTyVarBndrs flag GhcRn+               -> TcM a -> TcM (HsOuterTyVarBndrs flag GhcTc, a)+tcOuterTKBndrs skol_info+  = tcOuterTKBndrsX (smVanilla { sm_clone = False+                               , sm_tvtv = SMDSkolemTv skol_info })+                    skol_info+  -- Do not clone the outer binders+  -- See Note [Cloning for type variable binders] under "must not"++tcOuterTKBndrsX :: OutputableBndrFlag flag 'Renamed+                => SkolemMode -> SkolemInfo+                -> HsOuterTyVarBndrs flag GhcRn+                -> TcM a -> TcM (HsOuterTyVarBndrs flag GhcTc, a)+-- Push level, capture constraints, make implication+tcOuterTKBndrsX skol_mode skol_info outer_bndrs thing_inside+  = case outer_bndrs of+      HsOuterImplicit{hso_ximplicit = imp_tvs} ->+        do { (imp_tvs', thing) <- tcImplicitTKBndrsX skol_mode skol_info imp_tvs thing_inside+           ; return ( HsOuterImplicit{hso_ximplicit = imp_tvs'}+                    , thing) }+      HsOuterExplicit{hso_bndrs = exp_bndrs} ->+        do { (exp_tvs', thing) <- tcExplicitTKBndrsX skol_mode exp_bndrs thing_inside+           ; return ( HsOuterExplicit { hso_xexplicit = exp_tvs'+                                      , hso_bndrs     = exp_bndrs }+                    , thing) }++--------------------------------------+--    Explicit tyvar binders+--------------------------------------++tcExplicitTKBndrs :: OutputableBndrFlag flag 'Renamed+                  => SkolemInfo+                  -> [LHsTyVarBndr flag GhcRn]+                  -> TcM a+                  -> TcM ([VarBndr TyVar flag], a)+tcExplicitTKBndrs skol_info+  = tcExplicitTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = SMDSkolemTv skol_info })++tcExplicitTKBndrsX :: OutputableBndrFlag flag 'Renamed+                   => SkolemMode+                   -> [LHsTyVarBndr flag GhcRn]+                   -> TcM a+                   -> TcM ([VarBndr TyVar flag], a)+-- Push level, capture constraints, and emit an implication constraint.+-- The implication constraint has a ForAllSkol ic_info,+--   so that it is subject to a telescope test.+tcExplicitTKBndrsX skol_mode bndrs thing_inside+  | null bndrs+  = do { res <- thing_inside+       ; return ([], res) }++  | otherwise+  = do { (tclvl, wanted, (skol_tvs, res))+             <- pushLevelAndCaptureConstraints $+                bindExplicitTKBndrsX skol_mode bndrs $+                thing_inside++       -- Set up SkolemInfo for telescope test+       ; let bndr_1 = head bndrs; bndr_n = last bndrs+       ; skol_info <- mkSkolemInfo (ForAllSkol (HsTyVarBndrsRn  (unLoc <$> bndrs)))+         -- Notice that we use ForAllSkol here, ignoring the enclosing+         -- skol_info unlike tcImplicitTKBndrs, because the bad-telescope+         -- test applies only to ForAllSkol++       ; setSrcSpan (combineSrcSpans (getLocA bndr_1) (getLocA bndr_n))+       $ emitResidualTvConstraint skol_info (binderVars skol_tvs) tclvl wanted++       ; return (skol_tvs, res) }++----------------+-- | Skolemise the 'HsTyVarBndr's in an 'HsForAllTelescope' with the supplied+-- 'TcTyMode'.+bindExplicitTKBndrs_Skol+    :: (OutputableBndrFlag flag 'Renamed)+    => SkolemInfo+    -> [LHsTyVarBndr flag GhcRn]+    -> TcM a+    -> TcM ([VarBndr TyVar flag], a)++bindExplicitTKBndrs_Tv+    :: (OutputableBndrFlag flag 'Renamed)+    => [LHsTyVarBndr flag GhcRn]+    -> TcM a+    -> TcM ([VarBndr TyVar flag], a)++bindExplicitTKBndrs_Skol skol_info = bindExplicitTKBndrsX (smVanilla { sm_clone = False, sm_tvtv = SMDSkolemTv skol_info })+bindExplicitTKBndrs_Tv   = bindExplicitTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = SMDTyVarTv })+   -- sm_clone: see Note [Cloning for type variable binders]++bindExplicitTKBndrs_Q_Skol+    :: SkolemInfo+    -> ContextKind+    -> [LHsTyVarBndr () GhcRn]+    -> TcM a+    -> TcM ([TcTyVar], a)++bindExplicitTKBndrs_Q_Tv+    :: ContextKind+    -> [LHsTyVarBndr () GhcRn]+    -> TcM a+    -> TcM ([TcTyVar], a)+-- These do not clone: see Note [Cloning for type variable binders]+bindExplicitTKBndrs_Q_Skol skol_info ctxt_kind hs_bndrs thing_inside+  = liftFstM binderVars $+    bindExplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True+                                    , sm_kind = ctxt_kind, sm_tvtv = SMDSkolemTv skol_info })+                         hs_bndrs thing_inside+    -- sm_clone=False: see Note [Cloning for type variable binders]++bindExplicitTKBndrs_Q_Tv  ctxt_kind hs_bndrs thing_inside+  = liftFstM binderVars $+    bindExplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True+                                    , sm_tvtv = SMDTyVarTv, sm_kind = ctxt_kind })+                         hs_bndrs thing_inside+    -- sm_clone=False: see Note [Cloning for type variable binders]++bindExplicitTKBndrsX :: (OutputableBndrFlag flag 'Renamed)+    => SkolemMode+    -> [LHsTyVarBndr flag GhcRn]+    -> TcM a+    -> TcM ([VarBndr TyVar flag], a)  -- Returned [TcTyVar] are in 1-1 correspondence+                                      -- with the passed-in [LHsTyVarBndr]+bindExplicitTKBndrsX skol_mode@(SM { sm_parent = check_parent, sm_kind = ctxt_kind+                                   , sm_holes = hole_info })+                     hs_tvs thing_inside+  = do { traceTc "bindExplicitTKBndrs" (ppr hs_tvs)+       ; go hs_tvs }+  where+    tc_ki_mode = TcTyMode { mode_tyki = KindLevel, mode_holes = hole_info }+                 -- Inherit the HoleInfo from the context++    go [] = do { res <- thing_inside+               ; return ([], res) }+    go (L _ hs_tv : hs_tvs)+       = do { lcl_env <- getLclTypeEnv+            ; tv <- tc_hs_bndr lcl_env hs_tv+            -- Extend the environment as we go, in case a binder+            -- is mentioned in the kind of a later binder+            --   e.g. forall k (a::k). blah+            -- NB: tv's Name may differ from hs_tv's+            -- See Note [Cloning for type variable binders]+            ; (tvs,res) <- tcExtendNameTyVarEnv [(hsTyVarName hs_tv, tv)] $+                           go hs_tvs+            ; return (Bndr tv (hsTyVarBndrFlag hs_tv):tvs, res) }+++    tc_hs_bndr lcl_env (UserTyVar _ _ (L _ name))+      | check_parent+      , Just (ATyVar _ tv) <- lookupNameEnv lcl_env name+      = return tv+      | otherwise+      = do { kind <- newExpectedKind ctxt_kind+           ; newTyVarBndr skol_mode name kind }++    tc_hs_bndr lcl_env (KindedTyVar _ _ (L _ name) lhs_kind)+      | check_parent+      , Just (ATyVar _ tv) <- lookupNameEnv lcl_env name+      = do { kind <- tc_lhs_kind_sig tc_ki_mode (TyVarBndrKindCtxt name) lhs_kind+           ; discardResult $+             unifyKind (Just . NameThing $ name) kind (tyVarKind tv)+                          -- This unify rejects:+                          --    class C (m :: * -> *) where+                          --      type F (m :: *) = ...+           ; return tv }++      | otherwise+      = do { kind <- tc_lhs_kind_sig tc_ki_mode (TyVarBndrKindCtxt name) lhs_kind+           ; newTyVarBndr skol_mode name kind }++newTyVarBndr :: SkolemMode -> Name -> Kind -> TcM TcTyVar+newTyVarBndr (SM { sm_clone = clone, sm_tvtv = tvtv }) name kind+  = do { name <- case clone of+              True -> do { uniq <- newUnique+                         ; return (setNameUnique name uniq) }+              False -> return name+       ; details <- case tvtv of+                 SMDTyVarTv  -> newMetaDetails TyVarTv+                 SMDSkolemTv skol_info ->+                  do { lvl <- getTcLevel+                     ; return (SkolemTv skol_info lvl False) }+       ; return (mkTcTyVar name kind details) }++--------------------------------------+--    Implicit tyvar binders+--------------------------------------++tcImplicitTKBndrsX :: SkolemMode -> SkolemInfo+                   -> [Name]+                   -> TcM a+                   -> TcM ([TcTyVar], a)+-- The workhorse:+--    push level, capture constraints, and emit an implication constraint+tcImplicitTKBndrsX skol_mode skol_info bndrs thing_inside+  | null bndrs  -- Short-cut the common case with no quantifiers+                -- E.g. f :: Int -> Int+                --      makes a HsOuterImplicit with empty bndrs,+                --      and tcOuterTKBndrsX goes via here+  = do { res <- thing_inside; return ([], res) }+  | otherwise+  = do { (tclvl, wanted, (skol_tvs, res))+             <- pushLevelAndCaptureConstraints       $+                bindImplicitTKBndrsX skol_mode bndrs $+                thing_inside++       ; emitResidualTvConstraint skol_info skol_tvs tclvl wanted++       ; return (skol_tvs, res) }++------------------+bindImplicitTKBndrs_Skol,+  bindImplicitTKBndrs_Q_Skol :: SkolemInfo -> [Name] -> TcM a -> TcM ([TcTyVar], a)++bindImplicitTKBndrs_Tv, bindImplicitTKBndrs_Q_Tv :: [Name] -> TcM a -> TcM ([TcTyVar], a)+bindImplicitTKBndrs_Skol skol_info = bindImplicitTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = SMDSkolemTv skol_info })+bindImplicitTKBndrs_Tv   = bindImplicitTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = SMDTyVarTv })+bindImplicitTKBndrs_Q_Skol skol_info = bindImplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True, sm_tvtv = SMDSkolemTv skol_info })+bindImplicitTKBndrs_Q_Tv = bindImplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True, sm_tvtv = SMDTyVarTv })++bindImplicitTKBndrsX+   :: SkolemMode+   -> [Name]               -- Generated by renamer; not in dependency order+   -> TcM a+   -> TcM ([TcTyVar], a)   -- Returned [TcTyVar] are in 1-1 correspondence+                           -- with the passed in [Name]+bindImplicitTKBndrsX skol_mode@(SM { sm_parent = check_parent, sm_kind = ctxt_kind })+                     tv_names thing_inside+  = do { lcl_env <- getLclTypeEnv+       ; tkvs <- mapM (new_tv lcl_env) tv_names+       ; traceTc "bindImplicitTKBndrsX" (ppr tv_names $$ ppr tkvs)+       ; res <- tcExtendNameTyVarEnv (tv_names `zip` tkvs)+                thing_inside+       ; return (tkvs, res) }+  where+    new_tv lcl_env name+      | check_parent+      , Just (ATyVar _ tv) <- lookupNameEnv lcl_env name+      = return tv+      | otherwise+      = do { kind <- newExpectedKind ctxt_kind+           ; newTyVarBndr skol_mode name kind }++--------------------------------------+--           SkolemMode+--------------------------------------++-- | 'SkolemMode' describes how to typecheck an explicit ('HsTyVarBndr') or+-- implicit ('Name') binder in a type. It is just a record of flags+-- that describe what sort of 'TcTyVar' to create.+data SkolemMode+  = SM { sm_parent :: Bool    -- True <=> check the in-scope parent type variable+                              -- Used only for asssociated types++       , sm_clone  :: Bool    -- True <=> fresh unique+                              -- See Note [Cloning for type variable binders]++       , sm_tvtv   :: SkolemModeDetails    -- True <=> use a TyVarTv, rather than SkolemTv+                              -- Why?  See Note [Inferring kinds for type declarations]+                              -- in GHC.Tc.TyCl, and (in this module)+                              -- Note [Checking partial type signatures]++       , sm_kind   :: ContextKind  -- Use this for the kind of any new binders++       , sm_holes  :: HoleInfo     -- What to do for wildcards in the kind+       }++data SkolemModeDetails+  = SMDTyVarTv+  | SMDSkolemTv SkolemInfo+++smVanilla :: HasCallStack => SkolemMode+smVanilla = SM { sm_clone  = panic "sm_clone"  -- We always override this+               , sm_parent = False+               , sm_tvtv   = pprPanic "sm_tvtv" callStackDoc -- We always override this+               , sm_kind   = AnyKind+               , sm_holes  = Nothing }++{- Note [Cloning for type variable binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Sometimes we must clone the Name of a type variable binder (written in+the source program); and sometimes we must not. This is controlled by+the sm_clone field of SkolemMode.++In some cases it doesn't matter whether or not we clone. Perhaps+it'd be better to use MustClone/MayClone/MustNotClone.++When we /must not/ clone+* In the binders of a type signature (tcOuterTKBndrs)+      f :: forall a{27}. blah+      f = rhs+  Then 'a' scopes over 'rhs'. When we kind-check the signature (tcHsSigType),+  we must get the type (forall a{27}. blah) for the Id f, because+  we bring that type variable into scope when we typecheck 'rhs'.++* In the binders of a data family instance (bindOuterFamEqnTKBndrs)+     data instance+       forall p q. D (p,q) = D1 p | D2 q+  We kind-check the LHS in tcDataFamInstHeader, and then separately+  (in tcDataFamInstDecl) bring p,q into scope before looking at the+  the constructor decls.++* bindExplicitTKBndrs_Q_Tv/bindImplicitTKBndrs_Q_Tv do not clone+  We take advantage of this in kcInferDeclHeader:+     all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs)+  If we cloned, we'd need to take a bit more care here; not hard.++* bindExplicitTKBndrs_Q_Skol, bindExplicitTKBndrs_Skol, do not clone.+  There is no need, I think.++  The payoff here is that avoiding gratuitous cloning means that we can+  almost always take the fast path in swizzleTcTyConBndrs.++When we /must/ clone.+* bindOuterSigTKBndrs_Tv, bindExplicitTKBndrs_Tv do cloning++  This for a narrow and tricky reason which, alas, I couldn't find a+  simpler way round.  #16221 is the poster child:++     data SameKind :: k -> k -> *+     data T a = forall k2 (b :: k2). MkT (SameKind a b) !Int++  When kind-checking T, we give (a :: kappa1). Then:++  - In kcConDecl we make a TyVarTv unification variable kappa2 for k2+    (as described in Note [Using TyVarTvs for kind-checking GADTs],+    even though this example is an existential)+  - So we get (b :: kappa2) via bindExplicitTKBndrs_Tv+  - We end up unifying kappa1 := kappa2, because of the (SameKind a b)++  Now we generalise over kappa2. But if kappa2's Name is precisely k2+  (i.e. we did not clone) we'll end up giving T the utterly final kind+    T :: forall k2. k2 -> *+  Nothing directly wrong with that but when we typecheck the data constructor+  we have k2 in scope; but then it's brought into scope /again/ when we find+  the forall k2.  This is chaotic, and we end up giving it the type+    MkT :: forall k2 (a :: k2) k2 (b :: k2).+           SameKind @k2 a b -> Int -> T @{k2} a+  which is bogus -- because of the shadowing of k2, we can't+  apply T to the kind or a!++  And there no reason /not/ to clone the Name when making a unification+  variable.  So that's what we do.+-}++--------------------------------------+-- Binding type/class variables in the+-- kind-checking and typechecking phases+--------------------------------------++bindTyClTyVars :: Name -> ([TcTyConBinder] -> TcKind -> TcM a) -> TcM a+-- ^ Bring into scope the binders of a PolyTcTyCon+-- Used for the type variables of a type or class decl+-- in the "kind checking" and "type checking" pass,+-- but not in the initial-kind run.+bindTyClTyVars tycon_name thing_inside+  = do { tycon <- tcLookupTcTyCon tycon_name     -- The tycon is a PolyTcTyCon+       ; let res_kind   = tyConResKind tycon+             binders    = tyConBinders tycon+       ; traceTc "bindTyClTyVars" (ppr tycon_name $$ ppr binders)+       ; tcExtendTyVarEnv (binderVars binders) $+         thing_inside binders res_kind }++bindTyClTyVarsAndZonk :: Name -> ([TyConBinder] -> Kind -> TcM a) -> TcM a+-- Like bindTyClTyVars, but in addition+-- zonk the skolem TcTyVars of a PolyTcTyCon to TyVars+bindTyClTyVarsAndZonk tycon_name thing_inside+  = bindTyClTyVars tycon_name $ \ tc_bndrs tc_kind ->+    do { ze          <- mkEmptyZonkEnv NoFlexi+       ; (ze, bndrs) <- zonkTyVarBindersX ze tc_bndrs+       ; kind        <- zonkTcTypeToTypeX ze tc_kind+       ; thing_inside bndrs kind }+++{- *********************************************************************+*                                                                      *+             Kind generalisation+*                                                                      *+********************************************************************* -}++zonkAndScopedSort :: [TcTyVar] -> TcM [TcTyVar]+zonkAndScopedSort spec_tkvs+  = do { spec_tkvs <- zonkTcTyVarsToTcTyVars spec_tkvs+         -- Zonk the kinds, to we can do the dependency analayis++       -- Do a stable topological sort, following+       -- Note [Ordering of implicit variables] in GHC.Rename.HsType+       ; return (scopedSort spec_tkvs) }++-- | Generalize some of the free variables in the given type.+-- All such variables should be *kind* variables; any type variables+-- should be explicitly quantified (with a `forall`) before now.+--+-- The WantedConstraints are un-solved kind constraints. Generally+-- they'll be reported as errors later, but meanwhile we refrain+-- from quantifying over any variable free in these unsolved+-- constraints. See Note [Failure in local type signatures].+--+-- But in all cases, generalize only those variables whose TcLevel is+-- strictly greater than the ambient level. This "strictly greater+-- than" means that you likely need to push the level before creating+-- whatever type gets passed here.+--+-- Any variable whose level is greater than the ambient level but is+-- not selected to be generalized will be promoted. (See [Promoting+-- unification variables] in "GHC.Tc.Solver" and Note [Recipe for+-- checking a signature].)+--+-- The resulting KindVar are the variables to quantify over, in the+-- correct, well-scoped order. They should generally be Inferred, not+-- Specified, but that's really up to the caller of this function.+kindGeneralizeSome :: SkolemInfo+                   -> WantedConstraints+                   -> TcType    -- ^ needn't be zonked+                   -> TcM [KindVar]+kindGeneralizeSome skol_info wanted kind_or_type+  = do { -- Use the "Kind" variant here, as any types we see+         -- here will already have all type variables quantified;+         -- thus, every free variable is really a kv, never a tv.+       ; dvs <- candidateQTyVarsOfKind kind_or_type+       ; dvs <- filterConstrainedCandidates wanted dvs+       ; quantifyTyVars skol_info DefaultNonStandardTyVars dvs }++filterConstrainedCandidates+  :: WantedConstraints    -- Don't quantify over variables free in these+                          --   Not necessarily fully zonked+  -> CandidatesQTvs       -- Candidates for quantification+  -> TcM CandidatesQTvs+-- filterConstrainedCandidates removes any candidates that are free in+-- 'wanted'; instead, it promotes them.  This bit is very much like+-- decideMonoTyVars in GHC.Tc.Solver, but constraints are so much+-- simpler in kinds, it is much easier here. (In particular, we never+-- quantify over a constraint in a type.)+filterConstrainedCandidates wanted dvs+  | isEmptyWC wanted   -- Fast path for a common case+  = return dvs+  | otherwise+  = do { wc_tvs <- zonkTyCoVarsAndFV (tyCoVarsOfWC wanted)+       ; let (to_promote, dvs') = partitionCandidates dvs (`elemVarSet` wc_tvs)+       ; _ <- promoteTyVarSet to_promote+       ; return dvs' }++-- |- Specialised version of 'kindGeneralizeSome', but with empty+-- WantedConstraints, so no filtering is needed+-- i.e.   kindGeneraliseAll = kindGeneralizeSome emptyWC+kindGeneralizeAll :: SkolemInfo -> TcType -> TcM [KindVar]+kindGeneralizeAll skol_info kind_or_type+  = do { traceTc "kindGeneralizeAll" (ppr kind_or_type)+       ; dvs <- candidateQTyVarsOfKind kind_or_type+       ; quantifyTyVars skol_info DefaultNonStandardTyVars dvs }++-- | Specialized version of 'kindGeneralizeSome', but where no variables+-- can be generalized, but perhaps some may need to be promoted.+-- Use this variant when it is unknowable whether metavariables might+-- later be constrained.+--+-- To see why this promotion is needed, see+-- Note [Recipe for checking a signature], and especially+-- Note [Promotion in signatures].+kindGeneralizeNone :: TcType  -- needn't be zonked+                   -> TcM ()+kindGeneralizeNone kind_or_type+  = do { traceTc "kindGeneralizeNone" (ppr kind_or_type)+       ; dvs <- candidateQTyVarsOfKind kind_or_type+       ; _ <- promoteTyVarSet (candidateKindVars dvs)+       ; return () }++{- Note [Levels and generalisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  f x = e+with no type signature. We are currently at level i.+We must+  * Push the level to level (i+1)+  * Allocate a fresh alpha[i+1] for the result type+  * Check that e :: alpha[i+1], gathering constraint WC+  * Solve WC as far as possible+  * Zonking the result type alpha[i+1], say to beta[i-1] -> gamma[i]+  * Find the free variables with level > i, in this case gamma[i]+  * Skolemise those free variables and quantify over them, giving+       f :: forall g. beta[i-1] -> g+  * Emit the residiual constraint wrapped in an implication for g,+    thus   forall g. WC++All of this happens for types too.  Consider+  f :: Int -> (forall a. Proxy a -> Int)++Note [Kind generalisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~+We do kind generalisation only at the outer level of a type signature.+For example, consider+  T :: forall k. k -> *+  f :: (forall a. T a -> Int) -> Int+When kind-checking f's type signature we generalise the kind at+the outermost level, thus:+  f1 :: forall k. (forall (a:k). T k a -> Int) -> Int  -- YES!+and *not* at the inner forall:+  f2 :: (forall k. forall (a:k). T k a -> Int) -> Int  -- NO!+Reason: same as for HM inference on value level declarations,+we want to infer the most general type.  The f2 type signature+would be *less applicable* than f1, because it requires a more+polymorphic argument.++NB: There are no explicit kind variables written in f's signature.+When there are, the renamer adds these kind variables to the list of+variables bound by the forall, so you can indeed have a type that's+higher-rank in its kind. But only by explicit request.++Note [Kinds of quantified type variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+tcTyVarBndrsGen quantifies over a specified list of type variables,+*and* over the kind variables mentioned in the kinds of those tyvars.++Note that we must zonk those kinds (obviously) but less obviously, we+must return type variables whose kinds are zonked too. Example+    (a :: k7)  where  k7 := k9 -> k9+We must return+    [k9, a:k9->k9]+and NOT+    [k9, a:k7]+Reason: we're going to turn this into a for-all type,+   forall k9. forall (a:k7). blah+which the type checker will then instantiate, and instantiate does not+look through unification variables!++Hence using zonked_kinds when forming tvs'.++-}++-----------------------------------+etaExpandAlgTyCon :: TyConFlavour -> SkolemInfo+                  -> [TcTyConBinder] -> Kind+                  -> TcM ([TcTyConBinder], Kind)+etaExpandAlgTyCon flav skol_info tcbs res_kind+  | needsEtaExpansion flav+  = splitTyConKind skol_info in_scope avoid_occs res_kind+  | otherwise+  = return ([], res_kind)+  where+    tyvars     = binderVars tcbs+    in_scope   = mkInScopeSet (mkVarSet tyvars)+    avoid_occs = map getOccName tyvars++needsEtaExpansion :: TyConFlavour -> Bool+needsEtaExpansion NewtypeFlavour  = True+needsEtaExpansion DataTypeFlavour = True+needsEtaExpansion ClassFlavour    = True+needsEtaExpansion _               = False++splitTyConKind :: SkolemInfo+               -> InScopeSet+               -> [OccName]  -- Avoid these OccNames+               -> Kind       -- Must be zonked+               -> TcM ([TcTyConBinder], TcKind)+-- GADT decls can have a (perhaps partial) kind signature+--      e.g.  data T a :: * -> * -> * where ...+-- This function makes up suitable (kinded) TyConBinders for the+-- argument kinds.  E.g. in this case it might return+--   ([b::*, c::*], *)+-- Skolemises the type as it goes, returning skolem TcTyVars+-- Never emits constraints.+-- It's a little trickier than you might think: see Note [splitTyConKind]+-- See also Note [Datatype return kinds] in GHC.Tc.TyCl+splitTyConKind skol_info in_scope avoid_occs kind+  = do  { loc     <- getSrcSpanM+        ; uniqs   <- newUniqueSupply+        ; rdr_env <- getLocalRdrEnv+        ; lvl     <- getTcLevel+        ; let new_occs = [ occ+                         | str <- allNameStrings+                         , let occ = mkOccName tvName str+                         , isNothing (lookupLocalRdrOcc rdr_env occ)+                         -- Note [Avoid name clashes for associated data types]+                         , not (occ `elem` avoid_occs) ]+              new_uniqs = uniqsFromSupply uniqs+              subst = mkEmptyTCvSubst in_scope+              details = SkolemTv skol_info (pushTcLevel lvl) False+                        -- As always, allocate skolems one level in++              go occs uniqs subst acc kind+                = case splitPiTy_maybe kind of+                    Nothing -> (reverse acc, substTy subst kind)++                    Just (Anon af arg, kind')+                      -> go occs' uniqs' subst' (tcb : acc) kind'+                      where+                        tcb    = Bndr tv (AnonTCB af)+                        arg'   = substTy subst (scaledThing arg)+                        name   = mkInternalName uniq occ loc+                        tv     = mkTcTyVar name arg' details+                        subst' = extendTCvInScope subst tv+                        (uniq:uniqs') = uniqs+                        (occ:occs')   = occs++                    Just (Named (Bndr tv vis), kind')+                      -> go occs uniqs subst' (tcb : acc) kind'+                      where+                        tcb           = Bndr tv' (NamedTCB vis)+                        tc_tyvar      = mkTcTyVar (tyVarName tv) (tyVarKind tv) details+                        (subst', tv') = substTyVarBndr subst tc_tyvar++        ; return (go new_occs new_uniqs subst [] kind) }++-- | A description of whether something is a+--+-- * @data@ or @newtype@ ('DataDeclSort')+--+-- * @data instance@ or @newtype instance@ ('DataInstanceSort')+--+-- * @data family@ ('DataFamilySort')+--+-- At present, this data type is only consumed by 'checkDataKindSig'.+data DataSort+  = DataDeclSort     NewOrData+  | DataInstanceSort NewOrData+  | DataFamilySort++-- | Local helper type used in 'checkDataKindSig'.+--+-- Superficially similar to 'ContextKind', but it lacks 'AnyKind'+-- and 'AnyBoxedKind', and instead of @'TheKind' liftedTypeKind@+-- provides 'LiftedKind', which is much simpler to match on and+-- handle in 'isAllowedDataResKind'.+data AllowedDataResKind+  = AnyTYPEKind+  | AnyBoxedKind+  | LiftedKind++isAllowedDataResKind :: AllowedDataResKind -> Kind -> Bool+isAllowedDataResKind AnyTYPEKind  kind = tcIsRuntimeTypeKind kind+isAllowedDataResKind AnyBoxedKind kind = tcIsBoxedTypeKind kind+isAllowedDataResKind LiftedKind   kind = tcIsLiftedTypeKind kind++-- | Checks that the return kind in a data declaration's kind signature is+-- permissible. There are three cases:+--+-- If dealing with a @data@, @newtype@, @data instance@, or @newtype instance@+-- declaration, check that the return kind is @Type@.+--+-- If the declaration is a @newtype@ or @newtype instance@ and the+-- @UnliftedNewtypes@ extension is enabled, this check is slightly relaxed so+-- that a return kind of the form @TYPE r@ (for some @r@) is permitted.+-- See @Note [Implementation of UnliftedNewtypes]@ in "GHC.Tc.TyCl".+--+-- If dealing with a @data family@ declaration, check that the return kind is+-- either of the form:+--+-- 1. @TYPE r@ (for some @r@), or+--+-- 2. @k@ (where @k@ is a bare kind variable; see #12369)+--+-- See also Note [Datatype return kinds] in "GHC.Tc.TyCl"+checkDataKindSig :: DataSort -> Kind  -- any arguments in the kind are stripped off+                 -> TcM ()+checkDataKindSig data_sort kind+  = do { dflags <- getDynFlags+       ; traceTc "checkDataKindSig" (ppr kind)+       ; checkTc (tYPE_ok dflags || is_kind_var)+                 (err_msg dflags) }+  where+    res_kind = snd (tcSplitPiTys kind)+       -- Look for the result kind after+       -- peeling off any foralls and arrows++    pp_dec :: SDoc+    pp_dec = text $+      case data_sort of+        DataDeclSort     DataType -> "Data type"+        DataDeclSort     NewType  -> "Newtype"+        DataInstanceSort DataType -> "Data instance"+        DataInstanceSort NewType  -> "Newtype instance"+        DataFamilySort            -> "Data family"++    is_newtype :: Bool+    is_newtype =+      case data_sort of+        DataDeclSort     new_or_data -> new_or_data == NewType+        DataInstanceSort new_or_data -> new_or_data == NewType+        DataFamilySort               -> False++    is_datatype :: Bool+    is_datatype =+      case data_sort of+        DataDeclSort     DataType -> True+        DataInstanceSort DataType -> True+        _                         -> False++    is_data_family :: Bool+    is_data_family =+      case data_sort of+        DataDeclSort{}     -> False+        DataInstanceSort{} -> False+        DataFamilySort     -> True++    allowed_kind :: DynFlags -> AllowedDataResKind+    allowed_kind dflags+      | is_newtype && xopt LangExt.UnliftedNewtypes dflags+        -- With UnliftedNewtypes, we allow kinds other than Type, but they+        -- must still be of the form `TYPE r` since we don't want to accept+        -- Constraint or Nat.+        -- See Note [Implementation of UnliftedNewtypes] in GHC.Tc.TyCl.+      = AnyTYPEKind+      | is_data_family+        -- If this is a `data family` declaration, we don't need to check if+        -- UnliftedNewtypes is enabled, since data family declarations can+        -- have return kind `TYPE r` unconditionally (#16827).+      = AnyTYPEKind+      | is_datatype && xopt LangExt.UnliftedDatatypes dflags+        -- With UnliftedDatatypes, we allow kinds other than Type, but they+        -- must still be of the form `TYPE (BoxedRep l)`, so that we don't+        -- accept result kinds like `TYPE IntRep`.+        -- See Note [Implementation of UnliftedDatatypes] in GHC.Tc.TyCl.+      = AnyBoxedKind+      | otherwise+      = LiftedKind++    tYPE_ok :: DynFlags -> Bool+    tYPE_ok dflags = isAllowedDataResKind (allowed_kind dflags) res_kind++    -- In the particular case of a data family, permit a return kind of the+    -- form `:: k` (where `k` is a bare kind variable).+    is_kind_var :: Bool+    is_kind_var | is_data_family = isJust (tcGetCastedTyVar_maybe res_kind)+                | otherwise      = False++    pp_allowed_kind dflags =+      case allowed_kind dflags of+        AnyTYPEKind  -> ppr tYPETyCon+        AnyBoxedKind -> ppr boxedRepDataConTyCon+        LiftedKind   -> ppr liftedTypeKind++    err_msg :: DynFlags -> TcRnMessage+    err_msg dflags = TcRnUnknownMessage $ mkPlainError noHints $+      sep [ sep [ pp_dec <+>+                  text "has non-" <>+                  pp_allowed_kind dflags+                , (if is_data_family then text "and non-variable" else empty) <+>+                  text "return kind" <+> quotes (ppr kind) ]+          , ext_hint dflags ]++    ext_hint dflags+      | tcIsRuntimeTypeKind kind+      , is_newtype+      , not (xopt LangExt.UnliftedNewtypes dflags)+      = text "Perhaps you intended to use UnliftedNewtypes"+      | tcIsBoxedTypeKind kind+      , is_datatype+      , not (xopt LangExt.UnliftedDatatypes dflags)+      = text "Perhaps you intended to use UnliftedDatatypes"+      | otherwise+      = empty++-- | Checks that the result kind of a class is exactly `Constraint`, rejecting+-- type synonyms and type families that reduce to `Constraint`. See #16826.+checkClassKindSig :: Kind -> TcM ()+checkClassKindSig kind = checkTc (tcIsConstraintKind kind) err_msg+  where+    err_msg :: TcRnMessage+    err_msg = TcRnUnknownMessage $ mkPlainError noHints $+      text "Kind signature on a class must end with" <+> ppr constraintKind $$+      text "unobscured by type families"++tcbVisibilities :: TyCon -> [Type] -> [TyConBndrVis]+-- Result is in 1-1 correspondence with orig_args+tcbVisibilities tc orig_args+  = go (tyConKind tc) init_subst orig_args+  where+    init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfTypes orig_args))+    go _ _ []+      = []++    go fun_kind subst all_args@(arg : args)+      | Just (tcb, inner_kind) <- splitPiTy_maybe fun_kind+      = case tcb of+          Anon af _           -> AnonTCB af   : go inner_kind subst  args+          Named (Bndr tv vis) -> NamedTCB vis : go inner_kind subst' args+                 where+                    subst' = extendTCvSubst subst tv arg++      | not (isEmptyTCvSubst subst)+      = go (substTy subst fun_kind) init_subst all_args++      | otherwise+      = pprPanic "addTcbVisibilities" (ppr tc <+> ppr orig_args)+++{- Note [splitTyConKind]+~~~~~~~~~~~~~~~~~~~~~~~~+Given+  data T (a::*) :: * -> forall k. k -> *+we want to generate the extra TyConBinders for T, so we finally get+  (a::*) (b::*) (k::*) (c::k)+The function splitTyConKind generates these extra TyConBinders from+the result kind signature.  The same function is also used by+kcCheckDeclHeader_sig to get the [TyConBinder] from the Kind of+the TyCon given in a standalone kind signature.  E.g.+  type T :: forall (a::*). * -> forall k. k -> *++We need to take care to give the TyConBinders+  (a) Uniques that are fresh: the TyConBinders of a TyCon+      must have distinct uniques.++  (b) Preferably, OccNames that are fresh. If we happen to re-use+      OccNames that are other TyConBinders, we'll get a TyCon with+      TyConBinders like [a_72, a_53]; same OccName, different Uniques.+      Then when pretty-printing (e.g. in GHCi :info) we'll see+          data T a a0+      whereas we'd prefer+          data T a b+      (NB: the tidying happens in the conversion to Iface syntax,+      which happens as part of pretty-printing a TyThing.)++      Using fresh OccNames is not essential; it's cosmetic.+      And also see Note [Avoid name clashes for associated data types].++For (a) perhaps surprisingly, duplicated uniques can happen, even if+we use fresh uniques for Anon arrows.  Consider+   data T :: forall k. k -> forall k. k -> *+where the two k's are identical even up to their uniques.  Surprisingly,+this can happen: see #14515, #19092,3,4.  Then if we use those k's in+as TyConBinders we'll get duplicated uniques.++For (b) we'd like to avoid OccName clashes with the tyvars declared by+the user before the "::"; in the above example that is 'a'.++It's reasonably easy to solve all this; just run down the list with a+substitution; hence the recursive 'go' function.  But for the Uniques+it has to be done.++Note [Avoid name clashes for associated data types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider    class C a b where+               data D b :: * -> *+When typechecking the decl for D, we'll invent an extra type variable+for D, to fill out its kind.  Ideally we don't want this type variable+to be 'a', because when pretty printing we'll get+            class C a b where+               data D b a0+(NB: the tidying happens in the conversion to Iface syntax, which happens+as part of pretty-printing a TyThing.)++That's why we look in the LocalRdrEnv to see what's in scope. This is+important only to get nice-looking output when doing ":info C" in GHCi.+It isn't essential for correctness.+++************************************************************************+*                                                                      *+             Partial signatures+*                                                                      *+************************************************************************++-}++tcHsPartialSigType+  :: UserTypeCtxt+  -> LHsSigWcType GhcRn       -- The type signature+  -> TcM ( [(Name, TcTyVar)]  -- Wildcards+         , Maybe TcType       -- Extra-constraints wildcard+         , [(Name,InvisTVBinder)] -- Original tyvar names, in correspondence with+                              --   the implicitly and explicitly bound type variables+         , TcThetaType        -- Theta part+         , TcType )           -- Tau part+-- See Note [Checking partial type signatures]+tcHsPartialSigType ctxt sig_ty+  | HsWC { hswc_ext  = sig_wcs, hswc_body = sig_ty } <- sig_ty+  , L _ (HsSig{sig_bndrs = hs_outer_bndrs, sig_body = body_ty}) <- sig_ty+  , (hs_ctxt, hs_tau) <- splitLHsQualTy body_ty+  = addSigCtxt ctxt sig_ty $+    do { mode <- mkHoleMode TypeLevel HM_Sig+       ; (outer_bndrs, (wcs, wcx, theta, tau))+            <- solveEqualities "tcHsPartialSigType" $+               -- See Note [Failure in local type signatures]+               bindNamedWildCardBinders sig_wcs             $ \ wcs ->+               bindOuterSigTKBndrs_Tv_M mode hs_outer_bndrs $+               do {   -- Instantiate the type-class context; but if there+                      -- is an extra-constraints wildcard, just discard it here+                    (theta, wcx) <- tcPartialContext mode hs_ctxt++                  ; ek <- newOpenTypeKind+                  ; tau <- addTypeCtxt hs_tau $+                           tc_lhs_type mode hs_tau ek++                  ; return (wcs, wcx, theta, tau) }++       ; traceTc "tcHsPartialSigType 2" empty+       ; outer_bndrs <- scopedSortOuter outer_bndrs+       ; let outer_tv_bndrs = outerTyVarBndrs outer_bndrs+       ; traceTc "tcHsPartialSigType 3" empty++         -- No kind-generalization here:+       ; kindGeneralizeNone (mkInvisForAllTys outer_tv_bndrs $+                             mkPhiTy theta $+                             tau)++       -- Spit out the wildcards (including the extra-constraints one)+       -- as "hole" constraints, so that they'll be reported if necessary+       -- See Note [Extra-constraint holes in partial type signatures]+       ; mapM_ emitNamedTypeHole wcs++       -- Zonk, so that any nested foralls can "see" their occurrences+       -- See Note [Checking partial type signatures], and in particular+       -- Note [Levels for wildcards]+       ; outer_tv_bndrs <- mapM zonkInvisTVBinder outer_tv_bndrs+       ; theta          <- mapM zonkTcType theta+       ; tau            <- zonkTcType tau++         -- We return a proper (Name,InvisTVBinder) environment, to be sure that+         -- we bring the right name into scope in the function body.+         -- Test case: partial-sigs/should_compile/LocalDefinitionBug+       ; let outer_bndr_names :: [Name]+             outer_bndr_names = hsOuterTyVarNames hs_outer_bndrs+             tv_prs :: [(Name,InvisTVBinder)]+             tv_prs = outer_bndr_names `zip` outer_tv_bndrs++      -- NB: checkValidType on the final inferred type will be+      --     done later by checkInferredPolyId.  We can't do it+      --     here because we don't have a complete type to check++       ; traceTc "tcHsPartialSigType" (ppr tv_prs)+       ; return (wcs, wcx, tv_prs, theta, tau) }++tcPartialContext :: TcTyMode -> Maybe (LHsContext GhcRn) -> TcM (TcThetaType, Maybe TcType)+tcPartialContext _ Nothing = return ([], Nothing)+tcPartialContext mode (Just (L _ hs_theta))+  | Just (hs_theta1, hs_ctxt_last) <- snocView hs_theta+  , L wc_loc ty@(HsWildCardTy _) <- ignoreParens hs_ctxt_last+  = do { wc_tv_ty <- setSrcSpanA wc_loc $+                     tcAnonWildCardOcc YesExtraConstraint mode ty constraintKind+       ; theta <- mapM (tc_lhs_pred mode) hs_theta1+       ; return (theta, Just wc_tv_ty) }+  | otherwise+  = do { theta <- mapM (tc_lhs_pred mode) hs_theta+       ; return (theta, Nothing) }++{- Note [Checking partial type signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This Note is about tcHsPartialSigType.  See also+Note [Recipe for checking a signature]++When we have a partial signature like+   f :: forall a. a -> _+we do the following++* tcHsPartialSigType does not make quantified type (forall a. blah)+  and then instantiate it -- it makes no sense to instantiate a type+  with wildcards in it.  Rather, tcHsPartialSigType just returns the+  'a' and the 'blah' separately.++  Nor, for the same reason, do we push a level in tcHsPartialSigType.++* We instantiate 'a' to a unification variable, a TyVarTv, and /not/+  a skolem; hence the "_Tv" in bindExplicitTKBndrs_Tv.  Consider+    f :: forall a. a -> _+    g :: forall b. _ -> b+    f = g+    g = f+  They are typechecked as a recursive group, with monomorphic types,+  so 'a' and 'b' will get unified together.  Very like kind inference+  for mutually recursive data types (sans CUSKs or SAKS); see+  Note [Cloning for type variable binders]++* In GHC.Tc.Gen.Sig.tcUserSigType we return a PartialSig, which (unlike+  the companion CompleteSig) contains the original, as-yet-unchecked+  source-code LHsSigWcType++* Then, for f and g /separately/, we call tcInstSig, which in turn+  call tchsPartialSig (defined near this Note).  It kind-checks the+  LHsSigWcType, creating fresh unification variables for each "_"+  wildcard.  It's important that the wildcards for f and g are distinct+  because they might get instantiated completely differently.  E.g.+     f,g :: forall a. a -> _+     f x = a+     g x = True+  It's really as if we'd written two distinct signatures.++* Nested foralls. See Note [Levels for wildcards]++* Just as for ordinary signatures, we must solve local equalities and+  zonk the type after kind-checking it, to ensure that all the nested+  forall binders can "see" their occurrenceds++  Just as for ordinary signatures, this zonk also gets any Refl casts+  out of the way of instantiation.  Example: #18008 had+       foo :: (forall a. (Show a => blah) |> Refl) -> _+  and that Refl cast messed things up.  See #18062.++Note [Levels for wildcards]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+     f :: forall b. (forall a. a -> _) -> b+We do /not/ allow the "_" to be instantiated to 'a'; although we do+(as before) allow it to be instantiated to the (top level) 'b'.+Why not?  Suppose+   f x = (x True, x 'c')++During typecking the RHS we must instantiate that (forall a. a -> _),+so we must know /precisely/ where all the a's are; they must not be+hidden under (possibly-not-yet-filled-in) unification variables!++We achieve this as follows:++- For /named/ wildcards such sas+     g :: forall b. (forall la. a -> _x) -> b+  there is no problem: we create them at the outer level (ie the+  ambient level of the signature itself), and push the level when we+  go inside a forall.  So now the unification variable for the "_x"+  can't unify with skolem 'a'.++- For /anonymous/ wildcards, such as 'f' above, we carry the ambient+  level of the signature to the hole in the TcLevel part of the+  mode_holes field of TcTyMode.  Then, in tcAnonWildCardOcc we us that+  level (and /not/ the level ambient at the occurrence of "_") to+  create the unification variable for the wildcard.  That is the sole+  purpose of the TcLevel in the mode_holes field: to transport the+  ambient level of the signature down to the anonymous wildcard+  occurrences.++Note [Extra-constraint holes in partial type signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  f :: (_) => a -> a+  f x = ...++* The renamer leaves '_' untouched.++* Then, in tcHsPartialSigType, we make a new hole TcTyVar, in+  tcWildCardBinders.++* GHC.Tc.Gen.Bind.chooseInferredQuantifiers fills in that hole TcTyVar+  with the inferred constraints, e.g. (Eq a, Show a)++* GHC.Tc.Errors.mkHoleError finally reports the error.++An annoying difficulty happens if there are more than 64 inferred+constraints. Then we need to fill in the TcTyVar with (say) a 70-tuple.+Where do we find the TyCon?  For good reasons we only have constraint+tuples up to 62 (see Note [How tuples work] in GHC.Builtin.Types).  So how+can we make a 70-tuple?  This was the root cause of #14217.++It's incredibly tiresome, because we only need this type to fill+in the hole, to communicate to the error reporting machinery.  Nothing+more.  So I use a HACK:++* I make an /ordinary/ tuple of the constraints, in+  GHC.Tc.Gen.Bind.chooseInferredQuantifiers. This is ill-kinded because+  ordinary tuples can't contain constraints, but it works fine. And for+  ordinary tuples we don't have the same limit as for constraint+  tuples (which need selectors and an associated class).++* Because it is ill-kinded (unifying something of kind Constraint with+  something of kind Type), it should trip an assert in writeMetaTyVarRef.+  However, writeMetaTyVarRef uses eqType, not tcEqType, to avoid falling+  over in this scenario (and another scenario, as detailed in+  Note [coreView vs tcView] in GHC.Core.Type).++Result works fine, but it may eventually bite us.++See also Note [Do not simplify ConstraintHoles] in GHC.Tc.Solver for+information about how these are printed.++************************************************************************+*                                                                      *+      Pattern signatures (i.e signatures that occur in patterns)+*                                                                      *+********************************************************************* -}++tcHsPatSigType :: UserTypeCtxt+               -> HoleMode -- HM_Sig when in a SigPat, HM_TyAppPat when in a ConPat checking type applications.+               -> HsPatSigType GhcRn          -- The type signature+               -> ContextKind                -- What kind is expected+               -> TcM ( [(Name, TcTyVar)]     -- Wildcards+                      , [(Name, TcTyVar)]     -- The new bit of type environment, binding+                                              -- the scoped type variables+                      , TcType)       -- The type+-- Used for type-checking type signatures in+-- (a) patterns           e.g  f (x::Int) = e+-- (b) RULE forall bndrs  e.g. forall (x::Int). f x = x+-- See Note [Pattern signature binders and scoping] in GHC.Hs.Type+--+-- This may emit constraints+-- See Note [Recipe for checking a signature]+tcHsPatSigType ctxt hole_mode+  (HsPS { hsps_ext  = HsPSRn { hsps_nwcs = sig_wcs, hsps_imp_tvs = sig_ns }+        , hsps_body = hs_ty })+  ctxt_kind+  = addSigCtxt ctxt hs_ty $+    do { sig_tkv_prs <- mapM new_implicit_tv sig_ns+       ; mode <- mkHoleMode TypeLevel hole_mode+       ; (wcs, sig_ty)+            <- addTypeCtxt hs_ty                     $+               solveEqualities "tcHsPatSigType" $+                 -- See Note [Failure in local type signatures]+                 -- and c.f #16033+               bindNamedWildCardBinders sig_wcs $ \ wcs ->+               tcExtendNameTyVarEnv sig_tkv_prs $+               do { ek     <- newExpectedKind ctxt_kind+                  ; sig_ty <- tc_lhs_type mode hs_ty ek+                  ; return (wcs, sig_ty) }++        ; mapM_ emitNamedTypeHole wcs++          -- sig_ty might have tyvars that are at a higher TcLevel (if hs_ty+          -- contains a forall). Promote these.+          -- Ex: f (x :: forall a. Proxy a -> ()) = ... x ...+          -- When we instantiate x, we have to compare the kind of the argument+          -- to a's kind, which will be a metavariable.+          -- kindGeneralizeNone does this:+        ; kindGeneralizeNone sig_ty+        ; sig_ty <- zonkTcType sig_ty+        ; checkValidType ctxt sig_ty++        ; traceTc "tcHsPatSigType" (ppr sig_tkv_prs)+        ; return (wcs, sig_tkv_prs, sig_ty) }+  where+    new_implicit_tv name+      = do { kind <- newMetaKindVar+           ; tv   <- case ctxt of+                       RuleSigCtxt rname _  -> do+                        skol_info <- mkSkolemInfo (RuleSkol rname)+                        newSkolemTyVar skol_info name kind+                       _              -> newPatSigTyVar name kind+                       -- See Note [Typechecking pattern signature binders]+             -- NB: tv's Name may be fresh (in the case of newPatSigTyVar)+           ; return (name, tv) }++{- Note [Typechecking pattern signature binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See also Note [Type variables in the type environment] in GHC.Tc.Utils.+Consider++  data T where+    MkT :: forall a. a -> (a -> Int) -> T++  f :: T -> ...+  f (MkT x (f :: b -> c)) = <blah>++Here+ * The pattern (MkT p1 p2) creates a *skolem* type variable 'a_sk',+   It must be a skolem so that it retains its identity, and+   GHC.Tc.Errors.getSkolemInfo can thereby find the binding site for the skolem.++ * The type signature pattern (f :: b -> c) makes fresh meta-tyvars+   beta and gamma (TauTvs), and binds "b" :-> beta, "c" :-> gamma in the+   environment++ * Then unification makes beta := a_sk, gamma := Int+   That's why we must make beta and gamma a MetaTv,+   not a SkolemTv, so that it can unify to a_sk (or Int, respectively).++ * Finally, in '<blah>' we have the envt "b" :-> beta, "c" :-> gamma,+   so we return the pairs ("b" :-> beta, "c" :-> gamma) from tcHsPatSigType,++Another example (#13881):+   fl :: forall (l :: [a]). Sing l -> Sing l+   fl (SNil :: Sing (l :: [y])) = SNil+When we reach the pattern signature, 'l' is in scope from the+outer 'forall':+   "a" :-> a_sk :: *+   "l" :-> l_sk :: [a_sk]+We make up a fresh meta-TauTv, y_sig, for 'y', and kind-check+the pattern signature+   Sing (l :: [y])+That unifies y_sig := a_sk.  We return from tcHsPatSigType with+the pair ("y" :-> y_sig).++For RULE binders, though, things are a bit different (yuk).+  RULE "foo" forall (x::a) (y::[a]).  f x y = ...+Here this really is the binding site of the type variable so we'd like+to use a skolem, so that we get a complaint if we unify two of them+together.  Hence the new_implicit_tv function in tcHsPatSigType.+++************************************************************************+*                                                                      *+        Checking kinds+*                                                                      *+************************************************************************++-}++unifyKinds :: [LHsType GhcRn] -> [(TcType, TcKind)] -> TcM ([TcType], TcKind)+unifyKinds rn_tys act_kinds+  = do { kind <- newMetaKindVar+       ; let check rn_ty (ty, act_kind)+               = checkExpectedKind (unLoc rn_ty) ty act_kind kind+       ; tys' <- zipWithM check rn_tys act_kinds+       ; return (tys', kind) }++{-+************************************************************************+*                                                                      *+        Sort checking kinds+*                                                                      *+************************************************************************++tcLHsKindSig converts a user-written kind to an internal, sort-checked kind.+It does sort checking and desugaring at the same time, in one single pass.+-}++tcLHsKindSig :: UserTypeCtxt -> LHsKind GhcRn -> TcM Kind+tcLHsKindSig ctxt hs_kind+  = tc_lhs_kind_sig kindLevelMode ctxt hs_kind++tc_lhs_kind_sig :: TcTyMode -> UserTypeCtxt -> LHsKind GhcRn -> TcM Kind+tc_lhs_kind_sig mode ctxt hs_kind+-- See  Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType+-- Result is zonked+  = do { kind <- addErrCtxt (text "In the kind" <+> quotes (ppr hs_kind)) $+                 solveEqualities "tcLHsKindSig" $+                 tc_lhs_type mode hs_kind liftedTypeKind+       ; traceTc "tcLHsKindSig" (ppr hs_kind $$ ppr kind)+       -- No generalization:+       ; kindGeneralizeNone kind+       ; kind <- zonkTcType kind+         -- This zonk is very important in the case of higher rank kinds+         -- E.g. #13879    f :: forall (p :: forall z (y::z). <blah>).+         --                          <more blah>+         --      When instantiating p's kind at occurrences of p in <more blah>+         --      it's crucial that the kind we instantiate is fully zonked,+         --      else we may fail to substitute properly++       ; checkValidType ctxt kind+       ; traceTc "tcLHsKindSig2" (ppr kind)+       ; return kind }++promotionErr :: Name -> PromotionErr -> TcM a+promotionErr name err+  = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $+      (hang (pprPECategory err <+> quotes (ppr name) <+> text "cannot be used here")+                   2 (parens reason))+  where+    reason = case err of+               ConstrainedDataConPE pred+                              -> text "it has an unpromotable context"+                                 <+> quotes (ppr pred)+               FamDataConPE   -> text "it comes from a data family instance"+               NoDataKindsDC  -> text "perhaps you intended to use DataKinds"+               PatSynPE       -> text "pattern synonyms cannot be promoted"+               RecDataConPE   -> same_rec_group_msg+               ClassPE        -> same_rec_group_msg+               TyConPE        -> same_rec_group_msg++    same_rec_group_msg = text "it is defined and used in the same recursive group"++{-+************************************************************************+*                                                                      *+          Error messages and such+*                                                                      *+************************************************************************+-}+++-- | Make an appropriate message for an error in a function argument.+-- Used for both expressions and types.+funAppCtxt :: (Outputable fun, Outputable arg) => fun -> arg -> Int -> SDoc+funAppCtxt fun arg arg_no+  = hang (hsep [ text "In the", speakNth arg_no, text "argument of",                     quotes (ppr fun) <> text ", namely"])        2 (quotes (ppr arg))
compiler/GHC/Tc/Gen/Match.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP              #-}+ {-# LANGUAGE ConstraintKinds  #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes       #-}@@ -31,6 +31,7 @@    , tcBody    , tcDoStmt    , tcGuardStmt+   , checkPatCounts    ) where @@ -41,6 +42,7 @@                                        , tcCheckMonoExpr, tcCheckMonoExprNC                                        , tcCheckPolyExpr ) +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Env import GHC.Tc.Gen.Pat@@ -48,6 +50,7 @@ import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType import GHC.Tc.Gen.Bind+import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) import GHC.Tc.Utils.Unify import GHC.Tc.Types.Origin import GHC.Tc.Types.Evidence@@ -68,6 +71,7 @@ import GHC.Utils.Misc import GHC.Driver.Session ( getDynFlags ) +import GHC.Types.Error import GHC.Types.Fixity (LexicalFixity(..)) import GHC.Types.Name import GHC.Types.Id@@ -76,8 +80,6 @@ import Control.Monad import Control.Arrow ( second ) -#include "GhclibHsVersions.h"- {- ************************************************************************ *                                                                      *@@ -91,12 +93,12 @@ same number of arguments before using @tcMatches@ to do the work. -} -tcMatchesFun :: LocatedN Name+tcMatchesFun :: LocatedN Id -- MatchContext Id              -> MatchGroup GhcRn (LHsExpr GhcRn)              -> ExpRhoType    -- Expected type of function              -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))                                 -- Returns type of body-tcMatchesFun fn@(L _ fun_name) matches exp_ty+tcMatchesFun fun_id matches exp_ty   = do  {  -- Check that they all have the same no of arguments            -- Location is in the monad, set the caller so that            -- any inter-equation error messages get some vaguely@@ -104,7 +106,9 @@            -- ann-grabbing, because we don't always have annotations in            -- hand when we call tcMatchesFun...           traceTc "tcMatchesFun" (ppr fun_name $$ ppr exp_ty)-        ; checkArgs fun_name matches+           -- We can't easily call checkPatCounts here because fun_id can be an+           -- unfilled thunk+        ; checkArgCounts fun_name matches          ; matchExpectedFunTys herald ctxt arity exp_ty $ \ pat_tys rhs_ty ->              -- NB: exp_type may be polymorphic, but@@ -118,12 +122,17 @@           -- a multiplicity argument, and scale accordingly.           tcMatches match_ctxt pat_tys rhs_ty matches }   where+    fun_name = idName (unLoc fun_id)     arity  = matchGroupArity matches-    herald = text "The equation(s) for"-             <+> quotes (ppr fun_name) <+> text "have"+    herald = ExpectedFunTyMatches (NameThing fun_name) matches     ctxt   = GenSigCtxt  -- Was: FunSigCtxt fun_name True                          -- But that's wrong for f :: Int -> forall a. blah-    what   = FunRhs { mc_fun = fn, mc_fixity = Prefix, mc_strictness = strictness }+    what   = FunRhs { mc_fun = fun_id, mc_fixity = Prefix, mc_strictness = strictness }+                    -- Careful: this fun_id could be an unfilled+                    -- thunk from fixM in tcMonoBinds, so we're+                    -- not allowed to look at it, except for+                    -- idName.+                    -- See Note [fixM for rhs_ty in tcMonoBinds]     match_ctxt = MC { mc_what = what, mc_body = tcBody }     strictness       | [L _ match] <- unLoc $ mg_alts matches@@ -138,10 +147,10 @@ -}  tcMatchesCase :: (AnnoBody body) =>-                TcMatchCtxt body                         -- Case context-             -> Scaled TcSigmaType                       -- Type of scrutinee-             -> MatchGroup GhcRn (LocatedA (body GhcRn)) -- The case alternatives-             -> ExpRhoType                    -- Type of whole case expressions+                TcMatchCtxt body      -- ^ Case context+             -> Scaled TcSigmaTypeFRR -- ^ Type of scrutinee+             -> MatchGroup GhcRn (LocatedA (body GhcRn)) -- ^ The case alternatives+             -> ExpRhoType                               -- ^ Type of the whole case expression              -> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))                 -- Translated alternatives                 -- wrapper goes from MatchGroup's ty to expected ty@@ -149,14 +158,16 @@ tcMatchesCase ctxt (Scaled scrut_mult scrut_ty) matches res_ty   = tcMatches ctxt [Scaled scrut_mult (mkCheckExpType scrut_ty)] res_ty matches -tcMatchLambda :: SDoc -- see Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify+tcMatchLambda :: ExpectedFunTyOrigin -- see Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify               -> TcMatchCtxt HsExpr               -> MatchGroup GhcRn (LHsExpr GhcRn)               -> ExpRhoType               -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) tcMatchLambda herald match_ctxt match res_ty-  = matchExpectedFunTys herald GenSigCtxt n_pats res_ty $ \ pat_tys rhs_ty ->-    tcMatches match_ctxt pat_tys rhs_ty match+  =  do { checkPatCounts (mc_what match_ctxt) match+        ; matchExpectedFunTys herald GenSigCtxt n_pats res_ty $ \ pat_tys rhs_ty -> do+            -- checking argument counts since this is also used for \cases+            tcMatches match_ctxt pat_tys rhs_ty match }   where     n_pats | isEmptyMatchGroup match = 1   -- must be lambda-case            | otherwise               = matchGroupArity match@@ -186,7 +197,7 @@ ********************************************************************* -}  data TcMatchCtxt body   -- c.f. TcStmtCtxt, also in this module-  = MC { mc_what :: HsMatchContext GhcRn,  -- What kind of thing this is+  = MC { mc_what :: HsMatchContext GhcTc,  -- What kind of thing this is          mc_body :: LocatedA (body GhcRn)  -- Type checker for a body of                                            -- an alternative                  -> ExpRhoType@@ -198,16 +209,16 @@     , Anno (Match GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA     , Anno [LocatedA (Match GhcRn (LocatedA (body GhcRn)))] ~ SrcSpanAnnL     , Anno [LocatedA (Match GhcTc (LocatedA (body GhcTc)))] ~ SrcSpanAnnL-    , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ SrcSpan-    , Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan+    , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ SrcAnn NoEpAnns+    , Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns     , Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA     , Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA     )  -- | Type-check a MatchGroup. tcMatches :: (AnnoBody body ) => TcMatchCtxt body-          -> [Scaled ExpSigmaType]      -- Expected pattern types-          -> ExpRhoType          -- Expected result-type of the Match.+          -> [Scaled ExpSigmaTypeFRR] -- ^ Expected pattern types.+          -> ExpRhoType               -- ^ Expected result-type of the Match.           -> MatchGroup GhcRn (LocatedA (body GhcRn))           -> TcM (MatchGroup GhcTc (LocatedA (body GhcTc))) @@ -274,7 +285,7 @@ tcGRHSs ctxt (GRHSs _ grhss binds) res_ty   = do  { (binds', ugrhss)             <- tcLocalBinds binds $-               mapM (tcCollectingUsage . wrapLocM (tcGRHS ctxt res_ty)) grhss+               mapM (tcCollectingUsage . wrapLocMA (tcGRHS ctxt res_ty)) grhss         ; let (usages, grhss') = unzip ugrhss         ; tcEmitBindingUsage $ supUEs usages         ; return (GRHSs emptyComments grhss' binds') }@@ -299,7 +310,7 @@ ************************************************************************ -} -tcDoStmts :: HsStmtContext GhcRn+tcDoStmts :: HsDoFlavour           -> LocatedL [LStmt GhcRn (LHsExpr GhcRn)]           -> ExpRhoType           -> TcM (HsExpr GhcTc)          -- Returns a HsDo@@ -307,26 +318,25 @@   = do  { res_ty <- expTypeToType res_ty         ; (co, elt_ty) <- matchExpectedListTy res_ty         ; let list_ty = mkListTy elt_ty-        ; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts+        ; stmts' <- tcStmts (HsDoStmt ListComp) (tcLcStmt listTyCon) stmts                             (mkCheckExpType elt_ty)         ; return $ mkHsWrapCo co (HsDo list_ty ListComp (L l stmts')) }  tcDoStmts doExpr@(DoExpr _) (L l stmts) res_ty-  = do  { stmts' <- tcStmts doExpr tcDoStmt stmts res_ty+  = do  { stmts' <- tcStmts (HsDoStmt doExpr) tcDoStmt stmts res_ty         ; res_ty <- readExpType res_ty         ; return (HsDo res_ty doExpr (L l stmts')) }  tcDoStmts mDoExpr@(MDoExpr _) (L l stmts) res_ty-  = do  { stmts' <- tcStmts mDoExpr tcDoStmt stmts res_ty+  = do  { stmts' <- tcStmts (HsDoStmt mDoExpr) tcDoStmt stmts res_ty         ; res_ty <- readExpType res_ty         ; return (HsDo res_ty mDoExpr (L l stmts')) }  tcDoStmts MonadComp (L l stmts) res_ty-  = do  { stmts' <- tcStmts MonadComp tcMcStmt stmts res_ty+  = do  { stmts' <- tcStmts (HsDoStmt MonadComp) tcMcStmt stmts res_ty         ; res_ty <- readExpType res_ty         ; return (HsDo res_ty MonadComp (L l stmts')) }--tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)+tcDoStmts ctxt@GhciStmtCtxt _ _ = pprPanic "tcDoStmts" (pprHsDoFlavour ctxt)  tcBody :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc) tcBody body res_ty@@ -346,13 +356,13 @@ type TcCmdStmtChecker  = TcStmtChecker HsCmd  TcRhoType  type TcStmtChecker body rho_type-  =  forall thing. HsStmtContext GhcRn+  =  forall thing. HsStmtContext GhcTc                 -> Stmt GhcRn (LocatedA (body GhcRn))                 -> rho_type                 -- Result type for comprehension                 -> (rho_type -> TcM thing)  -- Checker for what follows the stmt                 -> TcM (Stmt GhcTc (LocatedA (body GhcTc)), thing) -tcStmts :: (AnnoBody body) => HsStmtContext GhcRn+tcStmts :: (AnnoBody body) => HsStmtContext GhcTc         -> TcStmtChecker body rho_type   -- NB: higher-rank type         -> [LStmt GhcRn (LocatedA (body GhcRn))]         -> rho_type@@ -362,7 +372,7 @@                         const (return ())        ; return stmts' } -tcStmtsAndThen :: (AnnoBody body) => HsStmtContext GhcRn+tcStmtsAndThen :: (AnnoBody body) => HsStmtContext GhcTc                -> TcStmtChecker body rho_type    -- NB: higher-rank type                -> [LStmt GhcRn (LocatedA (body GhcRn))]                -> rho_type@@ -426,6 +436,7 @@           -- two multiplicity to still be the same.           (rhs', rhs_ty) <- tcScalingUsage Many $ tcInferRhoNC rhs                                    -- Stmt has a context already+        ; hasFixedRuntimeRep_syntactic FRRBindStmtGuard rhs_ty         ; (pat', thing)  <- tcCheckPat_O (StmtCtxt ctxt) (lexprCtOrigin rhs)                                          pat (unrestricted rhs_ty) $                             thing_inside res_ty@@ -578,15 +589,17 @@  tcMcStmt ctxt (BindStmt xbsrn pat rhs) res_ty thing_inside            -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty-  = do  { ((rhs', pat_mult, pat', thing, new_res_ty), bind_op')+  = do  { ((rhs_ty, rhs', pat_mult, pat', thing, new_res_ty), bind_op')             <- tcSyntaxOp MCompOrigin (xbsrn_bindOp xbsrn)                           [SynRho, SynFun SynAny SynRho] res_ty $                \ [rhs_ty, pat_ty, new_res_ty] [rhs_mult, fun_mult, pat_mult] ->                do { rhs' <- tcScalingUsage rhs_mult $ tcCheckMonoExprNC rhs rhs_ty                   ; (pat', thing) <- tcScalingUsage fun_mult $ tcCheckPat (StmtCtxt ctxt) pat (Scaled pat_mult pat_ty) $                                      thing_inside (mkCheckExpType new_res_ty)-                  ; return (rhs', pat_mult, pat', thing, new_res_ty) }+                  ; return (rhs_ty, rhs', pat_mult, pat', thing, new_res_ty) } +        ; hasFixedRuntimeRep_syntactic (FRRBindStmt MonadComprehension) rhs_ty+         -- If (but only if) the pattern can fail, typecheck the 'fail' operator         ; fail_op' <- fmap join . forM (xbsrn_failOp xbsrn) $ \fail ->             tcMonadFailOp (MCompPatOrigin pat) pat' fail new_res_ty@@ -608,17 +621,23 @@           --    guard_op :: test_ty -> rhs_ty           --    then_op  :: rhs_ty -> new_res_ty -> res_ty           -- Where test_ty is, for example, Bool-        ; ((thing, rhs', rhs_ty, guard_op'), then_op')+        ; ((thing, rhs', rhs_ty, new_res_ty, test_ty, guard_op'), then_op')             <- tcSyntaxOp MCompOrigin then_op [SynRho, SynRho] res_ty $                \ [rhs_ty, new_res_ty] [rhs_mult, fun_mult] ->-               do { (rhs', guard_op')+               do { ((rhs', test_ty), guard_op')                       <- tcScalingUsage rhs_mult $                          tcSyntaxOp MCompOrigin guard_op [SynAny]                                     (mkCheckExpType rhs_ty) $-                         \ [test_ty] [test_mult] ->-                         tcScalingUsage test_mult $ tcCheckMonoExpr rhs test_ty+                         \ [test_ty] [test_mult] -> do+                           rhs' <- tcScalingUsage test_mult $ tcCheckMonoExpr rhs test_ty+                           return $ (rhs', test_ty)                   ; thing <- tcScalingUsage fun_mult $ thing_inside (mkCheckExpType new_res_ty)-                  ; return (thing, rhs', rhs_ty, guard_op') }+                  ; return (thing, rhs', rhs_ty, new_res_ty, test_ty, guard_op') }++        ; hasFixedRuntimeRep_syntactic FRRBodyStmtGuard test_ty+        ; hasFixedRuntimeRep_syntactic (FRRBodyStmt MonadComprehension 1) rhs_ty+        ; hasFixedRuntimeRep_syntactic (FRRBodyStmt MonadComprehension 2) new_res_ty+         ; return (BodyStmt rhs_ty rhs' then_op' guard_op', thing) }  -- Grouping statements@@ -845,14 +864,16 @@                 -- This level of generality is needed for using do-notation                 -- in full generality; see #1537 -          ((rhs', pat_mult, pat', new_res_ty, thing), bind_op')+          ((rhs_ty, rhs', pat_mult, pat', new_res_ty, thing), bind_op')             <- tcSyntaxOp DoOrigin (xbsrn_bindOp xbsrn) [SynRho, SynFun SynAny SynRho] res_ty $                 \ [rhs_ty, pat_ty, new_res_ty] [rhs_mult,fun_mult,pat_mult] ->                 do { rhs' <-tcScalingUsage rhs_mult $ tcCheckMonoExprNC rhs rhs_ty                    ; (pat', thing) <- tcScalingUsage fun_mult $ tcCheckPat (StmtCtxt ctxt) pat (Scaled pat_mult pat_ty) $                                       thing_inside (mkCheckExpType new_res_ty)-                   ; return (rhs', pat_mult, pat', new_res_ty, thing) }+                   ; return (rhs_ty, rhs', pat_mult, pat', new_res_ty, thing) } +        ; hasFixedRuntimeRep_syntactic (FRRBindStmt DoNotation) rhs_ty+         -- If (but only if) the pattern can fail, typecheck the 'fail' operator         ; fail_op' <- fmap join . forM (xbsrn_failOp xbsrn) $ \fail ->             tcMonadFailOp (DoPatOrigin pat) pat' fail new_res_ty@@ -879,12 +900,14 @@ tcDoStmt _ (BodyStmt _ rhs then_op _) res_ty thing_inside   = do  {       -- Deal with rebindable syntax;                 --   (>>) :: rhs_ty -> new_res_ty -> res_ty-        ; ((rhs', rhs_ty, thing), then_op')+        ; ((rhs', rhs_ty, new_res_ty, thing), then_op')             <- tcSyntaxOp DoOrigin then_op [SynRho, SynRho] res_ty $                \ [rhs_ty, new_res_ty] [rhs_mult,fun_mult] ->                do { rhs' <- tcScalingUsage rhs_mult $ tcCheckMonoExprNC rhs rhs_ty                   ; thing <- tcScalingUsage fun_mult $ thing_inside (mkCheckExpType new_res_ty)-                  ; return (rhs', rhs_ty, thing) }+                  ; return (rhs', rhs_ty, new_res_ty, thing) }+        ; hasFixedRuntimeRep_syntactic (FRRBodyStmt DoNotation 1) rhs_ty+        ; hasFixedRuntimeRep_syntactic (FRRBodyStmt DoNotation 2) new_res_ty         ; return (BodyStmt rhs_ty rhs' then_op' noSyntaxExpr, thing) }  tcDoStmt ctxt (RecStmt { recS_stmts = L l stmts, recS_later_ids = later_names@@ -1000,7 +1023,7 @@ -}  tcApplicativeStmts-  :: HsStmtContext GhcRn+  :: HsStmtContext GhcTc   -> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]   -> ExpRhoType                         -- rhs_ty   -> (TcRhoType -> TcM t)               -- thing_inside@@ -1068,10 +1091,10 @@      goArg _body_ty (ApplicativeArgMany x stmts ret pat ctxt, pat_ty, exp_ty)       = do { (stmts', (ret',pat')) <--                tcStmtsAndThen ctxt tcDoStmt stmts (mkCheckExpType exp_ty) $+                tcStmtsAndThen (HsDoStmt ctxt) tcDoStmt stmts (mkCheckExpType exp_ty) $                 \res_ty  -> do                   { ret'      <- tcExpr ret res_ty-                  ; (pat', _) <- tcCheckPat (StmtCtxt ctxt) pat (unrestricted pat_ty) $+                  ; (pat', _) <- tcCheckPat (StmtCtxt (HsDoStmt ctxt)) pat (unrestricted pat_ty) $                                  return ()                   ; return (ret', pat')                   }@@ -1114,22 +1137,35 @@ *                                                                      * ************************************************************************ -@sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same+@checkArgCounts@ takes a @[RenamedMatch]@ and decides whether the same number of args are used in each equation. -} -checkArgs :: AnnoBody body-          => Name -> MatchGroup GhcRn (LocatedA (body GhcRn)) -> TcM ()-checkArgs _ (MG { mg_alts = L _ [] })+checkArgCounts :: AnnoBody body+               => Name -> MatchGroup GhcRn (LocatedA (body GhcRn)) -> TcM ()+checkArgCounts = check_match_pats . (text "Equations for" <+>) . quotes . ppr++-- @checkPatCounts@ takes a @[RenamedMatch]@ and decides whether the same+-- number of patterns are used in each alternative+checkPatCounts :: AnnoBody body+               => HsMatchContext GhcTc -> MatchGroup GhcRn (LocatedA (body GhcRn))+               -> TcM ()+checkPatCounts = check_match_pats . pprMatchContextNouns++check_match_pats :: AnnoBody body+                 => SDoc -> MatchGroup GhcRn (LocatedA (body GhcRn))+                 -> TcM ()+check_match_pats _ (MG { mg_alts = L _ [] })     = return ()-checkArgs fun (MG { mg_alts = L _ (match1:matches) })+check_match_pats err_msg (MG { mg_alts = L _ (match1:matches) })     | null bad_matches     = return ()     | otherwise-    = failWithTc (vcat [ text "Equations for" <+> quotes (ppr fun) <+>-                         text "have different numbers of arguments"-                       , nest 2 (ppr (getLocA match1))-                       , nest 2 (ppr (getLocA (head bad_matches)))])+    = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $+      (vcat [ err_msg <+>+              text "have different numbers of arguments"+            , nest 2 (ppr (getLocA match1))+            , nest 2 (ppr (getLocA (head bad_matches)))])   where     n_args1 = args_in_match match1     bad_matches = [m | m <- matches, args_in_match m /= n_args1]
compiler/GHC/Tc/Gen/Match.hs-boot view
@@ -1,17 +1,17 @@ module GHC.Tc.Gen.Match where import GHC.Hs           ( GRHSs, MatchGroup, LHsExpr ) import GHC.Tc.Types.Evidence  ( HsWrapper )-import GHC.Types.Name   ( Name ) import GHC.Tc.Utils.TcType( ExpSigmaType, ExpRhoType ) import GHC.Tc.Types     ( TcM ) import GHC.Hs.Extension ( GhcRn, GhcTc ) import GHC.Parser.Annotation ( LocatedN )+import GHC.Types.Id (Id)  tcGRHSsPat    :: GRHSs GhcRn (LHsExpr GhcRn)               -> ExpRhoType               -> TcM (GRHSs GhcTc (LHsExpr GhcTc)) -tcMatchesFun :: LocatedN Name+tcMatchesFun :: LocatedN Id              -> MatchGroup GhcRn (LHsExpr GhcRn)              -> ExpSigmaType              -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
compiler/GHC/Tc/Gen/Pat.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-}@@ -21,28 +21,29 @@    , tcCheckPat, tcCheckPat_O, tcInferPat    , tcPats    , addDataConStupidTheta-   , badFieldCon    , polyPatSig    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import {-# SOURCE #-}   GHC.Tc.Gen.Expr( tcSyntaxOp, tcSyntaxOpGen, tcInferRho )  import GHC.Hs+import GHC.Hs.Syn.Type import GHC.Rename.Utils+import GHC.Tc.Errors.Types import GHC.Tc.Utils.Zonk import GHC.Tc.Gen.Sig( TcPragEnv, lookupPragEnv, addInlinePrags ) import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Instantiate+import GHC.Types.Error import GHC.Types.Id import GHC.Types.Var import GHC.Types.Name import GHC.Types.Name.Reader import GHC.Core.Multiplicity+import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) import GHC.Tc.Utils.Env import GHC.Tc.Utils.TcMType import GHC.Tc.Validity( arityErr )@@ -66,6 +67,7 @@ import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import qualified GHC.LanguageExtensions as LangExt import Control.Arrow  ( second ) import Control.Monad@@ -81,7 +83,7 @@  tcLetPat :: (Name -> Maybe TcId)          -> LetBndrSpec-         -> LPat GhcRn -> Scaled ExpSigmaType+         -> LPat GhcRn -> Scaled ExpSigmaTypeFRR          -> TcM a          -> TcM (LPat GhcTc, a) tcLetPat sig_fn no_gen pat pat_ty thing_inside@@ -96,10 +98,10 @@        ; tc_lpat pat_ty penv pat thing_inside }  ------------------tcPats :: HsMatchContext GhcRn-       -> [LPat GhcRn]            -- Patterns,-       -> [Scaled ExpSigmaType]         --   and their types-       -> TcM a                  --   and the checker for the body+tcPats :: HsMatchContext GhcTc+       -> [LPat GhcRn]             -- ^ atterns+       -> [Scaled ExpSigmaTypeFRR] -- ^ types of the patterns+       -> TcM a                    -- ^ checker for the body        -> TcM ([LPat GhcTc], a)  -- This is the externally-callable wrapper function@@ -118,25 +120,27 @@   where     penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin } -tcInferPat :: HsMatchContext GhcRn -> LPat GhcRn+tcInferPat :: FixedRuntimeRepContext+           -> HsMatchContext GhcTc+           -> LPat GhcRn            -> TcM a-           -> TcM ((LPat GhcTc, a), TcSigmaType)-tcInferPat ctxt pat thing_inside-  = tcInfer $ \ exp_ty ->+           -> TcM ((LPat GhcTc, a), TcSigmaTypeFRR)+tcInferPat frr_orig ctxt pat thing_inside+  = tcInferFRR frr_orig $ \ exp_ty ->     tc_lpat (unrestricted exp_ty) penv pat thing_inside  where     penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin } -tcCheckPat :: HsMatchContext GhcRn-           -> LPat GhcRn -> Scaled TcSigmaType+tcCheckPat :: HsMatchContext GhcTc+           -> LPat GhcRn -> Scaled TcSigmaTypeFRR            -> TcM a                     -- Checker for body            -> TcM (LPat GhcTc, a) tcCheckPat ctxt = tcCheckPat_O ctxt PatOrigin  -- | A variant of 'tcPat' that takes a custom origin-tcCheckPat_O :: HsMatchContext GhcRn+tcCheckPat_O :: HsMatchContext GhcTc              -> CtOrigin              -- ^ origin to use if the type needs inst'ing-             -> LPat GhcRn -> Scaled TcSigmaType+             -> LPat GhcRn -> Scaled TcSigmaTypeFRR              -> TcM a                 -- Checker for body              -> TcM (LPat GhcTc, a) tcCheckPat_O ctxt orig pat (Scaled pat_mult pat_ty) thing_inside@@ -161,7 +165,7 @@  data PatCtxt   = LamPat   -- Used for lambdas, case etc-       (HsMatchContext GhcRn)+       (HsMatchContext GhcTc)    | LetPat   -- Used only for let(rec) pattern bindings              -- See Note [Typing patterns in pattern bindings]@@ -202,7 +206,7 @@ *                                                                      * ********************************************************************* -} -tcPatBndr :: PatEnv -> Name -> Scaled ExpSigmaType -> TcM (HsWrapper, TcId)+tcPatBndr :: PatEnv -> Name -> Scaled ExpSigmaTypeFRR -> TcM (HsWrapper, TcId) -- (coi, xp) = tcPatBndr penv x pat_ty -- Then coi : pat_ty ~ typeof(xp) --@@ -222,7 +226,7 @@   | otherwise                          -- No signature   = do { (co, bndr_ty) <- case scaledThing exp_pat_ty of              Check pat_ty    -> promoteTcType bind_lvl pat_ty-             Infer infer_res -> ASSERT( bind_lvl == ir_lvl infer_res )+             Infer infer_res -> assert (bind_lvl == ir_lvl infer_res) $                                 -- If we were under a constructor that bumped the                                 -- level, we'd be in checking mode (see tcConArg)                                 -- hence this assertion@@ -322,14 +326,14 @@                                    setErrCtxt err_ctxt $                                    loop penv args                 -- setErrCtxt: restore context before doing the next pattern-                -- See note [Nesting] above+                -- See Note [Nesting] above                       ; return (p':ps', res) }          ; loop penv args }  ---------------------tc_lpat :: Scaled ExpSigmaType+tc_lpat :: Scaled ExpSigmaTypeFRR         -> Checker (LPat GhcRn) (LPat GhcTc) tc_lpat pat_ty penv (L span pat) thing_inside   = setSrcSpanA span $@@ -337,10 +341,10 @@                                           thing_inside         ; return (L span pat', res) } -tc_lpats :: [Scaled ExpSigmaType]+tc_lpats :: [Scaled ExpSigmaTypeFRR]          -> Checker [LPat GhcRn] [LPat GhcTc] tc_lpats tys penv pats-  = ASSERT2( equalLength pats tys, ppr pats $$ ppr tys )+  = assertPpr (equalLength pats tys) (ppr pats $$ ppr tys) $     tcMultiple (\ penv' (p,t) -> tc_lpat t penv' p)                penv                (zipEqual "tc_lpats" pats tys)@@ -350,7 +354,7 @@ checkManyPattern :: Scaled a -> TcM HsWrapper checkManyPattern pat_ty = tcSubMult NonLinearPatternOrigin Many (scaledMult pat_ty) -tc_pat  :: Scaled ExpSigmaType+tc_pat  :: Scaled ExpSigmaTypeFRR         -- ^ Fully refined result type         -> Checker (Pat GhcRn) (Pat GhcTc)         -- ^ Translated pattern@@ -365,9 +369,9 @@         ; pat_ty <- readExpType (scaledThing pat_ty)         ; return (mkHsWrapPat (wrap <.> mult_wrap) (VarPat x (L l id)) pat_ty, res) } -  ParPat x pat -> do+  ParPat x lpar pat rpar -> do         { (pat', res) <- tc_lpat pat_ty penv pat thing_inside-        ; return (ParPat x pat', res) }+        ; return (ParPat x lpar pat' rpar, res) }    BangPat x pat -> do         { (pat', res) <- tc_lpat pat_ty penv pat thing_inside@@ -428,9 +432,9 @@                -- Note [View patterns and polymorphism]           -- Expression must be a function-        ; let herald = text "A view pattern expression expects"+        ; let herald = ExpectedFunTyViewPat $ unLoc expr         ; (expr_wrap1, Scaled _mult inf_arg_ty, inf_res_sigma)-            <- matchActualFunTySigma herald (Just (ppr expr)) (1,[]) expr_ty+            <- matchActualFunTySigma herald (Just . HsExprRnThing $ unLoc expr) (1,[]) expr_ty                -- See Note [View patterns and polymorphism]                -- expr_wrap1 :: expr_ty "->" (inf_arg_ty -> inf_res_sigma) @@ -444,13 +448,16 @@         ; let Scaled w h_pat_ty = pat_ty         ; pat_ty <- readExpType h_pat_ty         ; let expr_wrap2' = mkWpFun expr_wrap2 idHsWrapper-                                    (Scaled w pat_ty) inf_res_sigma doc-               -- expr_wrap2' :: (inf_arg_ty -> inf_res_sigma) "->"-               --                (pat_ty -> inf_res_sigma)+                              (Scaled w pat_ty) inf_res_sigma+          -- expr_wrap2' :: (inf_arg_ty -> inf_res_sigma) "->"+          --                (pat_ty -> inf_res_sigma)+          -- NB: pat_ty comes from matchActualFunTySigma, so it has a+          -- fixed RuntimeRep, as needed to call mkWpFun.+        ; let               expr_wrap = expr_wrap2' <.> expr_wrap1 <.> mult_wrap-              doc = text "When checking the view pattern function:" <+> (ppr expr)-        ; return (ViewPat pat_ty (mkLHsWrap expr_wrap expr') pat', res)} +        ; return $ (ViewPat pat_ty (mkLHsWrap expr_wrap expr') pat', res) }+ {- Note [View patterns and polymorphism] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this exotic example:@@ -466,7 +473,7 @@  Then, when taking that arrow apart we want to get a *sigma* type (forall b. b->(Int,b)), because that's what we want to bind 'x' to.-Fortunately that's what matchExpectedFunTySigma returns anyway.+Fortunately that's what matchActualFunTySigma returns anyway. -}  -- Type signatures in patterns@@ -486,25 +493,16 @@  ------------------------ -- Lists, tuples, arrays-  ListPat Nothing pats -> do++  -- Necessarily a built-in list pattern, not an overloaded list pattern.+  -- See Note [Desugaring overloaded list patterns].+  ListPat _ pats -> do         { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv (scaledThing pat_ty)         ; (pats', res) <- tcMultiple (tc_lpat (pat_ty `scaledSet` mkCheckExpType elt_ty))                                      penv pats thing_inside         ; pat_ty <- readExpType (scaledThing pat_ty)         ; return (mkHsWrapPat coi-                         (ListPat (ListPatTc elt_ty Nothing) pats') pat_ty, res)-}--  ListPat (Just e) pats -> do-        { tau_pat_ty <- expTypeToType (scaledThing pat_ty)-        ; ((pats', res, elt_ty), e')-            <- tcSyntaxOpGen ListOrigin e [SynType (mkCheckExpType tau_pat_ty)]-                                          SynList $-                 \ [elt_ty] _ ->-                 do { (pats', res) <- tcMultiple (tc_lpat (pat_ty `scaledSet` mkCheckExpType elt_ty))-                                                 penv pats thing_inside-                    ; return (pats', res, elt_ty) }-        ; return (ListPat (ListPatTc elt_ty (Just (tau_pat_ty,e'))) pats', res)+                         (ListPat elt_ty pats') pat_ty, res) }    TuplePat _ pats boxity -> do@@ -537,8 +535,8 @@                 | otherwise        = unmangled_result          ; pat_ty <- readExpType (scaledThing pat_ty)-        ; ASSERT( con_arg_tys `equalLength` pats ) -- Syntactically enforced-          return (mkHsWrapPat coi possibly_mangled_result pat_ty, res)+        ; massert (con_arg_tys `equalLength` pats) -- Syntactically enforced+        ; return (mkHsWrapPat coi possibly_mangled_result pat_ty, res)         }    SumPat _ pat alt arity  -> do@@ -662,6 +660,7 @@                   ; return (lit2', wrap, bndr_id) }          ; pat_ty <- readExpType pat_exp_ty+         -- The Report says that n+k patterns must be in Integral         -- but it's silly to insist on this in the RebindableSyntax case         ; unlessM (xoptM LangExt.RebindableSyntax) $@@ -696,6 +695,9 @@       ; tc_pat pat_ty penv pat thing_inside }     _ -> panic "invalid splice in splice pat" +  XPat (HsPatExpanded lpat rpat) -> do+    { (rpat', res) <- tc_pat pat_ty penv rpat thing_inside+    ; return (XPat $ ExpansionPat lpat rpat', res) }  {- Note [Hopping the LIE in lazy patterns]@@ -774,9 +776,10 @@                                           2 (ppr res_ty)) ]             ; return (tidy_env, msg) } -patBindSigErr :: [(Name,TcTyVar)] -> SDoc+patBindSigErr :: [(Name,TcTyVar)] -> TcRnMessage patBindSigErr sig_tvs-  = hang (text "You cannot bind scoped type variable" <> plural sig_tvs+  = TcRnUnknownMessage $ mkPlainError noHints $+    hang (text "You cannot bind scoped type variable" <> plural sig_tvs           <+> pprQuotedList (map fst sig_tvs))        2 (text "in a pattern binding signature") @@ -856,7 +859,7 @@ --       with scrutinee of type (T ty)  tcConPat :: PatEnv -> LocatedN Name-         -> Scaled ExpSigmaType    -- Type of the pattern+         -> Scaled ExpSigmaTypeFRR    -- Type of the pattern          -> HsConPatDetails GhcRn -> TcM a          -> TcM (Pat GhcTc, a) tcConPat penv con_lname@(L _ con_name) pat_ty arg_pats thing_inside@@ -868,8 +871,21 @@                                              pat_ty arg_pats thing_inside         } +-- Warn when pattern matching on a GADT or a pattern synonym+-- when MonoLocalBinds is off.+warnMonoLocalBinds :: TcM ()+warnMonoLocalBinds+  = do { mono_local_binds <- xoptM LangExt.MonoLocalBinds+       ; unless mono_local_binds $+           addDiagnostic TcRnGADTMonoLocalBinds+           -- We used to require the GADTs or TypeFamilies extension+           -- to pattern match on a GADT (#2905, #7156)+           --+           -- In #20485 this was made into a warning.+       }+ tcDataConPat :: PatEnv -> LocatedN Name -> DataCon-             -> Scaled ExpSigmaType        -- Type of the pattern+             -> Scaled ExpSigmaTypeFRR        -- Type of the pattern              -> HsConPatDetails GhcRn -> TcM a              -> TcM (Pat GhcTc, a) tcDataConPat penv (L con_span con_name) data_con pat_ty_scaled@@ -899,25 +915,42 @@                   -- We want to create a well-kinded substitution, so                   -- that the instantiated type is well-kinded -        ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX tenv1 ex_tvs+        ; let mc = case pe_ctxt penv of+                     LamPat mc -> mc+                     LetPat {} -> PatBindRhs+        ; skol_info <- mkSkolemInfo (PatSkol (RealDataCon data_con) mc)+        ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX skol_info tenv1 ex_tvs                      -- Get location from monad, not from ex_tvs                      -- This freshens: See Note [Freshen existentials]-                     -- Why "super"? See Note [Binding when lookup up instances]+                     -- Why "super"? See Note [Binding when looking up instances]                      -- in GHC.Core.InstEnv.          ; let arg_tys' = substScaledTys tenv arg_tys               pat_mult = scaledMult pat_ty_scaled               arg_tys_scaled = map (scaleScaled pat_mult) arg_tys' -        ; traceTc "tcConPat" (vcat [ ppr con_name-                                   , pprTyVars univ_tvs-                                   , pprTyVars ex_tvs-                                   , ppr eq_spec-                                   , ppr theta-                                   , pprTyVars ex_tvs'-                                   , ppr ctxt_res_tys-                                   , ppr arg_tys'-                                   , ppr arg_pats ])+        -- This check is necessary to uphold the invariant that 'tcConArgs'+        -- is given argument types with a fixed runtime representation.+        -- See test case T20363.+        ; zipWithM_+            ( \ i arg_sty ->+              hasFixedRuntimeRep_syntactic+                (FRRDataConArg Pattern data_con i)+                (scaledThing arg_sty)+            )+            [1..]+            arg_tys'++        ; traceTc "tcConPat" (vcat [ text "con_name:" <+> ppr con_name+                                   , text "univ_tvs:" <+> pprTyVars univ_tvs+                                   , text "ex_tvs:" <+> pprTyVars ex_tvs+                                   , text "eq_spec:" <+> ppr eq_spec+                                   , text "theta:" <+> ppr theta+                                   , text "ex_tvs':" <+> pprTyVars ex_tvs'+                                   , text "ctxt_res_tys:" <+> ppr ctxt_res_tys+                                   , text "pat_ty:" <+> ppr pat_ty+                                   , text "arg_tys':" <+> ppr arg_tys'+                                   , text "arg_pats" <+> ppr arg_pats ])         ; if null ex_tvs && null eq_spec && null theta           then do { -- The common case; no class bindings etc                     -- (see Note [Arrows and patterns])@@ -940,24 +973,12 @@         { let theta'     = substTheta tenv (eqSpecPreds eq_spec ++ theta)                            -- order is *important* as we generate the list of                            -- dictionary binders from theta'-              no_equalities = null eq_spec && not (any isEqPred theta)-              skol_info = PatSkol (RealDataCon data_con) mc-              mc = case pe_ctxt penv of-                     LamPat mc -> mc-                     LetPat {} -> PatBindRhs -        ; gadts_on    <- xoptM LangExt.GADTs-        ; families_on <- xoptM LangExt.TypeFamilies-        ; checkTc (no_equalities || gadts_on || families_on)-                  (text "A pattern match on a GADT requires the" <+>-                   text "GADTs or TypeFamilies language extension")-                  -- #2905 decided that a *pattern-match* of a GADT-                  -- should require the GADT language flag.-                  -- Re TypeFamilies see also #7156+        ; when (not (null eq_spec) || any isEqPred theta) warnMonoLocalBinds          ; given <- newEvVars theta'         ; (ev_binds, (arg_pats', res))-             <- checkConstraints skol_info ex_tvs' given $+             <- checkConstraints (getSkolemInfo skol_info) ex_tvs' given $                 tcConArgs (RealDataCon data_con) arg_tys_scaled tenv penv arg_pats thing_inside          ; let res_pat = ConPat@@ -975,7 +996,7 @@         } }  tcPatSynPat :: PatEnv -> LocatedN Name -> PatSyn-            -> Scaled ExpSigmaType         -- Type of the pattern+            -> Scaled ExpSigmaType         -- ^ Type of the pattern             -> HsConPatDetails GhcRn -> TcM a             -> TcM (Pat GhcTc, a) tcPatSynPat penv (L con_span con_name) pat_syn pat_ty arg_pats thing_inside@@ -988,7 +1009,11 @@         ; let all_arg_tys = ty : prov_theta ++ (map scaledThing arg_tys)         ; checkGADT (PatSynCon pat_syn) ex_tvs all_arg_tys penv -        ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX subst ex_tvs+        ; skol_info <- case pe_ctxt penv of+                            LamPat mc -> mkSkolemInfo (PatSkol (PatSynCon pat_syn) mc)+                            LetPat {} -> return unkSkol -- Doesn't matter++        ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX skol_info subst ex_tvs            -- This freshens: Note [Freshen existentials]          ; let ty'         = substTy tenv ty@@ -998,6 +1023,8 @@               prov_theta' = substTheta tenv prov_theta               req_theta'  = substTheta tenv req_theta +        ; when (any isEqPred prov_theta) warnMonoLocalBinds+         ; mult_wrap <- checkManyPattern pat_ty             -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. @@ -1012,18 +1039,28 @@          ; prov_dicts' <- newEvVars prov_theta' -        ; let skol_info = case pe_ctxt penv of-                            LamPat mc -> PatSkol (PatSynCon pat_syn) mc-                            LetPat {} -> UnkSkol -- Doesn't matter          ; req_wrap <- instCall (OccurrenceOf con_name) (mkTyVarTys univ_tvs') req_theta'                       -- Origin (OccurrenceOf con_name):                       -- see Note [Call-stack tracing of pattern synonyms]         ; traceTc "instCall" (ppr req_wrap) +          -- Pattern synonyms can never have representation-polymorphic argument types,+          -- as checked in 'GHC.Tc.Gen.Sig.tcPatSynSig' (see use of 'FixedRuntimeRepPatSynSigArg')+          -- and 'GHC.Tc.TyCl.PatSyn.tcInferPatSynDecl'.+          -- (If you want to lift this restriction, use 'hasFixedRuntimeRep' here, to match+          -- 'tcDataConPat'.)+        ; let+            bad_arg_tys :: [(Int, Scaled Type)]+            bad_arg_tys = filter (\ (_, Scaled _ arg_ty) -> typeLevity_maybe arg_ty == Nothing)+                        $ zip [0..] arg_tys'+        ; massertPpr (null bad_arg_tys) $+            vcat [ text "tcPatSynPat: pattern arguments do not have a fixed RuntimeRep"+                 , text "bad_arg_tys:" <+> ppr bad_arg_tys ]+         ; traceTc "checkConstraints {" Outputable.empty         ; (ev_binds, (arg_pats', res))-             <- checkConstraints skol_info ex_tvs' prov_dicts' $+             <- checkConstraints (getSkolemInfo skol_info) ex_tvs' prov_dicts' $                 tcConArgs (PatSynCon pat_syn) arg_tys_scaled tenv penv arg_pats thing_inside          ; traceTc "checkConstraints }" (ppr ev_binds)@@ -1061,12 +1098,12 @@ whose Origin is (OccurrenceOf f).  See also Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence-and Note [Solving CallStack constraints] in GHC.Tc.Solver.Monad+and Note [Solving CallStack constraints] in GHC.Tc.Solver.Types -} ---------------------------- -- | Convenient wrapper for calling a matchExpectedXXX function matchExpectedPatTy :: (TcRhoType -> TcM (TcCoercionN, a))-                    -> PatEnv -> ExpSigmaType -> TcM (HsWrapper, a)+                    -> PatEnv -> ExpSigmaTypeFRR -> TcM (HsWrapper, a) -- See Note [Matching polytyped patterns] -- Returns a wrapper : pat_ty ~R inner_ty matchExpectedPatTy inner_match (PE { pe_orig = orig }) pat_ty@@ -1078,13 +1115,14 @@  ---------------------------- matchExpectedConTy :: PatEnv-                   -> TyCon      -- The TyCon that this data-                                 -- constructor actually returns-                                 -- In the case of a data family this is-                                 -- the /representation/ TyCon-                   -> Scaled ExpSigmaType  -- The type of the pattern; in the-                                           -- case of a data family this would-                                           -- mention the /family/ TyCon+                   -> TyCon+                       -- ^ The TyCon that this data constructor actually returns.+                       -- In the case of a data family, this is+                       -- the /representation/ TyCon.+                   -> Scaled ExpSigmaTypeFRR+                       -- ^ The type of the pattern.+                       -- In the case of a data family, this would+                       -- mention the /family/ TyCon                    -> TcM (HsWrapper, [TcSigmaType]) -- See Note [Matching constructor patterns] -- Returns a wrapper : pat_ty "->" T ty1 ... tyn@@ -1182,8 +1220,8 @@   these unifications.  The *only* thing the unification does is   to side-effect those unification variables, so that we know   what type x and y stand for; and cause an error if the equality-  is not soluble.  It's a bit like a Derived constraint arising-  from a functional dependency.+  is not soluble.  It's a bit like a constraint arising+  from a functional dependency, where we don't use the evidence.  * Exactly the same works for existential arguments      data T where@@ -1205,7 +1243,7 @@ -}  tcConArgs :: ConLike-          -> [Scaled TcSigmaType]+          -> [Scaled TcSigmaTypeFRR]           -> TCvSubst            -- Instantiating substitution for constructor type           -> Checker (HsConPatDetails GhcRn) (HsConPatDetails GhcTc) tcConArgs con_like arg_tys tenv penv con_args thing_inside = case con_args of@@ -1213,9 +1251,11 @@         { checkTc (con_arity == no_of_args)     -- Check correct arity                   (arityErr (text "constructor") con_like con_arity no_of_args) -        ; let con_binders = conLikeUserTyVarBinders con_like-        ; checkTc (type_args `leLength` con_binders)-                  (conTyArgArityErr con_like (length con_binders) (length type_args))+              -- forgetting to filter out inferred binders led to #20443+        ; let con_spec_binders = filter ((== SpecifiedSpec) . binderArgFlag) $+                                 conLikeUserTyVarBinders con_like+        ; checkTc (type_args `leLength` con_spec_binders)+                  (conTyArgArityErr con_like (length con_spec_binders) (length type_args))          ; let pats_w_tys = zipEqual "tcConArgs" arg_pats arg_tys         ; (type_args', (arg_pats', res))@@ -1225,7 +1265,7 @@           -- This unification is straight from Figure 7 of           -- "Type Variables in Patterns", Haskell'18         ; _ <- zipWithM (unifyType Nothing) type_args' (substTyVars tenv $-                                                        binderVars con_binders)+                                                        binderVars con_spec_binders)           -- OK to drop coercions here. These unifications are all about           -- guiding inference based on a user-written type annotation           -- See Note [Typechecking type applications in patterns]@@ -1252,13 +1292,13 @@       tc_field :: Checker (LHsRecField GhcRn (LPat GhcRn))                           (LHsRecField GhcTc (LPat GhcTc))       tc_field penv-               (L l (HsRecField ann (L loc (FieldOcc sel (L lr rdr))) pat pun))+               (L l (HsFieldBind ann (L loc (FieldOcc sel (L lr rdr))) pat pun))                thing_inside         = do { sel'   <- tcLookupId sel-             ; pat_ty <- setSrcSpan loc $ find_field_ty sel+             ; pat_ty <- setSrcSpanA loc $ find_field_ty sel                                             (occNameFS $ rdrNameOcc rdr)              ; (pat', res) <- tcConArg penv (pat, pat_ty) thing_inside-             ; return (L l (HsRecField ann (L loc (FieldOcc sel' (L lr rdr))) pat'+             ; return (L l (HsFieldBind ann (L loc (FieldOcc sel' (L lr rdr))) pat'                                                                         pun), res) }  @@ -1272,12 +1312,12 @@                 --      f (R { foo = (a,b) }) = a+b                 -- If foo isn't one of R's fields, we don't want to crash when                 -- typechecking the "a+b".-           [] -> failWith (badFieldCon con_like lbl)+           [] -> failWith (badFieldConErr (getName con_like) lbl)                  -- The normal case, when the field comes from the right constructor            (pat_ty : extras) -> do                 traceTc "find_field" (ppr pat_ty <+> ppr extras)-                ASSERT( null extras ) (return pat_ty)+                assert (null extras) (return pat_ty)        field_tys :: [(FieldLabel, Scaled TcType)]       field_tys = zip (conLikeFieldLabels con_like) arg_tys@@ -1295,7 +1335,8 @@                -- by the calls to unifyType in tcConArgs, which will also unify                -- kinds.        ; when (not (null sig_ibs) && inPatBind penv) $-           addErr (text "Binding type variables is not allowed in pattern bindings")+           addErr (TcRnUnknownMessage $ mkPlainError noHints $+                     text "Binding type variables is not allowed in pattern bindings")        ; result <- tcExtendNameTyVarEnv sig_wcs $                    tcExtendNameTyVarEnv sig_ibs $                    thing_inside@@ -1307,7 +1348,8 @@  addDataConStupidTheta :: DataCon -> [TcType] -> TcM () -- Instantiate the "stupid theta" of the data con, and throw--- the constraints into the constraint set+-- the constraints into the constraint set.+-- See Note [The stupid context] in GHC.Core.DataCon. addDataConStupidTheta data_con inst_tys   | null stupid_theta = return ()   | otherwise         = instStupidTheta origin inst_theta@@ -1325,9 +1367,10 @@ conTyArgArityErr :: ConLike                  -> Int   -- expected # of arguments                  -> Int   -- actual # of arguments-                 -> SDoc+                 -> TcRnMessage conTyArgArityErr con_like expected_number actual_number-  = text "Too many type arguments in constructor pattern for" <+> quotes (ppr con_like) $$+  = TcRnUnknownMessage $ mkPlainError noHints $+    text "Too many type arguments in constructor pattern for" <+> quotes (ppr con_like) $$     text "Expected no more than" <+> ppr expected_number <> semi <+> text "got" <+> ppr actual_number  {-@@ -1466,29 +1509,15 @@   PE { pe_ctxt = LamPat (ArrowMatchCtxt {}) }     | not $ isVanillaConLike conlike     -- See Note [Arrows and patterns]-    -> failWithTc existentialProcPat+    -> failWithTc TcRnArrowProcGADTPattern   PE { pe_lazy = True }     | has_existentials     -- See Note [Existential check]-    -> failWithTc existentialLazyPat+    -> failWithTc TcRnLazyGADTPattern   _ -> return ()   where     has_existentials :: Bool     has_existentials = any (`elemVarSet` tyCoVarsOfTypes arg_tys) ex_tvs--existentialLazyPat :: SDoc-existentialLazyPat-  = hang (text "An existential or GADT data constructor cannot be used")-       2 (text "inside a lazy (~) pattern")--existentialProcPat :: SDoc-existentialProcPat-  = text "Proc patterns cannot use existential or GADT data constructors"--badFieldCon :: ConLike -> FieldLabelString -> SDoc-badFieldCon con field-  = hsep [text "Constructor" <+> quotes (ppr con),-          text "does not have field", quotes (ppr field)]  polyPatSig :: TcType -> SDoc polyPatSig sig_ty
compiler/GHC/Tc/Gen/Rule.hs view
@@ -15,6 +15,7 @@ import GHC.Tc.Types import GHC.Tc.Utils.Monad import GHC.Tc.Solver+import GHC.Tc.Solver.Monad ( runTcS ) import GHC.Tc.Types.Constraint import GHC.Core.Predicate import GHC.Tc.Types.Origin@@ -28,9 +29,9 @@ import GHC.Core.Type import GHC.Core.TyCon( isTypeFamilyTyCon ) import GHC.Types.Id-import GHC.Types.Var( EvVar )+import GHC.Types.Var( EvVar, tyVarName ) import GHC.Types.Var.Set-import GHC.Types.Basic ( RuleName )+import GHC.Types.Basic ( RuleName, NonStandardDefaultingStrategy(..) ) import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Utils.Panic@@ -119,10 +120,10 @@                , rd_rhs  = rhs })   = addErrCtxt (ruleCtxt name)  $     do { traceTc "---- Rule ------" (pprFullRuleName rname)-+       ; skol_info <- mkSkolemInfo (RuleSkol name)         -- Note [Typechecking rules]        ; (tc_lvl, stuff) <- pushTcLevelM $-                            generateRuleConstraints ty_bndrs tm_bndrs lhs rhs+                            generateRuleConstraints name ty_bndrs tm_bndrs lhs rhs         ; let (id_bndrs, lhs', lhs_wanted                       , rhs', rhs_wanted, rule_ty) = stuff@@ -151,11 +152,20 @@         -- See Note [Re-quantify type variables in rules]        ; forall_tkvs <- candidateQTyVarsOfTypes (rule_ty : map idType tpl_ids)-       ; qtkvs <- quantifyTyVars forall_tkvs+       ; let don't_default = nonDefaultableTyVarsOfWC residual_lhs_wanted+       ; let weed_out = (`dVarSetMinusVarSet` don't_default)+             quant_cands = forall_tkvs { dv_kvs = weed_out (dv_kvs forall_tkvs)+                                       , dv_tvs = weed_out (dv_tvs forall_tkvs) }+       ; qtkvs <- quantifyTyVars skol_info DefaultNonStandardTyVars quant_cands        ; traceTc "tcRule" (vcat [ pprFullRuleName rname-                                , ppr forall_tkvs-                                , ppr qtkvs-                                , ppr rule_ty+                                , text "forall_tkvs:" <+> ppr forall_tkvs+                                , text "quant_cands:" <+> ppr quant_cands+                                , text "don't_default:" <+> ppr don't_default+                                , text "residual_lhs_wanted:" <+> ppr residual_lhs_wanted+                                , text "qtkvs:" <+> ppr qtkvs+                                , text "rule_ty:" <+> ppr rule_ty+                                , text "ty_bndrs:" <+> ppr ty_bndrs+                                , text "qtkvs ++ tpl_ids:" <+> ppr (qtkvs ++ tpl_ids)                                 , vcat [ ppr id <+> dcolon <+> ppr (idType id) | id <- tpl_ids ]                   ]) @@ -164,37 +174,35 @@        -- For the LHS constraints we must solve the remaining constraints        -- (a) so that we report insoluble ones        -- (b) so that we bind any soluble ones-       ; let skol_info = RuleSkol name-       ; (lhs_implic, lhs_binds) <- buildImplicationFor tc_lvl skol_info qtkvs+       ; (lhs_implic, lhs_binds) <- buildImplicationFor tc_lvl (getSkolemInfo skol_info) qtkvs                                          lhs_evs residual_lhs_wanted-       ; (rhs_implic, rhs_binds) <- buildImplicationFor tc_lvl skol_info qtkvs+       ; (rhs_implic, rhs_binds) <- buildImplicationFor tc_lvl (getSkolemInfo skol_info) qtkvs                                          lhs_evs rhs_wanted-        ; emitImplications (lhs_implic `unionBags` rhs_implic)        ; return $ HsRule { rd_ext = ext                          , rd_name = rname                          , rd_act = act                          , rd_tyvs = ty_bndrs -- preserved for ppr-ing-                         , rd_tmvs = map (noLoc . RuleBndr noAnn . noLocA)+                         , rd_tmvs = map (noLocA . RuleBndr noAnn . noLocA)                                          (qtkvs ++ tpl_ids)                          , rd_lhs  = mkHsDictLet lhs_binds lhs'                          , rd_rhs  = mkHsDictLet rhs_binds rhs' } } -generateRuleConstraints :: Maybe [LHsTyVarBndr () GhcRn] -> [LRuleBndr GhcRn]+generateRuleConstraints :: FastString+                        -> Maybe [LHsTyVarBndr () GhcRn] -> [LRuleBndr GhcRn]                         -> LHsExpr GhcRn -> LHsExpr GhcRn                         -> TcM ( [TcId]                                , LHsExpr GhcTc, WantedConstraints                                , LHsExpr GhcTc, WantedConstraints                                , TcType )-generateRuleConstraints ty_bndrs tm_bndrs lhs rhs+generateRuleConstraints rule_name ty_bndrs tm_bndrs lhs rhs   = do { ((tv_bndrs, id_bndrs), bndr_wanted) <- captureConstraints $-                                                tcRuleBndrs ty_bndrs tm_bndrs+                                                tcRuleBndrs rule_name ty_bndrs tm_bndrs               -- bndr_wanted constraints can include wildcard hole               -- constraints, which we should not forget about.               -- It may mention the skolem type variables bound by               -- the RULE.  c.f. #10072--       ; tcExtendTyVarEnv tv_bndrs $+       ; tcExtendNameTyVarEnv [(tyVarName tv, tv) | tv <- tv_bndrs] $          tcExtendIdEnv    id_bndrs $     do { -- See Note [Solve order for RULES]          ((lhs', rule_ty), lhs_wanted) <- captureConstraints (tcInferRho lhs)@@ -204,38 +212,39 @@        ; return (id_bndrs, lhs', all_lhs_wanted, rhs', rhs_wanted, rule_ty) } }  -- See Note [TcLevel in type checking rules]-tcRuleBndrs :: Maybe [LHsTyVarBndr () GhcRn] -> [LRuleBndr GhcRn]+tcRuleBndrs :: FastString -> Maybe [LHsTyVarBndr () GhcRn] -> [LRuleBndr GhcRn]             -> TcM ([TcTyVar], [Id])-tcRuleBndrs (Just bndrs) xs-  = do { (tybndrs1,(tys2,tms)) <- bindExplicitTKBndrs_Skol bndrs $-                                  tcRuleTmBndrs xs+tcRuleBndrs rule_name (Just bndrs) xs+  = do { skol_info <- mkSkolemInfo (RuleSkol rule_name)+       ; (tybndrs1,(tys2,tms)) <- bindExplicitTKBndrs_Skol skol_info bndrs $+                                  tcRuleTmBndrs rule_name xs        ; let tys1 = binderVars tybndrs1        ; return (tys1 ++ tys2, tms) } -tcRuleBndrs Nothing xs-  = tcRuleTmBndrs xs+tcRuleBndrs rule_name Nothing xs+  = tcRuleTmBndrs rule_name xs  -- See Note [TcLevel in type checking rules]-tcRuleTmBndrs :: [LRuleBndr GhcRn] -> TcM ([TcTyVar],[Id])-tcRuleTmBndrs [] = return ([],[])-tcRuleTmBndrs (L _ (RuleBndr _ (L _ name)) : rule_bndrs)+tcRuleTmBndrs :: FastString -> [LRuleBndr GhcRn] -> TcM ([TcTyVar],[Id])+tcRuleTmBndrs _ [] = return ([],[])+tcRuleTmBndrs rule_name (L _ (RuleBndr _ (L _ name)) : rule_bndrs)   = do  { ty <- newOpenFlexiTyVarTy-        ; (tyvars, tmvars) <- tcRuleTmBndrs rule_bndrs+        ; (tyvars, tmvars) <- tcRuleTmBndrs rule_name rule_bndrs         ; return (tyvars, mkLocalId name Many ty : tmvars) }-tcRuleTmBndrs (L _ (RuleBndrSig _ (L _ name) rn_ty) : rule_bndrs)+tcRuleTmBndrs rule_name (L _ (RuleBndrSig _ (L _ name) rn_ty) : rule_bndrs) --  e.g         x :: a->a --  The tyvar 'a' is brought into scope first, just as if you'd written --              a::*, x :: a->a --  If there's an explicit forall, the renamer would have already reported an --   error for each out-of-scope type variable used-  = do  { let ctxt = RuleSigCtxt name+  = do  { let ctxt = RuleSigCtxt rule_name name         ; (_ , tvs, id_ty) <- tcHsPatSigType ctxt HM_Sig rn_ty OpenKind         ; let id  = mkLocalId name Many id_ty                     -- See Note [Typechecking pattern signature binders] in GHC.Tc.Gen.HsType                -- The type variables scope over subsequent bindings; yuk         ; (tyvars, tmvars) <- tcExtendNameTyVarEnv tvs $-                                   tcRuleTmBndrs rule_bndrs+                                   tcRuleTmBndrs rule_name rule_bndrs         ; return (map snd tvs ++ tyvars, id : tmvars) }  ruleCtxt :: FastString -> SDoc@@ -403,7 +412,8 @@        ; lhs_clone <- cloneWC lhs_wanted        ; rhs_clone <- cloneWC rhs_wanted        ; setTcLevel tc_lvl $-         runTcSDeriveds    $+         discardResult     $+         runTcS            $          do { _ <- solveWanteds lhs_clone             ; _ <- solveWanteds rhs_clone                   -- Why do them separately?@@ -462,9 +472,9 @@   = float_wc emptyVarSet wc   where     float_wc :: TcTyCoVarSet -> WantedConstraints -> (Cts, WantedConstraints)-    float_wc skol_tvs (WC { wc_simple = simples, wc_impl = implics, wc_holes = holes })+    float_wc skol_tvs (WC { wc_simple = simples, wc_impl = implics, wc_errors = errs })       = ( simple_yes `andCts` implic_yes-        , emptyWC { wc_simple = simple_no, wc_impl = implics_no, wc_holes = holes })+        , emptyWC { wc_simple = simple_no, wc_impl = implics_no, wc_errors = errs })      where         (simple_yes, simple_no) = partitionBag (rule_quant_ct skol_tvs) simples         (implic_yes, implics_no) = mapAccumBagL (float_implic skol_tvs)@@ -478,12 +488,11 @@         new_skol_tvs = skol_tvs `extendVarSetList` ic_skols imp      rule_quant_ct :: TcTyCoVarSet -> Ct -> Bool-    rule_quant_ct skol_tvs ct-      | EqPred _ t1 t2 <- classifyPredType (ctPred ct)-      , not (ok_eq t1 t2)-       = False        -- Note [RULE quantification over equalities]-      | otherwise-      = tyCoVarsOfCt ct `disjointVarSet` skol_tvs+    rule_quant_ct skol_tvs ct = case classifyPredType (ctPred ct) of+      EqPred _ t1 t2+        | not (ok_eq t1 t2)+        -> False        -- Note [RULE quantification over equalities]+      _ -> tyCoVarsOfCt ct `disjointVarSet` skol_tvs      ok_eq t1 t2        | t1 `tcEqType` t2 = False
compiler/GHC/Tc/Gen/Sig.hs view
@@ -4,7 +4,7 @@  -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE TypeFamilies #-}  module GHC.Tc.Gen.Sig(@@ -15,6 +15,7 @@         isPartialSig, hasCompleteSig, tcIdSigName, tcSigInfoName,        completeSigPolyId_maybe, isCompleteHsSig,+       lhsSigWcTypeContextSpan, lhsSigTypeContextSpan,         tcTySigs, tcUserTypeSig, completeSigFromId,        tcInstSig,@@ -24,43 +25,51 @@        addInlinePrags, addInlinePragArity    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude +import GHC.Driver.Session+import GHC.Driver.Backend+ import GHC.Hs+++import GHC.Tc.Errors.Types ( FixedRuntimeRepProvenance(..), TcRnMessage(..) ) import GHC.Tc.Gen.HsType import GHC.Tc.Types import GHC.Tc.Solver( pushLevelAndSolveEqualitiesX, reportUnsolvedEqualities ) import GHC.Tc.Utils.Monad+import GHC.Tc.Utils.TcMType ( checkTypeHasFixedRuntimeRep ) import GHC.Tc.Utils.Zonk import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType-import GHC.Tc.Utils.TcMType import GHC.Tc.Validity ( checkValidType ) import GHC.Tc.Utils.Unify( tcTopSkolemise, unifyType ) import GHC.Tc.Utils.Instantiate( topInstantiate, tcInstTypeBndrs ) import GHC.Tc.Utils.Env( tcLookupId ) import GHC.Tc.Types.Evidence( HsWrapper, (<.>) )+ import GHC.Core( hasSomeUnfolding ) import GHC.Core.Type ( mkTyVarBinders ) import GHC.Core.Multiplicity -import GHC.Driver.Session-import GHC.Driver.Backend+import GHC.Types.Error import GHC.Types.Var ( TyVar, Specificity(..), tyVarKind, binderVars ) import GHC.Types.Id  ( Id, idName, idType, setInlinePragma                      , mkLocalId, realIdUnfolding )-import GHC.Builtin.Names( mkUnboundName ) import GHC.Types.Basic-import GHC.Unit.Module( getModule ) import GHC.Types.Name import GHC.Types.Name.Env-import GHC.Utils.Outputable-import GHC.Utils.Panic import GHC.Types.SrcLoc++import GHC.Builtin.Names( mkUnboundName )+import GHC.Unit.Module( getModule )+ import GHC.Utils.Misc as Utils ( singleton )+import GHC.Utils.Outputable+import GHC.Utils.Panic+ import GHC.Data.Maybe( orElse )+ import Data.Maybe( mapMaybe ) import Control.Monad( unless ) @@ -180,8 +189,8 @@  tcTySig :: LSig GhcRn -> TcM [TcSigInfo] tcTySig (L _ (IdSig _ id))-  = do { let ctxt = FunSigCtxt (idName id) False-                    -- False: do not report redundant constraints+  = do { let ctxt = FunSigCtxt (idName id) NoRRC+                    -- NoRRC: do not report redundant constraints                     -- The user has no control over the signature!              sig = completeSigFromId ctxt id        ; return [TcIdSig sig] }@@ -216,7 +225,7 @@ -- Nothing => Expression type signature   <expr> :: type tcUserTypeSig loc hs_sig_ty mb_name   | isCompleteHsSig hs_sig_ty-  = do { sigma_ty <- tcHsSigWcType ctxt_F hs_sig_ty+  = do { sigma_ty <- tcHsSigWcType ctxt_no_rrc hs_sig_ty        ; traceTc "tcuser" (ppr sigma_ty)        ; return $          CompleteSig { sig_bndr  = mkLocalId name Many sigma_ty@@ -225,27 +234,45 @@                                    -- anything, it is a top-level                                    -- definition. Which are all unrestricted in                                    -- the current implementation.-                     , sig_ctxt  = ctxt_T+                     , sig_ctxt  = ctxt_rrc  -- Report redundant constraints                      , sig_loc   = loc } }                        -- Location of the <type> in   f :: <type>    -- Partial sig with wildcards   | otherwise   = return (PartialSig { psig_name = name, psig_hs_ty = hs_sig_ty-                       , sig_ctxt = ctxt_F, sig_loc = loc })+                       , sig_ctxt = ctxt_no_rrc, sig_loc = loc })   where     name   = case mb_name of                Just n  -> n                Nothing -> mkUnboundName (mkVarOcc "<expression>")-    ctxt_F = case mb_name of-               Just n  -> FunSigCtxt n False-               Nothing -> ExprSigCtxt-    ctxt_T = case mb_name of-               Just n  -> FunSigCtxt n True-               Nothing -> ExprSigCtxt +    ctxt_rrc    = ctxt_fn (lhsSigWcTypeContextSpan hs_sig_ty)+    ctxt_no_rrc = ctxt_fn NoRRC +    ctxt_fn :: ReportRedundantConstraints -> UserTypeCtxt+    ctxt_fn rcc = case mb_name of+               Just n  -> FunSigCtxt n rcc+               Nothing -> ExprSigCtxt rcc +lhsSigWcTypeContextSpan :: LHsSigWcType GhcRn -> ReportRedundantConstraints+-- | Find the location of the top-level context of a HsType.  For example:+--+-- @+--   forall a b. (Eq a, Ord b) => blah+--               ^^^^^^^^^^^^^+-- @+-- If there is none, return Nothing+lhsSigWcTypeContextSpan (HsWC { hswc_body = sigType }) = lhsSigTypeContextSpan sigType++lhsSigTypeContextSpan :: LHsSigType GhcRn -> ReportRedundantConstraints+lhsSigTypeContextSpan (L _ HsSig { sig_body = sig_ty }) = go sig_ty+  where+    go (L _ (HsQualTy { hst_ctxt = L span _ })) = WantRRC $ locA span -- Found it!+    go (L _ (HsForAllTy { hst_body = hs_ty })) = go hs_ty  -- Look under foralls+    go (L _ (HsParTy _ hs_ty)) = go hs_ty  -- Look under parens+    go _ = NoRRC  -- Did not find it+ completeSigFromId :: UserTypeCtxt -> Id -> TcIdSigInfo -- Used for instance methods and record selectors completeSigFromId ctxt id@@ -274,7 +301,7 @@       HsListTy _ ty                  -> go ty       HsTupleTy _ _ tys              -> gos tys       HsSumTy _ tys                  -> gos tys-      HsOpTy _ ty1 _ ty2             -> go ty1 && go ty2+      HsOpTy _ _ ty1 _ ty2           -> go ty1 && go ty2       HsParTy _ ty                   -> go ty       HsIParamTy _ _ ty              -> go ty       HsKindSig _ ty kind            -> go ty && go kind@@ -287,7 +314,7 @@                  , hst_body = ty } -> no_anon_wc_tele tele                                         && go ty       HsQualTy { hst_ctxt = ctxt-               , hst_body = ty }  -> gos (fromMaybeContext ctxt) && go ty+               , hst_body = ty }  -> gos (unLoc ctxt) && go ty       HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)) -> go $ L noSrcSpanA ty       HsSpliceTy{} -> True       HsTyLit{} -> True@@ -379,12 +406,12 @@   , (ex_hs_tvbndrs, hs_prov, hs_body_ty) <- splitLHsSigmaTyInvis hs_ty1   = do { traceTc "tcPatSynSig 1" (ppr sig_ty) -       ; let skol_info = DataConSkol name+       ; skol_info <- mkSkolemInfo (DataConSkol name)        ; (tclvl, wanted, (outer_bndrs, (ex_bndrs, (req, prov, body_ty))))            <- pushLevelAndSolveEqualitiesX "tcPatSynSig"           $-                     -- See Note [solveEqualities in tcPatSynSig]-              tcOuterTKBndrs skol_info hs_outer_bndrs $-              tcExplicitTKBndrs ex_hs_tvbndrs         $+                     -- See Note [Report unsolved equalities in tcPatSynSig]+              tcOuterTKBndrs skol_info hs_outer_bndrs   $+              tcExplicitTKBndrs skol_info ex_hs_tvbndrs $               do { req     <- tcHsContext hs_req                  ; prov    <- tcHsContext hs_prov                  ; body_ty <- tcHsOpenType hs_body_ty@@ -405,7 +432,7 @@        ; let ungen_patsyn_ty = build_patsyn_type implicit_bndrs univ_bndrs                                                  req ex_bndrs prov body_ty        ; traceTc "tcPatSynSig" (ppr ungen_patsyn_ty)-       ; kvs <- kindGeneralizeAll ungen_patsyn_ty+       ; kvs <- kindGeneralizeAll skol_info ungen_patsyn_ty        ; reportUnsolvedEqualities skol_info kvs tclvl wanted                -- See Note [Report unsolved equalities in tcPatSynSig] @@ -425,10 +452,15 @@        ; checkValidType ctxt $          build_patsyn_type implicit_bndrs univ_bndrs req ex_bndrs prov body_ty -       -- arguments become the types of binders. We thus cannot allow-       -- levity polymorphism here-       ; let (arg_tys, _) = tcSplitFunTys body_ty-       ; mapM_ (checkForLevPoly empty . scaledThing) arg_tys+       -- Neither argument types nor the return type may be representation polymorphic.+       -- This is because, when creating a matcher:+       --   - the argument types become the the binder types (see test RepPolyPatySynArg),+       --   - the return type becomes the scrutinee type (see test RepPolyPatSynRes).+       ; let (arg_tys, res_ty) = tcSplitFunTys body_ty+       ; mapM_+           (\(Scaled _ arg_ty) -> checkTypeHasFixedRuntimeRep FixedRuntimeRepPatSynSigArg arg_ty)+           arg_tys+       ; checkTypeHasFixedRuntimeRep FixedRuntimeRepPatSynSigRes res_ty         ; traceTc "tcTySig }" $          vcat [ text "kvs"          <+> ppr_tvs (binderVars kv_bndrs)@@ -599,10 +631,12 @@          warn_multiple_inlines inl2 inls        | otherwise        = setSrcSpanA loc $-         addWarnTc NoReason-                     (hang (text "Multiple INLINE pragmas for" <+> ppr poly_id)-                       2 (vcat (text "Ignoring all but the first"-                                : map pp_inl (inl1:inl2:inls))))+         let dia = TcRnUnknownMessage $+               mkPlainDiagnostic WarningWithoutFlag noHints $+                 (hang (text "Multiple INLINE pragmas for" <+> ppr poly_id)+                   2 (vcat (text "Ignoring all but the first"+                            : map pp_inl (inl1:inl2:inls))))+         in addDiagnosticTc dia      pp_inl (L loc prag) = ppr prag <+> parens (ppr loc) @@ -751,9 +785,11 @@     is_bad_sig s = not (isSpecLSig s || isInlineLSig s || isSCCFunSig s)      warn_discarded_sigs-      = addWarnTc NoReason-                  (hang (text "Discarding unexpected pragmas for" <+> ppr poly_id)-                      2 (vcat (map (ppr . getLoc) bad_sigs)))+      = let dia = TcRnUnknownMessage $+              mkPlainDiagnostic WarningWithoutFlag noHints $+                (hang (text "Discarding unexpected pragmas for" <+> ppr poly_id)+                    2 (vcat (map (ppr . getLoc) bad_sigs)))+        in addDiagnosticTc dia  -------------- tcSpecPrag :: TcId -> Sig GhcRn -> TcM [TcSpecPrag]@@ -766,10 +802,11 @@ -- However we want to use fun_name in the error message, since that is -- what the user wrote (#8537)   = addErrCtxt (spec_ctxt prag) $-    do  { warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl))-                 (text "SPECIALISE pragma for non-overloaded function"-                  <+> quotes (ppr fun_name))-                  -- Note [SPECIALISE pragmas]+    do  { warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl)) $+                 TcRnUnknownMessage $ mkPlainDiagnostic WarningWithoutFlag noHints+                   (text "SPECIALISE pragma for non-overloaded function"+                    <+> quotes (ppr fun_name))+                    -- Note [SPECIALISE pragmas]         ; spec_prags <- mapM tc_one hs_tys         ; traceTc "tcSpecPrag" (ppr poly_id $$ nest 2 (vcat (map ppr spec_prags)))         ; return spec_prags }@@ -779,8 +816,8 @@     spec_ctxt prag = hang (text "In the pragma:") 2 (ppr prag)      tc_one hs_ty-      = do { spec_ty <- tcHsSigType   (FunSigCtxt name False) hs_ty-           ; wrap    <- tcSpecWrapper (FunSigCtxt name True)  poly_ty spec_ty+      = do { spec_ty <- tcHsSigType   (FunSigCtxt name NoRRC) hs_ty+           ; wrap    <- tcSpecWrapper (FunSigCtxt name (lhsSigTypeContextSpan hs_ty)) poly_ty spec_ty            ; return (SpecPrag poly_id wrap inl) }  tcSpecPrag _ prag = pprPanic "tcSpecPrag" (ppr prag)@@ -834,7 +871,9 @@       ; if hasSomeUnfolding (realIdUnfolding id)            -- See Note [SPECIALISE pragmas for imported Ids]         then tcSpecPrag id prag-        else do { addWarnTc NoReason (impSpecErr name)+        else do { let dia = TcRnUnknownMessage $+                        mkPlainDiagnostic WarningWithoutFlag noHints (impSpecErr name)+                ; addDiagnosticTc dia                 ; return [] } }  impSpecErr :: Name -> SDoc@@ -853,7 +892,7 @@ can't specialise it here; indeed the desugar falls over (#18118).  We used to test whether it had a user-specified INLINABLE pragma but,-because of Note [Worker-wrapper for INLINABLE functions] in+because of Note [Worker/wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap, even an INLINABLE function may end up with a wrapper that has no pragma, just an unfolding (#19246).  So now we just test whether the function has an unfolding.
compiler/GHC/Tc/Gen/Splice.hs view
@@ -10,6 +10,7 @@  {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-# LANGUAGE NamedFieldPuns #-}  {- (c) The University of Glasgow 2006@@ -30,18 +31,20 @@      finishTH, runTopSplice       ) where -#include "GhclibHsVersions.h"- import GHC.Prelude +import GHC.Driver.Errors import GHC.Driver.Plugins import GHC.Driver.Main import GHC.Driver.Session import GHC.Driver.Env import GHC.Driver.Hooks+import GHC.Driver.Config.Diagnostic+import GHC.Driver.Config.Finder  import GHC.Hs +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType import GHC.Tc.Gen.Expr@@ -81,7 +84,6 @@ import GHC.Rename.Splice( traceSplice, SpliceInfo(..)) import GHC.Rename.Expr import GHC.Rename.Env-import GHC.Rename.Utils  ( HsDocContext(..) ) import GHC.Rename.Fixity ( lookupFixityRn_help ) import GHC.Rename.HsType @@ -109,6 +111,7 @@ import GHC.Types.Fixity as Hs import GHC.Types.Annotations import GHC.Types.Name+import GHC.Types.Unique.Map import GHC.Serialized  import GHC.Unit.Finder@@ -118,9 +121,11 @@  import GHC.Utils.Misc import GHC.Utils.Panic as Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Lexeme import GHC.Utils.Outputable import GHC.Utils.Logger+import GHC.Utils.Exception (throwIO, ErrorCall(..))  import GHC.Utils.TmpFs ( newTempName, TempFileLifetime(..) ) @@ -139,7 +144,6 @@ #endif  import Control.Monad-import Control.Exception import Data.Binary import Data.Binary.Get import Data.List        ( find )@@ -152,6 +156,9 @@ import Data.Typeable ( typeOf, Typeable, TypeRep, typeRep ) import Data.Data (Data) import Data.Proxy    ( Proxy (..) )+import GHC.Parser.HaddockLex (lexHsDoc)+import GHC.Parser (parseIdentifier)+import GHC.Rename.Doc (rnHsDoc)  {- ************************************************************************@@ -161,8 +168,8 @@ ************************************************************************ -} -tcTypedBracket   :: HsExpr GhcRn -> HsBracket GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)-tcUntypedBracket :: HsExpr GhcRn -> HsBracket GhcRn -> [PendingRnSplice] -> ExpRhoType+tcTypedBracket   :: HsExpr GhcRn -> LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)+tcUntypedBracket :: HsExpr GhcRn -> HsQuote GhcRn -> [PendingRnSplice] -> ExpRhoType                  -> TcM (HsExpr GhcTc) tcSpliceExpr     :: HsSplice GhcRn  -> ExpRhoType -> TcM (HsExpr GhcTc)         -- None of these functions add constraints to the LIE@@ -182,9 +189,8 @@ -}  -- See Note [How brackets and nested splices are handled]--- tcTypedBracket :: HsBracket Name -> TcRhoType -> TcM (HsExpr TcId)-tcTypedBracket rn_expr brack@(TExpBr _ expr) res_ty-  = addErrCtxt (quotationCtxtDoc brack) $+tcTypedBracket rn_expr expr res_ty+  = addErrCtxt (quotationCtxtDoc expr) $     do { cur_stage <- getStage        ; ps_ref <- newMutVar []        ; lie_var <- getConstraintVar   -- Any constraints arising from nested splices@@ -198,28 +204,27 @@        -- Bundle them together so they can be used in GHC.HsToCore.Quote for desugaring        -- brackets.        ; let wrapper = QuoteWrapper ev_var m_var-       -- Typecheck expr to make sure it is valid,-       -- Throw away the typechecked expression but return its type.+       -- Typecheck expr to make sure it is valid.+       -- The typechecked expression won't be used, but we return it with its type.+       --   (See Note [The life cycle of a TH quotation] in GHC.Hs.Expr)        -- We'll typecheck it again when we splice it in somewhere-       ; (_tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var wrapper)) $-                                tcScalingUsage Many $-                                -- Scale by Many, TH lifting is currently nonlinear (#18465)-                                tcInferRhoNC expr-                                -- NC for no context; tcBracket does that+       ; (tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var wrapper)) $+                               tcScalingUsage Many $+                               -- Scale by Many, TH lifting is currently nonlinear (#18465)+                               tcInferRhoNC expr+                               -- NC for no context; tcBracket does that        ; let rep = getRuntimeRep expr_ty        ; meta_ty <- tcTExpTy m_var expr_ty        ; ps' <- readMutVar ps_ref-       ; texpco <- tcLookupId unsafeCodeCoerceName-       ; tcWrapResultO (Shouldn'tHappenOrigin "TExpBr")+       ; codeco <- tcLookupId unsafeCodeCoerceName+       ; bracket_ty <- mkAppTy m_var <$> tcMetaTy expTyConName+       ; tcWrapResultO (Shouldn'tHappenOrigin "TH typed bracket expression")                        rn_expr                        (unLoc (mkHsApp (mkLHsWrap (applyQuoteWrapper wrapper)-                                                  (nlHsTyApp texpco [rep, expr_ty]))-                                      (noLocA (HsTcBracketOut noExtField (Just wrapper) brack ps'))))+                                                  (nlHsTyApp codeco [rep, expr_ty]))+                                      (noLocA (HsTypedBracket (HsBracketTc (ExpBr noExtField expr) bracket_ty (Just wrapper) ps') tc_expr))))                        meta_ty res_ty }-tcTypedBracket _ other_brack _-  = pprPanic "tcTypedBracket" (ppr other_brack) --- tcUntypedBracket :: HsBracket Name -> [PendingRnSplice] -> ExpRhoType -> TcM (HsExpr TcId) -- See Note [Typechecking Overloaded Quotes] tcUntypedBracket rn_expr brack ps res_ty   = do { traceTc "tc_bracket untyped" (ppr brack $$ ppr ps)@@ -236,14 +241,15 @@        -- we want to reflect that in the overall type of the bracket.        ; ps' <- case quoteWrapperTyVarTy <$> brack_info of                   Just m_var -> mapM (tcPendingSplice m_var) ps-                  Nothing -> ASSERT(null ps) return []+                  Nothing -> assert (null ps) $ return []         ; traceTc "tc_bracket done untyped" (ppr expected_type)         -- Unify the overall type of the bracket with the expected result        -- type        ; tcWrapResultO BracketOrigin rn_expr-            (HsTcBracketOut noExtField brack_info brack ps')+            (HsUntypedBracket (HsBracketTc brack expected_type brack_info ps') (XQuote noExtField))+                -- (XQuote noExtField): see Note [The life cycle of a TH quotation] in GHC.Hs.Expr             expected_type res_ty         }@@ -265,7 +271,7 @@ -- | Compute the expected type of a quotation, and also the QuoteWrapper in -- the case where it is an overloaded quotation. All quotation forms are -- overloaded aprt from Variable quotations ('foo)-brackTy :: HsBracket GhcRn -> TcM (Maybe QuoteWrapper, Type)+brackTy :: HsQuote GhcRn -> TcM (Maybe QuoteWrapper, Type) brackTy b =   let mkTy n = do         -- New polymorphic type variable for the bracket@@ -288,7 +294,6 @@     (DecBrG {}) -> mkTy decsTyConName -- Result type is m [Dec]     (PatBr {})  -> mkTy patTyConName  -- Result type is m Pat     (DecBrL {}) -> panic "tcBrackTy: Unexpected DecBrL"-    (TExpBr {}) -> panic "tcUntypedBracket: Unexpected TExpBr"  --------------- -- | Typechecking a pending splice from a untyped bracket@@ -321,14 +326,15 @@        ; return (mkTyConApp codeCon [rep, m_ty, exp_ty]) }   where     err_msg ty-      = vcat [ text "Illegal polytype:" <+> ppr ty+      = TcRnUnknownMessage $ mkPlainError noHints $+      vcat [ text "Illegal polytype:" <+> ppr ty              , text "The type of a Typed Template Haskell expression must" <+>                text "not have any quantification." ] -quotationCtxtDoc :: HsBracket GhcRn -> SDoc+quotationCtxtDoc :: LHsExpr GhcRn -> SDoc quotationCtxtDoc br_body   = hang (text "In the Template Haskell quotation")-         2 (ppr br_body)+         2 (thTyBrackets . ppr $ br_body)     -- The whole of the rest of the file is the else-branch (ie stage2 only)@@ -362,43 +368,46 @@    and untyped   [|  e  |]  The life cycle of a typed bracket:-   * Starts as HsBracket+   * Starts as HsTypedBracket     * When renaming:         * Set the ThStage to (Brack s RnPendingTyped)         * Rename the body-        * Result is still a HsBracket+        * Result is a HsTypedBracket     * When typechecking:         * Set the ThStage to (Brack s (TcPending ps_var lie_var))-        * Typecheck the body, and throw away the elaborated result+        * Typecheck the body, and keep the elaborated result (despite never using it!)         * Nested splices (which must be typed) are typechecked, and           the results accumulated in ps_var; their constraints           accumulate in lie_var-        * Result is a HsTcBracketOut rn_brack pending_splices-          where rn_brack is the incoming renamed bracket+        * Result is a HsTypedBracket (HsBracketTc rn_brack ty quote_wrapper pending_splices) tc_brack+          where rn_brack is the untyped renamed exp quote constructed from the typed renamed expression :: HsQuote GhcRn  The life cycle of a un-typed bracket:-   * Starts as HsBracket+   * Starts as HsUntypedBracket     * When renaming:         * Set the ThStage to (Brack s (RnPendingUntyped ps_var))         * Rename the body         * Nested splices (which must be untyped) are renamed, and the           results accumulated in ps_var-        * Result is still (HsRnBracketOut rn_body pending_splices)+        * Result is a HsUntypedBracket pending_splices rn_body -   * When typechecking a HsRnBracketOut+   * When typechecking:         * Typecheck the pending_splices individually         * Ignore the body of the bracket; just check that the context           expects a bracket of that type (e.g. a [p| pat |] bracket should           be in a context needing a (Q Pat)-        * Result is a HsTcBracketOut rn_brack pending_splices-          where rn_brack is the incoming renamed bracket+        * Result is a HsUntypedBracket (HsBracketTc rn_brack ty quote_wrapper pending_splices) (XQuote noExtField)+          where rn_brack is the incoming renamed bracket :: HsQuote GhcRn+          and (XQuote noExtField) stands for the removal of the `HsQuote GhcTc` field (since `HsQuote GhcTc` isn't possible) +See the related Note [The life cycle of a TH quotation]  In both cases, desugaring happens like this:-  * HsTcBracketOut is desugared by GHC.HsToCore.Quote.dsBracket.  It+  * Hs*Bracket is desugared by GHC.HsToCore.Quote.dsBracket using the renamed+    expression held in `HsBracketTc` (`type instance X*Bracket GhcTc = HsBracketTc`). It        a) Extends the ds_meta environment with the PendingSplices          attached to the bracket@@ -420,11 +429,11 @@  Example:     Source:       f = [| Just $(g 3) |]-      The [| |] part is a HsBracket+      The [| |] part is a HsUntypedBracket GhcPs      Typechecked:  f = [| Just ${s7}(g 3) |]{s7 = g Int 3}-      The [| |] part is a HsBracketOut, containing *renamed*-        (not typechecked) expression+      The [| |] part is a HsUntypedBracket GhcTc, containing *renamed*+        (not typechecked) expression (see Note [The life cycle of a TH quotation])       The "s7" is the "splice point"; the (g Int 3) part         is a typechecked expression @@ -613,7 +622,6 @@  {- Note [Collecting modFinalizers in typed splices]    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- 'qAddModFinalizer' of the @Quasi TcM@ instance adds finalizers in the local environment (see Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice). Thus after executing the splice, we move the finalizers to the@@ -674,12 +682,8 @@ -- See Note [Running typed splices in the zonker] runTopSplice :: DelayedSplice -> TcM (HsExpr GhcTc) runTopSplice (DelayedSplice lcl_env orig_expr res_ty q_expr)-  = do-      errs_var <- getErrsVar-      setLclEnv lcl_env $ setErrsVar errs_var $ do {-         -- Set the errs_var to the errs_var from the current context,-         -- otherwise error messages can go missing in GHCi (#19470)-         zonked_ty <- zonkTcType res_ty+  = restoreLclEnv lcl_env $+    do { zonked_ty <- zonkTcType res_ty        ; zonked_q_expr <- zonkTopLExpr q_expr         -- See Note [Collecting modFinalizers in typed splices].        ; modfinalizers_ref <- newTcRef []@@ -689,7 +693,7 @@        ; mod_finalizers <- readTcRef modfinalizers_ref        ; addModFinalizersWithLclEnv $ ThModFinalizers mod_finalizers        -- We use orig_expr here and not q_expr when tracing as a call to-       -- unsafeTExpCoerce is added to the original expression by the+       -- unsafeCodeCoerce is added to the original expression by the        -- typechecker when typed quotes are type checked.        ; traceSplice (SpliceInfo { spliceDescription = "expression"                                  , spliceIsDecl      = False@@ -923,6 +927,48 @@          -> TcM [LHsDecl GhcPs] runMetaD = runMeta metaRequestD +{- Note [Errors in desugaring a splice]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+What should we do if there are errors when desugaring a splice? We should+abort. There are several cases to consider:++(a) The desugarer hits an unrecoverable error and fails in the monad.+(b) The desugarer hits a recoverable error, reports it, and continues.+(c) The desugarer reports a fatal warning (with -Werror), reports it, and continues.+(d) The desugarer reports a non-fatal warning, and continues.++Each case is tested in th/T19709[abcd].++General principle: we wish to report all messages from dealing with a splice+eagerly, as these messages arise during an earlier stage than type-checking+generally. It's also likely that a compile-time warning from spliced code+will be easier to understand then an error that arises from processing the+code the splice produces. (Rationale: the warning will be about the code the+user actually wrote, not what is generated.)++Case (a): We have no choice but to abort here, but we must make sure that+the messages are printed or logged before aborting. Logging them is annoying,+because we're in the type-checker, and the messages are DsMessages, from the+desugarer. So we report and then fail in the monad. This case is detected+by the fact that initDsTc returns Nothing.++Case (b): We detect this case by looking for errors in the messages returned+from initDsTc and aborting if we spot any (after printing, of course). Note+that initDsTc will return a Just ds_expr in this case, but we don't wish to+use the (likely very bogus) expression.++Case (c): This is functionally the same as (b), except that the expression+isn't bogus. We still don't wish to use it, as the user's request for -Werror+tells us not to.++Case (d): We report the warnings and then carry on with the expression.+This might result in warnings printed out of source order, but this is+appropriate, as the warnings from the splice arise from an earlier stage+of compilation.++Previously, we failed to abort in cases (b) and (c), leading to #19709.+-}+ --------------- runMeta' :: Bool                 -- Whether code should be printed in the exception message          -> (hs_syn -> SDoc)                                    -- how to print the code@@ -938,19 +984,35 @@         -- Check that we've had no errors of any sort so far.         -- For example, if we found an error in an earlier defn f, but         -- recovered giving it type f :: forall a.a, it'd be very dodgy-        -- to carry ont.  Mind you, the staging restrictions mean we won't+        -- to carry on.  Mind you, the staging restrictions mean we won't         -- actually run f, but it still seems wrong. And, more concretely,         -- see #5358 for an example that fell over when trying to-        -- reify a function with a "?" kind in it.  (These don't occur-        -- in type-correct programs.+        -- reify a function with an unlifted kind in it.  (These don't occur+        -- in type-correct programs.)         ; failIfErrsM          -- run plugins         ; hsc_env <- getTopEnv-        ; expr' <- withPlugins hsc_env spliceRunAction expr+        ; expr' <- withPlugins (hsc_plugins hsc_env) spliceRunAction expr          -- Desugar-        ; ds_expr <- initDsTc (dsLExpr expr')+        ; (ds_msgs, mb_ds_expr) <- initDsTc (dsLExpr expr')++        -- Print any messages (even warnings) eagerly: they might be helpful if anything+        -- goes wrong. See Note [Errors in desugaring a splice]. This happens in all+        -- cases.+        ; logger <- getLogger+        ; diag_opts <- initDiagOpts <$> getDynFlags+        ; liftIO $ printMessages logger diag_opts ds_msgs++        ; ds_expr <- case mb_ds_expr of+            Nothing      -> failM   -- Case (a) from Note [Errors in desugaring a splice]+            Just ds_expr ->  -- There still might be a fatal warning or recoverable+                             -- Cases (b) and (c) from Note [Errors in desugaring a splice]+              do { when (errorsOrFatalWarningsFound ds_msgs)+                     failM+                 ; return ds_expr }+         -- Compile and link it; might fail if linking fails         ; src_span <- getSrcSpanM         ; traceTc "About to run (desugared)" (ppr ds_expr)@@ -958,7 +1020,7 @@                          GHC.Driver.Main.hscCompileCoreExpr hsc_env src_span ds_expr         ; case either_hval of {             Left exn   -> fail_with_exn "compile and link" exn ;-            Right hval -> do+            Right (hval, needed_mods, needed_pkgs) -> do          {       -- Coerce it to Q t, and run it @@ -972,12 +1034,13 @@                 --                 -- See Note [Exceptions in TH]           let expr_span = getLocA expr+        ; recordThNeededRuntimeDeps needed_mods needed_pkgs         ; either_tval <- tryAllM $                          setSrcSpan expr_span $ -- Set the span so that qLocation can                                                 -- see where this splice is              do { mb_result <- run_and_convert expr_span hval                 ; case mb_result of-                    Left err     -> failWithTc err+                    Left err     -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints err)                     Right result -> do { traceTc "Got HsSyn result:" (ppr_hs result)                                        ; return $! result } } @@ -995,7 +1058,7 @@         let msg = vcat [text "Exception when trying to" <+> text phase <+> text "compile-time code:",                         nest 2 (text exn_msg),                         if show_code then text "Code:" <+> ppr expr else empty]-        failWithTc msg+        failWithTc (TcRnUnknownMessage $ mkPlainError noHints msg)  {- Note [Running typed splices in the zonker]@@ -1111,8 +1174,9 @@    -- 'msg' is forced to ensure exceptions don't escape,   -- see Note [Exceptions in TH]-  qReport True msg  = seqList msg $ addErr  (text msg)-  qReport False msg = seqList msg $ addWarn NoReason (text msg)+  qReport True msg  = seqList msg $ addErr $ TcRnUnknownMessage $ mkPlainError noHints (text msg)+  qReport False msg = seqList msg $ addDiagnostic $ TcRnUnknownMessage $+    mkPlainDiagnostic WarningWithoutFlag noHints (text msg)    qLocation = do { m <- getModule                  ; l <- getSrcSpanM@@ -1144,6 +1208,10 @@         -- we'll only fail higher up.   qRecover recover main = tryTcDiscardingErrs recover main +  qGetPackageRoot = do+    dflags <- getDynFlags+    return $ fromMaybe "." (workingDirectory dflags)+   qAddDependentFile fp = do     ref <- fmap tcg_dependent_files getGblEnv     dep_files <- readTcRef ref@@ -1153,14 +1221,14 @@     dflags <- getDynFlags     logger <- getLogger     tmpfs  <- hsc_tmpfs <$> getTopEnv-    liftIO $ newTempName logger tmpfs dflags TFL_GhcSession suffix+    liftIO $ newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession suffix    qAddTopDecls thds = do       l <- getSrcSpanM       th_origin <- getThSpliceOrigin       let either_hval = convertToHsDecls th_origin l thds       ds <- case either_hval of-              Left exn -> failWithTc $+              Left exn -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $                 hang (text "Error in a declaration passed to addTopDecls:")                    2 exn               Right ds -> return ds@@ -1178,7 +1246,8 @@       checkTopDecl (ForD _ (ForeignImport { fd_name = L _ name }))         = bindName name       checkTopDecl _-        = addErr $ text "Only function, value, annotation, and foreign import declarations may be added with addTopDecl"+        = addErr $ TcRnUnknownMessage $ mkPlainError noHints $+          text "Only function, value, annotation, and foreign import declarations may be added with addTopDecl"        bindName :: RdrName -> TcM ()       bindName (Exact n)@@ -1187,8 +1256,8 @@              }        bindName name =-          addErr $-          hang (text "The binder" <+> quotes (ppr name) <+> ptext (sLit "is not a NameU."))+          addErr $ TcRnUnknownMessage $ mkPlainError noHints $+          hang (text "The binder" <+> quotes (ppr name) <+> text "is not a NameU.")              2 (text "Probable cause: you used mkName instead of newName to generate a binding.")    qAddForeignFilePath lang fp = do@@ -1202,7 +1271,11 @@    qAddCorePlugin plugin = do       hsc_env <- getTopEnv-      r <- liftIO $ findHomeModule hsc_env (mkModuleName plugin)+      let fc        = hsc_FC hsc_env+      let home_unit = hsc_home_unit hsc_env+      let dflags    = hsc_dflags hsc_env+      let fopts     = initFinderOpts dflags+      r <- liftIO $ findHomeModule fc fopts home_unit (mkModuleName plugin)       let err = hang             (text "addCorePlugin: invalid plugin module "                <+> text (show plugin)@@ -1210,8 +1283,8 @@             2             (text "Plugins in the current package can't be specified.")       case r of-        Found {} -> addErr err-        FoundMultiple {} -> addErr err+        Found {} -> addErr $ TcRnUnknownMessage $ mkPlainError noHints err+        FoundMultiple {} -> addErr $ TcRnUnknownMessage $ mkPlainError noHints err         _ -> return ()       th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv       updTcRef th_coreplugins_var (plugin:)@@ -1236,10 +1309,13 @@     th_doc_var <- tcg_th_docs <$> getGblEnv     resolved_doc_loc <- resolve_loc doc_loc     is_local <- checkLocalName resolved_doc_loc-    unless is_local $ failWithTc $ text+    unless is_local $ failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ text       "Can't add documentation to" <+> ppr_loc doc_loc <+>       text "as it isn't inside the current module"-    updTcRef th_doc_var (Map.insert resolved_doc_loc s)+    let ds = mkGeneratedHsDocString s+        hd = lexHsDoc parseIdentifier ds+    hd' <- rnHsDoc hd+    updTcRef th_doc_var (Map.insert resolved_doc_loc hd')     where       resolve_loc (TH.DeclDoc n) = DeclDoc <$> lookupThName n       resolve_loc (TH.ArgDoc n i) = ArgDoc <$> lookupThName n <*> pure i@@ -1263,40 +1339,41 @@   qGetDoc (TH.InstDoc t) = lookupThInstName t >>= lookupDeclDoc   qGetDoc (TH.ArgDoc n i) = lookupThName n >>= lookupArgDoc i   qGetDoc TH.ModuleDoc = do-    (moduleDoc, _, _) <- getGblEnv >>= extractDocs-    return (fmap unpackHDS moduleDoc)+    df <- getDynFlags+    docs <- getGblEnv >>= extractDocs df+    return (renderHsDocString . hsDocString <$> (docs_mod_hdr =<< docs))  -- | Looks up documentation for a declaration in first the current module, -- otherwise tries to find it in another module via 'hscGetModuleInterface'. lookupDeclDoc :: Name -> TcM (Maybe String) lookupDeclDoc nm = do-  (_, DeclDocMap declDocs, _) <- getGblEnv >>= extractDocs-  fam_insts <- tcg_fam_insts <$> getGblEnv-  traceTc "lookupDeclDoc" (ppr nm <+> ppr declDocs <+> ppr fam_insts)-  case Map.lookup nm declDocs of-    Just doc -> pure $ Just (unpackHDS doc)+  df <- getDynFlags+  Docs{docs_decls} <- fmap (fromMaybe emptyDocs) $ getGblEnv >>= extractDocs df+  case lookupUniqMap docs_decls nm of+    Just doc -> pure $ Just (renderHsDocStrings $ map hsDocString doc)     Nothing -> do       -- Wasn't in the current module. Try searching other external ones!       mIface <- getExternalModIface nm       case mIface of-        Nothing -> pure Nothing-        Just ModIface { mi_decl_docs = DeclDocMap dmap } ->-          pure $ unpackHDS <$> Map.lookup nm dmap+        Just ModIface { mi_docs = Just Docs{docs_decls = dmap} } ->+          pure $ renderHsDocStrings . map hsDocString <$> lookupUniqMap dmap nm+        _ -> pure Nothing  -- | Like 'lookupDeclDoc', looks up documentation for a function argument. If -- it can't find any documentation for a function in this module, it tries to -- find it in another module. lookupArgDoc :: Int -> Name -> TcM (Maybe String) lookupArgDoc i nm = do-  (_, _, ArgDocMap argDocs) <- getGblEnv >>= extractDocs-  case Map.lookup nm argDocs of-    Just m -> pure $ unpackHDS <$> IntMap.lookup i m+  df <- getDynFlags+  Docs{docs_args = argDocs} <- fmap (fromMaybe emptyDocs) $ getGblEnv >>= extractDocs df+  case lookupUniqMap argDocs nm of+    Just m -> pure $ renderHsDocString . hsDocString <$> IntMap.lookup i m     Nothing -> do       mIface <- getExternalModIface nm       case mIface of-        Nothing -> pure Nothing-        Just ModIface { mi_arg_docs = ArgDocMap amap } ->-          pure $ unpackHDS <$> (Map.lookup nm amap >>= IntMap.lookup i)+        Just ModIface { mi_docs = Just Docs{docs_args = amap} } ->+          pure $ renderHsDocString . hsDocString <$> (lookupUniqMap amap nm >>= IntMap.lookup i)+        _ -> pure Nothing  -- | Returns the module a Name belongs to, if it is isn't local. getExternalModIface :: Name -> TcM (Maybe ModIface)@@ -1322,49 +1399,51 @@     Right (_, (inst:_)) -> return $ getName inst     Right (_, [])       -> noMatches   where-    noMatches = failWithTc $+    noMatches = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $       text "Couldn't find any instances of"         <+> ppr_th th_type         <+> text "to add documentation to" -    -- | Get the name of the class for the instance we are documenting+    -- Get the name of the class for the instance we are documenting     -- > inst_cls_name (Monad Maybe) == Monad     -- > inst_cls_name C = C     inst_cls_name :: TH.Type -> TcM TH.Name-    inst_cls_name (TH.AppT t _)           = inst_cls_name t-    inst_cls_name (TH.SigT n _)           = inst_cls_name n-    inst_cls_name (TH.VarT n)             = pure n-    inst_cls_name (TH.ConT n)             = pure n-    inst_cls_name (TH.PromotedT n)        = pure n-    inst_cls_name (TH.InfixT _ n _)       = pure n-    inst_cls_name (TH.UInfixT _ n _)      = pure n-    inst_cls_name (TH.ParensT t)          = inst_cls_name t+    inst_cls_name (TH.AppT t _)              = inst_cls_name t+    inst_cls_name (TH.SigT n _)              = inst_cls_name n+    inst_cls_name (TH.VarT n)                = pure n+    inst_cls_name (TH.ConT n)                = pure n+    inst_cls_name (TH.PromotedT n)           = pure n+    inst_cls_name (TH.InfixT _ n _)          = pure n+    inst_cls_name (TH.UInfixT _ n _)         = pure n+    inst_cls_name (TH.PromotedInfixT _ n _)  = pure n+    inst_cls_name (TH.PromotedUInfixT _ n _) = pure n+    inst_cls_name (TH.ParensT t)             = inst_cls_name t -    inst_cls_name (TH.ForallT _ _ _)      = inst_cls_name_err-    inst_cls_name (TH.ForallVisT _ _)     = inst_cls_name_err-    inst_cls_name (TH.AppKindT _ _)       = inst_cls_name_err-    inst_cls_name (TH.TupleT _)           = inst_cls_name_err-    inst_cls_name (TH.UnboxedTupleT _)    = inst_cls_name_err-    inst_cls_name (TH.UnboxedSumT _)      = inst_cls_name_err-    inst_cls_name TH.ArrowT               = inst_cls_name_err-    inst_cls_name TH.MulArrowT            = inst_cls_name_err-    inst_cls_name TH.EqualityT            = inst_cls_name_err-    inst_cls_name TH.ListT                = inst_cls_name_err-    inst_cls_name (TH.PromotedTupleT _)   = inst_cls_name_err-    inst_cls_name TH.PromotedNilT         = inst_cls_name_err-    inst_cls_name TH.PromotedConsT        = inst_cls_name_err-    inst_cls_name TH.StarT                = inst_cls_name_err-    inst_cls_name TH.ConstraintT          = inst_cls_name_err-    inst_cls_name (TH.LitT _)             = inst_cls_name_err-    inst_cls_name TH.WildCardT            = inst_cls_name_err-    inst_cls_name (TH.ImplicitParamT _ _) = inst_cls_name_err+    inst_cls_name (TH.ForallT _ _ _)         = inst_cls_name_err+    inst_cls_name (TH.ForallVisT _ _)        = inst_cls_name_err+    inst_cls_name (TH.AppKindT _ _)          = inst_cls_name_err+    inst_cls_name (TH.TupleT _)              = inst_cls_name_err+    inst_cls_name (TH.UnboxedTupleT _)       = inst_cls_name_err+    inst_cls_name (TH.UnboxedSumT _)         = inst_cls_name_err+    inst_cls_name TH.ArrowT                  = inst_cls_name_err+    inst_cls_name TH.MulArrowT               = inst_cls_name_err+    inst_cls_name TH.EqualityT               = inst_cls_name_err+    inst_cls_name TH.ListT                   = inst_cls_name_err+    inst_cls_name (TH.PromotedTupleT _)      = inst_cls_name_err+    inst_cls_name TH.PromotedNilT            = inst_cls_name_err+    inst_cls_name TH.PromotedConsT           = inst_cls_name_err+    inst_cls_name TH.StarT                   = inst_cls_name_err+    inst_cls_name TH.ConstraintT             = inst_cls_name_err+    inst_cls_name (TH.LitT _)                = inst_cls_name_err+    inst_cls_name TH.WildCardT               = inst_cls_name_err+    inst_cls_name (TH.ImplicitParamT _ _)    = inst_cls_name_err -    inst_cls_name_err = failWithTc $+    inst_cls_name_err = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $       text "Couldn't work out what instance"         <+> ppr_th th_type         <+> text "is supposed to be" -    -- | Basically does the opposite of 'mkThAppTs'+    -- Basically does the opposite of 'mkThAppTs'     -- > inst_arg_types (Monad Maybe) == [Maybe]     -- > inst_arg_types C == []     inst_arg_types :: TH.Type -> [TH.Type]@@ -1445,7 +1524,7 @@ -- See Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs. runRemoteTH   :: IServInstance-  -> [Messages DecoratedSDoc]   --  saved from nested calls to qRecover+  -> [Messages TcRnMessage]   --  saved from nested calls to qRecover   -> TcM () runRemoteTH iserv recovers = do   THMsg msg <- liftIO $ readIServ iserv getTHMessage@@ -1482,7 +1561,7 @@     QFail str -> fail str  {- Note [TH recover with -fexternal-interpreter]-+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Recover is slightly tricky to implement.  The meaning of "recover a b" is@@ -1555,6 +1634,7 @@     wrapTHResult $ (map B.pack <$> getAnnotationsByTypeRep lookup tyrep)   ReifyModule m -> wrapTHResult $ TH.qReifyModule m   ReifyConStrictness nm -> wrapTHResult $ TH.qReifyConStrictness nm+  GetPackageRoot -> wrapTHResult $ TH.qGetPackageRoot   AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f   AddTempFile s -> wrapTHResult $ TH.qAddTempFile s   AddModFinalizer r -> do@@ -1620,16 +1700,16 @@                rnImplicitTvOccs Nothing tv_rdrs $ \ tv_names ->                do { (rn_ty, fvs) <- rnLHsType doc rdr_ty                   ; return ((tv_names, rn_ty), fvs) }-+        ; skol_info <- mkSkolemInfo ReifySkol         ; (tclvl, wanted, (tvs, ty))             <- pushLevelAndSolveEqualitiesX "reifyInstances"  $-               bindImplicitTKBndrs_Skol tv_names              $+               bindImplicitTKBndrs_Skol skol_info tv_names              $                tcInferLHsType rn_ty          ; tvs <- zonkAndScopedSort tvs          -- Avoid error cascade if there are unsolved-        ; reportUnsolvedEqualities ReifySkol tvs tclvl wanted+        ; reportUnsolvedEqualities skol_info tvs tclvl wanted          ; ty <- zonkTcTypeToType ty                 -- Substitute out the meta type variables@@ -1643,21 +1723,22 @@                -> do { inst_envs <- tcGetInstEnvs                      ; let (matches, unifies, _) = lookupInstEnv False inst_envs cls tys                      ; traceTc "reifyInstances'1" (ppr matches)-                     ; return $ Left (cls, map fst matches ++ unifies) }+                     ; return $ Left (cls, map fst matches ++ getPotentialUnifiers unifies) }                | isOpenFamilyTyCon tc                -> do { inst_envs <- tcGetFamInstEnvs                      ; let matches = lookupFamInstEnv inst_envs tc tys                      ; traceTc "reifyInstances'2" (ppr matches)                      ; return $ Right (tc, map fim_instance matches) }-            _  -> bale_out (hang (text "reifyInstances:" <+> quotes (ppr ty))-                               2 (text "is not a class constraint or type family application")) }+            _  -> bale_out $ TcRnUnknownMessage $ mkPlainError noHints $+                  (hang (text "reifyInstances:" <+> quotes (ppr ty))+                      2 (text "is not a class constraint or type family application")) }   where     doc = ClassInstanceCtx     bale_out msg = failWithTc msg      cvt :: Origin -> SrcSpan -> TH.Type -> TcM (LHsType GhcPs)     cvt origin loc th_ty = case convertToHsType origin loc th_ty of-      Left msg -> failWithTc msg+      Left msg -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints msg)       Right ty -> return ty  {-@@ -1750,17 +1831,18 @@      do { mb_thing <- tcLookupImported_maybe name         ; case mb_thing of             Succeeded thing -> return (AGlobal thing)-            Failed msg      -> failWithTc msg+            Failed msg      -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints msg)     }}}} -notInScope :: TH.Name -> SDoc-notInScope th_name = quotes (text (TH.pprint th_name)) <+>-                     text "is not in scope at a reify"+notInScope :: TH.Name -> TcRnMessage+notInScope th_name = TcRnUnknownMessage $ mkPlainError noHints $+  quotes (text (TH.pprint th_name)) <+>+          text "is not in scope at a reify"         -- Ugh! Rather an indirect way to display the name -notInEnv :: Name -> SDoc-notInEnv name = quotes (ppr name) <+>-                     text "is not in the type environment at a reify"+notInEnv :: Name -> TcRnMessage+notInEnv name = TcRnUnknownMessage $ mkPlainError noHints $+  quotes (ppr name) <+> text "is not in the type environment at a reify"  ------------------------------ reifyRoles :: TH.Name -> TcM [TH.Role]@@ -1768,7 +1850,7 @@   = do { thing <- getThing th_name        ; case thing of            AGlobal (ATyCon tc) -> return (map reify_role (tyConRoles tc))-           _ -> failWithTc (text "No roles associated with" <+> (ppr thing))+           _ -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints $ text "No roles associated with" <+> (ppr thing))        }   where     reify_role Nominal          = TH.NominalR@@ -1842,7 +1924,7 @@    | isPrimTyCon tc   = return (TH.PrimTyConI (reifyName tc) (length (tyConVisibleTyVars tc))-                          (isUnliftedTyCon tc))+                          (isUnliftedTypeKind (tyConResKind tc)))    | isTypeFamilyTyCon tc   = do { let tvs      = tyConTyVars tc@@ -1956,7 +2038,7 @@                 -- constructors can be declared infix.                 -- See Note [Infix GADT constructors] in GHC.Tc.TyCl.               | dataConIsInfix dc && not isGadtDataCon ->-                  ASSERT( r_arg_tys `lengthIs` 2 ) do+                  assert (r_arg_tys `lengthIs` 2) $ do                   { let [r_a1, r_a2] = r_arg_tys                         [s1,   s2]   = dcdBangs                   ; return $ TH.InfixC (s1,r_a1) name (s2,r_a2) }@@ -1967,7 +2049,7 @@                   return $ TH.NormalC name (dcdBangs `zip` r_arg_tys)         ; let (ex_tvs', theta') | isGadtDataCon = (g_user_tvs, g_theta)-                               | otherwise     = ASSERT( all isTyVar ex_tvs )+                               | otherwise     = assert (all isTyVar ex_tvs)                                                  -- no covars for haskell syntax                                                  (map mk_specified ex_tvs, theta)              ret_con | null ex_tvs' && null theta' = return main_con@@ -1975,7 +2057,7 @@                          { cxt <- reifyCxt theta'                          ; ex_tvs'' <- reifyTyVarBndrs ex_tvs'                          ; return (TH.ForallC ex_tvs'' cxt main_con) }-       ; ASSERT( r_arg_tys `equalLength` dcdBangs )+       ; assert (r_arg_tys `equalLength` dcdBangs)          ret_con }   where     mk_specified tv = Bndr tv SpecifiedSpec@@ -2301,11 +2383,11 @@   | otherwise      = do { [r1,r2] <- reifyTypes [t1,t2]                         ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) } reifyType ty@(FunTy { ft_af = af, ft_mult = tm, ft_arg = t1, ft_res = t2 })-  | InvisArg <- af = noTH (sLit "linear invisible argument") (ppr ty)+  | InvisArg <- af = noTH (text "linear invisible argument") (ppr ty)   | otherwise      = do { [rm,r1,r2] <- reifyTypes [tm,t1,t2]                         ; return (TH.MulArrowT `TH.AppT` rm `TH.AppT` r1 `TH.AppT` r2) } reifyType (CastTy t _)      = reifyType t -- Casts are ignored in TH-reifyType ty@(CoercionTy {})= noTH (sLit "coercions in types") (ppr ty)+reifyType ty@(CoercionTy {})= noTH (text "coercions in types") (ppr ty)  reify_for_all :: TyCoRep.ArgFlag -> TyCoRep.Type -> TcM TH.Type -- Arg of reify_for_all is always ForAllTy or a predicate FunTy@@ -2436,7 +2518,7 @@         -- have free variables, we may need to generate NameL's for them.   where     name    = getName thing-    mod     = ASSERT( isExternalName name ) nameModule name+    mod     = assert (isExternalName name) $ nameModule name     pkg_str = unitString (moduleUnit mod)     mod_str = moduleNameString (moduleName mod)     occ_str = occNameString occ@@ -2454,7 +2536,7 @@   | otherwise = TH.mkNameG_v pkg_str mod_str occ_str   where     name    = flSelector fl-    mod     = ASSERT( isExternalName name ) nameModule name+    mod     = assert (isExternalName name) $ nameModule name     pkg_str = unitString (moduleUnit mod)     mod_str = moduleNameString (moduleName mod)     occ_str = unpackFS (flLabel fl)@@ -2555,15 +2637,17 @@       usageToModule this_pkg (UsageHomeModule { usg_mod_name = mn }) = Just $ mkModule this_pkg mn       usageToModule _ (UsagePackageModule { usg_mod = m }) = Just m       usageToModule _ (UsageMergedRequirement { usg_mod = m }) = Just m+      usageToModule this_pkg (UsageHomeModuleInterface { usg_mod_name = mn }) = Just $ mkModule this_pkg mn  ------------------------------ mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type mkThAppTs fun_ty arg_tys = foldl' TH.AppT fun_ty arg_tys -noTH :: PtrString -> SDoc -> TcM a-noTH s d = failWithTc (hsep [text "Can't represent" <+> ptext s <+>-                                text "in Template Haskell:",-                             nest 2 d])+noTH :: SDoc -> SDoc -> TcM a+noTH s d = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $+  (hsep [text "Can't represent" <+> s <+>+         text "in Template Haskell:",+           nest 2 d])  ppr_th :: TH.Ppr a => a -> SDoc ppr_th x = text (TH.pprint x)
compiler/GHC/Tc/Gen/Splice.hs-boot view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-}  module GHC.Tc.Gen.Splice where@@ -11,23 +10,23 @@ import GHC.Types.Annotations ( Annotation, CoreAnnTarget ) import GHC.Hs.Extension ( GhcRn, GhcPs, GhcTc ) -import GHC.Hs     ( HsSplice, HsBracket, HsExpr, LHsExpr, LHsType, LPat,-                    LHsDecl, ThModFinalizers )+import GHC.Hs     ( HsSplice, HsQuote, HsExpr, LHsExpr, LHsType,+                    LPat, LHsDecl, ThModFinalizers ) import qualified Language.Haskell.TH as TH  tcSpliceExpr :: HsSplice GhcRn              -> ExpRhoType              -> TcM (HsExpr GhcTc) +tcTypedBracket :: HsExpr GhcRn+               -> LHsExpr GhcRn+               -> ExpRhoType+               -> TcM (HsExpr GhcTc) tcUntypedBracket :: HsExpr GhcRn-                 -> HsBracket GhcRn+                 -> HsQuote GhcRn                  -> [PendingRnSplice]                  -> ExpRhoType                  -> TcM (HsExpr GhcTc)-tcTypedBracket :: HsExpr GhcRn-               -> HsBracket GhcRn-               -> ExpRhoType-               -> TcM (HsExpr GhcTc)  runTopSplice :: DelayedSplice -> TcM (HsExpr GhcTc)
compiler/GHC/Tc/Instance/Class.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -6,15 +5,14 @@      matchGlobalInst,      ClsInstResult(..),      InstanceWhat(..), safeOverlap, instanceReturnsDictCon,-     AssocInstInfo(..), isNotAssociated+     AssocInstInfo(..), isNotAssociated,   ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Driver.Session +import GHC.Core.TyCo.Rep  import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad@@ -27,7 +25,7 @@ import GHC.Rename.Env( addUsedGRE )  import GHC.Builtin.Types-import GHC.Builtin.Types.Prim( eqPrimTyCon, eqReprPrimTyCon )+import GHC.Builtin.Types.Prim import GHC.Builtin.Names  import GHC.Types.Name.Reader( lookupGRE_FieldLabel, greMangledName )@@ -35,18 +33,23 @@ import GHC.Types.Name   ( Name, pprDefinedAt ) import GHC.Types.Var.Env ( VarEnv ) import GHC.Types.Id+import GHC.Types.Var  import GHC.Core.Predicate import GHC.Core.InstEnv import GHC.Core.Type-import GHC.Core.Make ( mkCharExpr, mkStringExprFS, mkNaturalExpr )+import GHC.Core.Make ( mkCharExpr, mkNaturalExpr, mkStringExprFS, mkCoreLams ) import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Core.Class +import GHC.Core ( Expr(Var, App, Cast, Let), Bind (NonRec) )+import GHC.Types.Basic+ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc( splitAtList, fstOf3 )+import GHC.Data.FastString  import Data.Maybe @@ -98,14 +101,23 @@    | NotSure      -- Multiple matches and/or one or more unifiers -data InstanceWhat-  = BuiltinInstance-  | BuiltinEqInstance   -- A built-in "equality instance"; see the-                        -- GHC.Tc.Solver.Monad Note [Solved dictionaries]-  | LocalInstance-  | TopLevInstance { iw_dfun_id   :: DFunId-                   , iw_safe_over :: SafeOverlapping }+data InstanceWhat  -- How did we solve this constraint?+  = BuiltinEqInstance    -- Built-in solver for (t1 ~ t2), (t1 ~~ t2), Coercible t1 t2+                         -- See GHC.Tc.Solver.InertSet Note [Solved dictionaries] +  | BuiltinTypeableInstance TyCon   -- Built-in solver for Typeable (T t1 .. tn)+                         -- See Note [Well-staged instance evidence]++  | BuiltinInstance      -- Built-in solver for (C t1 .. tn) where C is+                         --   KnownNat, .. etc (classes with no top-level evidence)++  | LocalInstance        -- Solved by a quantified constraint+                         -- See GHC.Tc.Solver.InertSet Note [Solved dictionaries]++  | TopLevInstance       -- Solved by a top-level instance decl+      { iw_dfun_id   :: DFunId+      , iw_safe_over :: SafeOverlapping }+ instance Outputable ClsInstResult where   ppr NoInstance = text "NoInstance"   ppr NotSure    = text "NotSure"@@ -115,6 +127,7 @@  instance Outputable InstanceWhat where   ppr BuiltinInstance   = text "a built-in instance"+  ppr BuiltinTypeableInstance {} = text "a built-in typeable instance"   ppr BuiltinEqInstance = text "a built-in equality instance"   ppr LocalInstance     = text "a locally-quantified instance"   ppr (TopLevInstance { iw_dfun_id = dfun })@@ -126,9 +139,10 @@ safeOverlap _                                      = True  instanceReturnsDictCon :: InstanceWhat -> Bool--- See Note [Solved dictionaries] in GHC.Tc.Solver.Monad+-- See Note [Solved dictionaries] in GHC.Tc.Solver.InertSet instanceReturnsDictCon (TopLevInstance {}) = True instanceReturnsDictCon BuiltinInstance     = True+instanceReturnsDictCon BuiltinTypeableInstance {} = True instanceReturnsDictCon BuiltinEqInstance   = False instanceReturnsDictCon LocalInstance       = False @@ -145,6 +159,7 @@   = matchKnownChar dflags short_cut clas tys   | isCTupleClass clas                = matchCTuple          clas tys   | cls_name == typeableClassName     = matchTypeable        clas tys+  | cls_name == withDictClassName     = matchWithDict             tys   | clas `hasKey` heqTyConKey         = matchHeteroEquality       tys   | clas `hasKey` eqTyConKey          = matchHomoEquality         tys   | clas `hasKey` coercibleTyConKey   = matchCoercible            tys@@ -174,12 +189,12 @@         ; case (matches, unify, safeHaskFail) of              -- Nothing matches-            ([], [], _)+            ([], NoUnifiers, _)                 -> do { traceTc "matchClass not matching" (ppr pred)                       ; return NoInstance }              -- A single match (& no safe haskell failure)-            ([(ispec, inst_tys)], [], False)+            ([(ispec, inst_tys)], NoUnifiers, False)                 | short_cut_solver      -- Called from the short-cut solver                 , isOverlappable ispec                 -- If the instance has OVERLAPPABLE or OVERLAPS or INCOHERENT@@ -361,8 +376,8 @@               -> Bool      -- True <=> caller is the short-cut solver                            -- See Note [Shortcut solving: overlap]               -> Class -> [Type] -> TcM ClsInstResult-matchKnownNat _ _ clas [ty]     -- clas = KnownNat-  | Just n <- isNumLitTy ty  = makeLitDict clas ty (mkNaturalExpr n)+matchKnownNat dflags _ clas [ty]     -- clas = KnownNat+  | Just n <- isNumLitTy ty  = makeLitDict clas ty (mkNaturalExpr (targetPlatform dflags) n) matchKnownNat df sc clas tys = matchInstEnv df sc clas tys  -- See Note [Fabricating Evidence for Literals in Backpack] for why  -- this lookup into the instance environment is required.@@ -421,6 +436,182 @@  {- ******************************************************************** *                                                                     *+                   Class lookup for WithDict+*                                                                     *+***********************************************************************-}++-- See Note [withDict]+matchWithDict :: [Type] -> TcM ClsInstResult+matchWithDict [cls, mty]+    -- Check that cls is a class constraint `C t_1 ... t_n`, where+    -- `dict_tc = C` and `dict_args = t_1 ... t_n`.+  | Just (dict_tc, dict_args) <- tcSplitTyConApp_maybe cls+    -- Check that C is a class of the form+    -- `class C a_1 ... a_n where op :: meth_ty`+    -- and in that case let+    -- co :: C t1 ..tn ~R# inst_meth_ty+  , Just (inst_meth_ty, co) <- tcInstNewTyCon_maybe dict_tc dict_args+  = do { sv <- mkSysLocalM (fsLit "withDict_s") Many mty+       ; k  <- mkSysLocalM (fsLit "withDict_k") Many (mkInvisFunTyMany cls openAlphaTy)++       ; let evWithDict_type = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar] $+                               mkVisFunTysMany [mty, mkInvisFunTyMany cls openAlphaTy] openAlphaTy++       ; wd_id <- mkSysLocalM (fsLit "withDict_wd") Many evWithDict_type+       ; let wd_id' = wd_id `setInlinePragma` neverInlinePragma+               -- Inlining withDict can cause the specialiser to incorrectly common up+               -- distinct evidence terms. See (WD6) in Note [withDict].++       -- Given co2 : mty ~N# inst_meth_ty, construct the method of+       -- the WithDict dictionary:+       -- \@(r : RuntimeRep) @(a :: TYPE r) (sv : mty) (k :: cls => a) -> k (sv |> (sub co; sym co2))+       ; let evWithDict co2 =+               let wd_rhs = mkCoreLams [ runtimeRep1TyVar, openAlphaTyVar, sv, k ] $+                            Var k `App` Cast (Var sv) (mkTcTransCo (mkTcSubCo co2) (mkTcSymCo co))+               in Let (NonRec wd_id' wd_rhs) (Var wd_id')+         -- Why a Let?  See (WD6) in Note [withDict]++       ; tc <- tcLookupTyCon withDictClassName+       ; let Just withdict_data_con+                 = tyConSingleDataCon_maybe tc    -- "Data constructor"+                                                  -- for WithDict+             mk_ev [c] = evDataConApp withdict_data_con+                            [cls, mty] [evWithDict (evTermCoercion (EvExpr c))]+             mk_ev e   = pprPanic "matchWithDict" (ppr e)++       ; return $ OneInst { cir_new_theta = [mkPrimEqPred mty inst_meth_ty]+                          , cir_mk_ev     = mk_ev+                          , cir_what      = BuiltinInstance }+       }++matchWithDict _+  = return NoInstance++{-+Note [withDict]+~~~~~~~~~~~~~~~+The class `WithDict` is defined as:++    class WithDict cls meth where+        withDict :: forall {rr :: RuntimeRep} (r :: TYPE rr). meth -> (cls => r) -> r++This class is special, like `Typeable`: GHC automatically solves+for instances of `WithDict`, users cannot write their own.++It is used to implement a primitive that we cannot define in Haskell+but we can write in Core.++`WithDict` is used to create dictionaries for classes with a single method.+Consider a class like this:++   class C a where+     f :: T a++We can use `withDict` to cast values of type `T a` into dictionaries for `C a`.+To do this, we can define a function like this in the library:++  withT :: T a -> (C a => b) -> b+  withT t k = withDict @(C a) @(T a) t k++Here:++* The `cls` in `withDict` is instantiated to `C a`.++* The `meth` in `withDict` is instantiated to `T a`.+  The definition of `T` itself is irrelevant, only that `C a` is a class+  with a single method of type `T a`.++* The `r` in `withDict` is instantiated to `b`.++For any single-method class C:+   class C a1 .. an where op :: meth_ty++The solver will solve the constraint `WithDict (C t1 .. tn) mty`+as if the following instance declaration existed:++instance (mty ~# inst_meth_ty) => WithDict (C t1..tn) mty where+  withDict = \@{rr} @(r :: TYPE rr) (sv :: mty) (k :: C t1..tn => r) ->+    k (sv |> (sub co2; sym co))++That is, it matches on the first (constraint) argument of C; if C is+a single-method class, the instance "fires" and emits an equality+constraint `mty ~ inst_meth_ty`, where `inst_meth_ty` is `meth_ty[ti/ai]`.+The coercion `co2` witnesses the equality `mty ~ inst_meth_ty`.++The coercion `co` is a newtype coercion that coerces from `C t1 ... tn`+to `inst_meth_ty`.+This coercion is guaranteed to exist by virtue of the fact that+C is a class with exactly one method and no superclasses, so it+is treated like a newtype when compiled to Core.++The condition that `C` is a single-method class is implemented in the+guards of matchWithDict's definition.+If the conditions are not held, the rewriting will not fire,+and we'll report an unsolved constraint.++Some further observations about `withDict`:++(WD1) The `cls` in the type of withDict must be explicitly instantiated with+      visible type application, as invoking `withDict` would be ambiguous+      otherwise.++      For examples of how `withDict` is used in the `base` library, see `withSNat`+      in GHC.TypeNats, as well as `withSChar` and `withSSymbol` in GHC.TypeLits.++(WD2) The `r` is representation-polymorphic, to support things like+      `withTypeable` in `Data.Typeable.Internal`.++(WD3) As an alternative to `withDict`, one could define functions like `withT`+      above in terms of `unsafeCoerce`. This is more error-prone, however.++(WD4) In order to define things like `reifySymbol` below:++        reifySymbol :: forall r. String -> (forall (n :: Symbol). KnownSymbol n => r) -> r++      `withDict` needs to be instantiated with `Any`, like so:++        reifySymbol n k = withDict @(KnownSymbol Any) @String @r n (k @Any)++      The use of `Any` is explained in Note [NOINLINE someNatVal] in+      base:GHC.TypeNats.++(WD5) In earlier implementations, `withDict` was implemented as an identifier+      with special handling during either constant-folding or desugaring.+      The current approach is more robust, previously the type of `withDict`+      did not have a type-class constraint and was overly polymorphic.+      See #19915.++(WD6) In fact we desugar `withDict @(C t_1 ... t_n) @mty @{rr} @r` to++         let wd = \sv k -> k (sv |> co)+             {-# NOINLINE wd #-}+         in wd++      The local `let` and NOINLINE pragma ensure that the type-class specialiser+      doesn't wrongly common up distinct evidence terms. This is super important!+      Suppose we have calls+          withDict A k+          withDict B k+      where k1, k2 :: C T -> blah.  If we inline those withDict calls we'll get+          k (A |> co1)+          k (B |> co2)+      and the Specialiser will assume that those arguments (of type `C T`) are+      the same, will specialise `k` for that type, and will call the same,+      specialised function from both call sites.  #21575 is a concrete case in point.++      Solution: never inline `withDict`. Note that it is not sufficient to delay+      inlining until after the specialiser (that is, until Phase 2), because if+      we inline withDict in module A but import it in module B, the specialiser+      will try to common up the two distinct evidence terms.+      See test case T21575b.++      This solution is unsatisfactory, as it imposes a performance overhead+      on uses of withDict.++-}++{- ********************************************************************+*                                                                     *                    Class lookup for Typeable *                                                                     * ***********************************************************************-}@@ -464,9 +655,10 @@ doTyConApp :: Class -> Type -> TyCon -> [Kind] -> TcM ClsInstResult doTyConApp clas ty tc kind_args   | tyConIsTypeable tc-  = return $ OneInst { cir_new_theta = (map (mk_typeable_pred clas) kind_args)-                     , cir_mk_ev     = mk_ev-                     , cir_what      = BuiltinInstance }+  = do+     return $ OneInst { cir_new_theta = (map (mk_typeable_pred clas) kind_args)+                      , cir_mk_ev     = mk_ev+                      , cir_what      = BuiltinTypeableInstance tc }   | otherwise   = return NoInstance   where@@ -610,7 +802,6 @@   where     args' = [k, k, t1, t2] matchCoercible args = pprPanic "matchLiftedCoercible" (ppr args)-  {- ******************************************************************** *                                                                     *
compiler/GHC/Tc/Instance/Family.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, GADTs, ViewPatterns #-}+{-# LANGUAGE GADTs, ViewPatterns #-}  -- | The @FamInst@ type: family instance heads module GHC.Tc.Instance.Family (@@ -25,10 +25,10 @@ import GHC.Core.DataCon ( dataConName ) import GHC.Core.TyCo.Rep import GHC.Core.TyCo.FVs-import GHC.Core.TyCo.Ppr ( pprWithExplicitKindsWhen )  import GHC.Iface.Load +import GHC.Tc.Errors.Types import GHC.Tc.Types.Evidence import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Instantiate( freshenTyVarBndrs, freshenCoVarBndrsX )@@ -49,19 +49,19 @@ import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.FV  import GHC.Data.Bag( Bag, unionBags, unitBag ) import GHC.Data.Maybe  import Control.Monad-import Data.List ( sortBy ) import Data.List.NonEmpty ( NonEmpty(..) )+import qualified Data.List.NonEmpty as NE import Data.Function ( on )  import qualified GHC.LanguageExtensions  as LangExt--#include "GhclibHsVersions.h"+import GHC.Unit.Env (unitEnv_hpts)  {- Note [The type family instance consistency story] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -294,14 +294,14 @@ -- See Note [The type family instance consistency story]. checkFamInstConsistency :: [Module] -> TcM () checkFamInstConsistency directlyImpMods-  = do { (eps, hpt) <- getEpsAndHpt+  = do { (eps, hug) <- getEpsAndHug        ; traceTc "checkFamInstConsistency" (ppr directlyImpMods)        ; let { -- Fetch the iface of a given module.  Must succeed as                -- all directly imported modules must already have been loaded.                modIface mod =-                 case lookupIfaceByModule hpt (eps_PIT eps) mod of+                 case lookupIfaceByModule hug (eps_PIT eps) mod of                    Nothing    -> panicDoc "FamInst.checkFamInstConsistency"-                                          (ppr mod $$ pprHPT hpt)+                                          (ppr mod $$ ppr hug)                    Just iface -> iface                 -- Which family instance modules were checked for consistency@@ -319,7 +319,8 @@              ; hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv                                . md_fam_insts . hm_details              ; hpt_fam_insts = mkModuleEnv [ (hmiModule hmi, hmiFamInstEnv hmi)-                                           | hmi <- eltsHpt hpt]+                                           | hpt <- unitEnv_hpts hug+                                           , hmi <- eltsHpt hpt ]               } @@ -511,7 +512,7 @@   , let rep_tc = dataFamInstRepTyCon rep_fam         co     = mkUnbranchedAxInstCo Representational ax rep_args                                       (mkCoVarCos cvs)-  = ASSERT( null rep_cos ) -- See Note [Constrained family instances] in GHC.Core.FamInstEnv+  = assert (null rep_cos) $ -- See Note [Constrained family instances] in GHC.Core.FamInstEnv     Just (rep_tc, rep_args, co)    | otherwise@@ -532,7 +533,7 @@ -- It does not look through type families. -- It does not normalise arguments to a tycon. ----- If the result is Just (rep_ty, (co, gres), rep_ty), then+-- If the result is Just ((gres, co), rep_ty), then --    co : ty ~R rep_ty --    gres are the GREs for the data constructors that --                          had to be in scope@@ -699,7 +700,7 @@ checkForConflicts inst_envs fam_inst   = do { let conflicts = lookupFamInstEnvConflicts inst_envs fam_inst        ; traceTc "checkForConflicts" $-         vcat [ ppr (map fim_instance conflicts)+         vcat [ ppr conflicts               , ppr fam_inst               -- , ppr inst_envs          ]@@ -752,7 +753,7 @@    -> [Bool]       -- ^ Injectivity annotation    -> TcM () reportInjectivityErrors dflags fi_ax axiom inj-  = ASSERT2( any id inj, text "No injective type variables" )+  = assertPpr (any id inj) (text "No injective type variables") $     do let lhs             = coAxBranchLHS axiom            rhs             = coAxBranchRHS axiom            fam_tc          = coAxiomTyCon fi_ax@@ -906,8 +907,8 @@                   -> [Type] -- LHS arguments                   -> Type   -- the RHS                   -> ( TyVarSet-                     , Bool   -- True <=> one or more variable is used invisibly-                     , Bool ) -- True <=> suggest -XUndecidableInstances+                     , HasKinds                     -- YesHasKinds <=> one or more variable is used invisibly+                     , SuggestUndecidableInstances) -- YesSuggestUndecidableInstaces <=> suggest -XUndecidableInstances -- See Note [Verifying injectivity annotation] in GHC.Core.FamInstEnv. -- This function implements check (4) described there, further -- described in Note [Coverage condition for injective type families].@@ -918,7 +919,7 @@ -- precise names of variables that are not mentioned in the RHS. unusedInjTvsInRHS dflags tycon@(tyConInjectivityInfo -> Injective inj_list) lhs rhs =   -- Note [Coverage condition for injective type families], step 5-  (bad_vars, any_invisible, suggest_undec)+  (bad_vars, hasKinds any_invisible, suggestUndecidableInstances suggest_undec)     where       undec_inst = xopt LangExt.UndecidableInstances dflags @@ -939,7 +940,7 @@                       (lhs_vars `subVarSet` fvVarSet (injectiveVarsOfType True rhs))  -- When the type family is not injective in any arguments-unusedInjTvsInRHS _ _ _ _ = (emptyVarSet, False, False)+unusedInjTvsInRHS _ _ _ _ = (emptyVarSet, NoHasKinds, NoSuggestUndecidableInstaces)  --------------------------------------- -- Producing injectivity error messages@@ -950,90 +951,58 @@ reportConflictingInjectivityErrs :: TyCon -> [CoAxBranch] -> CoAxBranch -> TcM () reportConflictingInjectivityErrs _ [] _ = return () reportConflictingInjectivityErrs fam_tc (confEqn1:_) tyfamEqn-  = addErrs [buildInjectivityError fam_tc herald (confEqn1 :| [tyfamEqn])]-  where-    herald = text "Type family equation right-hand sides overlap; this violates" $$-             text "the family's injectivity annotation:"---- | Injectivity error herald common to all injectivity errors.-injectivityErrorHerald :: SDoc-injectivityErrorHerald =-  text "Type family equation violates the family's injectivity annotation."-+  = addErrs [buildInjectivityError (TcRnFamInstNotInjective InjErrRhsOverlap)+                                   fam_tc+                                   (confEqn1 :| [tyfamEqn])]  -- | Report error message for equation with injective type variables unused in -- the RHS. Note [Coverage condition for injective type families], step 6 reportUnusedInjectiveVarsErr :: TyCon                              -> TyVarSet-                             -> Bool   -- True <=> print invisible arguments-                             -> Bool   -- True <=> suggest -XUndecidableInstances+                             -> HasKinds                    -- YesHasKinds <=> print invisible arguments+                             -> SuggestUndecidableInstances -- YesSuggestUndecidableInstaces <=> suggest -XUndecidableInstances                              -> CoAxBranch                              -> TcM () reportUnusedInjectiveVarsErr fam_tc tvs has_kinds undec_inst tyfamEqn-  = let (loc, doc) = buildInjectivityError fam_tc-                                  (injectivityErrorHerald $$-                                   herald $$-                                   text "In the type family equation:")-                                  (tyfamEqn :| [])-    in addErrAt loc (pprWithExplicitKindsWhen has_kinds doc)-    where-      herald = sep [ what <+> text "variable" <>-                  pluralVarSet tvs <+> pprVarSet tvs (pprQuotedList . scopedSort)-                , text "cannot be inferred from the right-hand side." ]-               $$ extra--      what | has_kinds = text "Type/kind"-           | otherwise = text "Type"--      extra | undec_inst = text "Using UndecidableInstances might help"-            | otherwise  = empty+  = let reason     = InjErrCannotInferFromRhs tvs has_kinds undec_inst+        (loc, dia) = buildInjectivityError (TcRnFamInstNotInjective reason) fam_tc (tyfamEqn :| [])+    in addErrAt loc dia  -- | Report error message for equation that has a type family call at the top -- level of RHS reportTfHeadedErr :: TyCon -> CoAxBranch -> TcM () reportTfHeadedErr fam_tc branch-  = addErrs [buildInjectivityError fam_tc-               (injectivityErrorHerald $$-                 text "RHS of injective type family equation cannot" <+>-                 text "be a type family:")-               (branch :| [])]+  = addErrs [buildInjectivityError (TcRnFamInstNotInjective InjErrRhsCannotBeATypeFam)+                                   fam_tc+                                   (branch :| [])]  -- | Report error message for equation that has a bare type variable in the RHS -- but LHS pattern is not a bare type variable. reportBareVariableInRHSErr :: TyCon -> [Type] -> CoAxBranch -> TcM () reportBareVariableInRHSErr fam_tc tys branch-  = addErrs [buildInjectivityError fam_tc-                 (injectivityErrorHerald $$-                  text "RHS of injective type family equation is a bare" <+>-                  text "type variable" $$-                  text "but these LHS type and kind patterns are not bare" <+>-                  text "variables:" <+> pprQuotedList tys)-                 (branch :| [])]+  = addErrs [buildInjectivityError (TcRnFamInstNotInjective (InjErrRhsBareTyVar tys))+                                   fam_tc+                                   (branch :| [])] -buildInjectivityError :: TyCon -> SDoc -> NonEmpty CoAxBranch -> (SrcSpan, SDoc)-buildInjectivityError fam_tc herald (eqn1 :| rest_eqns)-  = ( coAxBranchSpan eqn1-    , hang herald-         2 (vcat (map (pprCoAxBranchUser fam_tc) (eqn1 : rest_eqns))) )+buildInjectivityError :: (TyCon -> NonEmpty CoAxBranch -> TcRnMessage)+                      -> TyCon+                      -> NonEmpty CoAxBranch+                      -> (SrcSpan, TcRnMessage)+buildInjectivityError mkErr fam_tc branches+  = ( coAxBranchSpan (NE.head branches), mkErr fam_tc branches ) -reportConflictInstErr :: FamInst -> [FamInstMatch] -> TcRn ()+reportConflictInstErr :: FamInst -> [FamInst] -> TcRn () reportConflictInstErr _ []   = return ()  -- No conflicts-reportConflictInstErr fam_inst (match1 : _)-  | FamInstMatch { fim_instance = conf_inst } <- match1-  , let sorted  = sortBy (SrcLoc.leftmost_smallest `on` getSpan) [fam_inst, conf_inst]-        fi1     = head sorted-        span    = coAxBranchSpan (coAxiomSingleBranch (famInstAxiom fi1))-  = setSrcSpan span $ addErr $-    hang (text "Conflicting family instance declarations:")-       2 (vcat [ pprCoAxBranchUser (coAxiomTyCon ax) (coAxiomSingleBranch ax)-               | fi <- sorted-               , let ax = famInstAxiom fi ])- where-   getSpan = getSrcSpan . famInstAxiom+reportConflictInstErr fam_inst (conf_inst : _) =    -- The sortBy just arranges that instances are displayed in order    -- of source location, which reduced wobbling in error messages,    -- and is better for users+  let   sorted  = NE.sortBy (SrcLoc.leftmost_smallest `on` getSpan) (fam_inst NE.:| [conf_inst])+        fi1     = NE.head sorted+        span    = coAxBranchSpan (coAxiomSingleBranch (famInstAxiom fi1))+        getSpan = getSrcSpan . famInstAxiom+  in setSrcSpan span $ addErr $ TcRnConflictingFamInstDecls sorted  tcGetFamInstEnvs :: TcM FamInstEnvs -- Gets both the external-package inst-env
compiler/GHC/Tc/Instance/FunDeps.hs view
@@ -5,7 +5,7 @@  -} -{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}  -- | Functional dependencies --@@ -18,11 +18,10 @@    , checkInstCoverage    , checkFunDeps    , pprFundeps+   , instFD, closeWrtFunDeps    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Types.Name@@ -42,7 +41,7 @@  import GHC.Utils.Outputable import GHC.Utils.FV-import GHC.Utils.Error( Validity(..), allValid )+import GHC.Utils.Error( Validity'(..), Validity, allValid ) import GHC.Utils.Misc import GHC.Utils.Panic @@ -120,6 +119,7 @@           , fd_pred1 :: PredType   -- The FunDepEqn arose from           , fd_pred2 :: PredType   --  combining these two constraints           , fd_loc   :: loc  }+    deriving Functor  {- Given a bunch of predicates that must hold, such as@@ -206,16 +206,11 @@  improveFromInstEnv :: InstEnvs                    -> (PredType -> SrcSpan -> loc)-                   -> PredType+                   -> Class -> [Type]                    -> [FunDepEqn loc] -- Needs to be a FunDepEqn because                                       -- of quantified variables -- Post: Equations oriented from the template (matching instance) to the workitem!-improveFromInstEnv inst_env mk_loc pred-  | Just (cls, tys) <- ASSERT2( isClassPred pred, ppr pred )-                       getClassPredTys_maybe pred-  , let (cls_tvs, cls_fds) = classTvsFds cls-        instances          = classInstances inst_env cls-        rough_tcs          = roughMatchTcs tys+improveFromInstEnv inst_env mk_loc cls tys   = [ FDEqn { fd_qtvs = meta_tvs, fd_eqs = eqs             , fd_pred1 = p_inst, fd_pred2 = pred             , fd_loc = mk_loc p_inst (getSrcSpan (is_dfun ispec)) }@@ -231,9 +226,15 @@                                       tys trimmed_tcs -- NB: orientation     , let p_inst = mkClassPred cls (is_tys ispec)     ]-improveFromInstEnv _ _ _ = []+  where+    (cls_tvs, cls_fds) = classTvsFds cls+    instances          = classInstances inst_env cls+    rough_tcs          = RM_KnownTc (className cls) : roughMatchTcs tys+    pred               = mkClassPred cls tys  ++ improveClsFD :: [TyVar] -> FunDep TyVar    -- One functional dependency from the class              -> ClsInst                    -- An instance template              -> [Type] -> [RoughMatchTc]   -- Arguments of this (C tys) predicate@@ -266,9 +267,9 @@   = []          -- Filter out ones that can't possibly match,    | otherwise-  = ASSERT2( equalLength tys_inst tys_actual &&-             equalLength tys_inst clas_tvs-            , ppr tys_inst <+> ppr tys_actual )+  = assertPpr (equalLength tys_inst tys_actual &&+               equalLength tys_inst clas_tvs)+              (ppr tys_inst <+> ppr tys_actual) $      case tcMatchTyKis ltys1 ltys2 of         Nothing  -> []@@ -351,7 +352,7 @@  For the coverage condition, we check    (normal)    fv(t2) `subset` fv(t1)-   (liberal)   fv(t2) `subset` oclose(fv(t1), theta)+   (liberal)   fv(t2) `subset` closeWrtFunDeps(fv(t1), theta)  The liberal version  ensures the self-consistency of the instance, but it does not guarantee termination. Example:@@ -364,7 +365,7 @@    instance Mul a b c => Mul a [b] [c] where x .*. v = map (x.*.) v  In the third instance, it's not the case that fv([c]) `subset` fv(a,[b]).-But it is the case that fv([c]) `subset` oclose( theta, fv(a,[b]) )+But it is the case that fv([c]) `subset` closeWrtFunDeps( theta, fv(a,[b]) )  But it is a mistake to accept the instance because then this defn:         f = \ b x y -> if b then x .*. [y] else y@@ -376,7 +377,7 @@                   -> Class -> [PredType] -> [Type]                   -> Validity -- "be_liberal" flag says whether to use "liberal" coverage of---              See Note [Coverage Condition] below+--              See Note [Coverage condition] below -- -- Return values --    Nothing  => no problems@@ -397,7 +398,7 @@          undetermined_tvs | be_liberal = liberal_undet_tvs                           | otherwise  = conserv_undet_tvs -         closed_ls_tvs = oclose theta ls_tvs+         closed_ls_tvs = closeWrtFunDeps theta ls_tvs          liberal_undet_tvs = (`minusVarSet` closed_ls_tvs) <$> rs_tvs          conserv_undet_tvs = (`minusVarSet` ls_tvs)        <$> rs_tvs @@ -408,7 +409,7 @@                vcat [ -- text "ls_tvs" <+> ppr ls_tvs                       -- , text "closed ls_tvs" <+> ppr (closeOverKinds ls_tvs)                       -- , text "theta" <+> ppr theta-                      -- , text "oclose" <+> ppr (oclose theta (closeOverKinds ls_tvs))+                      -- , text "closeWrtFunDeps" <+> ppr (closeWrtFunDeps theta (closeOverKinds ls_tvs))                       -- , text "rs_tvs" <+> ppr rs_tvs                       sep [ text "The"                             <+> ppWhen be_liberal (text "liberal")@@ -467,17 +468,17 @@     we get {l,k,xs} -> b    * Note the 'k'!! We must call closeOverKinds on the seed set-    ls_tvs = {l,r,xs}, BEFORE doing oclose, else the {l,k,xs}->b+    ls_tvs = {l,r,xs}, BEFORE doing closeWrtFunDeps, else the {l,k,xs}->b     fundep won't fire.  This was the reason for #10564. -  * So starting from seeds {l,r,xs,k} we do oclose to get+  * So starting from seeds {l,r,xs,k} we do closeWrtFunDeps to get     first {l,r,xs,k,b}, via the HMemberM constraint, and then     {l,r,xs,k,b,v}, via the HasFieldM1 constraint.    * And that fixes v.  However, we must closeOverKinds whenever augmenting the seed set-in oclose!  Consider #10109:+in closeWrtFunDeps!  Consider #10109:    data Succ a   -- Succ :: forall k. k -> *   class Add (a :: k1) (b :: k2) (ab :: k3) | a b -> ab@@ -493,25 +494,27 @@ Bottom line:   * closeOverKinds on initial seeds (done automatically     by tyCoVarsOfTypes in checkInstCoverage)-  * and closeOverKinds whenever extending those seeds (in oclose)+  * and closeOverKinds whenever extending those seeds (in closeWrtFunDeps)  Note [The liberal coverage condition] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-(oclose preds tvs) closes the set of type variables tvs,+(closeWrtFunDeps preds tvs) closes the set of type variables tvs, wrt functional dependencies in preds.  The result is a superset of the argument set.  For example, if we have         class C a b | a->b where ... then-        oclose [C (x,y) z, C (x,p) q] {x,y} = {x,y,z}+        closeWrtFunDeps [C (x,y) z, C (x,p) q] {x,y} = {x,y,z} because if we know x and y then that fixes z.  We also use equality predicates in the predicates; if we have an assumption `t1 ~ t2`, then we use the fact that if we know `t1` we also know `t2` and the other way.-  eg    oclose [C (x,y) z, a ~ x] {a,y} = {a,y,z,x}+  eg    closeWrtFunDeps [C (x,y) z, a ~ x] {a,y} = {a,y,z,x} -oclose is used (only) when checking the coverage condition for-an instance declaration+closeWrtFunDeps is used+ - when checking the coverage condition for an instance declaration+ - when determining which tyvars are unquantifiable during generalization, in+   GHC.Tc.Solver.decideMonoTyVars.  Note [Equality superclasses] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -522,10 +525,10 @@   * (a ~~ b) is a superclass of (a ~ b)   * (a ~# b) is a superclass of (a ~~ b) -So when oclose expands superclasses we'll get a (a ~# [b]) superclass.+So when closeWrtFunDeps expands superclasses we'll get a (a ~# [b]) superclass. But that's an EqPred not a ClassPred, and we jolly well do want to account for the mutual functional dependencies implied by (t1 ~# t2).-Hence the EqPred handling in oclose.  See #10778.+Hence the EqPred handling in closeWrtFunDeps.  See #10778.  Note [Care with type functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -535,7 +538,7 @@   type family G c d = r | r -> d  Now consider-  oclose (C (F a b) (G c d)) {a,b}+  closeWrtFunDeps (C (F a b) (G c d)) {a,b}  Knowing {a,b} fixes (F a b) regardless of the injectivity of F. But knowing (G c d) fixes only {d}, because G is only injective@@ -544,12 +547,17 @@ Hence the tyCoVarsOfTypes/injTyVarsOfTypes dance in tv_fds. -} -oclose :: [PredType] -> TyCoVarSet -> TyCoVarSet+closeWrtFunDeps :: [PredType] -> TyCoVarSet -> TyCoVarSet -- See Note [The liberal coverage condition]-oclose preds fixed_tvs+closeWrtFunDeps preds fixed_tvs   | null tv_fds = fixed_tvs -- Fast escape hatch for common case.-  | otherwise   = fixVarSet extend fixed_tvs+  | otherwise   = assertPpr (closeOverKinds fixed_tvs == fixed_tvs)+                    (vcat [ text "closeWrtFunDeps: fixed_tvs is not closed over kinds"+                          , text "fixed_tvs:" <+> ppr fixed_tvs+                          , text "closure:" <+> ppr (closeOverKinds fixed_tvs) ])+                $ fixVarSet extend fixed_tvs   where+     extend fixed_tvs = foldl' add fixed_tvs tv_fds        where           add fixed_tvs (ls,rs)@@ -675,8 +683,9 @@ -- Hence, we Nothing-ise the tb and tc types right here -- -- Result list is same length as input list, just with more Nothings-trimRoughMatchTcs clas_tvs (ltvs, _) mb_tcs-  = zipWith select clas_tvs mb_tcs+trimRoughMatchTcs _clas_tvs _ [] = panic "trimRoughMatchTcs: nullary [RoughMatchTc]"+trimRoughMatchTcs clas_tvs (ltvs, _) (cls:mb_tcs)+  = cls : zipWith select clas_tvs mb_tcs   where     select clas_tv mb_tc | clas_tv `elem` ltvs = mb_tc-                         | otherwise           = OtherTc+                         | otherwise           = RM_WildCard
compiler/GHC/Tc/Instance/Typeable.hs view
@@ -3,15 +3,13 @@ (c) The GRASP/AQUA Project, Glasgow University, 1992-1999 -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-}  module GHC.Tc.Instance.Typeable(mkTypeableBinds, tyConIsTypeable) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Platform @@ -47,10 +45,9 @@ import GHC.Utils.Panic import GHC.Data.FastString ( FastString, mkFastString, fsLit ) -import Control.Monad.Trans.State+import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Class (lift) import Data.Maybe ( isJust )-import Data.Word( Word64 )  {- Note [Grand plan for Typeable] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -175,7 +172,7 @@        } } }   where     needs_typeable_binds tc-      | tc `elem` ghcTypesTypeableTyCons+      | tc `elem` [runtimeRepTyCon, levityTyCon, vecCountTyCon, vecElemTyCon]       = False       | otherwise =           isAlgTyCon tc@@ -336,15 +333,7 @@                      -- Build TypeRepTodos for types in GHC.Prim                    ; todo2 <- todoForTyCons gHC_PRIM ghc_prim_module_id                                             ghcPrimTypeableTyCons--                   ; tcg_env <- getGblEnv-                   ; let mod_id = case tcg_tr_module tcg_env of  -- Should be set by now-                                   Just mod_id -> mod_id-                                   Nothing     -> pprPanic "tcMkTypeableBinds" empty--                   ; todo3 <- todoForTyCons gHC_TYPES mod_id ghcTypesTypeableTyCons--                   ; return ( gbl_env' , [todo1, todo2, todo3])+                   ; return ( gbl_env' , [todo1, todo2])                    }            else do gbl_env <- getGblEnv                    return (gbl_env, [])@@ -359,18 +348,12 @@ -- Note [Built-in syntax and the OrigNameCache] in "GHC.Iface.Env" for more. ghcPrimTypeableTyCons :: [TyCon] ghcPrimTypeableTyCons = concat-    [ map (tupleTyCon Unboxed) [0..mAX_TUPLE_SIZE]+    [ [ runtimeRepTyCon, levityTyCon, vecCountTyCon, vecElemTyCon ]+    , map (tupleTyCon Unboxed) [0..mAX_TUPLE_SIZE]     , map sumTyCon [2..mAX_SUM_SIZE]     , primTyCons     ] --- | These are types which are defined in GHC.Types but are needed in order to--- typecheck the other generated bindings, therefore to avoid ordering issues we--- generate them up-front along with the bindings from GHC.Prim.-ghcTypesTypeableTyCons :: [TyCon]-ghcTypesTypeableTyCons = [ runtimeRepTyCon, levityTyCon-                         , vecCountTyCon, vecElemTyCon ]- data TypeableStuff     = Stuff { platform       :: Platform        -- ^ Target platform             , trTyConDataCon :: DataCon         -- ^ of @TyCon@@@ -657,11 +640,11 @@                    -> LHsExpr GhcTc mkTyConRepTyConRHS (Stuff {..}) todo tycon kind_rep   =           nlHsDataCon trTyConDataCon-    `nlHsApp` nlHsLit (word64 platform high)-    `nlHsApp` nlHsLit (word64 platform low)+    `nlHsApp` nlHsLit (HsWord64Prim NoSourceText (toInteger high))+    `nlHsApp` nlHsLit (HsWord64Prim NoSourceText (toInteger low))     `nlHsApp` mod_rep_expr todo     `nlHsApp` trNameLit (mkFastString tycon_str)-    `nlHsApp` nlHsLit (int n_kind_vars)+    `nlHsApp` nlHsLit (HsIntPrim NoSourceText (toInteger n_kind_vars))     `nlHsApp` kind_rep   where     n_kind_vars = length $ filter isNamedTyConBinder (tyConBinders tycon)@@ -675,14 +658,6 @@                                                    , mod_fingerprint todo                                                    , fingerprintString tycon_str                                                    ]--    int :: Int -> HsLit GhcTc-    int n = HsIntPrim (SourceText $ show n) (toInteger n)--word64 :: Platform -> Word64 -> HsLit GhcTc-word64 platform n = case platformWordSize platform of-   PW4 -> HsWord64Prim NoSourceText (toInteger n)-   PW8 -> HsWordPrim   NoSourceText (toInteger n)  {- Note [Representing TyCon kinds: KindRep]
compiler/GHC/Tc/Module.hs view
@@ -6,6 +6,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE TupleSections #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -26,6 +27,8 @@         tcRnDeclsi,         isGHCiMonad,         runTcInteractive,    -- Used by GHC API clients (#8878)+        withTcPlugins,       -- Used by GHC API clients (#20499)+        withHoleFitPlugins,  -- Used by GHC API clients (#20499)         tcRnLookupName,         tcRnGetInfo,         tcRnModule, tcRnModuleTcRnM,@@ -52,8 +55,10 @@ import GHC.Driver.Env import GHC.Driver.Plugins import GHC.Driver.Session+import GHC.Driver.Config.Diagnostic  import GHC.Tc.Errors.Hole.FitTypes ( HoleFitPluginR (..) )+import GHC.Tc.Errors.Types import {-# SOURCE #-} GHC.Tc.Gen.Splice ( finishTH, runRemoteModFinalizers ) import GHC.Tc.Gen.HsType import GHC.Tc.Validity( checkValidType )@@ -86,11 +91,11 @@ import GHC.Rename.Splice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) ) import GHC.Rename.HsType import GHC.Rename.Expr-import GHC.Rename.Utils  ( HsDocContext(..) ) import GHC.Rename.Fixity ( lookupFixityRn ) import GHC.Rename.Names import GHC.Rename.Env import GHC.Rename.Module+import GHC.Rename.Doc  import GHC.Iface.Syntax   ( ShowSub(..), showToHeader ) import GHC.Iface.Type     ( ShowForAllFlag(..) )@@ -115,6 +120,7 @@ import GHC.Core.Type import GHC.Core.Class import GHC.Core.Coercion.Axiom+import GHC.Core.Reduction ( Reduction(..) ) import GHC.Core.Unify( RoughMatchTc(..) ) import GHC.Core.FamInstEnv    ( FamInst, pprFamInst, famInstsRepTyCons@@ -129,6 +135,7 @@ import GHC.Utils.Error import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Misc import GHC.Utils.Logger @@ -147,9 +154,9 @@ import GHC.Types.Basic hiding( SuccessFlag(..) ) import GHC.Types.Annotations import GHC.Types.SrcLoc-import GHC.Types.SourceText import GHC.Types.SourceFile import GHC.Types.TyThing.Ppr ( pprTyThingInContext )+import GHC.Types.PkgQual import qualified GHC.LanguageExtensions as LangExt  import GHC.Unit.External@@ -176,8 +183,6 @@ import Control.DeepSeq import Control.Monad -#include "GhclibHsVersions.h"- {- ************************************************************************ *                                                                      *@@ -191,16 +196,18 @@            -> ModSummary            -> Bool              -- True <=> save renamed syntax            -> HsParsedModule-           -> IO (Messages DecoratedSDoc, Maybe TcGblEnv)+           -> IO (Messages TcRnMessage, Maybe TcGblEnv)  tcRnModule hsc_env mod_sum save_rn_syntax    parsedModule@HsParsedModule {hpm_module= L loc this_module}  | RealSrcSpan real_loc _ <- loc- = withTiming logger dflags+ = withTiming logger               (text "Renamer/typechecker"<+>brackets (ppr this_mod))               (const ()) $    initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $-          withTcPlugins hsc_env $ withHoleFitPlugins hsc_env $+          withTcPlugins hsc_env $+          withDefaultingPlugins hsc_env $+          withHoleFitPlugins hsc_env $            tcRnModuleTcRnM hsc_env mod_sum parsedModule pair @@ -209,11 +216,10 @@    where     hsc_src = ms_hsc_src mod_sum-    dflags  = hsc_dflags hsc_env     logger  = hsc_logger hsc_env     home_unit = hsc_home_unit hsc_env-    err_msg = mkPlainMsgEnvelope loc $-              text "Module does not have a RealSrcSpan:" <+> ppr this_mod+    err_msg = mkPlainErrorMsgEnvelope loc $+              TcRnModMissingRealSrcSpan this_mod      pair :: (Module, SrcSpan)     pair@(this_mod,_)@@ -258,13 +264,15 @@         ; let { prel_imports = mkPrelImports (moduleName this_mod) prel_imp_loc                                implicit_prelude import_decls } -        ; whenWOptM Opt_WarnImplicitPrelude $-             when (notNull prel_imports) $-                addWarn (Reason Opt_WarnImplicitPrelude) (implicitPreludeWarn)+        ; when (notNull prel_imports) $ do+            let msg = TcRnUnknownMessage $+                        mkPlainDiagnostic (WarningWithFlag Opt_WarnImplicitPrelude) noHints (implicitPreludeWarn)+            addDiagnostic msg          ; -- TODO This is a little skeevy; maybe handle a bit more directly           let { simplifyImport (L _ idecl) =-                  ( fmap sl_fs (ideclPkgQual idecl) , reLoc $ ideclName idecl)+                  ( renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName idecl) (ideclPkgQual idecl)+                  , reLoc $ ideclName idecl)               }         ; raw_sig_imports <- liftIO                              $ findExtraSigImports hsc_env hsc_src@@ -273,32 +281,35 @@                              $ implicitRequirements hsc_env                                 (map simplifyImport (prel_imports                                                      ++ import_decls))-        ; let { mkImport (Nothing, L _ mod_name) = noLocA+        ; let { mkImport mod_name = noLocA                 $ (simpleImportDecl mod_name)-                  { ideclHiding = Just (False, noLocA [])}-              ; mkImport _ = panic "mkImport" }-        ; let { all_imports = prel_imports ++ import_decls-                       ++ map mkImport (raw_sig_imports ++ raw_req_imports) }+                  { ideclHiding = Just (False, noLocA [])}}+        ; let { withReason t imps = map (,text t) imps }+        ; let { all_imports = withReason "is implicitly imported" prel_imports+                  ++ withReason "is directly imported" import_decls+                  ++ withReason "is an extra sig import" (map mkImport raw_sig_imports)+                  ++ withReason "is an implicit req import" (map mkImport raw_req_imports) }         ; -- OK now finally rename the imports           tcg_env <- {-# SCC "tcRnImports" #-}                      tcRnImports hsc_env all_imports -       ;  -- Don't need to rename the Haddock documentation,-          -- it's not parsed by GHC anymore.-          -- Make sure to do this before 'tcRnSrcDecls', because we need the-          -- module header when we're splicing TH, since it can be accessed via-          -- 'getDoc'.-          tcg_env <- return (tcg_env-                              { tcg_doc_hdr = maybe_doc_hdr })-+        -- Put a version of the header without identifier info into the tcg_env+        -- Make sure to do this before 'tcRnSrcDecls', because we need the+        -- module header when we're splicing TH, since it can be accessed via+        -- 'getDoc'.+        -- We will rename it properly after renaming everything else so that+        -- haddock can link the identifiers+        ; tcg_env <- return (tcg_env+                              { tcg_doc_hdr = fmap (\(WithHsDocIdentifiers str _) -> WithHsDocIdentifiers str [])+                                                                                 <$> maybe_doc_hdr })         ; -- If the whole module is warned about or deprecated           -- (via mod_deprec) record that in tcg_warns. If we do thereby add           -- a WarnAll, it will override any subsequent deprecations added to tcg_warns-          let { tcg_env1 = case mod_deprec of-                             Just (L _ txt) ->-                               tcg_env {tcg_warns = WarnAll txt}-                             Nothing            -> tcg_env-              }+        ; tcg_env1 <- case mod_deprec of+                             Just (L _ txt) -> do { txt' <- rnWarningTxt txt+                                                  ; pure $ tcg_env {tcg_warns = WarnAll txt'}+                                                  }+                             Nothing            -> pure tcg_env         ; setGblEnv tcg_env1           $ do { -- Rename and type check the declarations                  traceRn "rn1a" empty@@ -328,11 +339,17 @@                         -- because the latter might add new bindings for                         -- boot_dfuns, which may be mentioned in imported                         -- unfoldings.-                        -- Report unused names+                      ; -- Report unused names                         -- Do this /after/ typeinference, so that when reporting                         -- a function with no type signature we can give the                         -- inferred type-                        reportUnusedNames tcg_env hsc_src+                      ; reportUnusedNames tcg_env hsc_src++                      -- Rename the module header properly after we have renamed everything else+                      ; maybe_doc_hdr <- traverse rnLHsDoc maybe_doc_hdr;+                      ; tcg_env <- return (tcg_env+                                            { tcg_doc_hdr = maybe_doc_hdr })+                       ; -- add extra source files to tcg_dependent_files                         addDependentFiles src_files                         -- Ensure plugins run with the same tcg_env that we pass in@@ -359,32 +376,31 @@ ************************************************************************ -} -tcRnImports :: HscEnv -> [LImportDecl GhcPs] -> TcM TcGblEnv+tcRnImports :: HscEnv -> [(LImportDecl GhcPs, SDoc)] -> TcM TcGblEnv tcRnImports hsc_env import_decls   = do  { (rn_imports, rdr_env, imports, hpc_info) <- rnImports import_decls ;          ; this_mod <- getModule-        ; let { dep_mods :: ModuleNameEnv ModuleNameWithIsBoot-              ; dep_mods = imp_dep_mods imports--                -- We want instance declarations from all home-package+        ; gbl_env <- getGblEnv+        ; let { -- We want instance declarations from all home-package                 -- modules below this one, including boot modules, except                 -- ourselves.  The 'except ourselves' is so that we don't                 -- get the instances from this module's hs-boot file.  This                 -- filtering also ensures that we don't see instances from                 -- modules batch (@--make@) compiled before this one, but                 -- which are not below this one.-              ; want_instances :: ModuleName -> Bool-              ; want_instances mod = mod `elemUFM` dep_mods-                                   && mod /= moduleName this_mod-              ; (home_insts, home_fam_insts) = hptInstances hsc_env-                                                            want_instances+              ; (home_insts, home_fam_insts) =++                    hptInstancesBelow hsc_env (homeUnitId $ hsc_home_unit hsc_env) (GWIB (moduleName this_mod)(hscSourceToIsBoot (tcg_src gbl_env)))+               } ;                  -- Record boot-file info in the EPS, so that it's                 -- visible to loadHiBootInterface in tcRnSrcDecls,                 -- and any other incrementally-performed imports-        ; updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ;+              ; when (isOneShot (ghcMode (hsc_dflags hsc_env))) $ do {+                  updateEps_ $ \eps  -> eps { eps_is_boot = imp_boot_mods imports }+               }                  -- Update the gbl env         ; updGblEnv ( \ gbl ->@@ -392,13 +408,13 @@               tcg_rdr_env      = tcg_rdr_env gbl `plusGlobalRdrEnv` rdr_env,               tcg_imports      = tcg_imports gbl `plusImportAvails` imports,               tcg_rn_imports   = rn_imports,-              tcg_inst_env     = extendInstEnvList (tcg_inst_env gbl) home_insts,+              tcg_inst_env     = tcg_inst_env gbl `unionInstEnv` home_insts,               tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl)                                                       home_fam_insts,               tcg_hpc          = hpc_info             }) $ do { -        ; traceRn "rn1" (ppr (imp_dep_mods imports))+        ; traceRn "rn1" (ppr (imp_direct_dep_mods imports))                 -- Fail if there are any errors so far                 -- The error printing (if needed) takes advantage                 -- of the tcg_env we have now set@@ -455,7 +471,7 @@       --  * the local env exposes the local Ids to simplifyTop,       --    so that we get better error messages (monomorphism restriction)       ; new_ev_binds <- {-# SCC "simplifyTop" #-}-                        setEnvs (tcg_env, tcl_env) $+                        restoreEnvs (tcg_env, tcl_env) $                         do { lie_main <- checkMainType tcg_env                            ; simplifyTop (lie `andWC` lie_main) } @@ -464,6 +480,9 @@                    mkTypeableBinds        ; traceTc "Tc9" empty+      ; failIfErrsM    -- Stop now if if there have been errors+                       -- Continuing is a waste of time; and we may get debug+                       -- warnings when zonking about strangely-typed TyCons!          -- Zonk the final code.  This must be done last.         -- Even simplifyTop may do some unification.@@ -496,19 +515,23 @@       --------- Deal with the exports ----------       -- Can't be done earlier, because the export list must "see"       -- the declarations created by the finalizers-      ; tcg_env <- setEnvs (tcg_env, tcl_env) $+      ; tcg_env <- restoreEnvs (tcg_env, tcl_env) $                    rnExports explicit_mod_hdr export_ies        --------- Emit the ':Main.main = runMainIO main' declaration ----------       -- Do this /after/ rnExports, so that it can consult       -- the tcg_exports created by rnExports       ; (tcg_env, main_ev_binds)-           <- setEnvs (tcg_env, tcl_env) $+           <- restoreEnvs (tcg_env, tcl_env) $               do { (tcg_env, lie) <- captureTopConstraints $                                      checkMain explicit_mod_hdr export_ies                  ; ev_binds <- simplifyTop lie                  ; return (tcg_env, ev_binds) } +      ; failIfErrsM    -- Stop now if if there have been errors+                       -- Continuing is a waste of time; and we may get debug+                       -- warnings when zonking about strangely-typed TyCons!+       ---------- Final zonking ---------------       -- Zonk the new bindings arising from running the finalisers,       -- and main. This won't give rise to any more finalisers as you@@ -543,10 +566,7 @@   = {-# SCC "zonkTopDecls" #-}     setGblEnv tcg_env $ -- This sets the GlobalRdrEnv which is used when rendering                         --   error messages during zonking (notably levity errors)-    do { failIfErrsM    -- Don't zonk if there have been errors-                        -- It's a waste of time; and we may get debug warnings-                        -- about strangely-typed TyCons!-       ; let all_ev_binds = cur_ev_binds `unionBags` ev_binds+    do { let all_ev_binds = cur_ev_binds `unionBags` ev_binds        ; zonkTopDecls all_ev_binds binds rules imp_specs fords }  -- | Runs TH finalizers and renames and typechecks the top-level declarations@@ -560,7 +580,7 @@   else do     writeTcRef th_modfinalizers_var []     let run_finalizer (lcl_env, f) =-            setLclEnv lcl_env (runRemoteModFinalizers f)+            restoreLclEnv lcl_env (runRemoteModFinalizers f)      (_, lie_th) <- captureTopConstraints $                    mapM_ run_finalizer th_modfinalizers@@ -569,7 +589,7 @@       -- we have to run tc_rn_src_decls to get them     (tcg_env, tcl_env, lie_top_decls) <- tc_rn_src_decls [] -    setEnvs (tcg_env, tcl_env) $ do+    restoreEnvs (tcg_env, tcl_env) $ do       -- Subsequent rounds of finalizers run after any new constraints are       -- simplified, or some types might not be complete when using reify       -- (see #12777).@@ -608,7 +628,7 @@                         { Nothing -> return ()                         ; Just (SpliceDecl _ (L loc _) _, _) ->                             setSrcSpanA loc-                            $ addErr (text+                            $ addErr (TcRnUnknownMessage $ mkPlainError noHints $ text                                 ("Declaration splices are not "                                   ++ "permitted inside top-level "                                   ++ "declarations added with addTopDecls"))@@ -636,7 +656,7 @@                                       tcTopSrcDecls rn_decls          -- If there is no splice, we're nearly done-      ; setEnvs (tcg_env, tcl_env) $+      ; restoreEnvs (tcg_env, tcl_env) $         case group_tail of           { Nothing -> return (tcg_env, tcl_env, lie1) @@ -698,7 +718,7 @@                  -- Typecheck type/class/instance decls         ; traceTc "Tc2 (boot)" empty-        ; (tcg_env, inst_infos, _deriv_binds)+        ; (tcg_env, inst_infos, _deriv_binds, _th_bndrs)              <- tcTyClsInstDecls tycl_decls deriv_decls val_binds         ; setGblEnv tcg_env     $ do { @@ -730,7 +750,8 @@  badBootDecl :: HscSource -> String -> LocatedA decl -> TcM () badBootDecl hsc_src what (L loc _)-  = addErrAt (locA loc) (char 'A' <+> text what+  = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $+    (char 'A' <+> text what       <+> text "declaration is not (currently) allowed in a"       <+> (case hsc_src of             HsBootFile -> text "hs-boot"@@ -866,9 +887,6 @@      check_export boot_avail     -- boot_avail is exported by the boot iface       | name `elem` boot_dfun_names = return ()-      | isWiredInName name          = return () -- No checking for wired-in names.  In particular,-                                                -- 'error' is handled by a rather gross hack-                                                -- (see comments in GHC.Err.hs-boot)          -- Check that the actual module exports the same thing       | not (null missing_names)@@ -975,7 +993,7 @@ checkBootDecl :: Bool -> TyThing -> TyThing -> Maybe SDoc  checkBootDecl _ (AnId id1) (AnId id2)-  = ASSERT(id1 == id2)+  = assert (id1 == id2) $     check (idType id1 `eqType` idType id2)           (text "The two types are different") @@ -1115,7 +1133,7 @@   | Just syn_rhs1 <- synTyConRhs_maybe tc1   , Just syn_rhs2 <- synTyConRhs_maybe tc2   , Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)-  = ASSERT(tc1 == tc2)+  = assert (tc1 == tc2) $     checkRoles roles1 roles2 `andThenCheck`     check (eqTypeX env syn_rhs1 syn_rhs2) empty   -- nothing interesting to say   -- This allows abstract 'data T a' to be implemented using 'type T = ...'@@ -1145,7 +1163,7 @@    | Just fam_flav1 <- famTyConFlav_maybe tc1   , Just fam_flav2 <- famTyConFlav_maybe tc2-  = ASSERT(tc1 == tc2)+  = assert (tc1 == tc2) $     let eqFamFlav OpenSynFamilyTyCon   OpenSynFamilyTyCon = True         eqFamFlav (DataFamilyTyCon {}) (DataFamilyTyCon {}) = True         -- This case only happens for hsig merging:@@ -1171,7 +1189,7 @@    | isAlgTyCon tc1 && isAlgTyCon tc2   , Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)-  = ASSERT(tc1 == tc2)+  = assert (tc1 == tc2) $     checkRoles roles1 roles2 `andThenCheck`     check (eqListBy (eqTypeX env)                      (tyConStupidTheta tc1) (tyConStupidTheta tc2))@@ -1266,7 +1284,7 @@     --     -- See also 'HowAbstract' and Note [Skolem abstract data]. -    -- | Given @type T tvs = ty@, where @ty@ decomposes into @tc2' args@,+    -- Given @type T tvs = ty@, where @ty@ decomposes into @tc2' args@,     -- check that this synonym is an acceptable implementation of @tc1@.     -- See Note [Synonyms implement abstract data]     checkSynAbsData :: [TyVar] -> Type -> TyCon -> [Type] -> Maybe SDoc@@ -1280,7 +1298,7 @@                 `andThenCheck`         -- Don't report roles errors unless the type synonym is nullary         checkUnless (not (null tvs)) $-            ASSERT( null roles2 )+            assert (null roles2) $             -- If we have something like:             --             --  signature H where@@ -1302,7 +1320,7 @@                     Nothing -> Just roles_msg -} -    eqAlgRhs _ AbstractTyCon _rhs2+    eqAlgRhs _ (AbstractTyCon {}) _rhs2       = checkSuccess -- rhs2 is guaranteed to be injective, since it's an AlgTyCon     eqAlgRhs _  tc1@DataTyCon{} tc2@DataTyCon{} =         checkListBy eqCon (data_cons tc1) (data_cons tc2) (text "constructors")@@ -1359,24 +1377,27 @@ emptyRnEnv2 = mkRnEnv2 emptyInScopeSet  -----------------missingBootThing :: Bool -> Name -> String -> SDoc+missingBootThing :: Bool -> Name -> String -> TcRnMessage missingBootThing is_boot name what-  = quotes (ppr name) <+> text "is exported by the"+  = TcRnUnknownMessage $ mkPlainError noHints $+    quotes (ppr name) <+> text "is exported by the"     <+> (if is_boot then text "hs-boot" else text "hsig")     <+> text "file, but not"     <+> text what <+> text "the module" -badReexportedBootThing :: Bool -> Name -> Name -> SDoc+badReexportedBootThing :: Bool -> Name -> Name -> TcRnMessage badReexportedBootThing is_boot name name'-  = withUserStyle alwaysQualify AllTheWay $ vcat+  = TcRnUnknownMessage $ mkPlainError noHints $+    withUserStyle alwaysQualify AllTheWay $ vcat         [ text "The" <+> (if is_boot then text "hs-boot" else text "hsig")            <+> text "file (re)exports" <+> quotes (ppr name)         , text "but the implementing module exports a different identifier" <+> quotes (ppr name')         ] -bootMisMatch :: Bool -> SDoc -> TyThing -> TyThing -> SDoc+bootMisMatch :: Bool -> SDoc -> TyThing -> TyThing -> TcRnMessage bootMisMatch is_boot extra_info real_thing boot_thing-  = pprBootMisMatch is_boot extra_info real_thing real_doc boot_doc+  = TcRnUnknownMessage $ mkPlainError noHints $+    pprBootMisMatch is_boot extra_info real_thing real_doc boot_doc   where     to_doc       = pprTyThingInContext $ showToHeader { ss_forall =@@ -1404,9 +1425,10 @@             extra_info           ] -instMisMatch :: DFunId -> SDoc+instMisMatch :: DFunId -> TcRnMessage instMisMatch dfun-  = hang (text "instance" <+> ppr (idType dfun))+  = TcRnUnknownMessage $ mkPlainError noHints $+    hang (text "instance" <+> ppr (idType dfun))        2 (text "is defined in the hs-boot file, but not in the module itself")  {-@@ -1455,9 +1477,11 @@                 -- Source-language instances, including derivings,                 -- and import the supporting declarations         traceTc "Tc3" empty ;-        (tcg_env, inst_infos, XValBindsLR (NValBinds deriv_binds deriv_sigs))+        (tcg_env, inst_infos, th_bndrs,+         XValBindsLR (NValBinds deriv_binds deriv_sigs))             <- tcTyClsInstDecls tycl_decls deriv_decls val_binds ; +        updLclEnv (\tcl_env -> tcl_env { tcl_th_bndrs = th_bndrs `plusNameEnv` tcl_th_bndrs tcl_env }) $         setGblEnv tcg_env       $ do {                  -- Generate Applicative/Monad proposal (AMP) warnings@@ -1484,14 +1508,14 @@                 -- the bindings produced in a Data instance.)         traceTc "Tc5" empty ;         tc_envs <- tcTopBinds val_binds val_sigs;-        setEnvs tc_envs $ do {+        restoreEnvs tc_envs $ do {                  -- Now GHC-generated derived bindings, generics, and selectors                 -- Do not generate warnings from compiler-generated code;                 -- hence the use of discardWarnings         tc_envs@(tcg_env, tcl_env)             <- discardWarnings (tcTopBinds deriv_binds deriv_sigs) ;-        setEnvs tc_envs $ do {  -- Environment doesn't change now+        restoreEnvs tc_envs $ do {  -- Environment doesn't change now                  -- Second pass over class and instance declarations,                 -- now using the kind-checked decls@@ -1543,10 +1567,13 @@  tcSemigroupWarnings :: TcM () tcSemigroupWarnings = do-    traceTc "tcSemigroupWarnings" empty-    let warnFlag = Opt_WarnSemigroup-    tcPreludeClashWarn warnFlag sappendName-    tcMissingParentClassWarn warnFlag monoidClassName semigroupClassName+    mod <- getModule+    -- ghc-prim doesn't depend on base+    unless (moduleUnit mod == primUnit) $ do+      traceTc "tcSemigroupWarnings" empty+      let warnFlag = Opt_WarnSemigroup+      tcPreludeClashWarn warnFlag sappendName+      tcMissingParentClassWarn warnFlag monoidClassName semigroupClassName   -- | Warn on local definitions of names that would clash with future Prelude@@ -1572,7 +1599,7 @@     -- Continue only the name is imported from Prelude     ; when (importedViaPrelude name rnImports) $ do       -- Handle 2.-4.-    { rdrElts <- fmap (concat . occEnvElts . tcg_rdr_env) getGblEnv+    { rdrElts <- fmap (concat . nonDetOccEnvElts . tcg_rdr_env) getGblEnv      ; let clashes :: GlobalRdrElt -> Bool           clashes x = isLocalDef && nameClashes && isNotInProperModule@@ -1592,7 +1619,9 @@     ; traceTc "tcPreludeClashWarn/prelude_functions"                 (hang (ppr name) 4 (sep [ppr clashingElts])) -    ; let warn_msg x = addWarnAt (Reason warnFlag) (nameSrcSpan (greMangledName x)) (hsep+    ; let warn_msg x = addDiagnosticAt (nameSrcSpan (greMangledName x)) $+            TcRnUnknownMessage $+            mkPlainDiagnostic (WarningWithFlag warnFlag) noHints $ (hsep               [ text "Local definition of"               , (quotes . ppr . nameOccName . greMangledName) x               , text "clashes with a future Prelude name." ]@@ -1686,9 +1715,9 @@        }}   where     -- Check whether the desired superclass exists in a given environment.-    checkShouldInst :: Class   -- ^ Class of existing instance-                    -> Class   -- ^ Class there should be an instance of-                    -> ClsInst -- ^ Existing instance+    checkShouldInst :: Class   -- Class of existing instance+                    -> Class   -- Class there should be an instance of+                    -> ClsInst -- Existing instance                     -> TcM ()     checkShouldInst isClass shouldClass isInst       = do { instEnv <- tcGetInstEnvs@@ -1702,8 +1731,9 @@            -- "<location>: Warning: <type> is an instance of <is> but not            -- <should>" e.g. "Foo is an instance of Monad but not Applicative"            ; let instLoc = srcLocSpan . nameSrcLoc $ getName isInst-                 warnMsg (KnownTc name:_) =-                      addWarnAt (Reason warnFlag) instLoc $+                 warnMsg (RM_KnownTc name:_) =+                      addDiagnosticAt instLoc $+                        TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag warnFlag) noHints $                            hsep [ (quotes . ppr . nameOccName) name                                 , text "is an instance of"                                 , (ppr . nameOccName . className) isClass@@ -1714,7 +1744,7 @@                            hsep [ text "This will become an error in"                                 , text "a future release." ]                  warnMsg _ = pure ()-           ; when (null shouldInsts && null instanceMatches) $+           ; when (nullUnifiers shouldInsts && null instanceMatches) $                   warnMsg (is_tcs isInst)            } @@ -1732,13 +1762,14 @@                          [InstInfo GhcRn],    -- Source-code instance decls to                                               -- process; contains all dfuns for                                               -- this module+                          ThBindEnv,          -- TH binding levels                           HsValBinds GhcRn)   -- Supporting bindings for derived                                               -- instances  tcTyClsInstDecls tycl_decls deriv_decls binds  = tcAddDataFamConPlaceholders (tycl_decls >>= group_instds) $    tcAddPatSynPlaceholders (getPatSynBinds binds) $-   do { (tcg_env, inst_info, deriv_info)+   do { (tcg_env, inst_info, deriv_info, th_bndrs)           <- tcTyAndClassDecls tycl_decls ;       ; setGblEnv tcg_env $ do {           -- With the @TyClDecl@s and @InstDecl@s checked we're ready to@@ -1752,7 +1783,7 @@               <- tcInstDeclsDeriv deriv_info deriv_decls           ; setGblEnv tcg_env' $ do {                 failIfErrsM-              ; pure (tcg_env', inst_info' ++ inst_info, val_binds)+              ; pure ( tcg_env', inst_info' ++ inst_info, th_bndrs, val_binds )       }}}  {- *********************************************************************@@ -1769,7 +1800,7 @@ -- See Note [Dealing with main] checkMainType tcg_env   = do { hsc_env <- getTopEnv-       ; if tcg_mod tcg_env /= mainModIs hsc_env+       ; if tcg_mod tcg_env /= mainModIs (hsc_HUE hsc_env)          then return emptyWC else      do { rdr_env <- getGlobalRdrEnv@@ -1782,7 +1813,7 @@             [main_gre] ->      do { let main_name = greMangledName main_gre-             ctxt      = FunSigCtxt main_name False+             ctxt      = FunSigCtxt main_name NoRRC        ; main_id   <- tcLookupId main_name        ; (io_ty,_) <- getIOType        ; let main_ty   = idType main_id@@ -1806,7 +1837,7 @@       ; tcg_env <- getGblEnv        ; let dflags      = hsc_dflags hsc_env-            main_mod    = mainModIs hsc_env+            main_mod    = mainModIs (hsc_HUE hsc_env)             main_occ    = getMainOcc dflags              exported_mains :: [Name]@@ -1824,7 +1855,7 @@               generateMainBinding tcg_env main_name             | otherwise-           -> ASSERT( null exported_mains )+           -> assert (null exported_mains) $               -- A fully-checked export list can't contain more               -- than one function with the same OccName               do { complain_no_main dflags main_mod main_occ@@ -1840,7 +1871,8 @@         -- in other modes, add error message and go on with typechecking.      noMainMsg main_mod main_occ-      = text "The" <+> ppMainFn main_occ+      = TcRnUnknownMessage $ mkPlainError noHints $+            text "The" <+> ppMainFn main_occ         <+> text "is not" <+> text defOrExp <+> text "module"         <+> quotes (ppr main_mod) @@ -1881,7 +1913,7 @@     ; (ev_binds, main_expr) <- setMainCtxt main_name io_ty $                                tcCheckMonoExpr main_expr_rn io_ty -            -- See Note [Root-main Id]+            -- See Note [Root-main id]             -- Construct the binding             --      :Main.main :: IO res_ty = runMainIO res_ty main     ; run_main_id <- tcLookupId runMainIOName@@ -1920,7 +1952,7 @@     checkConstraints skol_info [] []  $  -- Builds an implication if necessary     thing_inside                         -- e.g. with -fdefer-type-errors   where-    skol_info = SigSkol (FunSigCtxt main_name False) io_ty []+    skol_info = SigSkol (FunSigCtxt main_name NoRRC) io_ty []     main_ctxt = text "When checking the type of the"                 <+> ppMainFn (nameOccName main_name) @@ -2016,16 +2048,17 @@ ********************************************************* -} -runTcInteractive :: HscEnv -> TcRn a -> IO (Messages DecoratedSDoc, Maybe a)+runTcInteractive :: HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a) -- Initialise the tcg_inst_env with instances from all home modules. -- This mimics the more selective call to hptInstances in tcRnImports runTcInteractive hsc_env thing_inside-  = initTcInteractive hsc_env $ withTcPlugins hsc_env $ withHoleFitPlugins hsc_env $+  = initTcInteractive hsc_env $ withTcPlugins hsc_env $+    withDefaultingPlugins hsc_env $ withHoleFitPlugins hsc_env $     do { traceTc "setInteractiveContext" $             vcat [ text "ic_tythings:" <+> vcat (map ppr (ic_tythings icxt))-                 , text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) ic_insts)-                 , text "ic_rn_gbl_env (LocalDef)" <+>-                      vcat (map ppr [ local_gres | gres <- occEnvElts (ic_rn_gbl_env icxt)+                 , text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) (instEnvElts ic_insts))+                 , text "icReaderEnv (LocalDef)" <+>+                      vcat (map ppr [ local_gres | gres <- nonDetOccEnvElts (icReaderEnv icxt)                                                  , let local_gres = filter isLocalGRE gres                                                  , not (null local_gres) ]) ] @@ -2036,41 +2069,36 @@         ; !orphs <- fmap (force . concat) . forM (ic_imports icxt) $ \i ->             case i of                   -- force above: see #15111-                IIModule n -> getOrphans n Nothing-                IIDecl i ->-                  let mb_pkg = sl_fs <$> ideclPkgQual i in-                  getOrphans (unLoc (ideclName i)) mb_pkg+                IIModule n -> getOrphans n NoPkgQual+                IIDecl i   -> getOrphans (unLoc (ideclName i))+                                         (renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i)) -       ; let imports = emptyImportAvails {-                            imp_orphs = orphs-                        }+       ; let imports = emptyImportAvails { imp_orphs = orphs } -       ; (gbl_env, lcl_env) <- getEnvs-       ; let gbl_env' = gbl_env {-                           tcg_rdr_env      = ic_rn_gbl_env icxt-                         , tcg_type_env     = type_env-                         , tcg_inst_env     = extendInstEnvList-                                               (extendInstEnvList (tcg_inst_env gbl_env) ic_insts)-                                               home_insts-                         , tcg_fam_inst_env = extendFamInstEnvList+             upd_envs (gbl_env, lcl_env) = (gbl_env', lcl_env')+               where+                 gbl_env' = gbl_env { tcg_rdr_env      = icReaderEnv icxt+                                    , tcg_type_env     = type_env++                                    , tcg_inst_env     = tcg_inst_env gbl_env `unionInstEnv` ic_insts `unionInstEnv` home_insts+                                    , tcg_fam_inst_env = extendFamInstEnvList                                                (extendFamInstEnvList (tcg_fam_inst_env gbl_env)                                                                      ic_finsts)                                                home_fam_insts-                         , tcg_field_env    = mkNameEnv con_fields-                              -- setting tcg_field_env is necessary-                              -- to make RecordWildCards work (test: ghci049)-                         , tcg_fix_env      = ic_fix_env icxt-                         , tcg_default      = ic_default icxt-                              -- must calculate imp_orphs of the ImportAvails-                              -- so that instance visibility is done correctly-                         , tcg_imports      = imports-                         }+                                    , tcg_field_env    = mkNameEnv con_fields+                                         -- setting tcg_field_env is necessary+                                         -- to make RecordWildCards work (test: ghci049)+                                    , tcg_fix_env      = ic_fix_env icxt+                                    , tcg_default      = ic_default icxt+                                         -- must calculate imp_orphs of the ImportAvails+                                         -- so that instance visibility is done correctly+                                    , tcg_imports      = imports } -             lcl_env' = tcExtendLocalTypeEnv lcl_env lcl_ids+                 lcl_env' = tcExtendLocalTypeEnv lcl_env lcl_ids -       ; setEnvs (gbl_env', lcl_env') thing_inside }+       ; updEnvs upd_envs thing_inside }   where-    (home_insts, home_fam_insts) = hptInstances hsc_env (\_ -> True)+    (home_insts, home_fam_insts) = hptAllInstances hsc_env      icxt                     = hsc_IC hsc_env     (ic_insts, ic_finsts)    = ic_instances icxt@@ -2089,7 +2117,7 @@       = Right thing      type_env1 = mkTypeEnvWithImplicits top_ty_things-    type_env  = extendTypeEnvWithIds type_env1 (map instanceDFunId ic_insts)+    type_env  = extendTypeEnvWithIds type_env1 (map instanceDFunId (instEnvElts ic_insts))                 -- Putting the dfuns in the type_env                 -- is just to keep Core Lint happy @@ -2132,7 +2160,7 @@ -- The returned TypecheckedHsExpr is of type IO [ () ], a list of the bound -- values, coerced to (). tcRnStmt :: HscEnv -> GhciLStmt GhcPs-         -> IO (Messages DecoratedSDoc, Maybe ([Id], LHsExpr GhcTc, FixityEnv))+         -> IO (Messages TcRnMessage, Maybe ([Id], LHsExpr GhcTc, FixityEnv)) tcRnStmt hsc_env rdr_stmt   = runTcInteractive hsc_env $ do { @@ -2141,37 +2169,19 @@     zonked_expr <- zonkTopLExpr tc_expr ;     zonked_ids  <- zonkTopBndrs bound_ids ; -    failIfErrsM ;  -- we can't do the next step if there are levity polymorphism errors+    failIfErrsM ;  -- we can't do the next step if there are+                   -- representation polymorphism errors                    -- test case: ghci/scripts/T13202{,a}          -- None of the Ids should be of unboxed type, because we         -- cast them all to HValues in the end!-    mapM_ bad_unboxed (filter (isUnliftedType . idType) zonked_ids) ;+    mapM_ bad_unboxed (filter (mightBeUnliftedType . idType) zonked_ids) ;      traceTc "tcs 1" empty ;     this_mod <- getModule ;     global_ids <- mapM (externaliseAndTidyId this_mod) zonked_ids ;         -- Note [Interactively-bound Ids in GHCi] in GHC.Driver.Env -{- ----------------------------------------------   At one stage I removed any shadowed bindings from the type_env;-   they are inaccessible but might, I suppose, cause a space leak if we leave them there.-   However, with Template Haskell they aren't necessarily inaccessible.  Consider this-   GHCi session-         Prelude> let f n = n * 2 :: Int-         Prelude> fName <- runQ [| f |]-         Prelude> $(return $ AppE fName (LitE (IntegerL 7)))-         14-         Prelude> let f n = n * 3 :: Int-         Prelude> $(return $ AppE fName (LitE (IntegerL 7)))-   In the last line we use 'fName', which resolves to the *first* 'f'-   in scope. If we delete it from the type env, GHCi crashes because-   it doesn't expect that.--   Hence this code is commented out---------------------------------------------------- -}-     traceOptTcRn Opt_D_dump_tc         (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,                text "Typechecked expr" <+> ppr zonked_expr]) ;@@ -2179,7 +2189,8 @@     return (global_ids, zonked_expr, fix_env)     }   where-    bad_unboxed id = addErr (sep [text "GHCi can't bind a variable of unlifted type:",+    bad_unboxed id = addErr $ TcRnUnknownMessage $ mkPlainError noHints $+      (sep [text "GHCi can't bind a variable of unlifted type:",                                   nest 2 (pprPrefixOcc id <+> dcolon <+> ppr (idType id))])  {-@@ -2230,6 +2241,9 @@ -- An expression typed at the prompt is treated very specially tcUserStmt (L loc (BodyStmt _ expr _ _))   = do  { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr)++        ; dumpOptTcRn Opt_D_dump_rn_ast "Renamer" FormatHaskell+            (showAstData NoBlankSrcSpan NoBlankEpAnnotations rn_expr)                -- Don't try to typecheck if the renamer fails!         ; ghciStep <- getGhciStepIO         ; uniq <- newUnique@@ -2326,6 +2340,9 @@                                  then no_it_plans                                  else it_plans +        ; dumpOptTcRn Opt_D_dump_tc_ast "Typechecker AST" FormatHaskell+              (showAstData NoBlankSrcSpan NoBlankEpAnnotations plan)+         ; fix_env <- getFixityEnv         ; return (plan, fix_env) } @@ -2379,7 +2396,7 @@  tcUserStmt rdr_stmt@(L loc _)   = do { (([rn_stmt], fix_env), fvs) <- checkNoErrs $-           rnStmts GhciStmtCtxt rnExpr [rdr_stmt] $ \_ -> do+           rnStmts (HsDoStmt GhciStmtCtxt) rnExpr [rdr_stmt] $ \_ -> do              fix_env <- getFixityEnv              return (fix_env, emptyFVs)             -- Don't try to typecheck if the renamer fails!@@ -2444,7 +2461,7 @@       ; ret_id  <- tcLookupId returnIOName             -- return @ IO       ; let ret_ty      = mkListTy unitTy             io_ret_ty   = mkTyConApp ioTyCon [ret_ty]-            tc_io_stmts = tcStmtsAndThen GhciStmtCtxt tcDoStmt stmts+            tc_io_stmts = tcStmtsAndThen (HsDoStmt GhciStmtCtxt) tcDoStmt stmts                                          (mkCheckExpType io_ret_ty)             names = collectLStmtsBinders CollNoDictBinders stmts @@ -2464,8 +2481,8 @@        ; traceTc "GHC.Tc.Module.tcGhciStmts: done" empty -      -- rec_expr is the expression-      --      returnIO @ [()] [unsafeCoerce# () x, ..,  unsafeCorece# () z]+      -- ret_expr is the expression+      --      returnIO @[()] [unsafeCoerce# () x, ..,  unsafeCoerce# () z]       --       -- Despite the inconvenience of building the type applications etc,       -- this *has* to be done in type-annotated post-typecheck form@@ -2499,8 +2516,8 @@ getGhciStepIO = do     ghciTy <- getGHCiMonad     a_tv <- newName (mkTyVarOccFS (fsLit "a"))-    let ghciM   = nlHsAppTy (nlHsTyVar ghciTy) (nlHsTyVar a_tv)-        ioM     = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv)+    let ghciM   = nlHsAppTy (nlHsTyVar NotPromoted ghciTy) (nlHsTyVar NotPromoted a_tv)+        ioM     = nlHsAppTy (nlHsTyVar NotPromoted ioTyConName) (nlHsTyVar NotPromoted a_tv)          step_ty :: LHsSigType GhcRn         step_ty = noLocA $ HsSig@@ -2513,7 +2530,7 @@      return (noLocA $ ExprWithTySig noExtField (nlHsVar ghciStepIoMName) stepTy) -isGHCiMonad :: HscEnv -> String -> IO (Messages DecoratedSDoc, Maybe Name)+isGHCiMonad :: HscEnv -> String -> IO (Messages TcRnMessage, Maybe Name) isGHCiMonad hsc_env ty   = runTcInteractive hsc_env $ do         rdrEnv <- getGlobalRdrEnv@@ -2527,8 +2544,8 @@                 _ <- tcLookupInstance ghciClass [userTy]                 return name -            Just _  -> failWithTc $ text "Ambiguous type!"-            Nothing -> failWithTc $ text ("Can't find type:" ++ ty)+            Just _  -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ text "Ambiguous type!"+            Nothing -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ text ("Can't find type:" ++ ty)  -- | How should we infer a type? See Note [TcRnExprMode] data TcRnExprMode = TM_Inst     -- ^ Instantiate inferred quantifiers only (:type)@@ -2540,7 +2557,7 @@ tcRnExpr :: HscEnv          -> TcRnExprMode          -> LHsExpr GhcPs-         -> IO (Messages DecoratedSDoc, Maybe Type)+         -> IO (Messages TcRnMessage, Maybe Type) tcRnExpr hsc_env mode rdr_expr   = runTcInteractive hsc_env $     do {@@ -2574,7 +2591,7 @@      -- See Note [Normalising the type in :type]     fam_envs <- tcGetFamInstEnvs ;-    let { normalised_type = snd $ normaliseType fam_envs Nominal ty+    let { normalised_type = reductionReducedType $ normaliseType fam_envs Nominal ty           -- normaliseType returns a coercion which we discard, so the Role is irrelevant.         ; final_type = if isSigmaTy res_ty then ty else normalised_type } ;     return final_type }@@ -2632,13 +2649,13 @@ -------------------------- tcRnImportDecls :: HscEnv                 -> [LImportDecl GhcPs]-                -> IO (Messages DecoratedSDoc, Maybe GlobalRdrEnv)+                -> IO (Messages TcRnMessage, Maybe GlobalRdrEnv) -- Find the new chunk of GlobalRdrEnv created by this list of import -- decls.  In contract tcRnImports *extends* the TcGblEnv. tcRnImportDecls hsc_env import_decls  =  runTcInteractive hsc_env $     do { gbl_env <- updGblEnv zap_rdr_env $-                    tcRnImports hsc_env import_decls+                    tcRnImports hsc_env $ map (,text "is directly imported") import_decls        ; return (tcg_rdr_env gbl_env) }   where     zap_rdr_env gbl_env = gbl_env { tcg_rdr_env = emptyGlobalRdrEnv }@@ -2648,7 +2665,7 @@          -> ZonkFlexi          -> Bool        -- Normalise the returned type          -> LHsType GhcPs-         -> IO (Messages DecoratedSDoc, Maybe (Type, Kind))+         -> IO (Messages TcRnMessage, Maybe (Type, Kind)) tcRnType hsc_env flexi normalise rdr_type   = runTcInteractive hsc_env $     setXOptM LangExt.PolyKinds $   -- See Note [Kind-generalise in tcRnType]@@ -2673,10 +2690,10 @@         -- Since all the wanteds are equalities, the returned bindings will be empty        ; empty_binds <- simplifyTop wanted-       ; MASSERT2( isEmptyBag empty_binds, ppr empty_binds )+       ; massertPpr (isEmptyBag empty_binds) (ppr empty_binds)         -- Do kind generalisation; see Note [Kind-generalise in tcRnType]-       ; kvs <- kindGeneralizeAll kind+       ; kvs <- kindGeneralizeAll unkSkol kind         ; e <- mkEmptyZonkEnv flexi        ; ty  <- zonkTcTypeToTypeX e ty@@ -2688,7 +2705,7 @@        --   normaliseType: expand type-family applications        --   expandTypeSynonyms: expand type synonyms (#18828)        ; fam_envs <- tcGetFamInstEnvs-       ; let ty' | normalise = expandTypeSynonyms $ snd $+       ; let ty' | normalise = expandTypeSynonyms $ reductionReducedType $                                normaliseType fam_envs Nominal ty                  | otherwise = ty @@ -2712,7 +2729,7 @@   reverse :: forall a. [a] -> [a]    -- foo :: forall a f b. (Show a, Num b, Foldable f) => a -> f b -> String-  > :type +v foo @Int+  > :type foo @Int   forall f b. (Show Int, Num b, Foldable f) => Int -> f b -> String    Note that Show Int is still reported, because the solver never got a chance@@ -2782,7 +2799,7 @@  tcRnDeclsi :: HscEnv            -> [LHsDecl GhcPs]-           -> IO (Messages DecoratedSDoc, Maybe TcGblEnv)+           -> IO (Messages TcRnMessage, Maybe TcGblEnv) tcRnDeclsi hsc_env local_decls   = runTcInteractive hsc_env $     tcRnSrcDecls False Nothing local_decls@@ -2807,13 +2824,13 @@ -- a package module with an interface on disk.  If neither of these is -- true, then the result will be an error indicating the interface -- could not be found.-getModuleInterface :: HscEnv -> Module -> IO (Messages DecoratedSDoc, Maybe ModIface)+getModuleInterface :: HscEnv -> Module -> IO (Messages TcRnMessage, Maybe ModIface) getModuleInterface hsc_env mod   = runTcInteractive hsc_env $     loadModuleInterface (text "getModuleInterface") mod  tcRnLookupRdrName :: HscEnv -> LocatedN RdrName-                  -> IO (Messages DecoratedSDoc, Maybe [Name])+                  -> IO (Messages TcRnMessage, Maybe [Name]) -- ^ Find all the Names that this RdrName could mean, in GHCi tcRnLookupRdrName hsc_env (L loc rdr_name)   = runTcInteractive hsc_env $@@ -2824,10 +2841,11 @@          let rdr_names = dataTcOccs rdr_name        ; names_s <- mapM lookupInfoOccRn rdr_names        ; let names = concat names_s-       ; when (null names) (addErrTc (text "Not in scope:" <+> quotes (ppr rdr_name)))+       ; when (null names) (addErrTc $ TcRnUnknownMessage $ mkPlainError noHints $+           (text "Not in scope:" <+> quotes (ppr rdr_name)))        ; return names } -tcRnLookupName :: HscEnv -> Name -> IO (Messages DecoratedSDoc, Maybe TyThing)+tcRnLookupName :: HscEnv -> Name -> IO (Messages TcRnMessage, Maybe TyThing) tcRnLookupName hsc_env name   = runTcInteractive hsc_env $     tcRnLookupName' name@@ -2846,7 +2864,7 @@  tcRnGetInfo :: HscEnv             -> Name-            -> IO ( Messages DecoratedSDoc+            -> IO ( Messages TcRnMessage                   , Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))  -- Used to implement :info in GHCi@@ -2914,7 +2932,7 @@     home_unit = hsc_home_unit hsc_env      unqual_mods = [ nameModule name-                  | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt)+                  | gre <- globalRdrEnvElts (icReaderEnv ictxt)                   , let name = greMangledName gre                   , nameIsFromExternalPackage home_unit name                   , isTcOcc (nameOccName name)   -- Types and classes only@@ -2938,11 +2956,11 @@  tcDump :: TcGblEnv -> TcRn () tcDump env- = do { dflags <- getDynFlags ;-        unit_state <- hsc_units <$> getTopEnv ;+ = do { unit_state <- hsc_units <$> getTopEnv ;+        logger <- getLogger ;          -- Dump short output if -ddump-types or -ddump-tc-        when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)+        when (logHasDumpFlag logger Opt_D_dump_types || logHasDumpFlag logger Opt_D_dump_tc)           (dumpTcRn True Opt_D_dump_types             "" FormatText (pprWithUnitState unit_state short_dump)) ; @@ -2975,9 +2993,9 @@          , ppr_fam_insts fam_insts          , ppr_rules rules          , text "Dependent modules:" <+>-                pprUFM (imp_dep_mods imports) (ppr . sort)+                (ppr . sort . installedModuleEnvElts $ imp_direct_dep_mods imports)          , text "Dependent packages:" <+>-                ppr (S.toList $ imp_dep_pkgs imports)]+                ppr (S.toList $ imp_dep_direct_pkgs imports)]                 -- The use of sort is just to reduce unnecessary                 -- wobbling in testsuite output @@ -2998,6 +3016,7 @@       | otherwise = hasTopUserName id                     && case idDetails id of                          VanillaId    -> True+                         WorkerLikeId{} -> True                          RecSelId {}  -> True                          ClassOpId {} -> True                          FCallId {}   -> True@@ -3093,33 +3112,51 @@  withTcPlugins :: HscEnv -> TcM a -> TcM a withTcPlugins hsc_env m =-    case getTcPlugins hsc_env of+    case catMaybes $ mapPlugins (hsc_plugins hsc_env) tcPlugin of        []      -> m  -- Common fast case        plugins -> do-                ev_binds_var <- newTcEvBinds-                (solvers,stops) <- unzip `fmap` mapM (startPlugin ev_binds_var) plugins-                -- This ensures that tcPluginStop is called even if a type+                (solvers, rewriters, stops) <-+                  unzip3 `fmap` mapM start_plugin plugins+                let+                  rewritersUniqFM :: UniqFM TyCon [TcPluginRewriter]+                  !rewritersUniqFM = sequenceUFMList rewriters+                -- The following ensures that tcPluginStop is called even if a type                 -- error occurs during compilation (Fix of #10078)                 eitherRes <- tryM $-                  updGblEnv (\e -> e { tcg_tc_plugins = solvers }) m-                mapM_ (flip runTcPluginM ev_binds_var) stops+                  updGblEnv (\e -> e { tcg_tc_plugin_solvers   = solvers+                                     , tcg_tc_plugin_rewriters = rewritersUniqFM }) m+                mapM_ runTcPluginM stops                 case eitherRes of                   Left _ -> failM                   Right res -> return res   where-  startPlugin ev_binds_var (TcPlugin start solve stop) =-    do s <- runTcPluginM start ev_binds_var-       return (solve s, stop s)--getTcPlugins :: HscEnv -> [GHC.Tc.Utils.Monad.TcPlugin]-getTcPlugins hsc_env = catMaybes $ mapPlugins hsc_env (\p args -> tcPlugin p args)+  start_plugin (TcPlugin start solve rewrite stop) =+    do s <- runTcPluginM start+       return (solve s, rewrite s, stop s) +withDefaultingPlugins :: HscEnv -> TcM a -> TcM a+withDefaultingPlugins hsc_env m =+  do case catMaybes $ mapPlugins (hsc_plugins hsc_env) defaultingPlugin of+       [] -> m  -- Common fast case+       plugins  -> do (plugins,stops) <- mapAndUnzipM start_plugin plugins+                      -- This ensures that dePluginStop is called even if a type+                      -- error occurs during compilation+                      eitherRes <- tryM $ do+                        updGblEnv (\e -> e { tcg_defaulting_plugins = plugins }) m+                      mapM_ runTcPluginM stops+                      case eitherRes of+                        Left _ -> failM+                        Right res -> return res+  where+  start_plugin (DefaultingPlugin start fill stop) =+    do s <- runTcPluginM start+       return (fill s, stop s)  withHoleFitPlugins :: HscEnv -> TcM a -> TcM a withHoleFitPlugins hsc_env m =-  case getHfPlugins hsc_env of+  case catMaybes $ mapPlugins (hsc_plugins hsc_env) holeFitPlugin of     [] -> m  -- Common fast case-    plugins -> do (plugins,stops) <- unzip `fmap` mapM startPlugin plugins+    plugins -> do (plugins,stops) <- mapAndUnzipM start_plugin plugins                   -- This ensures that hfPluginStop is called even if a type                   -- error occurs during compilation.                   eitherRes <- tryM $@@ -3129,21 +3166,17 @@                     Left _ -> failM                     Right res -> return res   where-    startPlugin (HoleFitPluginR init plugin stop) =+    start_plugin (HoleFitPluginR init plugin stop) =       do ref <- init          return (plugin ref, stop ref) -getHfPlugins :: HscEnv -> [HoleFitPluginR]-getHfPlugins hsc_env =-  catMaybes $ mapPlugins hsc_env (\p args -> holeFitPlugin p args) - runRenamerPlugin :: TcGblEnv                  -> HsGroup GhcRn                  -> TcM (TcGblEnv, HsGroup GhcRn) runRenamerPlugin gbl_env hs_group = do     hsc_env <- getTopEnv-    withPlugins hsc_env+    withPlugins (hsc_plugins hsc_env)       (\p opts (e, g) -> ( mark_plugin_unsafe (hsc_dflags hsc_env)                             >> renamedResultAction p opts e g))       (gbl_env, hs_group)@@ -3154,7 +3187,7 @@ -- exception/signal an error. type RenamedStuff =         (Maybe (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)],-                Maybe LHsDocString))+                Maybe (LHsDoc GhcRn)))  -- | Extract the renamed information from TcGblEnv. getRenamedStuff :: TcGblEnv -> RenamedStuff@@ -3166,7 +3199,7 @@ runTypecheckerPlugin :: ModSummary -> TcGblEnv -> TcM TcGblEnv runTypecheckerPlugin sum gbl_env = do     hsc_env <- getTopEnv-    withPlugins hsc_env+    withPlugins (hsc_plugins hsc_env)       (\p opts env -> mark_plugin_unsafe (hsc_dflags hsc_env)                         >> typeCheckResultAction p opts sum env)       gbl_env@@ -3175,6 +3208,7 @@ mark_plugin_unsafe dflags = unless (gopt Opt_PluginTrustworthy dflags) $   recordUnsafeInfer pluginUnsafe   where-    unsafeText = "Use of plugins makes the module unsafe"-    pluginUnsafe = unitBag ( mkPlainWarnMsg noSrcSpan-                                   (Outputable.text unsafeText) )+    !diag_opts = initDiagOpts dflags+    pluginUnsafe =+      singleMessage $+      mkPlainMsgEnvelope diag_opts noSrcSpan TcRnUnsafeDueToPlugin
compiler/GHC/Tc/Module.hs-boot view
@@ -2,11 +2,11 @@  import GHC.Prelude import GHC.Types.TyThing(TyThing)+import GHC.Tc.Errors.Types (TcRnMessage) import GHC.Tc.Types (TcM)-import GHC.Utils.Outputable (SDoc) import GHC.Types.Name (Name)  checkBootDeclM :: Bool  -- ^ True <=> an hs-boot file (could also be a sig)                -> TyThing -> TyThing -> TcM ()-missingBootThing :: Bool -> Name -> String -> SDoc-badReexportedBootThing :: Bool -> Name -> Name -> SDoc+missingBootThing :: Bool -> Name -> String -> TcRnMessage+badReexportedBootThing :: Bool -> Name -> Name -> TcRnMessage
+ compiler/GHC/Tc/Plugin.hs view
@@ -0,0 +1,194 @@++-- | This module provides an interface for typechecker plugins to+-- access select functions of the 'TcM', principally those to do with+-- reading parts of the state.+module GHC.Tc.Plugin (+        -- * Basic TcPluginM functionality+        TcPluginM,+        tcPluginIO,+        tcPluginTrace,+        unsafeTcPluginTcM,++        -- * Finding Modules and Names+        Finder.FindResult(..),+        findImportedModule,+        lookupOrig,++        -- * Looking up Names in the typechecking environment+        tcLookupGlobal,+        tcLookupTyCon,+        tcLookupDataCon,+        tcLookupClass,+        tcLookup,+        tcLookupId,++        -- * Getting the TcM state+        getTopEnv,+        getTargetPlatform,+        getEnvs,+        getInstEnvs,+        getFamInstEnvs,+        matchFam,++        -- * Type variables+        newUnique,+        newFlexiTyVar,+        isTouchableTcPluginM,++        -- * Zonking+        zonkTcType,+        zonkCt,++        -- * Creating constraints+        newWanted,+        newGiven,+        newCoercionHole,++        -- * Manipulating evidence bindings+        newEvVar,+        setEvBind,+    ) where++import GHC.Prelude++import GHC.Platform (Platform)++import qualified GHC.Tc.Utils.Monad     as TcM+import qualified GHC.Tc.Solver.Monad    as TcS+import qualified GHC.Tc.Utils.Env       as TcM+import qualified GHC.Tc.Utils.TcMType   as TcM+import qualified GHC.Tc.Instance.Family as TcM+import qualified GHC.Iface.Env          as IfaceEnv+import qualified GHC.Unit.Finder        as Finder++import GHC.Core.FamInstEnv     ( FamInstEnv )+import GHC.Tc.Utils.Monad      ( TcGblEnv, TcLclEnv, TcPluginM+                               , unsafeTcPluginTcM+                               , liftIO, traceTc )+import GHC.Tc.Types.Constraint ( Ct, CtLoc, CtEvidence(..) )+import GHC.Tc.Utils.TcMType    ( TcTyVar, TcType )+import GHC.Tc.Utils.Env        ( TcTyThing )+import GHC.Tc.Types.Evidence   ( CoercionHole, EvTerm(..)+                               , EvExpr, EvBindsVar, EvBind, mkGivenEvBind )+import GHC.Types.Var           ( EvVar )++import GHC.Unit.Module    ( ModuleName, Module )+import GHC.Types.Name     ( OccName, Name )+import GHC.Types.TyThing  ( TyThing )+import GHC.Core.Reduction ( Reduction )+import GHC.Core.TyCon     ( TyCon )+import GHC.Core.DataCon   ( DataCon )+import GHC.Core.Class     ( Class )+import GHC.Driver.Env       ( HscEnv(..) )+import GHC.Utils.Outputable ( SDoc )+import GHC.Core.Type        ( Kind, Type, PredType )+import GHC.Types.Id         ( Id )+import GHC.Core.InstEnv     ( InstEnvs )+import GHC.Types.Unique     ( Unique )+import GHC.Types.PkgQual    ( PkgQual )+++-- | Perform some IO, typically to interact with an external tool.+tcPluginIO :: IO a -> TcPluginM a+tcPluginIO a = unsafeTcPluginTcM (liftIO a)++-- | Output useful for debugging the compiler.+tcPluginTrace :: String -> SDoc -> TcPluginM ()+tcPluginTrace a b = unsafeTcPluginTcM (traceTc a b)+++findImportedModule :: ModuleName -> PkgQual -> TcPluginM Finder.FindResult+findImportedModule mod_name mb_pkg = do+    hsc_env <- getTopEnv+    tcPluginIO $ Finder.findImportedModule hsc_env mod_name mb_pkg++lookupOrig :: Module -> OccName -> TcPluginM Name+lookupOrig mod = unsafeTcPluginTcM . IfaceEnv.lookupOrig mod+++tcLookupGlobal :: Name -> TcPluginM TyThing+tcLookupGlobal = unsafeTcPluginTcM . TcM.tcLookupGlobal++tcLookupTyCon :: Name -> TcPluginM TyCon+tcLookupTyCon = unsafeTcPluginTcM . TcM.tcLookupTyCon++tcLookupDataCon :: Name -> TcPluginM DataCon+tcLookupDataCon = unsafeTcPluginTcM . TcM.tcLookupDataCon++tcLookupClass :: Name -> TcPluginM Class+tcLookupClass = unsafeTcPluginTcM . TcM.tcLookupClass++tcLookup :: Name -> TcPluginM TcTyThing+tcLookup = unsafeTcPluginTcM . TcM.tcLookup++tcLookupId :: Name -> TcPluginM Id+tcLookupId = unsafeTcPluginTcM . TcM.tcLookupId+++getTopEnv :: TcPluginM HscEnv+getTopEnv = unsafeTcPluginTcM TcM.getTopEnv++getTargetPlatform :: TcPluginM Platform+getTargetPlatform = unsafeTcPluginTcM TcM.getPlatform+++getEnvs :: TcPluginM (TcGblEnv, TcLclEnv)+getEnvs = unsafeTcPluginTcM TcM.getEnvs++getInstEnvs :: TcPluginM InstEnvs+getInstEnvs = unsafeTcPluginTcM TcM.tcGetInstEnvs++getFamInstEnvs :: TcPluginM (FamInstEnv, FamInstEnv)+getFamInstEnvs = unsafeTcPluginTcM TcM.tcGetFamInstEnvs++matchFam :: TyCon -> [Type]+         -> TcPluginM (Maybe Reduction)+matchFam tycon args = unsafeTcPluginTcM $ TcS.matchFamTcM tycon args++newUnique :: TcPluginM Unique+newUnique = unsafeTcPluginTcM TcM.newUnique++newFlexiTyVar :: Kind -> TcPluginM TcTyVar+newFlexiTyVar = unsafeTcPluginTcM . TcM.newFlexiTyVar++isTouchableTcPluginM :: TcTyVar -> TcPluginM Bool+isTouchableTcPluginM = unsafeTcPluginTcM . TcM.isTouchableTcM++-- Confused by zonking? See Note [What is zonking?] in GHC.Tc.Utils.TcMType.+zonkTcType :: TcType -> TcPluginM TcType+zonkTcType = unsafeTcPluginTcM . TcM.zonkTcType++zonkCt :: Ct -> TcPluginM Ct+zonkCt = unsafeTcPluginTcM . TcM.zonkCt++-- | Create a new Wanted constraint with the given 'CtLoc'.+newWanted :: CtLoc -> PredType -> TcPluginM CtEvidence+newWanted loc pty+  = unsafeTcPluginTcM (TcM.newWantedWithLoc loc pty)++-- | Create a new given constraint, with the supplied evidence.+--+-- This should only be invoked within 'tcPluginSolve'.+newGiven :: EvBindsVar -> CtLoc -> PredType -> EvExpr -> TcPluginM CtEvidence+newGiven tc_evbinds loc pty evtm = do+   new_ev <- newEvVar pty+   setEvBind tc_evbinds $ mkGivenEvBind new_ev (EvExpr evtm)+   return CtGiven { ctev_pred = pty, ctev_evar = new_ev, ctev_loc = loc }++-- | Create a fresh evidence variable.+--+-- This should only be invoked within 'tcPluginSolve'.+newEvVar :: PredType -> TcPluginM EvVar+newEvVar = unsafeTcPluginTcM . TcM.newEvVar++-- | Create a fresh coercion hole.+-- This should only be invoked within 'tcPluginSolve'.+newCoercionHole :: PredType -> TcPluginM CoercionHole+newCoercionHole = unsafeTcPluginTcM . TcM.newCoercionHole++-- | Bind an evidence variable.+--+-- This should only be invoked within 'tcPluginSolve'.+setEvBind :: EvBindsVar -> EvBind -> TcPluginM ()+setEvBind tc_evbinds ev_bind = do+    unsafeTcPluginTcM $ TcM.addTcEvBind tc_evbinds ev_bind
compiler/GHC/Tc/Solver.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE RecursiveDo #-}  module GHC.Tc.Solver(        InferMode(..), simplifyInfer, findInferredDiff,@@ -22,16 +22,15 @@        promoteTyVarSet, simplifyAndEmitFlatConstraints,         -- For Rules we need these-       solveWanteds, solveWantedsAndDrop,-       approximateWC, runTcSDeriveds-  ) where+       solveWanteds,+       approximateWC -#include "GhclibHsVersions.h"+  ) where  import GHC.Prelude  import GHC.Data.Bag-import GHC.Core.Class ( Class, classKey, classTyCon )+import GHC.Core.Class import GHC.Driver.Session import GHC.Tc.Utils.Instantiate import GHC.Data.List.SetOps@@ -41,6 +40,7 @@ import GHC.Builtin.Utils import GHC.Builtin.Names import GHC.Tc.Errors+import GHC.Tc.Errors.Types import GHC.Tc.Types.Evidence import GHC.Tc.Solver.Interact import GHC.Tc.Solver.Canonical   ( makeSuperClasses, solveCallStack )@@ -48,20 +48,24 @@ import GHC.Tc.Utils.Unify        ( buildTvImplication ) import GHC.Tc.Utils.TcMType as TcM import GHC.Tc.Utils.Monad   as TcM+import GHC.Tc.Solver.InertSet import GHC.Tc.Solver.Monad  as TcS import GHC.Tc.Types.Constraint+import GHC.Tc.Instance.FunDeps import GHC.Core.Predicate import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType import GHC.Core.Type import GHC.Core.Ppr-import GHC.Builtin.Types ( liftedRepTy, manyDataConTy )+import GHC.Core.TyCon    ( TyConBinder, isTypeFamilyTyCon )+import GHC.Builtin.Types ( liftedRepTy, manyDataConTy, liftedDataConTy ) import GHC.Core.Unify    ( tcMatchTyKi ) import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Types.Var import GHC.Types.Var.Set-import GHC.Types.Basic    ( IntWithInf, intGtLimit )+import GHC.Types.Basic    ( IntWithInf, intGtLimit+                          , DefaultingStrategy(..), NonStandardDefaultingStrategy(..) ) import GHC.Types.Error import qualified GHC.LanguageExtensions as LangExt @@ -69,6 +73,7 @@ import Data.Foldable      ( toList ) import Data.List          ( partition ) import Data.List.NonEmpty ( NonEmpty(..) )+import GHC.Data.Maybe     ( mapMaybe )  {- *********************************************************************************@@ -121,7 +126,7 @@   = do { empty_binds <- simplifyTop (mkImplicWC implics)         -- Since all the inputs are implications the returned bindings will be empty-       ; MASSERT2( isEmptyBag empty_binds, ppr empty_binds )+       ; massertPpr (isEmptyBag empty_binds) (ppr empty_binds)         ; return () } @@ -153,23 +158,23 @@             ; whyUnsafe <- getWarningMessages <$> TcM.readTcRef errs_var            ; TcM.writeTcRef errs_var saved_msg-           ; recordUnsafeInfer whyUnsafe+           ; recordUnsafeInfer (mkMessages whyUnsafe)            }        ; traceTc "reportUnsolved (unsafe overlapping) }" empty         ; return (evBindMapBinds binds1 `unionBags` binds2) } -pushLevelAndSolveEqualities :: SkolemInfo -> [TcTyVar] -> TcM a -> TcM a+pushLevelAndSolveEqualities :: SkolemInfoAnon -> [TyConBinder] -> TcM a -> TcM a -- Push level, and solve all resulting equalities -- If there are any unsolved equalities, report them -- and fail (in the monad) -- -- Panics if we solve any non-equality constraints.  (In runTCSEqualities -- we use an error thunk for the evidence bindings.)-pushLevelAndSolveEqualities skol_info skol_tvs thing_inside+pushLevelAndSolveEqualities skol_info_anon tcbs thing_inside   = do { (tclvl, wanted, res) <- pushLevelAndSolveEqualitiesX                                       "pushLevelAndSolveEqualities" thing_inside-       ; reportUnsolvedEqualities skol_info skol_tvs tclvl wanted+       ; report_unsolved_equalities skol_info_anon (binderVars tcbs) tclvl wanted        ; return res }  pushLevelAndSolveEqualitiesX :: String -> TcM a@@ -212,7 +217,7 @@ simplifyAndEmitFlatConstraints :: WantedConstraints -> TcM () -- See Note [Failure in local type signatures] simplifyAndEmitFlatConstraints wanted-  = do { -- Solve and zonk to esablish the+  = do { -- Solve and zonk to establish the          -- preconditions for floatKindEqualities          wanted <- runTcSEqualities (solveWanteds wanted)        ; wanted <- TcM.zonkWC wanted@@ -223,22 +228,23 @@                          -- Emit the bad constraints, wrapped in an implication                          -- See Note [Wrapping failing kind equalities]                          ; tclvl  <- TcM.getTcLevel-                         ; implic <- buildTvImplication UnkSkol [] (pushTcLevel tclvl) wanted-                                    --                  ^^^^^^   |  ^^^^^^^^^^^^^^^^^-                                    -- it's OK to use UnkSkol    |  we must increase the TcLevel,-                                    -- because we don't bind     |  as explained in-                                    -- any skolem variables here |  Note [Wrapping failing kind equalities]+                         ; implic <- buildTvImplication unkSkolAnon [] (pushTcLevel tclvl) wanted+                                        --                  ^^^^^^   |  ^^^^^^^^^^^^^^^^^+                                        -- it's OK to use unkSkol    |  we must increase the TcLevel,+                                        -- because we don't bind     |  as explained in+                                        -- any skolem variables here |  Note [Wrapping failing kind equalities]                          ; emitImplication implic                          ; failM }-           Just (simples, holes)+           Just (simples, errs)               -> do { _ <- promoteTyVarSet (tyCoVarsOfCts simples)                     ; traceTc "emitFlatConstraints }" $                       vcat [ text "simples:" <+> ppr simples-                           , text "holes:  " <+> ppr holes ]-                    ; emitHoles holes -- Holes don't need promotion+                           , text "errs:   " <+> ppr errs ]+                      -- Holes and other delayed errors don't need promotion+                    ; emitDelayedErrors errs                     ; emitSimples simples } } -floatKindEqualities :: WantedConstraints -> Maybe (Bag Ct, Bag Hole)+floatKindEqualities :: WantedConstraints -> Maybe (Bag Ct, Bag DelayedError) -- Float out all the constraints from the WantedConstraints, -- Return Nothing if any constraints can't be floated (captured -- by skolems), or if there is an insoluble constraint, or@@ -251,15 +257,15 @@ -- See Note [floatKindEqualities vs approximateWC] floatKindEqualities wc = float_wc emptyVarSet wc   where-    float_wc :: TcTyCoVarSet -> WantedConstraints -> Maybe (Bag Ct, Bag Hole)+    float_wc :: TcTyCoVarSet -> WantedConstraints -> Maybe (Bag Ct, Bag DelayedError)     float_wc trapping_tvs (WC { wc_simple = simples                               , wc_impl = implics-                              , wc_holes = holes })+                              , wc_errors = errs })       | all is_floatable simples-      = do { (inner_simples, inner_holes)+      = do { (inner_simples, inner_errs)                 <- flatMapBagPairM (float_implic trapping_tvs) implics            ; return ( simples `unionBags` inner_simples-                    , holes `unionBags` inner_holes) }+                    , errs `unionBags` inner_errs) }       | otherwise       = Nothing       where@@ -267,7 +273,7 @@            | insolubleEqCt ct = False            | otherwise        = tyCoVarsOfCt ct `disjointVarSet` trapping_tvs -    float_implic :: TcTyCoVarSet -> Implication -> Maybe (Bag Ct, Bag Hole)+    float_implic :: TcTyCoVarSet -> Implication -> Maybe (Bag Ct, Bag DelayedError)     float_implic trapping_tvs (Implic { ic_wanted = wanted, ic_given_eqs = given_eqs                                       , ic_skols = skols, ic_status = status })       | isInsolubleStatus status@@ -456,13 +462,20 @@ -- -- The provided SkolemInfo and [TcTyVar] arguments are used in an implication to -- provide skolem info for any errors.--- reportUnsolvedEqualities skol_info skol_tvs tclvl wanted+  = report_unsolved_equalities (getSkolemInfo skol_info) skol_tvs tclvl wanted++report_unsolved_equalities :: SkolemInfoAnon -> [TcTyVar] -> TcLevel+                           -> WantedConstraints -> TcM ()+report_unsolved_equalities skol_info_anon skol_tvs tclvl wanted   | isEmptyWC wanted   = return ()-  | otherwise++  | otherwise  -- NB: we build an implication /even if skol_tvs is empty/,+               -- just to ensure that our level invariants hold, specifically+               -- (WantedInv).  See Note [TcLevel invariants].   = checkNoErrs $   -- Fail-    do { implic <- buildTvImplication skol_info skol_tvs tclvl wanted+    do { implic <- buildTvImplication skol_info_anon skol_tvs tclvl wanted        ; reportAllUnsolved (mkImplicWC (unitBag implic)) }  @@ -471,7 +484,7 @@ simplifyTopWanteds :: WantedConstraints -> TcS WantedConstraints     -- See Note [Top-level Defaulting Plan] simplifyTopWanteds wanteds-  = do { wc_first_go <- nestTcS (solveWantedsAndDrop wanteds)+  = do { wc_first_go <- nestTcS (solveWanteds wanteds)                             -- This is where the main work happens        ; dflags <- getDynFlags        ; try_tyvar_defaulting dflags wc_first_go }@@ -484,14 +497,22 @@       , gopt Opt_PrintExplicitRuntimeReps dflags -- See Note [Defaulting insolubles]       = try_class_defaulting wc       | otherwise-      = do { free_tvs <- TcS.zonkTyCoVarsAndFVList (tyCoVarsOfWCList wc)-           ; let meta_tvs = filter (isTyVar <&&> isMetaTyVar) free_tvs-                   -- zonkTyCoVarsAndFV: the wc_first_go is not yet zonked-                   -- filter isMetaTyVar: we might have runtime-skolems in GHCi,-                   -- and we definitely don't want to try to assign to those!-                   -- The isTyVar is needed to weed out coercion variables+      = do { -- Need to zonk first, as the WantedConstraints are not yet zonked.+           ; free_tvs <- TcS.zonkTyCoVarsAndFVList (tyCoVarsOfWCList wc)+           ; let defaultable_tvs = filter can_default free_tvs+                 can_default tv+                   =   isTyVar tv+                       -- Weed out coercion variables. -           ; defaulted <- mapM defaultTyVarTcS meta_tvs   -- Has unification side effects+                    && isMetaTyVar tv+                       -- Weed out runtime-skolems in GHCi, which we definitely+                       -- shouldn't try to default.++                    && not (tv `elemVarSet` nonDefaultableTyVarsOfWC wc)+                       -- Weed out variables for which defaulting would be unhelpful,+                       -- e.g. alpha appearing in [W] alpha[conc] ~# rr[sk].++           ; defaulted <- mapM defaultTyVarTcS defaultable_tvs -- Has unification side effects            ; if or defaulted              then do { wc_residual <- nestTcS (solveWanteds wc)                             -- See Note [Must simplify after defaulting]@@ -501,12 +522,12 @@     try_class_defaulting :: WantedConstraints -> TcS WantedConstraints     try_class_defaulting wc       | isEmptyWC wc || insolubleWC wc -- See Note [Defaulting insolubles]-      = return wc+      = try_callstack_defaulting wc       | otherwise  -- See Note [When to do type-class defaulting]       = do { something_happened <- applyDefaultingRules wc                                    -- See Note [Top-level Defaulting Plan]            ; if something_happened-             then do { wc_residual <- nestTcS (solveWantedsAndDrop wc)+             then do { wc_residual <- nestTcS (solveWanteds wc)                      ; try_class_defaulting wc_residual }                   -- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence              else try_callstack_defaulting wc }@@ -582,6 +603,20 @@ errors if there are *any* insoluble errors, anywhere, but that seems too drastic. +Note [Don't default in syntactic equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When there are unsolved syntactic equalities such as++  rr[sk] ~S# alpha[conc]++we should not default alpha, lest we obtain a poor error message such as++  Couldn't match kind `rr' with `LiftedRep'++We would rather preserve the original syntactic equality to be+reported to the user, especially as the concrete metavariable alpha+might store an informative origin for the user.+ Note [Must simplify after defaulting] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We may have a deeply buried constraint@@ -664,7 +699,7 @@ Secondly, when should these heuristics be enforced? We enforced them when the type-class method call site is in a module marked `-XSafe` or `-XTrustworthy`. This allows `-XUnsafe` modules to operate without restriction, and for Safe-Haskell inferrence to infer modules with unsafe overlaps as unsafe.+Haskell inference to infer modules with unsafe overlaps as unsafe.  One alternative design would be to also consider if an instance was imported as a `safe` import or not and only apply the restriction to instances imported@@ -728,17 +763,17 @@     available and how they overlap. So we once again call `lookupInstEnv` to     figure that out so we can generate a helpful error message. - 6) `GHC.Tc.Utils.Monad.recordUnsafeInfer` -- Save the unsafe result and reason in an-      IORef called `tcg_safeInfer`.+ 6) `GHC.Tc.Utils.Monad.recordUnsafeInfer` -- Save the unsafe result and reason in+      IORefs called `tcg_safe_infer` and `tcg_safe_infer_reason`. - 7) `GHC.Driver.Main.tcRnModule'` -- Reads `tcg_safeInfer` after type-checking, calling-    `GHC.Driver.Main.markUnsafeInfer` (passing the reason along) when safe-inferrence+ 7) `GHC.Driver.Main.tcRnModule'` -- Reads `tcg_safe_infer` after type-checking, calling+    `GHC.Driver.Main.markUnsafeInfer` (passing the reason along) when safe-inference     failed.  Note [No defaulting in the ambiguity check] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When simplifying constraints for the ambiguity check, we use-solveWantedsAndDrop, not simplifyTopWanteds, so that we do no defaulting.+solveWanteds, not simplifyTopWanteds, so that we do no defaulting. #11947 was an example:    f :: Num a => Int -> Int This is ambiguous of course, but we don't want to default the@@ -785,16 +820,32 @@  which is just plain wrong. -Conclusion: we should do RuntimeRep-defaulting on insolubles only when the user does not-want to hear about RuntimeRep stuff -- that is, when -fprint-explicit-runtime-reps-is not set.+Another situation in which we don't want to default involves concrete metavariables.++In equalities such as   alpha[conc] ~# rr[sk]  ,  alpha[conc] ~# RR beta[tau]+for a type family RR (all at kind RuntimeRep), we would prefer to report a+representation-polymorphism error rather than default alpha and get error:++  Could not unify `rr` with `Lifted` / Could not unify `RR b0` with `Lifted`++which is very confusing. For this reason, we weed out the concrete+metavariables participating in such equalities in nonDefaultableTyVarsOfWC.+Just looking at insolublity is not enough, as `alpha[conc] ~# RR beta[tau]` could+become soluble after defaulting beta (see also #21430).++Conclusion: we should do RuntimeRep-defaulting on insolubles only when the+user does not want to hear about RuntimeRep stuff -- that is, when+-fprint-explicit-runtime-reps is not set.+However, we must still take care not to default concrete type variables+participating in an equality with a non-concrete type, as seen in the+last example above. -}  ------------------ simplifyAmbiguityCheck :: Type -> WantedConstraints -> TcM () simplifyAmbiguityCheck ty wanteds   = do { traceTc "simplifyAmbiguityCheck {" (text "type = " <+> ppr ty $$ text "wanted = " <+> ppr wanteds)-       ; (final_wc, _) <- runTcS $ solveWantedsAndDrop wanteds+       ; (final_wc, _) <- runTcS $ solveWanteds wanteds              -- NB: no defaulting!  See Note [No defaulting in the ambiguity check]         ; traceTc "End simplifyAmbiguityCheck }" empty@@ -822,18 +873,83 @@ simplifyDefault theta   = do { traceTc "simplifyDefault" empty        ; wanteds  <- newWanteds DefaultOrigin theta-       ; unsolved <- runTcSDeriveds (solveWantedsAndDrop (mkSimpleWC wanteds))+       ; (unsolved, _) <- runTcS (solveWanteds (mkSimpleWC wanteds))        ; return (isEmptyWC unsolved) }  ------------------+{- Note [Pattern match warnings with insoluble Givens]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A pattern match on a GADT can introduce new type-level information, which needs+to be analysed in order to get the expected pattern match warnings.++For example:++> type IsBool :: Type -> Constraint+> type family IsBool a where+>   IsBool Bool = ()+>   IsBool b    = b ~ Bool+>+> data T a where+>   MkTInt  :: Int -> T Int+>   MkTBool :: IsBool b => b -> T b+>+> f :: T Int -> Int+> f (MkTInt i) = i++The pattern matching performed by `f` is complete: we can't ever call+`f (MkTBool b)`, as type-checking that application would require producing+evidence for `Int ~ Bool`, which can't be done.++The pattern match checker uses `tcCheckGivens` to accumulate all the Given+constraints, and relies on `tcCheckGivens` to return Nothing if the+Givens become insoluble.   `tcCheckGivens` in turn relies on `insolubleCt`+to identify these insoluble constraints.  So the precise definition of+`insolubleCt` has a big effect on pattern match overlap warnings.++To detect this situation, we check whether there are any insoluble Given+constraints. In the example above, the insoluble constraint was an+equality constraint, but it is also important to detect custom type errors:++> type NotInt :: Type -> Constraint+> type family NotInt a where+>   NotInt Int = TypeError (Text "That's Int, silly.")+>   NotInt _   = ()+>+> data R a where+>   MkT1 :: a -> R a+>   MkT2 :: NotInt a => R a+>+> foo :: R Int -> Int+> foo (MkT1 x) = x++To see that we can't call `foo (MkT2)`, we must detect that `NotInt Int` is insoluble+because it is a custom type error.+Failing to do so proved quite inconvenient for users, as evidence by the+tickets #11503 #14141 #16377 #20180.+Test cases: T11503, T14141.++Examples of constraints that tcCheckGivens considers insoluble:+  - Int ~ Bool,+  - Coercible Float Word,+  - TypeError msg.++Non-examples:+  - constraints which we know aren't satisfied,+    e.g. Show (Int -> Int) when no such instance is in scope,+  - Eq (TypeError msg),+  - C (Int ~ Bool), with @class C (c :: Constraint)@.+-}+ tcCheckGivens :: InertSet -> Bag EvVar -> TcM (Maybe InertSet) -- ^ Return (Just new_inerts) if the Givens are satisfiable, Nothing if definitely--- contradictory+-- contradictory.+--+-- See Note [Pattern match warnings with insoluble Givens] above. tcCheckGivens inerts given_ids = do   (sat, new_inerts) <- runTcSInerts inerts $ do     traceTcS "checkGivens {" (ppr inerts <+> ppr given_ids)     lcl_env <- TcS.getLclEnv-    let given_loc = mkGivenLoc topTcLevel UnkSkol lcl_env+    let given_loc = mkGivenLoc topTcLevel (getSkolemInfo unkSkol) lcl_env     let given_cts = mkGivens given_loc (bagToList given_ids)     -- See Note [Superclasses and satisfiability]     solveSimpleGivens given_cts@@ -863,7 +979,7 @@   (sat, _new_inerts) <- runTcSInerts inerts $ do     traceTcS "checkWanteds {" (ppr inerts <+> ppr wanteds)     -- See Note [Superclasses and satisfiability]-    wcs <- solveWantedsAndDrop (mkSimpleWC cts)+    wcs <- solveWanteds (mkSimpleWC cts)     traceTcS "checkWanteds }" (ppr wcs)     return (isSolvedWC wcs)   return sat@@ -945,6 +1061,55 @@ has a strictly-increased level compared to the ambient level outside the let binding. +Note [Inferring principal types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We don't always infer principal types. For instance, the inferred type for++> f x = show [x]++is++> f :: Show a => a -> String++This is not the most general type if we allow flexible contexts.+Indeed, if we try to write the following++> g :: Show [a] => a -> String+> g x = f x++we get the error:++  * Could not deduce (Show a) arising from a use of `f'+    from the context: Show [a]++Though replacing f x in the right-hand side of g with the definition+of f x works, the call to f x does not. This is the hallmark of+unprincip{led,al} types.++Another example:++> class C a+> class D a where+>   d :: a+> instance C a => D a where+>   d = undefined+> h _ = d   -- argument is to avoid the monomorphism restriction++The inferred type for h is++> h :: C a => t -> a++even though++> h :: D a => t -> a++is more general.++The fix is easy: don't simplify constraints before inferring a type.+That is, have the inferred type quantify over all constraints that arise+in a definition's right-hand side, even if they are simplifiable.+Unfortunately, this would yield all manner of unwieldy types,+and so we won't do so. -}  -- | How should we choose which constraints to quantify over?@@ -954,7 +1119,7 @@                                   -- the :type +d case; this mode refuses                                   -- to quantify over any defaultable constraint                | NoRestrictions   -- ^ Quantify over any constraint that-                                  -- satisfies 'GHC.Tc.Utils.TcType.pickQuantifiablePreds'+                                  -- satisfies pickQuantifiablePreds  instance Outputable InferMode where   ppr ApplyMR         = text "ApplyMR"@@ -982,7 +1147,9 @@                                    , pred <- sig_inst_theta sig ]         ; dep_vars <- candidateQTyVarsOfTypes (psig_tv_tys ++ psig_theta ++ map snd name_taus)-       ; qtkvs <- quantifyTyVars dep_vars++       ; skol_info <- mkSkolemInfo (InferSkol name_taus)+       ; qtkvs <- quantifyTyVars skol_info DefaultNonStandardTyVars dep_vars        ; traceTc "simplifyInfer: empty WC" (ppr name_taus $$ ppr qtkvs)        ; return (qtkvs, [], emptyTcEvBinds, False) } @@ -1007,11 +1174,12 @@         ; ev_binds_var <- TcM.newTcEvBinds        ; psig_evs     <- newWanteds AnnOrigin psig_theta-       ; wanted_transformed_incl_derivs+       ; wanted_transformed             <- setTcLevel rhs_tclvl $                runTcSWithEvBinds ev_binds_var $                solveWanteds (mkSimpleWC psig_evs `andWC` wanteds)                -- psig_evs : see Note [Add signature contexts as wanteds]+               -- See Note [Inferring principal types]         -- Find quant_pred_candidates, the predicates that        -- we'll consider quantifying over@@ -1019,12 +1187,9 @@        --      the psig_theta; it's just the extra bit        -- NB2: We do not do any defaulting when inferring a type, this can lead        --      to less polymorphic types, see Note [Default while Inferring]-       ; wanted_transformed_incl_derivs <- TcM.zonkWC wanted_transformed_incl_derivs-       ; let definite_error = insolubleWC wanted_transformed_incl_derivs+       ; wanted_transformed <- TcM.zonkWC wanted_transformed+       ; let definite_error = insolubleWC wanted_transformed                               -- See Note [Quantification with errors]-                              -- NB: must include derived errors in this test,-                              --     hence "incl_derivs"-             wanted_transformed = dropDerivedWC wanted_transformed_incl_derivs              quant_pred_candidates                | definite_error = []                | otherwise      = ctsPreds (approximateWC False wanted_transformed)@@ -1034,11 +1199,17 @@        -- NB: bound_theta are constraints we want to quantify over,        --     including the psig_theta, which we always quantify over        -- NB: bound_theta are fully zonked-       ; (qtvs, bound_theta, co_vars) <- decideQuantification infer_mode rhs_tclvl+       ; rec { (qtvs, bound_theta, co_vars) <- decideQuantification skol_info infer_mode rhs_tclvl                                                      name_taus partial_sigs                                                      quant_pred_candidates-       ; bound_theta_vars <- mapM TcM.newEvVar bound_theta+             ;  bound_theta_vars <- mapM TcM.newEvVar bound_theta +             ; let full_theta = map idType bound_theta_vars+             ; skol_info <- mkSkolemInfo (InferSkol [ (name, mkSigmaTy [] full_theta ty)+                                                    | (name, ty) <- name_taus ])+       }++        -- Now emit the residual constraint        ; emitResidualConstraints rhs_tclvl ev_binds_var                                  name_taus co_vars qtvs bound_theta_vars@@ -1060,7 +1231,7 @@ -------------------- emitResidualConstraints :: TcLevel -> EvBindsVar                         -> [(Name, TcTauType)]-                        -> VarSet -> [TcTyVar] -> [EvVar]+                        -> CoVarSet -> [TcTyVar] -> [EvVar]                         -> WantedConstraints -> TcM () -- Emit the remaining constraints from the RHS. emitResidualConstraints rhs_tclvl ev_binds_var@@ -1071,7 +1242,11 @@   | otherwise   = do { wanted_simple <- TcM.zonkSimples (wc_simple wanteds)        ; let (outer_simple, inner_simple) = partitionBag is_mono wanted_simple-             is_mono ct = isWantedCt ct && ctEvId ct `elemVarSet` co_vars+             is_mono ct+               | Just ct_ev_id <- wantedEvId_maybe ct+               = ct_ev_id `elemVarSet` co_vars+               | otherwise+               = False              -- Reason for the partition:              -- see Note [Emitting the residual implication in simplifyInfer] @@ -1119,12 +1294,12 @@     do { lcl_env   <- TcM.getLclEnv        ; given_ids <- mapM TcM.newEvVar annotated_theta        ; wanteds   <- newWanteds AnnOrigin inferred_theta-       ; let given_loc = mkGivenLoc topTcLevel UnkSkol lcl_env+       ; let given_loc = mkGivenLoc topTcLevel (getSkolemInfo unkSkol) lcl_env              given_cts = mkGivens given_loc given_ids -       ; residual <- runTcSDeriveds $-                     do { _ <- solveSimpleGivens given_cts-                        ; solveSimpleWanteds (listToBag (map mkNonCanonical wanteds)) }+       ; (residual, _) <- runTcS $+                          do { _ <- solveSimpleGivens given_cts+                             ; solveSimpleWanteds (listToBag (map mkNonCanonical wanteds)) }          -- NB: There are no meta tyvars fromn this level annotated_theta          -- because we have either promoted them or unified them          -- See `Note [Quantification and partial signatures]` Wrinkle 2@@ -1220,19 +1395,21 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If the monomorphism restriction does not apply, then we quantify as follows: -* Step 1. Take the global tyvars, and "grow" them using the equality-  constraints+* Step 1: decideMonoTyVars.+  Take the global tyvars, and "grow" them using functional dependencies      E.g.  if x:alpha is in the environment, and alpha ~ [beta] (which can           happen because alpha is untouchable here) then do not quantify over           beta, because alpha fixes beta, and beta is effectively free in-          the environment too+          the environment too; this logic extends to general fundeps, not+          just equalities    We also account for the monomorphism restriction; if it applies,   add the free vars of all the constraints.    Result is mono_tvs; we will not quantify over these. -* Step 2. Default any non-mono tyvars (i.e ones that are definitely+* Step 2: defaultTyVarsAndSimplify.+  Default any non-mono tyvars (i.e ones that are definitely   not going to become further constrained), and re-simplify the   candidate constraints. @@ -1244,34 +1421,191 @@    This is all very tiresome. -* Step 3: decide which variables to quantify over, as follows:+  This step also promotes the mono_tvs from Step 1. See+  Note [Promote monomorphic tyvars]. In fact, the *only*+  use of the mono_tvs from Step 1 is to promote them here.+  This promotion effectively stops us from quantifying over them+  later, in Step 3. Because the actual variables to quantify+  over are determined in Step 3 (not in Step 1), it is OK for+  the mono_tvs to be missing some variables free in the+  environment. This is why removing the psig_qtvs is OK in+  decideMonoTyVars. Test case for this scenario: T14479. -  - Take the free vars of the tau-type (zonked_tau_tvs) and "grow"-    them using all the constraints.  These are tau_tvs_plus+* Step 3: decideQuantifiedTyVars.+  Decide which variables to quantify over, as follows: -  - Use quantifyTyVars to quantify over (tau_tvs_plus - mono_tvs), being-    careful to close over kinds, and to skolemise the quantified tyvars.-    (This actually unifies each quantifies meta-tyvar with a fresh skolem.)+  - Take the free vars of the partial-type-signature types and constraints,+    and the tau-type (zonked_tau_tvs), and then "grow"+    them using all the constraints.  These are grown_tcvs.+    See Note [growThetaTyVars vs closeWrtFunDeps]. +  - Use quantifyTyVars to quantify over the free variables of all the types+    involved, but only those in the grown_tcvs.+   Result is qtvs.  * Step 4: Filter the constraints using pickQuantifiablePreds and the   qtvs. We have to zonk the constraints first, so they "see" the   freshly created skolems. +Note [Lift equality constraints when quantifying]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We can't quantify over a constraint (t1 ~# t2) because that isn't a+predicate type; see Note [Types for coercions, predicates, and evidence]+in GHC.Core.TyCo.Rep.++So we have to 'lift' it to (t1 ~ t2).  Similarly (~R#) must be lifted+to Coercible.++This tiresome lifting is the reason that pick_me (in+pickQuantifiablePreds) returns a Maybe rather than a Bool.++Note [Inheriting implicit parameters]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this:++        f x = (x::Int) + ?y++where f is *not* a top-level binding.+From the RHS of f we'll get the constraint (?y::Int).+There are two types we might infer for f:++        f :: Int -> Int++(so we get ?y from the context of f's definition), or++        f :: (?y::Int) => Int -> Int++At first you might think the first was better, because then+?y behaves like a free variable of the definition, rather than+having to be passed at each call site.  But of course, the WHOLE+IDEA is that ?y should be passed at each call site (that's what+dynamic binding means) so we'd better infer the second.++BOTTOM LINE: when *inferring types* you must quantify over implicit+parameters, *even if* they don't mention the bound type variables.+Reason: because implicit parameters, uniquely, have local instance+declarations. See pickQuantifiablePreds.++Note [Quantifying over equality constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Should we quantify over an equality constraint (s ~ t)?  In general, we don't.+Doing so may simply postpone a type error from the function definition site to+its call site.  (At worst, imagine (Int ~ Bool)).++However, consider this+         forall a. (F [a] ~ Int) => blah+Should we quantify over the (F [a] ~ Int).  Perhaps yes, because at the call+site we will know 'a', and perhaps we have instance  F [Bool] = Int.+So we *do* quantify over a type-family equality where the arguments mention+the quantified variables.++Note [Unconditionally resimplify constraints when quantifying]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+During quantification (in defaultTyVarsAndSimplify, specifically), we re-invoke+the solver to simplify the constraints before quantifying them. We do this for+two reasons, enumerated below. We could, in theory, detect when either of these+cases apply and simplify only then, but collecting this information is bothersome,+and simplifying redundantly causes no real harm. Note that this code path+happens only for definitions+  * without a type signature+  * when -XMonoLocalBinds does not apply+  * with unsolved constraints+and so the performance cost will be small.++1. Defaulting++Defaulting the variables handled by defaultTyVar may unlock instance simplifications.+Example (typecheck/should_compile/T20584b):++  with (t :: Double) (u :: String) = printf "..." t u++We know the types of t and u, but we do not know the return type of `with`. So, we+assume `with :: alpha`, where `alpha :: TYPE rho`. The type of printf is+  printf :: PrintfType r => String -> r+The occurrence of printf is instantiated with a fresh var beta. We then get+  beta := Double -> String -> alpha+and+  [W] PrintfType (Double -> String -> alpha)++Module Text.Printf exports+  instance (PrintfArg a, PrintfType r) => PrintfType (a -> r)+and it looks like that instance should apply.++But I have elided some key details: (->) is polymorphic over multiplicity and+runtime representation. Here it is in full glory:+  [W] PrintfType ((Double :: Type) %m1 -> (String :: Type) %m2 -> (alpha :: TYPE rho))+  instance (PrintfArg a, PrintfType r) => PrintfType ((a :: Type) %Many -> (r :: Type))++Because we do not know that m1 is Many, we cannot use the instance. (Perhaps a better instance+would have an explicit equality constraint to the left of =>, but that's not what we have.)+Then, in defaultTyVarsAndSimplify, we get m1 := Many, m2 := Many, and rho := LiftedRep.+Yet it's too late to simplify the quantified constraint, and thus GHC infers+  wait :: PrintfType (Double -> String -> t) => Double -> String -> t+which is silly. Simplifying again after defaulting solves this problem.++2. Interacting functional dependencies++Suppose we have++  class C a b | a -> b++and we are running simplifyInfer over++  forall[2] x. () => [W] C a beta1[1]+  forall[2] y. () => [W] C a beta2[1]++These are two implication constraints, both of which contain a+wanted for the class C. Neither constraint mentions the bound+skolem. We might imagine that these constraint could thus float+out of their implications and then interact, causing beta1 to unify+with beta2, but constraints do not currently float out of implications.++Unifying the beta1 and beta2 is important. Without doing so, then we might+infer a type like (C a b1, C a b2) => a -> a, which will fail to pass the+ambiguity check, which will say (rightly) that it cannot unify b1 with b2, as+required by the fundep interactions. This happens in the parsec library, and+in test case typecheck/should_compile/FloatFDs.++If we re-simplify, however, the two fundep constraints will interact, causing+a unification between beta1 and beta2, and all will be well. The key step+is that this simplification happens *after* the call to approximateWC in+simplifyInfer.++Note [Do not quantify over constraints that determine a variable]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (typecheck/should_compile/tc231), where we're trying to infer+the type of a top-level declaration. We have+  class Zork s a b | a -> b+and the candidate constraint at the end of simplifyInfer is+  [W] Zork alpha (Z [Char]) beta+We definitely do want to quantify over alpha (which is mentioned in+the tau-type). But we do *not* want to quantify over beta: it is+determined by the functional dependency on Zork: note that the second+argument to Zork in the Wanted is a variable-free Z [Char].++The question here: do we want to quantify over the constraint? Definitely not.+Since we're not quantifying over beta, GHC has no choice but to zap beta+to Any, and then we infer a type involving (Zork a (Z [Char]) Any => ...). No no no.++The no_fixed_dependencies check in pickQuantifiablePreds eliminates this+candidate from the pool. Because there are no Zork instances in scope, this+program is rejected.+ -}  decideQuantification-  :: InferMode+  :: SkolemInfo+  -> InferMode   -> TcLevel   -> [(Name, TcTauType)]   -- Variables to be generalised   -> [TcIdSigInst]         -- Partial type signatures (if any)   -> [PredType]            -- Candidate theta; already zonked   -> TcM ( [TcTyVar]       -- Quantify over these (skolems)          , [PredType]      -- and this context (fully zonked)-         , VarSet)+         , CoVarSet) -- See Note [Deciding quantification]-decideQuantification infer_mode rhs_tclvl name_taus psigs candidates+decideQuantification skol_info infer_mode rhs_tclvl name_taus psigs candidates   = do { -- Step 1: find the mono_tvs        ; (mono_tvs, candidates, co_vars) <- decideMonoTyVars infer_mode                                               name_taus psigs candidates@@ -1281,7 +1615,7 @@        ; candidates <- defaultTyVarsAndSimplify rhs_tclvl mono_tvs candidates         -- Step 3: decide which kind/type variables to quantify over-       ; qtvs <- decideQuantifiedTyVars name_taus psigs candidates+       ; qtvs <- decideQuantifiedTyVars skol_info name_taus psigs candidates         -- Step 4: choose which of the remaining candidate        --         predicates to actually quantify over@@ -1358,7 +1692,7 @@ -- Decide which tyvars and covars cannot be generalised: --   (a) Free in the environment --   (b) Mentioned in a constraint we can't generalise---   (c) Connected by an equality to (a) or (b)+--   (c) Connected by an equality or fundep to (a) or (b) -- Also return CoVars that appear free in the final quantified types --   we can't quantify over these, and we must make sure they are in scope decideMonoTyVars infer_mode name_taus psigs candidates@@ -1366,7 +1700,7 @@         -- If possible, we quantify over partial-sig qtvs, so they are        -- not mono. Need to zonk them because they are meta-tyvar TyVarTvs-       ; psig_qtvs <- mapM zonkTcTyVarToTyVar $ binderVars $+       ; psig_qtvs <-  zonkTcTyVarsToTcTyVars $ binderVars $                       concatMap (map snd . sig_inst_skols) psigs         ; psig_theta <- mapM TcM.zonkTcType $@@ -1377,7 +1711,7 @@        ; tc_lvl <- TcM.getTcLevel        ; let psig_tys = mkTyVarTys psig_qtvs ++ psig_theta -             co_vars = coVarsOfTypes (psig_tys ++ taus)+             co_vars = coVarsOfTypes (psig_tys ++ taus ++ candidates)              co_var_tvs = closeOverKinds co_vars                -- The co_var_tvs are tvs mentioned in the types of covars or                -- coercion holes. We can't quantify over these covars, so we@@ -1388,7 +1722,7 @@              mono_tvs0 = filterVarSet (not . isQuantifiableTv tc_lvl) $                          tyCoVarsOfTypes candidates                -- We need to grab all the non-quantifiable tyvars in the-               -- candidates so that we can grow this set to find other+               -- types so that we can grow this set to find other                -- non-quantifiable tyvars. This can happen with something                -- like                --    f x y = ...@@ -1400,44 +1734,58 @@                -- alpha. Actual test case: typecheck/should_compile/tc213               mono_tvs1 = mono_tvs0 `unionVarSet` co_var_tvs+               -- mono_tvs1 is now the set of variables from an outer scope+               -- (that's mono_tvs0) and the set of covars, closed over kinds.+               -- Given this set of variables we know we will not quantify,+               -- we want to find any other variables that are determined by this+               -- set, by functional dependencies or equalities. We thus use+               -- closeWrtFunDeps to find all further variables determined by this root+               -- set. See Note [growThetaTyVars vs closeWrtFunDeps] -             eq_constraints = filter isEqPrimPred candidates-             mono_tvs2      = growThetaTyVars eq_constraints mono_tvs1+             non_ip_candidates = filterOut isIPLikePred candidates+               -- implicit params don't really determine a type variable+               -- (that is, we might have IP "c" Bool and IP "c" Int in different+               -- places within the same program), and+               -- skipping this causes implicit params to monomorphise too many+               -- variables; see Note [Inheriting implicit parameters] in+               -- GHC.Tc.Solver. Skipping causes typecheck/should_compile/tc219+               -- to fail. +             mono_tvs2 = closeWrtFunDeps non_ip_candidates mono_tvs1+               -- mono_tvs2 now contains any variable determined by the "root+               -- set" of monomorphic tyvars in mono_tvs1.+              constrained_tvs = filterVarSet (isQuantifiableTv tc_lvl) $-                               (growThetaTyVars eq_constraints-                                               (tyCoVarsOfTypes no_quant)-                                `minusVarSet` mono_tvs2)-                               `delVarSetList` psig_qtvs+                               closeWrtFunDeps non_ip_candidates (tyCoVarsOfTypes no_quant)+                                `minusVarSet` mono_tvs2              -- constrained_tvs: the tyvars that we are not going to              -- quantify solely because of the monomorphism restriction              ---             -- (`minusVarSet` mono_tvs2`): a type variable is only+             -- (`minusVarSet` mono_tvs2): a type variable is only              --   "constrained" (so that the MR bites) if it is not-             --   free in the environment (#13785)-             --+             --   free in the environment (#13785) or is determined+             --   by some variable that is free in the env't++             mono_tvs = (mono_tvs2 `unionVarSet` constrained_tvs)+                          `delVarSetList` psig_qtvs              -- (`delVarSetList` psig_qtvs): if the user has explicitly              --   asked for quantification, then that request "wins"-             --   over the MR.  Note: do /not/ delete psig_qtvs from-             --   mono_tvs1, because mono_tvs1 cannot under any circumstances-             --   be quantified (#14479); see-             --   Note [Quantification and partial signatures], Wrinkle 3, 4--             mono_tvs = mono_tvs2 `unionVarSet` constrained_tvs+             --   over the MR.+             --+             -- What if a psig variable is also free in the environment+             -- (i.e. says "no" to isQuantifiableTv)? That's OK: explanation+             -- in Step 2 of Note [Deciding quantification].             -- Warn about the monomorphism restriction-       ; warn_mono <- woptM Opt_WarnMonomorphism-       ; when (case infer_mode of { ApplyMR -> warn_mono; _ -> False}) $-         warnTc (Reason Opt_WarnMonomorphism)-                (constrained_tvs `intersectsVarSet` tyCoVarsOfTypes taus)-                mr_msg+       ; when (case infer_mode of { ApplyMR -> True; _ -> False}) $ do+           let dia = TcRnMonomorphicBindings (map fst name_taus)+           diagnosticTc (constrained_tvs `intersectsVarSet` tyCoVarsOfTypes taus) dia         ; traceTc "decideMonoTyVars" $ vcat            [ text "infer_mode =" <+> ppr infer_mode            , text "mono_tvs0 =" <+> ppr mono_tvs0            , text "no_quant =" <+> ppr no_quant            , text "maybe_quant =" <+> ppr maybe_quant-           , text "eq_constraints =" <+> ppr eq_constraints            , text "mono_tvs =" <+> ppr mono_tvs            , text "co_vars =" <+> ppr co_vars ] @@ -1459,27 +1807,19 @@       | otherwise       = False -    pp_bndrs = pprWithCommas (quotes . ppr . fst) name_taus-    mr_msg =-         hang (sep [ text "The Monomorphism Restriction applies to the binding"-                     <> plural name_taus-                   , text "for" <+> pp_bndrs ])-            2 (hsep [ text "Consider giving"-                    , text (if isSingleton name_taus then "it" else "them")-                    , text "a type signature"])- ------------------- defaultTyVarsAndSimplify :: TcLevel-                         -> TyCoVarSet+                         -> TyCoVarSet          -- Promote these mono-tyvars                          -> [PredType]          -- Assumed zonked                          -> TcM [PredType]      -- Guaranteed zonked--- Default any tyvar free in the constraints,+-- Promote the known-monomorphic tyvars;+-- Default any tyvar free in the constraints; -- and re-simplify in case the defaulting allows further simplification defaultTyVarsAndSimplify rhs_tclvl mono_tvs candidates   = do {  -- Promote any tyvars that we cannot generalise           -- See Note [Promote monomorphic tyvars]        ; traceTc "decideMonoTyVars: promotion:" (ppr mono_tvs)-       ; any_promoted <- promoteTyVarSet mono_tvs+       ; _ <- promoteTyVarSet mono_tvs         -- Default any kind/levity vars        ; DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs}@@ -1489,26 +1829,28 @@                 -- the constraints generated         ; poly_kinds  <- xoptM LangExt.PolyKinds-       ; default_kvs <- mapM (default_one poly_kinds True)-                             (dVarSetElems cand_kvs)-       ; default_tvs <- mapM (default_one poly_kinds False)-                             (dVarSetElems (cand_tvs `minusDVarSet` cand_kvs))-       ; let some_default = or default_kvs || or default_tvs+       ; mapM_ (default_one poly_kinds True) (dVarSetElems cand_kvs)+       ; mapM_ (default_one poly_kinds False) (dVarSetElems (cand_tvs `minusDVarSet` cand_kvs)) -       ; case () of-           _ | some_default -> simplify_cand candidates-             | any_promoted -> mapM TcM.zonkTcType candidates-             | otherwise    -> return candidates+       ; simplify_cand candidates        }   where     default_one poly_kinds is_kind_var tv       | not (isMetaTyVar tv)-      = return False+      = return ()       | tv `elemVarSet` mono_tvs-      = return False+      = return ()       | otherwise-      = defaultTyVar (not poly_kinds && is_kind_var) tv+      = void $ defaultTyVar+          (if not poly_kinds && is_kind_var+           then DefaultKindVars+           else NonStandardDefaulting DefaultNonStandardTyVars)+          -- NB: only pass 'DefaultKindVars' when we know we're dealing with a kind variable.+          tv +       -- this common case (no inferred contraints) should be fast+    simplify_cand [] = return []+       -- see Note [Unconditionally resimplify constraints when quantifying]     simplify_cand candidates       = do { clone_wanteds <- newWanteds DefaultOrigin candidates            ; WC { wc_simple = simples } <- setTcLevel rhs_tclvl $@@ -1523,12 +1865,13 @@  ------------------ decideQuantifiedTyVars-   :: [(Name,TcType)]   -- Annotated theta and (name,tau) pairs+   :: SkolemInfo+   -> [(Name,TcType)]   -- Annotated theta and (name,tau) pairs    -> [TcIdSigInst]     -- Partial signatures    -> [PredType]        -- Candidates, zonked    -> TcM [TyVar] -- Fix what tyvars we are going to quantify over, and quantify them-decideQuantifiedTyVars name_taus psigs candidates+decideQuantifiedTyVars skol_info name_taus psigs candidates   = do {     -- Why psig_tys? We try to quantify over everything free in here              -- See Note [Quantification and partial signatures]              --     Wrinkles 2 and 3@@ -1543,6 +1886,7 @@              seed_tys = psig_tys ++ tau_tys               -- Now "grow" those seeds to find ones reachable via 'candidates'+             -- See Note [growThetaTyVars vs closeWrtFunDeps]              grown_tcvs = growThetaTyVars candidates (tyCoVarsOfTypes seed_tys)         -- Now we have to classify them into kind variables and type variables@@ -1567,18 +1911,93 @@            , text "grown_tcvs =" <+> ppr grown_tcvs            , text "dvs =" <+> ppr dvs_plus]) -       ; quantifyTyVars dvs_plus }+       ; quantifyTyVars skol_info DefaultNonStandardTyVars dvs_plus }  ------------------+-- | When inferring types, should we quantify over a given predicate?+-- Generally true of classes; generally false of equality constraints.+-- Equality constraints that mention quantified type variables and+-- implicit variables complicate the story. See Notes+-- [Inheriting implicit parameters] and [Quantifying over equality constraints]+pickQuantifiablePreds+  :: TyVarSet           -- Quantifying over these+  -> TcThetaType        -- Proposed constraints to quantify+  -> TcThetaType        -- A subset that we can actually quantify+-- This function decides whether a particular constraint should be+-- quantified over, given the type variables that are being quantified+pickQuantifiablePreds qtvs theta+  = let flex_ctxt = True in  -- Quantify over non-tyvar constraints, even without+                             -- -XFlexibleContexts: see #10608, #10351+         -- flex_ctxt <- xoptM Opt_FlexibleContexts+    mapMaybe (pick_me flex_ctxt) theta+  where+    pick_me flex_ctxt pred+      = case classifyPredType pred of++          ClassPred cls tys+            | Just {} <- isCallStackPred cls tys+              -- NEVER infer a CallStack constraint.  Otherwise we let+              -- the constraints bubble up to be solved from the outer+              -- context, or be defaulted when we reach the top-level.+              -- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence+            -> Nothing++            | isIPClass cls+            -> Just pred -- See Note [Inheriting implicit parameters]++            | pick_cls_pred flex_ctxt cls tys+            -> Just pred++          EqPred eq_rel ty1 ty2+            | quantify_equality eq_rel ty1 ty2+            , Just (cls, tys) <- boxEqPred eq_rel ty1 ty2+              -- boxEqPred: See Note [Lift equality constraints when quantifying]+            , pick_cls_pred flex_ctxt cls tys+            -> Just (mkClassPred cls tys)++          IrredPred ty+            | tyCoVarsOfType ty `intersectsVarSet` qtvs+            -> Just pred++          _ -> Nothing+++    pick_cls_pred flex_ctxt cls tys+      = tyCoVarsOfTypes tys `intersectsVarSet` qtvs+        && (checkValidClsArgs flex_ctxt cls tys)+           -- Only quantify over predicates that checkValidType+           -- will pass!  See #10351.+        && (no_fixed_dependencies cls tys)++    -- See Note [Do not quantify over constraints that determine a variable]+    no_fixed_dependencies cls tys+      = and [ qtvs `intersectsVarSet` tyCoVarsOfTypes fd_lhs_tys+            | fd <- cls_fds+            , let (fd_lhs_tys, _) = instFD fd cls_tvs tys ]+      where+        (cls_tvs, cls_fds) = classTvsFds cls++    -- See Note [Quantifying over equality constraints]+    quantify_equality NomEq  ty1 ty2 = quant_fun ty1 || quant_fun ty2+    quantify_equality ReprEq _   _   = True++    quant_fun ty+      = case tcSplitTyConApp_maybe ty of+          Just (tc, tys) | isTypeFamilyTyCon tc+                         -> tyCoVarsOfTypes tys `intersectsVarSet` qtvs+          _ -> False+++------------------ growThetaTyVars :: ThetaType -> TyCoVarSet -> TyCoVarSet--- See Note [Growing the tau-tvs using constraints]+-- See Note [growThetaTyVars vs closeWrtFunDeps] growThetaTyVars theta tcvs   | null theta = tcvs   | otherwise  = transCloVarSet mk_next seed_tcvs   where     seed_tcvs = tcvs `unionVarSet` tyCoVarsOfTypes ips     (ips, non_ips) = partition isIPLikePred theta-                         -- See Note [Inheriting implicit parameters] in GHC.Tc.Utils.TcType+                         -- See Note [Inheriting implicit parameters]      mk_next :: VarSet -> VarSet -- Maps current set to newly-grown ones     mk_next so_far = foldr (grow_one so_far) emptyVarSet non_ips@@ -1613,7 +2032,7 @@  * not forced to be monomorphic (mono_tvs),    for example by being free in the environment. -However, in the case of a partial type signature, be doing inference+However, in the case of a partial type signature, we are doing inference *in the presence of a type signature*. For example:    f :: _ -> a    f x = ...@@ -1627,7 +2046,7 @@      f :: _ -> Maybe a      f x = True && x   The inferred type of 'f' is f :: Bool -> Bool, but there's a-  left-over error of form (HoleCan (Maybe a ~ Bool)).  The error-reporting+  left-over error of form (Maybe a ~ Bool).  The error-reporting   machine expects to find a binding site for the skolem 'a', so we   add it to the quantified tyvars. @@ -1668,18 +2087,56 @@   refrain from bogusly quantifying, in GHC.Tc.Solver.decideMonoTyVars.  We   report the error later, in GHC.Tc.Gen.Bind.chooseInferredQuantifiers. -Note [Growing the tau-tvs using constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-(growThetaTyVars insts tvs) is the result of extending the set-    of tyvars, tvs, using all conceivable links from pred+Note [growThetaTyVars vs closeWrtFunDeps]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC has two functions, growThetaTyVars and closeWrtFunDeps, both with+the same type and similar behavior. This Note outlines the differences+and why we use one or the other. -E.g. tvs = {a}, preds = {H [a] b, K (b,Int) c, Eq e}-Then growThetaTyVars preds tvs = {a,b,c}+Both functions take a list of constraints. We will call these the+*candidates*. -Notice that-   growThetaTyVars is conservative       if v might be fixed by vs-                                         => v `elem` grow(vs,C)+closeWrtFunDeps takes a set of "determined" type variables and finds the+closure of that set with respect to the functional dependencies+within the class constraints in the set of candidates. So, if we+have +  class C a b | a -> b+  class D a b   -- no fundep+  candidates = {C (Maybe a) (Either b c), D (Maybe a) (Either d e)}++then closeWrtFunDeps {a} will return the set {a,b,c}.+This is because, if `a` is determined, then `b` and `c` are, too,+by functional dependency. closeWrtFunDeps called with any seed set not including+`a` will just return its argument, as only `a` determines any other+type variable (in this example).++growThetaTyVars operates similarly, but it behaves as if every+constraint has a functional dependency among all its arguments.+So, continuing our example, growThetaTyVars {a} will return+{a,b,c,d,e}. Put another way, growThetaTyVars grows the set of+variables to include all variables that are mentioned in the same+constraint (transitively).++We use closeWrtFunDeps in places where we need to know which variables are+*always* determined by some seed set. This includes+  * when determining the mono-tyvars in decideMonoTyVars. If `a`+    is going to be monomorphic, we need b and c to be also: they+    are determined by the choice for `a`.+  * when checking instance coverage, in+    GHC.Tc.Instance.FunDeps.checkInstCoverage++On the other hand, we use growThetaTyVars where we need to know+which variables *might* be determined by some seed set. This includes+  * deciding quantification (GHC.Tc.Gen.Bind.chooseInferredQuantifiers+    and decideQuantifiedTyVars+How can `a` determine (say) `d` in the example above without a fundep?+Suppose we have+  instance (b ~ a, c ~ a) => D (Maybe [a]) (Either b c)+Now, if `a` turns out to be a list, it really does determine b and c.+The danger in overdoing quantification is the creation of an ambiguous+type signature, but this is conveniently caught in the validity checker.+ Note [Quantification with errors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we find that the RHS of the definition has some absolutely-insoluble@@ -1708,12 +2165,6 @@ the recovery from failM emits no code at all, so there is no function to run!   But -fdefer-type-errors aspires to produce a runnable program. -NB that we must include *derived* errors in the check for insolubles.-Example:-    (a::*) ~ Int#-We get an insoluble derived error *~#, and we don't want to discard-it before doing the isInsolubleWC test!  (#8262)- Note [Default while Inferring] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Our current plan is that defaulting only happens at simplifyTop and@@ -1795,27 +2246,16 @@ simplifyWantedsTcM :: [CtEvidence] -> TcM WantedConstraints -- Solve the specified Wanted constraints -- Discard the evidence binds--- Discards all Derived stuff in result -- Postcondition: fully zonked simplifyWantedsTcM wanted   = do { traceTc "simplifyWantedsTcM {" (ppr wanted)-       ; (result, _) <- runTcS (solveWantedsAndDrop (mkSimpleWC wanted))+       ; (result, _) <- runTcS (solveWanteds (mkSimpleWC wanted))        ; result <- TcM.zonkWC result        ; traceTc "simplifyWantedsTcM }" (ppr result)        ; return result } -solveWantedsAndDrop :: WantedConstraints -> TcS WantedConstraints--- Since solveWanteds returns the residual WantedConstraints,--- it should always be called within a runTcS or something similar,--- Result is not zonked-solveWantedsAndDrop wanted-  = do { wc <- solveWanteds wanted-       ; return (dropDerivedWC wc) }- solveWanteds :: WantedConstraints -> TcS WantedConstraints--- so that the inert set doesn't mindlessly propagate.--- NB: wc_simples may be wanted /or/ derived now-solveWanteds wc@(WC { wc_holes = holes })+solveWanteds wc@(WC { wc_errors = errs })   = do { cur_lvl <- TcS.getTcLevel        ; traceTcS "solveWanteds {" $          vcat [ text "Level =" <+> ppr cur_lvl@@ -1824,8 +2264,8 @@        ; dflags <- getDynFlags        ; solved_wc <- simplify_loop 0 (solverIterations dflags) True wc -       ; holes' <- simplifyHoles holes-       ; let final_wc = solved_wc { wc_holes = holes' }+       ; errs' <- simplifyDelayedErrors errs+       ; let final_wc = solved_wc { wc_errors = errs' }         ; ev_binds_var <- getTcEvBindsVar        ; bb <- TcS.getTcEvBindsMap ev_binds_var@@ -1839,7 +2279,7 @@               -> WantedConstraints -> TcS WantedConstraints -- Do a round of solving, and call maybe_simplify_again to iterate -- The 'definitely_redo_implications' flags is False if the only reason we--- are iterating is that we have added some new Derived superclasses (from Wanteds)+-- are iterating is that we have added some new Wanted superclasses -- hoping for fundeps to help us; see Note [Superclass iteration] -- -- Does not affect wc_holes at all; reason: wc_holes never affects anything@@ -1855,7 +2295,7 @@        ; (unifs1, wc1) <- reportUnifications $  -- See Note [Superclass iteration]                           solveSimpleWanteds simples                 -- Any insoluble constraints are in 'simples' and so get rewritten-                -- See Note [Rewrite insolubles] in GHC.Tc.Solver.Monad+                -- See Note [Rewrite insolubles] in GHC.Tc.Solver.InertSet         ; wc2 <- if not definitely_redo_implications  -- See Note [Superclass iteration]                    && unifs1 == 0                    -- for this conditional@@ -1867,6 +2307,7 @@                                      , wc_impl = implics2 }) }         ; unif_happened <- resetUnificationFlag+       ; csTraceTcS $ text "unif_happened" <+> ppr unif_happened          -- Note [The Unification Level Flag] in GHC.Tc.Solver.Monad        ; maybe_simplify_again (n+1) limit unif_happened wc2 } @@ -1878,11 +2319,7 @@          -- Typically if we blow the limit we are going to report some other error          -- (an unsolved constraint), and we don't want that error to suppress          -- the iteration limit warning!-         addErrTcS (hang (text "solveWanteds: too many iterations"-                   <+> parens (text "limit =" <+> ppr limit))-                2 (vcat [ text "Unsolved:" <+> ppr wc-                        , text "Set limit with -fconstraint-solver-iterations=n; n=0 for no limit"-                  ]))+         addErrTcS $ TcRnSimplifierTooManyIterations simples limit wc        ; return wc }    | unif_happened@@ -1915,15 +2352,15 @@ where   class D a b | a -> b   class D a b => C a b-We will expand d's superclasses, giving [D] D Int beta, in the hope of geting+We will expand d's superclasses, giving [W] D Int beta, in the hope of geting fundeps to unify beta.  Doing so is usually fruitless (no useful fundeps), and if so it seems a pity to waste time iterating the implications (forall b. blah) (If we add new Given superclasses it's a different matter: it's really worth looking at the implications.)  Hence the definitely_redo_implications flag to simplify_loop.  It's usually-True, but False in the case where the only reason to iterate is new Derived-superclasses.  In that case we check whether the new Deriveds actually led to+True, but False in the case where the only reason to iterate is new Wanted+superclasses.  In that case we check whether the new Wanteds actually led to any new unifications, and iterate the implications only if so. -} @@ -1977,9 +2414,6 @@                   ; solveSimpleGivens givens                    ; residual_wanted <- solveWanteds wanteds-                        -- solveWanteds, *not* solveWantedsAndDrop, because-                        -- we want to retain derived equalities so we can float-                        -- them out in floatEqualities.                    ; (has_eqs, given_insols) <- getHasGivenEqs tclvl                         -- Call getHasGivenEqs /after/ solveWanteds, because@@ -2015,21 +2449,21 @@     -- remaining commented out for now.     {-     check_tc_level = do { cur_lvl <- TcS.getTcLevel-                        ; MASSERT2( tclvl == pushTcLevel cur_lvl , text "Cur lvl =" <+> ppr cur_lvl $$ text "Imp lvl =" <+> ppr tclvl ) }+                        ; massertPpr (tclvl == pushTcLevel cur_lvl)+                                     (text "Cur lvl =" <+> ppr cur_lvl $$ text "Imp lvl =" <+> ppr tclvl) }     -}  ---------------------- setImplicationStatus :: Implication -> TcS (Maybe Implication)--- Finalise the implication returned from solveImplication:---    * Set the ic_status field---    * Trim the ic_wanted field to remove Derived constraints+-- Finalise the implication returned from solveImplication,+-- setting the ic_status field -- Precondition: the ic_status field is not already IC_Solved -- Return Nothing if we can discard the implication altogether setImplicationStatus implic@(Implic { ic_status     = status                                     , ic_info       = info                                     , ic_wanted     = wc                                     , ic_given      = givens })- | ASSERT2( not (isSolvedStatus status ), ppr info )+ | assertPpr (not (isSolvedStatus status)) (ppr info) $    -- Precondition: we only set the status if it is not already solved    not (isSolvedWC pruned_wc)  = do { traceTcS "setImplicationStatus(not-all-solved) {" (ppr implic)@@ -2089,13 +2523,12 @@                  then Nothing                  else Just final_implic }  where-   WC { wc_simple = simples, wc_impl = implics, wc_holes = holes } = wc+   WC { wc_simple = simples, wc_impl = implics, wc_errors = errs } = wc -   pruned_simples = dropDerivedSimples simples    pruned_implics = filterBag keep_me implics-   pruned_wc = WC { wc_simple = pruned_simples+   pruned_wc = WC { wc_simple = simples                   , wc_impl   = pruned_implics-                  , wc_holes  = holes }   -- do not prune holes; these should be reported+                  , wc_errors = errs }   -- do not prune holes; these should be reported     keep_me :: Implication -> Bool    keep_me ic@@ -2131,12 +2564,12 @@       | otherwise       = go (later_skols `extendVarSet` one_skol) earlier_skols -warnRedundantGivens :: SkolemInfo -> Bool+warnRedundantGivens :: SkolemInfoAnon -> Bool warnRedundantGivens (SigSkol ctxt _ _)   = case ctxt of-       FunSigCtxt _ warn_redundant -> warn_redundant-       ExprSigCtxt                 -> True-       _                           -> False+       FunSigCtxt _ rrc -> reportRedundantConstraints rrc+       ExprSigCtxt rrc  -> reportRedundantConstraints rrc+       _                -> False    -- To think about: do we want to report redundant givens for   -- pattern synonyms, PatSynSigSkol? c.f #9953, comment:21.@@ -2209,9 +2642,13 @@      | otherwise = evVarsOfTerm rhs `unionVarSet` needs  --------------------------------------------------simplifyHoles :: Bag Hole -> TcS (Bag Hole)-simplifyHoles = mapBagM simpl_hole+simplifyDelayedErrors :: Bag DelayedError -> TcS (Bag DelayedError)+simplifyDelayedErrors = mapBagM simpl_err   where+    simpl_err :: DelayedError -> TcS DelayedError+    simpl_err (DE_Hole hole) = DE_Hole <$> simpl_hole hole+    simpl_err err@(DE_NotConcrete {}) = return err+     simpl_hole :: Hole -> TcS Hole       -- See Note [Do not simplify ConstraintHoles]@@ -2443,18 +2880,20 @@ -- | Like 'defaultTyVar', but in the TcS monad. defaultTyVarTcS :: TcTyVar -> TcS Bool defaultTyVarTcS the_tv-  | isRuntimeRepVar the_tv-  , not (isTyVarTyVar the_tv)+  | isTyVarTyVar the_tv     -- TyVarTvs should only be unified with a tyvar     -- never with a type; c.f. GHC.Tc.Utils.TcMType.defaultTyVar     -- and Note [Inferring kinds for type declarations] in GHC.Tc.TyCl+  = return False+  | isRuntimeRepVar the_tv   = do { traceTcS "defaultTyVarTcS RuntimeRep" (ppr the_tv)        ; unifyTyVar the_tv liftedRepTy        ; return True }+  | isLevityVar the_tv+  = do { traceTcS "defaultTyVarTcS Levity" (ppr the_tv)+       ; unifyTyVar the_tv liftedDataConTy+       ; return True }   | isMultiplicityVar the_tv-  , not (isTyVarTyVar the_tv)  -- TyVarTvs should only be unified with a tyvar-                             -- never with a type; c.f. TcMType.defaultTyVar-                             -- See Note [Kind generalisation and SigTvs]   = do { traceTcS "defaultTyVarTcS Multiplicity" (ppr the_tv)        ; unifyTyVar the_tv manyDataConTy        ; return True }@@ -2462,7 +2901,9 @@   = return False  -- the common case  approximateWC :: Bool -> WantedConstraints -> Cts--- Postcondition: Wanted or Derived Cts+-- Second return value is the depleted wc+-- Third return value is YesFDsCombined <=> multiple constraints for the same fundep floated+-- Postcondition: Wanted Cts -- See Note [ApproximateWC] -- See Note [floatKindEqualities vs approximateWC] approximateWC float_past_equalities wc@@ -2545,7 +2986,6 @@ contamination stuff.  There was zero effect on the testsuite (not even #8155). ------ End of historical note ----------- - Note [DefaultTyVar] ~~~~~~~~~~~~~~~~~~~ defaultTyVar is used on any un-instantiated meta type variables to@@ -2564,7 +3004,7 @@ hand.  However we aren't ready to default them fully to () or whatever, because the type-class defaulting rules have yet to run. -An alternate implementation would be to emit a derived constraint setting+An alternate implementation would be to emit a Wanted constraint setting the RuntimeRep variable to LiftedRep, but this seems unnecessarily indirect.  Note [Promote _and_ default when inferring]@@ -2645,6 +3085,17 @@   = do { info@(default_tys, _) <- getDefaultInfo        ; wanteds               <- TcS.zonkWC wanteds +       ; tcg_env <- TcS.getGblEnv+       ; let plugins = tcg_defaulting_plugins tcg_env++       ; plugin_defaulted <- if null plugins then return [] else+           do {+             ; traceTcS "defaultingPlugins {" (ppr wanteds)+             ; defaultedGroups <- mapM (run_defaulting_plugin wanteds) plugins+             ; traceTcS "defaultingPlugins }" (ppr defaultedGroups)+             ; return defaultedGroups+             }+        ; let groups = findDefaultableGroups info wanteds         ; traceTcS "applyDefaultingRules {" $@@ -2656,12 +3107,25 @@         ; traceTcS "applyDefaultingRules }" (ppr something_happeneds) -       ; return (or something_happeneds) }+       ; return $ or something_happeneds || or plugin_defaulted }+    where run_defaulting_plugin wanteds p =+            do { groups <- runTcPluginTcS (p wanteds)+               ; defaultedGroups <-+                    filterM (\g -> disambigGroup+                                   (deProposalCandidates g)+                                   (deProposalTyVar g, deProposalCts g))+                    groups+               ; traceTcS "defaultingPlugin " $ ppr defaultedGroups+               ; case defaultedGroups of+                 [] -> return False+                 _  -> return True+               } + findDefaultableGroups     :: ( [Type]        , (Bool,Bool) )     -- (Overloaded strings, extended default rules)-    -> WantedConstraints   -- Unsolved (wanted or derived)+    -> WantedConstraints   -- Unsolved     -> [(TyVar, [Ct])] findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds   | null default_tys@@ -2712,14 +3176,13 @@         | otherwise         = all is_std_class clss && (any (isNumClass ovl_strings) clss)      -- is_std_class adds IsString to the standard numeric classes,-    -- when -foverloaded-strings is enabled+    -- when -XOverloadedStrings is enabled     is_std_class cls = isStandardClass cls ||                        (ovl_strings && (cls `hasKey` isStringClassKey))  ------------------------------ disambigGroup :: [Type]            -- The default types-              -> (TcTyVar, [Ct])   -- All classes of the form (C a)-                                   --  sharing same type variable+              -> (TcTyVar, [Ct])   -- All constraints sharing same type variable               -> TcS Bool   -- True <=> something happened, reflected in ty_binds  disambigGroup [] _@@ -2733,7 +3196,7 @@        ; if success then              -- Success: record the type variable binding, and return              do { unifyTyVar the_tv default_ty-                ; wrapWarnTcS $ warnDefaulting wanteds default_ty+                ; wrapWarnTcS $ warnDefaulting the_tv wanteds default_ty                 ; traceTcS "disambigGroup succeeded }" (ppr default_ty)                 ; return True }          else@@ -2746,9 +3209,14 @@       | Just subst <- mb_subst       = do { lcl_env <- TcS.getLclEnv            ; tc_lvl <- TcS.getTcLevel-           ; let loc = mkGivenLoc tc_lvl UnkSkol lcl_env-           ; wanted_evs <- mapM (newWantedEvVarNC loc . substTy subst . ctPred)-                                wanteds+           ; let loc = mkGivenLoc tc_lvl (getSkolemInfo unkSkol) lcl_env+           -- Equality constraints are possible due to type defaulting plugins+           ; wanted_evs <- sequence [ newWantedNC loc rewriters pred'+                                    | wanted <- wanteds+                                    , CtWanted { ctev_pred = pred+                                               , ctev_rewriters = rewriters }+                                        <- return (ctEvidence wanted)+                                    , let pred' = substTy subst pred ]            ; fmap isEmptyWC $              solveSimpleWanteds $ listToBag $              map mkNonCanonical wanted_evs }@@ -2764,14 +3232,14 @@       -- ill-kinded defaulting attempts like (Eq []) or (Foldable Int) here.  -- In interactive mode, or with -XExtendedDefaultRules,--- we default Show a to Show () to avoid graututious errors on "show []"+-- we default Show a to Show () to avoid gratuitous errors on "show []" isInteractiveClass :: Bool   -- -XOverloadedStrings?                    -> Class -> Bool isInteractiveClass ovl_strings cls     = isNumClass ovl_strings cls || (classKey cls `elem` interactiveClassKeys)      -- isNumClass adds IsString to the standard numeric classes,-    -- when -foverloaded-strings is enabled+    -- when -XOverloadedStrings is enabled isNumClass :: Bool   -- -XOverloadedStrings?            -> Class -> Bool isNumClass ovl_strings cls
compiler/GHC/Tc/Solver/Canonical.hs view
@@ -4,14 +4,12 @@  module GHC.Tc.Solver.Canonical(      canonicalize,-     unifyDerived,+     unifyWanted,      makeSuperClasses,      StopOrContinue(..), stopWith, continueWith, andWhenContinue,      solveCallStack    -- For GHC.Tc.Solver   ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Tc.Types.Constraint@@ -22,14 +20,17 @@ import GHC.Core.Type import GHC.Tc.Solver.Rewrite import GHC.Tc.Solver.Monad+import GHC.Tc.Solver.InertSet import GHC.Tc.Types.Evidence import GHC.Tc.Types.EvTerm import GHC.Core.Class+import GHC.Core.DataCon ( dataConName ) import GHC.Core.TyCon import GHC.Core.Multiplicity import GHC.Core.TyCo.Rep   -- cleverly decomposes types, good for completeness checking import GHC.Core.Coercion import GHC.Core.Coercion.Axiom+import GHC.Core.Reduction import GHC.Core import GHC.Types.Id( mkTemplateLocals ) import GHC.Core.FamInstEnv ( FamInstEnvs )@@ -39,10 +40,13 @@ import GHC.Types.Var.Set( delVarSetList, anyVarSet ) import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Builtin.Types ( anyTypeOfKind ) import GHC.Types.Name.Set import GHC.Types.Name.Reader import GHC.Hs.Type( HsIPName(..) )+import GHC.Types.Unique  ( hasKey )+import GHC.Builtin.Names ( coercibleTyConKey )  import GHC.Data.Pair import GHC.Utils.Misc@@ -53,6 +57,7 @@ import Data.List  ( zip4 ) import GHC.Types.Basic +import qualified Data.Semigroup as S import Data.Bifunctor ( bimap ) import Data.Foldable ( traverse_ ) @@ -107,9 +112,10 @@     --    e.g. a ~ [a], where [G] a ~ [Int], can decompose  canonicalize (CDictCan { cc_ev = ev, cc_class  = cls-                       , cc_tyargs = xis, cc_pend_sc = pend_sc })+                       , cc_tyargs = xis, cc_pend_sc = pend_sc+                       , cc_fundeps = fds })   = {-# SCC "canClass" #-}-    canClass ev cls xis pend_sc+    canClass ev cls xis pend_sc fds  canonicalize (CEqCan { cc_ev     = ev                      , cc_lhs    = lhs@@ -129,6 +135,7 @@                                   canIrred ev       ForAllPred tvs th p   -> do traceTcS "canEvNC:forall" (ppr pred)                                   canForAllNC ev tvs th p+   where     pred = ctEvPred ev @@ -148,39 +155,46 @@   | isGiven ev  -- See Note [Eagerly expand given superclasses]   = do { sc_cts <- mkStrictSuperClasses ev [] [] cls tys        ; emitWork sc_cts-       ; canClass ev cls tys False }+       ; canClass ev cls tys False fds } -  | isWanted ev+  | CtWanted { ctev_rewriters = rewriters } <- ev   , Just ip_name <- isCallStackPred cls tys-  , OccurrenceOf func <- ctLocOrigin loc+  , isPushCallStackOrigin orig   -- If we're given a CallStack constraint that arose from a function   -- call, we need to push the current call-site onto the stack instead   -- of solving it directly from a given.   -- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence-  -- and Note [Solving CallStack constraints] in GHC.Tc.Solver.Monad+  -- and Note [Solving CallStack constraints] in GHC.Tc.Solver.Types   = do { -- First we emit a new constraint that will capture the          -- given CallStack.        ; let new_loc = setCtLocOrigin loc (IPOccOrigin (HsIPName ip_name))                             -- We change the origin to IPOccOrigin so                             -- this rule does not fire again.                             -- See Note [Overview of implicit CallStacks]+                            -- in GHC.Tc.Types.Evidence -       ; new_ev <- newWantedEvVarNC new_loc pred+       ; new_ev <- newWantedEvVarNC new_loc rewriters pred           -- Then we solve the wanted by pushing the call-site          -- onto the newly emitted CallStack-       ; let ev_cs = EvCsPushCall func (ctLocSpan loc) (ctEvExpr new_ev)+       ; let ev_cs = EvCsPushCall (callStackOriginFS orig)+                                  (ctLocSpan loc) (ctEvExpr new_ev)        ; solveCallStack ev ev_cs -       ; canClass new_ev cls tys False }+       ; canClass new_ev cls tys+                  False -- No superclasses+                  False -- No top level instances for fundeps+       }    | otherwise-  = canClass ev cls tys (has_scs cls)+  = canClass ev cls tys (has_scs cls) fds    where     has_scs cls = not (null (classSCTheta cls))     loc  = ctEvLoc ev+    orig = ctLocOrigin loc     pred = ctEvPred ev+    fds  = classHasFds cls  solveCallStack :: CtEvidence -> EvCallStack -> TcS () -- Also called from GHC.Tc.Solver when defaulting call stacks@@ -195,20 +209,21 @@ canClass :: CtEvidence          -> Class -> [Type]          -> Bool            -- True <=> un-explored superclasses+         -> Bool            -- True <=> unexploited fundep(s)          -> TcS (StopOrContinue Ct) -- Precondition: EvVar is class evidence -canClass ev cls tys pend_sc-  =   -- all classes do *nominal* matching-    ASSERT2( ctEvRole ev == Nominal, ppr ev $$ ppr cls $$ ppr tys )-    do { (xis, cos) <- rewriteArgsNom ev cls_tc tys-       ; let co = mkTcTyConAppCo Nominal cls_tc cos-             xi = mkClassPred cls xis+canClass ev cls tys pend_sc fds+  = -- all classes do *nominal* matching+    assertPpr (ctEvRole ev == Nominal) (ppr ev $$ ppr cls $$ ppr tys) $+    do { (redns@(Reductions _ xis), rewriters) <- rewriteArgsNom ev cls_tc tys+       ; let redn@(Reduction _ xi) = mkClassPredRedn cls redns              mk_ct new_ev = CDictCan { cc_ev = new_ev                                      , cc_tyargs = xis                                      , cc_class = cls-                                     , cc_pend_sc = pend_sc }-       ; mb <- rewriteEvidence ev xi co+                                     , cc_pend_sc = pend_sc+                                     , cc_fundeps = fds }+       ; mb <- rewriteEvidence rewriters ev redn        ; traceTcS "canClass" (vcat [ ppr ev                                    , ppr xi, ppr mb ])        ; return (fmap mk_ct mb) }@@ -225,15 +240,14 @@   We get a Wanted (Eq a), which can only be solved from the superclass   of the Given (Ord a). -* For wanteds [W], and deriveds [WD], [D], they may give useful+* For wanteds [W], they may give useful   functional dependencies.  E.g.      class C a b | a -> b where ...      class C a b => D a b where ...   Now a [W] constraint (D Int beta) has (C Int beta) as a superclass   and that might tell us about beta, via C's fundeps.  We can get this-  by generating a [D] (C Int beta) constraint.  It's derived because-  we don't actually have to cough up any evidence for it; it's only there-  to generate fundep equalities.+  by generating a [W] (C Int beta) constraint. We won't use the evidence,+  but it may lead to unification.  See Note [Why adding superclasses can help]. @@ -283,7 +297,7 @@    GHC.Tc.Solver.simpl_loop and solveWanteds.     This may succeed in generating (a finite number of) extra Givens,-   and extra Deriveds. Both may help the proof.+   and extra Wanteds. Both may help the proof.  3a An important wrinkle: only expand Givens from the current level.    Two reasons:@@ -377,7 +391,7 @@     Suppose we want to solve          [G] C a b          [W] C a beta-    Then adding [D] beta~b will let us solve it.+    Then adding [W] beta~b will let us solve it.      -- Example 2 (similar but using a type-equality superclass)         class (F a ~ b) => C a b@@ -386,8 +400,8 @@          [W] C a beta     Follow the superclass rules to add          [G] F a ~ b-         [D] F a ~ beta-    Now we get [D] beta ~ b, and can solve that.+         [W] F a ~ beta+    Now we get [W] beta ~ b, and can solve that.      -- Example (tcfail138)       class L a b | a -> b@@ -402,9 +416,9 @@       [W] G (Maybe a)     Use the instance decl to get       [W] C a beta-    Generate its derived superclass-      [D] L a beta.  Now using fundeps, combine with [G] L a b to get-      [D] beta ~ b+    Generate its superclass+      [W] L a beta.  Now using fundeps, combine with [G] L a b to get+      [W] beta ~ b     which is what we want.  Note [Danger of adding superclasses during solving]@@ -421,8 +435,8 @@ If we were to be adding the superclasses during simplification we'd get:    [W] RealOf e ~ e    [W] Normed e-   [D] RealOf e ~ fuv-   [D] Num fuv+   [W] RealOf e ~ fuv+   [W] Num fuv ==>    e := fuv, Num fuv, Normed fuv, RealOf fuv ~ fuv @@ -431,9 +445,6 @@ definitely only once, during canonicalisation, this situation can't happen. -Mind you, now that Wanteds cannot rewrite Derived, I think this particular-situation can't happen.- Note [Nested quantified constraint superclasses] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider (typecheck/should_compile/T17202)@@ -476,7 +487,7 @@   -}  makeSuperClasses :: [Ct] -> TcS [Ct]--- Returns strict superclasses, transitively, see Note [The superclasses story]+-- Returns strict superclasses, transitively, see Note [The superclass story] -- See Note [The superclass story] -- The loop-breaking here follows Note [Expanding superclasses] in GHC.Tc.Utils.TcType -- Specifically, for an incoming (C t) constraint, we return all of (C t)'s@@ -494,8 +505,8 @@     go (CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys })       = mkStrictSuperClasses ev [] [] cls tys     go (CQuantCan (QCI { qci_pred = pred, qci_ev = ev }))-      = ASSERT2( isClassPred pred, ppr pred )  -- The cts should all have-                                               -- class pred heads+      = assertPpr (isClassPred pred) (ppr pred) $  -- The cts should all have+                                                   -- class pred heads         mkStrictSuperClasses ev tvs theta cls tys       where         (tvs, theta, cls, tys) = tcSplitDFunTy (ctEvPred ev)@@ -520,19 +531,21 @@ -- nor are repeated mk_strict_superclasses rec_clss (CtGiven { ctev_evar = evar, ctev_loc = loc })                        tvs theta cls tys-  = concatMapM (do_one_given (mk_given_loc loc)) $+  = concatMapM do_one_given $     classSCSelIds cls   where     dict_ids  = mkTemplateLocals theta     size      = sizeTypes tys -    do_one_given given_loc sel_id+    do_one_given sel_id       | isUnliftedType sc_pred+         -- NB: class superclasses are never representation-polymorphic,+         -- so isUnliftedType is OK here.       , not (null tvs && null theta)       = -- See Note [Equality superclasses in quantified constraints]         return []       | otherwise-      = do { given_ev <- newGivenEvVar given_loc $+      = do { given_ev <- newGivenEvVar sc_loc $                          mk_given_desc sel_id sc_pred            ; mk_superclasses rec_clss given_ev tvs theta sc_pred }       where@@ -562,13 +575,20 @@             `App` (evId evar `mkVarApps` (tvs ++ dict_ids))             `mkVarApps` sc_tvs -    mk_given_loc loc+    sc_loc        | isCTupleClass cls        = loc   -- For tuple predicates, just take them apart, without                -- adding their (large) size into the chain.  When we                -- get down to a base predicate, we'll include its size.                -- #10335 +       |  isEqPredClass cls+       || cls `hasKey` coercibleTyConKey+       = loc   -- The only superclasses of ~, ~~, and Coercible are primitive+               -- equalities, and they don't use the InstSCOrigin mechanism+               -- detailed in Note [Solving superclass constraints] in+               -- GHC.Tc.TyCl.Instance. Skip for a tiny performance win.+          -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance          -- for explantation of InstSCOrigin and Note [Replacement vs keeping] in          -- GHC.Tc.Solver.Interact for why we need OtherSCOrigin and depths@@ -589,18 +609,19 @@  mk_strict_superclasses rec_clss ev tvs theta cls tys   | all noFreeVarsOfType tys-  = return [] -- Wanteds with no variables yield no deriveds.+  = return [] -- Wanteds with no variables yield no superclass constraints.               -- See Note [Improvement from Ground Wanteds] -  | otherwise -- Wanted/Derived case, just add Derived superclasses+  | otherwise -- Wanted case, just add Wanted superclasses               -- that can lead to improvement.-  = ASSERT2( null tvs && null theta, ppr tvs $$ ppr theta )-    concatMapM do_one_derived (immSuperClasses cls tys)+  = assertPpr (null tvs && null theta) (ppr tvs $$ ppr theta) $+    concatMapM do_one (immSuperClasses cls tys)   where-    loc = ctEvLoc ev+    loc = ctEvLoc ev `updateCtLocOrigin` WantedSuperclassOrigin (ctEvPred ev) -    do_one_derived sc_pred-      = do { sc_ev <- newDerivedNC loc sc_pred+    do_one sc_pred+      = do { traceTcS "mk_strict_superclasses Wanted" (ppr (mkClassPred cls tys) $$ ppr sc_pred)+           ; sc_ev <- newWantedNC loc (ctEvRewriters ev) sc_pred            ; mk_superclasses rec_clss sc_ev [] [] sc_pred }  {- Note [Improvement from Ground Wanteds]@@ -608,8 +629,8 @@ Suppose class C b a => D a b and consider   [W] D Int Bool-Is there any point in emitting [D] C Bool Int?  No!  The only point of-emitting superclass constraints for W/D constraints is to get+Is there any point in emitting [W] C Bool Int?  No!  The only point of+emitting superclass constraints for W constraints is to get improvement, extra unifications that result from functional dependencies.  See Note [Why adding superclasses can help] above. @@ -649,7 +670,7 @@      this_ct | null tvs, null theta             = CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys-                       , cc_pend_sc = loop_found }+                       , cc_pend_sc = loop_found, cc_fundeps = classHasFds cls }                  -- NB: If there is a loop, we cut off, so we have not                  --     added the superclasses, hence cc_pend_sc = True             | otherwise@@ -707,15 +728,18 @@ canIrred ev   = do { let pred = ctEvPred ev        ; traceTcS "can_pred" (text "IrredPred = " <+> ppr pred)-       ; (xi,co) <- rewrite ev pred -- co :: xi ~ pred-       ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev ->+       ; (redn, rewriters) <- rewrite ev pred+       ; rewriteEvidence rewriters ev redn `andWhenContinue` \ new_ev ->      do { -- Re-classify, in case rewriting has improved its shape          -- Code is like the canNC, except          -- that the IrredPred branch stops work        ; case classifyPredType (ctEvPred new_ev) of            ClassPred cls tys     -> canClassNC new_ev cls tys-           EqPred eq_rel ty1 ty2 -> canEqNC new_ev eq_rel ty1 ty2+           EqPred eq_rel ty1 ty2 -> -- IrredPreds have kind Constraint, so+                                    -- cannot become EqPreds+                                    pprPanic "canIrred: EqPred"+                                      (ppr ev $$ ppr eq_rel $$ ppr ty1 $$ ppr ty2)            ForAllPred tvs th p   -> -- this is highly suspect; Quick Look                                     -- should never leave a meta-var filled                                     -- in with a polytype. This is #18987.@@ -822,8 +846,8 @@ canForAll ev pend_sc   = do { -- First rewrite it to apply the current substitution          let pred = ctEvPred ev-       ; (xi,co) <- rewrite ev pred -- co :: xi ~ pred-       ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev ->+       ; (redn, rewriters) <- rewrite ev pred+       ; rewriteEvidence rewriters ev redn `andWhenContinue` \ new_ev ->      do { -- Now decompose into its pieces and solve it          -- (It takes a lot less code to rewrite before decomposing.)@@ -835,23 +859,27 @@  solveForAll :: CtEvidence -> [TyVar] -> TcThetaType -> PredType -> Bool             -> TcS (StopOrContinue Ct)-solveForAll ev tvs theta pred pend_sc-  | CtWanted { ctev_dest = dest } <- ev+solveForAll ev@(CtWanted { ctev_dest = dest, ctev_rewriters = rewriters, ctev_loc = loc })+            tvs theta pred _pend_sc   = -- See Note [Solving a Wanted forall-constraint]-    do { let skol_info = QuantCtxtSkol-             empty_subst = mkEmptyTCvSubst $ mkInScopeSet $+    setLclEnv (ctLocEnv loc) $+    -- This setLclEnv is important: the emitImplicationTcS uses that+    -- TcLclEnv for the implication, and that in turn sets the location+    -- for the Givens when solving the constraint (#21006)+    do { skol_info <- mkSkolemInfo QuantCtxtSkol+       ; let empty_subst = mkEmptyTCvSubst $ mkInScopeSet $                            tyCoVarsOfTypes (pred:theta) `delVarSetList` tvs-       ; (subst, skol_tvs) <- tcInstSkolTyVarsX empty_subst tvs+       ; (subst, skol_tvs) <- tcInstSkolTyVarsX skol_info empty_subst tvs        ; given_ev_vars <- mapM newEvVar (substTheta subst theta)         ; (lvl, (w_id, wanteds))              <- pushLevelNoWorkList (ppr skol_info) $-                do { wanted_ev <- newWantedEvVarNC loc $+                do { wanted_ev <- newWantedEvVarNC loc rewriters $                                   substTy subst pred                    ; return ( ctEvEvId wanted_ev                             , unitBag (mkNonCanonical wanted_ev)) } -      ; ev_binds <- emitImplicationTcS lvl skol_info skol_tvs+      ; ev_binds <- emitImplicationTcS lvl (getSkolemInfo skol_info) skol_tvs                                        given_ev_vars wanteds        ; setWantedEvTerm dest $@@ -860,15 +888,11 @@        ; stopWith ev "Wanted forall-constraint" } -  | isGiven ev   -- See Note [Solving a Given forall-constraint]+ -- See Note [Solving a Given forall-constraint]+solveForAll ev@(CtGiven {}) tvs _theta pred pend_sc   = do { addInertForAll qci        ; stopWith ev "Given forall-constraint" }--  | otherwise-  = do { traceTcS "discarding derived forall-constraint" (ppr ev)-       ; stopWith ev "Derived forall-constraint" }   where-    loc = ctEvLoc ev     qci = QCI { qci_ev = ev, qci_tvs = tvs               , qci_pred = pred, qci_pend_sc = pend_sc } @@ -891,7 +915,6 @@ via addInertForall.  Then, if we look up (C x Int Bool), say, we'll find a match in the InstEnv. - ************************************************************************ *                                                                      * *        Equalities@@ -989,7 +1012,7 @@    | ReprEq <- eq_rel   , Just stuff2 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty2-  = can_eq_newtype_nc ev IsSwapped  ty2 stuff2 ty1 ps_ty1+  = can_eq_newtype_nc ev IsSwapped ty2 stuff2 ty1 ps_ty1  -- Then, get rid of casts can_eq_nc' rewritten _rdr_env _envs ev eq_rel (CastTy ty1 co1) _ ty2 ps_ty2@@ -1055,9 +1078,9 @@  -- No similarity in type structure detected. Rewrite and try again. can_eq_nc' False rdr_env envs ev eq_rel _ ps_ty1 _ ps_ty2-  = do { (xi1, co1) <- rewrite ev ps_ty1-       ; (xi2, co2) <- rewrite ev ps_ty2-       ; new_ev <- rewriteEqEvidence ev NotSwapped xi1 xi2 co1 co2+  = do { (redn1@(Reduction _ xi1), rewriters1) <- rewrite ev ps_ty1+       ; (redn2@(Reduction _ xi2), rewriters2) <- rewrite ev ps_ty2+       ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2        ; can_eq_nc' True rdr_env envs new_ev eq_rel xi1 xi1 xi2 xi2 }  ----------------------------@@ -1175,7 +1198,7 @@ --  so we must proceed one binder at a time (#13879)  can_eq_nc_forall ev eq_rel s1 s2- | CtWanted { ctev_loc = loc, ctev_dest = orig_dest } <- ev+ | CtWanted { ctev_loc = loc, ctev_dest = orig_dest, ctev_rewriters = rewriters } <- ev  = do { let free_tvs       = tyCoVarsOfTypes [s1,s2]             (bndrs1, phi1) = tcSplitForAllTyVarBinders s1             (bndrs2, phi2) = tcSplitForAllTyVarBinders s2@@ -1188,18 +1211,18 @@         else    do { traceTcS "Creating implication for polytype equality" $ ppr ev       ; let empty_subst1 = mkEmptyTCvSubst $ mkInScopeSet free_tvs-      ; (subst1, skol_tvs) <- tcInstSkolTyVarsX empty_subst1 $+      ; skol_info <- mkSkolemInfo (UnifyForAllSkol phi1)+      ; (subst1, skol_tvs) <- tcInstSkolTyVarsX skol_info empty_subst1 $                               binderVars bndrs1 -      ; let skol_info = UnifyForAllSkol phi1-            phi1' = substTy subst1 phi1+      ; let phi1' = substTy subst1 phi1              -- Unify the kinds, extend the substitution             go :: [TcTyVar] -> TCvSubst -> [TyVarBinder]                -> TcS (TcCoercion, Cts)             go (skol_tv:skol_tvs) subst (bndr2:bndrs2)               = do { let tv2 = binderVar bndr2-                   ; (kind_co, wanteds1) <- unify loc Nominal (tyVarKind skol_tv)+                   ; (kind_co, wanteds1) <- unify loc rewriters Nominal (tyVarKind skol_tv)                                                   (substTy subst (tyVarKind tv2))                    ; let subst' = extendTvSubstAndInScope subst tv2                                        (mkCastTy (mkTyVarTy skol_tv) kind_co)@@ -1211,8 +1234,8 @@              -- Done: unify phi1 ~ phi2             go [] subst bndrs2-              = ASSERT( null bndrs2 )-                unify loc (eqRelRole eq_rel) phi1' (substTyUnchecked subst phi2)+              = assert (null bndrs2) $+                unify loc rewriters (eqRelRole eq_rel) phi1' (substTyUnchecked subst phi2)              go _ _ _ = panic "cna_eq_nc_forall"  -- case (s:ss) [] @@ -1220,25 +1243,25 @@        ; (lvl, (all_co, wanteds)) <- pushLevelNoWorkList (ppr skol_info) $                                     go skol_tvs empty_subst2 bndrs2-      ; emitTvImplicationTcS lvl skol_info skol_tvs wanteds+      ; emitTvImplicationTcS lvl (getSkolemInfo skol_info) skol_tvs wanteds        ; setWantedEq orig_dest all_co       ; stopWith ev "Deferred polytype equality" } }   | otherwise  = do { traceTcS "Omitting decomposition of given polytype equality" $-        pprEq s1 s2    -- See Note [Do not decompose given polytype equalities]+        pprEq s1 s2    -- See Note [Do not decompose Given polytype equalities]       ; stopWith ev "Discard given polytype equality" }   where-    unify :: CtLoc -> Role -> TcType -> TcType -> TcS (TcCoercion, Cts)+    unify :: CtLoc -> RewriterSet -> Role -> TcType -> TcType -> TcS (TcCoercion, Cts)     -- This version returns the wanted constraint rather     -- than putting it in the work list-    unify loc role ty1 ty2+    unify loc rewriters role ty1 ty2       | ty1 `tcEqType` ty2       = return (mkTcReflCo role ty1, emptyBag)       | otherwise-      = do { (wanted, co) <- newWantedEq loc role ty1 ty2+      = do { (wanted, co) <- newWantedEq loc rewriters role ty1 ty2            ; return (co, unitBag (mkNonCanonical wanted)) }  ---------------------------------@@ -1456,9 +1479,9 @@                   -> TcType               -- ^ ty2                   -> TcType               -- ^ ty2, with type synonyms                   -> TcS (StopOrContinue Ct)-can_eq_newtype_nc ev swapped ty1 ((gres, co), ty1') ty2 ps_ty2+can_eq_newtype_nc ev swapped ty1 ((gres, co1), ty1') ty2 ps_ty2   = do { traceTcS "can_eq_newtype_nc" $-         vcat [ ppr ev, ppr swapped, ppr co, ppr gres, ppr ty1', ppr ty2 ]+         vcat [ ppr ev, ppr swapped, ppr co1, ppr gres, ppr ty1', ppr ty2 ]           -- check for blowing our stack:          -- See Note [Newtypes can blow the stack]@@ -1474,8 +1497,11 @@          -- module, don't warn about it being unused.          -- See Note [Tracking unused binding and imports] in GHC.Tc.Utils. -       ; new_ev <- rewriteEqEvidence ev swapped ty1' ps_ty2-                                     (mkTcSymCo co) (mkTcReflCo Representational ps_ty2)+       ; let redn1 = mkReduction co1 ty1'++       ; new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped+                     redn1+                     (mkReflRedn Representational ps_ty2)        ; can_eq_nc False new_ev ReprEq ty1' ty1' ty2 ps_ty2 }   where     gre_list = bagToList gres@@ -1493,16 +1519,12 @@ -- to an irreducible constraint; see typecheck/should_compile/T10494 -- See Note [Decomposing AppTy at representational role] can_eq_app ev s1 t1 s2 t2-  | CtDerived {} <- ev-  = do { unifyDeriveds loc [Nominal, Nominal] [s1, t1] [s2, t2]-       ; stopWith ev "Decomposed [D] AppTy" }--  | CtWanted { ctev_dest = dest } <- ev-  = do { co_s <- unifyWanted loc Nominal s1 s2+  | CtWanted { ctev_dest = dest, ctev_rewriters = rewriters } <- ev+  = do { co_s <- unifyWanted rewriters loc Nominal s1 s2        ; let arg_loc                | isNextArgVisible s1 = loc                | otherwise           = updateCtLocOrigin loc toInvisibleOrigin-       ; co_t <- unifyWanted arg_loc Nominal t1 t2+       ; co_t <- unifyWanted rewriters arg_loc Nominal t1 t2        ; let co = mkAppCo co_s co_t        ; setWantedEq dest co        ; stopWith ev "Decomposed [W] AppTy" }@@ -1550,9 +1572,9 @@   = do { traceTcS "Decomposing cast" (vcat [ ppr ev                                            , ppr ty1 <+> text "|>" <+> ppr co1                                            , ppr ps_ty2 ])-       ; new_ev <- rewriteEqEvidence ev swapped ty1 ps_ty2-                                     (mkTcGReflRightCo role ty1 co1)-                                     (mkTcReflCo role ps_ty2)+       ; new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped+                      (mkGReflLeftRedn role ty1 co1)+                      (mkReflRedn role ps_ty2)        ; can_eq_nc rewritten new_ev eq_rel ty1 ty1 ty2 ps_ty2 }   where     role = eqRelRole eq_rel@@ -1659,18 +1681,13 @@ at role X.  Pursuing the details requires exploring three axes:-* Flavour: Given vs. Derived vs. Wanted+* Flavour: Given vs. Wanted * Role: Nominal vs. Representational * TyCon species: datatype vs. newtype vs. data family vs. type family vs. type variable  (A type variable isn't a TyCon, of course, but it's convenient to put the AppTy case in the same table.) -Right away, we can say that Derived behaves just as Wanted for the purposes-of decomposition. The difference between Derived and Wanted is the handling of-evidence. Since decomposition in these cases isn't a matter of soundness but of-guessing, we want the same behaviour regardless of evidence.- Here is a table (discussion following) detailing where decomposition of    (T s1 ... sn) ~r (T t1 .. tn) is allowed.  The first four lines (Data types ... type family) refer@@ -1697,7 +1714,7 @@ {1}: Type families can be injective in some, but not all, of their arguments, so we want to do partial decomposition. This is quite different than the way other decomposition is done, where the decomposed equalities replace the original-one. We thus proceed much like we do with superclasses, emitting new Deriveds+one. We thus proceed much like we do with superclasses, emitting new Wanteds when "decomposing" a partially-injective type family Wanted. Injective type families have no corresponding evidence of their injectivity, so we cannot decompose an injective-type-family Given.@@ -1711,6 +1728,27 @@  {4}: See Note [Decomposing AppTy at representational role] +   Because type variables can stand in for newtypes, we conservatively do not+   decompose AppTys over representational equality. Here are two examples that+   demonstrate why we can't:++   4a: newtype Phant a = MkPhant Int+       [W] alpha Int ~R beta Bool++   If we eventually solve alpha := Phant and beta := Phant, then we can solve+   this equality by unwrapping. But it would have been disastrous to decompose+   the wanted to produce Int ~ Bool, which is definitely insoluble.++   4b: newtype Age = MkAge Int+       [W] alpha Age ~R Maybe Int++   First, a question: if we know that ty1 ~R ty2, can we conclude that+   a ty1 ~R a ty2? Not for all a. This is precisely why we need role annotations+   on type constructors. So, if we were to decompose, we would need to+   decompose to [W] alpha ~R Maybe and [W] Age ~ Int. On the other hand, if we+   later solve alpha := Maybe, then we would decompose to [W] Age ~R Int, and+   that would be soluble.+ In the implementation of can_eq_nc and friends, we don't directly pattern match using lines like in the tables above, as those tables don't cover all cases (what about PrimTyCon? tuples?). Instead we just ask about injectivity,@@ -1848,18 +1886,15 @@                           -> TcS (StopOrContinue Ct) -- Precondition: tys1 and tys2 are the same length, hence "OK" canDecomposableTyConAppOK ev eq_rel tc tys1 tys2-  = ASSERT( tys1 `equalLength` tys2 )+  = assert (tys1 `equalLength` tys2) $     do { traceTcS "canDecomposableTyConAppOK"                   (ppr ev $$ ppr eq_rel $$ ppr tc $$ ppr tys1 $$ ppr tys2)        ; case ev of-           CtDerived {}-             -> unifyDeriveds loc tc_roles tys1 tys2--           CtWanted { ctev_dest = dest }+           CtWanted { ctev_dest = dest, ctev_rewriters = rewriters }                   -- new_locs and tc_roles are both infinite, so                   -- we are guaranteed that cos has the same length                   -- as tys1 and tys2-             -> do { cos <- zipWith4M unifyWanted new_locs tc_roles tys1 tys2+             -> do { cos <- zipWith4M (unifyWanted rewriters) new_locs tc_roles tys1 tys2                    ; setWantedEq dest (mkTyConAppCo role tc cos) }             CtGiven { ctev_evar = evar }@@ -1909,14 +1944,14 @@ canEqFailure ev NomEq ty1 ty2   = canEqHardFailure ev ty1 ty2 canEqFailure ev ReprEq ty1 ty2-  = do { (xi1, co1) <- rewrite ev ty1-       ; (xi2, co2) <- rewrite ev ty2+  = do { (redn1, rewriters1) <- rewrite ev ty1+       ; (redn2, rewriters2) <- rewrite ev ty2             -- We must rewrite the types before putting them in the             -- inert set, so that we are sure to kick them out when             -- new equalities become available        ; traceTcS "canEqFailure with ReprEq" $-         vcat [ ppr ev, ppr ty1, ppr ty2, ppr xi1, ppr xi2 ]-       ; new_ev <- rewriteEqEvidence ev NotSwapped xi1 xi2 co1 co2+         vcat [ ppr ev, ppr redn1, ppr redn2 ]+       ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2        ; continueWith (mkIrredCt ReprEqReason new_ev) }  -- | Call when canonicalizing an equality fails with utterly no hope.@@ -1925,9 +1960,9 @@ -- See Note [Make sure that insolubles are fully rewritten] canEqHardFailure ev ty1 ty2   = do { traceTcS "canEqHardFailure" (ppr ty1 $$ ppr ty2)-       ; (s1, co1) <- rewrite ev ty1-       ; (s2, co2) <- rewrite ev ty2-       ; new_ev <- rewriteEqEvidence ev NotSwapped s1 s2 co1 co2+       ; (redn1, rewriters1) <- rewrite ev ty1+       ; (redn2, rewriters2) <- rewrite ev ty2+       ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2        ; continueWith (mkIrredCt ShapeMismatchReason new_ev) }  {-@@ -1971,7 +2006,7 @@ all the way down, so that it accurately reflects  (a) the mutable reference substitution in force at start of solving  (b) any ty-binds in force at this point in solving-See Note [Rewrite insolubles] in GHC.Tc.Solver.Monad.+See Note [Rewrite insolubles] in GHC.Tc.Solver.InertSet. And if we don't do this there is a bad danger that GHC.Tc.Solver.applyTyVarDefaulting will find a variable that has in fact been substituted.@@ -1982,21 +2017,6 @@ No -- what would the evidence look like?  So instead we simply discard this given evidence. --Note [Combining insoluble constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-As this point we have an insoluble constraint, like Int~Bool.-- * If it is Wanted, delete it from the cache, so that subsequent-   Int~Bool constraints give rise to separate error messages-- * But if it is Derived, DO NOT delete from cache.  A class constraint-   may get kicked out of the inert set, and then have its functional-   dependency Derived constraints generated a second time. In that-   case we don't want to get two (or more) error messages by-   generating two (or more) insoluble fundep constraints from the same-   class constraint.- Note [No top-level newtypes on RHS of representational equalities] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we're in this situation:@@ -2022,8 +2042,8 @@     g _ = f (undefined :: F a)  For g we get [G]  g1 : UnF (F a) ~ a-             [WD] w1 : UnF (F beta) ~ beta-             [WD] w2 : F a ~ F beta+             [W] w1 : UnF (F beta) ~ beta+             [W] w2 : F a ~ F beta  g1 is canonical (CEqCan). It is oriented as above because a is not touchable. See canEqTyVarFunEq.@@ -2038,17 +2058,16 @@  But if w2 is swapped around, to -    [D] w3 : F beta ~ F a+    [W] w3 : F beta ~ F a -then (after emitting shadow Deriveds, etc. See GHC.Tc.Solver.Monad-Note [The improvement story and derived shadows]) we'll kick w1 out of the inert+then we'll kick w1 out of the inert set (it mentions the LHS of w3). We then rewrite w1 to -    [D] w4 : UnF (F a) ~ beta+    [W] w4 : UnF (F a) ~ beta  and then, using g1, to -    [D] w5 : a ~ beta+    [W] w5 : a ~ beta  at which point we can unify and go on to glory. (This rewriting actually happens all at once, in the call to rewrite during canonicalisation.)@@ -2064,7 +2083,7 @@ -}  ----------------------canEqCanLHS :: CtEvidence          -- ev :: lhs ~ rhs+canEqCanLHS :: CtEvidence            -- ev :: lhs ~ rhs             -> EqRel -> SwapFlag             -> CanEqLHS              -- lhs (or, if swapped, rhs)             -> TcType                -- lhs: pretty lhs, already rewritten@@ -2075,7 +2094,7 @@   = canEqCanLHSHomo ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2    | otherwise-  = canEqCanLHSHetero ev eq_rel swapped lhs1 ps_xi1 k1 xi2 ps_xi2 k2+  = canEqCanLHSHetero ev eq_rel swapped lhs1 k1 xi2 k2    where     k1 = canEqLHSKind lhs1@@ -2083,41 +2102,42 @@  canEqCanLHSHetero :: CtEvidence         -- :: (xi1 :: ki1) ~ (xi2 :: ki2)                   -> EqRel -> SwapFlag-                  -> CanEqLHS -> TcType -- xi1, pretty xi1+                  -> CanEqLHS           -- xi1                   -> TcKind             -- ki1-                  -> TcType -> TcType   -- xi2, pretty xi2 :: ki2+                  -> TcType             -- xi2                   -> TcKind             -- ki2                   -> TcS (StopOrContinue Ct)-canEqCanLHSHetero ev eq_rel swapped lhs1 ps_xi1 ki1 xi2 ps_xi2 ki2+canEqCanLHSHetero ev eq_rel swapped lhs1 ki1 xi2 ki2   -- See Note [Equalities with incompatible kinds]-  = do { kind_co <- emit_kind_co   -- :: ki2 ~N ki1+  = do { (kind_ev, kind_co) <- mk_kind_eq   -- :: ki2 ~N ki1         ; let  -- kind_co :: (ki2 :: *) ~N (ki1 :: *)   (whether swapped or not)-              -- co1     :: kind(tv1) ~N ki1-             rhs'    = xi2    `mkCastTy` kind_co   -- :: ki1-             ps_rhs' = ps_xi2 `mkCastTy` kind_co   -- :: ki1-             rhs_co  = mkTcGReflLeftCo role xi2 kind_co-               -- rhs_co :: (xi2 |> kind_co) ~ xi2+             lhs_redn = mkReflRedn role xi1+             rhs_redn = mkGReflRightRedn role xi2 kind_co -             lhs_co = mkTcReflCo role xi1+             -- See Note [Equalities with incompatible kinds], Wrinkle (1)+             -- This will be ignored in rewriteEqEvidence if the work item is a Given+             rewriters = rewriterSetFromCo kind_co         ; traceTcS "Hetero equality gives rise to kind equality"            (ppr kind_co <+> dcolon <+> sep [ ppr ki2, text "~#", ppr ki1 ])-       ; type_ev <- rewriteEqEvidence ev swapped xi1 rhs' lhs_co rhs_co+       ; type_ev <- rewriteEqEvidence rewriters ev swapped lhs_redn rhs_redn -          -- rewriteEqEvidence carries out the swap, so we're NotSwapped any more-       ; canEqCanLHSHomo type_ev eq_rel NotSwapped lhs1 ps_xi1 rhs' ps_rhs' }+       ; emitWorkNC [type_ev]  -- delay the type equality until after we've finished+                               -- the kind equality, which may unlock things+                               -- See Note [Equalities with incompatible kinds]++       ; canEqNC kind_ev NomEq ki2 ki1 }   where-    emit_kind_co :: TcS CoercionN-    emit_kind_co-      | CtGiven { ctev_evar = evar } <- ev-      = do { let kind_co = maybe_sym $ mkTcKindCo (mkTcCoVarCo evar)  -- :: k2 ~ k1-           ; kind_ev <- newGivenEvVar kind_loc (kind_pty, evCoercion kind_co)-           ; emitWorkNC [kind_ev]-           ; return (ctEvCoercion kind_ev) }+    mk_kind_eq :: TcS (CtEvidence, CoercionN)+    mk_kind_eq = case ev of+      CtGiven { ctev_evar = evar }+        -> do { let kind_co = maybe_sym $ mkTcKindCo (mkTcCoVarCo evar)  -- :: k2 ~ k1+              ; kind_ev <- newGivenEvVar kind_loc (kind_pty, evCoercion kind_co)+              ; return (kind_ev, ctEvCoercion kind_ev) } -      | otherwise-      = unifyWanted kind_loc Nominal ki2 ki1+      CtWanted { ctev_rewriters = rewriters }+        -> newWantedEq kind_loc rewriters Nominal ki2 ki1      xi1      = canEqLHSType lhs1     loc      = ctev_loc ev@@ -2187,7 +2207,7 @@   , TyFamLHS fun_tc2 fun_args2 <- lhs2   = do { traceTcS "canEqCanLHS2 two type families" (ppr lhs1 $$ ppr lhs2) -         -- emit derived equalities for injective type families+         -- emit wanted equalities for injective type families        ; let inj_eqns :: [TypeEqn]  -- TypeEqn = Pair Type              inj_eqns                | ReprEq <- eq_rel   = []   -- injectivity applies only for nom. eqs.@@ -2220,11 +2240,13 @@                | otherwise  -- ordinary, non-injective type family                = [] -       ; unless (isGiven ev) $-         mapM_ (unifyDerived (ctEvLoc ev) Nominal) inj_eqns+       ; case ev of+           CtWanted { ctev_rewriters = rewriters } ->+             mapM_ (\ (Pair t1 t2) -> unifyWanted rewriters (ctEvLoc ev) Nominal t1 t2) inj_eqns+           CtGiven {} -> return ()+             -- See Note [No Given/Given fundeps] in GHC.Tc.Solver.Interact         ; tclvl <- getTcLevel-       ; dflags <- getDynFlags        ; let tvs1 = tyCoVarsOfTypes fun_args1              tvs2 = tyCoVarsOfTypes fun_args2 @@ -2235,9 +2257,9 @@                 -- If we have F a ~ F (F a), we want to swap.              swap_for_occurs-               | cterHasNoProblem   $ checkTyFamEq dflags fun_tc2 fun_args2+               | cterHasNoProblem   $ checkTyFamEq fun_tc2 fun_args2                                                    (mkTyConApp fun_tc1 fun_args1)-               , cterHasOccursCheck $ checkTyFamEq dflags fun_tc1 fun_args1+               , cterHasOccursCheck $ checkTyFamEq fun_tc1 fun_args1                                                    (mkTyConApp fun_tc2 fun_args2)                = True @@ -2281,10 +2303,9 @@                 -> TcS (StopOrContinue Ct) canEqTyVarFunEq ev eq_rel swapped tv1 ps_xi1 fun_tc2 fun_args2 ps_xi2 mco   = do { is_touchable <- touchabilityTest (ctEvFlavour ev) tv1 rhs-       ; dflags       <- getDynFlags        ; if | case is_touchable of { Untouchable -> False; _ -> True }             , cterHasNoProblem $-                checkTyVarEq dflags tv1 rhs `cterRemoveProblem` cteTypeFamily+                checkTyVarEq tv1 rhs `cterRemoveProblem` cteTypeFamily             -> canEqCanLHSFinish ev eq_rel swapped (TyVarLHS tv1) rhs              | otherwise@@ -2302,8 +2323,8 @@ -- want to rewrite the LHS to (as per e.g. swapOverTyVars) canEqCanLHSFinish :: CtEvidence                   -> EqRel -> SwapFlag-                  -> CanEqLHS              -- lhs (or, if swapped, rhs)-                  -> TcType          -- rhs, pretty rhs+                  -> CanEqLHS             -- lhs (or, if swapped, rhs)+                  -> TcType               -- rhs (or, if swapped, lhs)                   -> TcS (StopOrContinue Ct) canEqCanLHSFinish ev eq_rel swapped lhs rhs -- RHS is fully rewritten, but with type synonyms@@ -2311,21 +2332,25 @@ -- guaranteed that tyVarKind lhs == typeKind rhs, for (TyEq:K) -- (TyEq:N) is checked in can_eq_nc', and (TyEq:TV) is handled in canEqCanLHS2 -  = do { dflags <- getDynFlags-       ; new_ev <- rewriteEqEvidence ev swapped lhs_ty rhs rewrite_co1 rewrite_co2+  = do {+          -- this performs the swap if necessary+         new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped+                                     (mkReflRedn role lhs_ty)+                                     (mkReflRedn role rhs)       -- by now, (TyEq:K) is already satisfied-       ; MASSERT(canEqLHSKind lhs `eqType` tcTypeKind rhs)+       ; massert (canEqLHSKind lhs `eqType` tcTypeKind rhs)       -- by now, (TyEq:N) is already satisfied (if applicable)-       ; MASSERT(not bad_newtype)+       ; assertPprM ty_eq_N_OK $+           vcat [ text "CanEqCanLHSFinish: (TyEq:N) not satisfied"+                , text "rhs:" <+> ppr rhs+                ]       -- guarantees (TyEq:OC), (TyEq:F)      -- Must do the occurs check even on tyvar/tyvar      -- equalities, in case have  x ~ (y :: ..x...); this is #12593.-     -- This next line checks also for coercion holes (TyEq:H); see-     -- Note [Equalities with incompatible kinds]-       ; let result0 = checkTypeEq dflags lhs rhs `cterRemoveProblem` cteTypeFamily+       ; let result0 = checkTypeEq lhs rhs `cterRemoveProblem` cteTypeFamily      -- type families are OK here      -- NB: no occCheckExpand here; see Note [Rewriting synonyms] in GHC.Tc.Solver.Rewrite @@ -2334,10 +2359,7 @@                         NomEq  -> result0                         ReprEq -> cterSetOccursCheckSoluble result0 -             reason | result `cterHasOnlyProblem` cteHoleBlocker-                    = HoleBlockerReason (coercionHolesOfType rhs)-                    | otherwise-                    = NonCanonicalReason result+             reason = NonCanonicalReason result         ; if cterHasNoProblem result          then do { traceTcS "CEqCan" (ppr lhs $$ ppr rhs)@@ -2352,22 +2374,23 @@                          do { traceTcS "canEqCanLHSFinish can't make a canonical"                                        (ppr lhs $$ ppr rhs)                             ; continueWith (mkIrredCt reason new_ev) }-                     ; Just (co, new_rhs) ->+                     ; Just rhs_redn@(Reduction _ new_rhs) ->               do { traceTcS "canEqCanLHSFinish breaking a cycle" $                             ppr lhs $$ ppr rhs                  ; traceTcS "new RHS:" (ppr new_rhs)                     -- This check is Detail (1) in the Note-                 ; if cterHasOccursCheck (checkTypeEq dflags lhs new_rhs)+                 ; if cterHasOccursCheck (checkTypeEq lhs new_rhs)                     then do { traceTcS "Note [Type equality cycles] Detail (1)"                                       (ppr new_rhs)                            ; continueWith (mkIrredCt reason new_ev) }                     else do { -- See Detail (6) of Note [Type equality cycles]-                             new_new_ev <- rewriteEqEvidence new_ev NotSwapped-                                             lhs_ty new_rhs-                                             (mkTcNomReflCo lhs_ty) co+                             new_new_ev <- rewriteEqEvidence emptyRewriterSet+                                             new_ev NotSwapped+                                             (mkReflRedn Nominal lhs_ty)+                                             rhs_redn                             ; continueWith (CEqCan { cc_ev = new_new_ev                                                   , cc_lhs = lhs@@ -2378,15 +2401,20 @@      lhs_ty = canEqLHSType lhs -    rewrite_co1  = mkTcReflCo role lhs_ty-    rewrite_co2  = mkTcReflCo role rhs--    -- This is about (TyEq:N)-    bad_newtype | ReprEq <- eq_rel-                , Just tc <- tyConAppTyCon_maybe rhs-                = isNewTyCon tc-                | otherwise-                = False+    -- This is about (TyEq:N): check that we don't have a newtype+    -- whose constructor is in scope at the top-level of the RHS.+    ty_eq_N_OK :: TcS Bool+    ty_eq_N_OK+      | ReprEq <- eq_rel+      , Just tc <- tyConAppTyCon_maybe rhs+      , Just con <- newTyConDataCon_maybe tc+      -- #21010: only a problem if the newtype constructor is in scope+      -- yet we didn't rewrite it away.+      = do { rdr_env <- getGlobalRdrEnvTcS+           ; let con_in_scope = isJust $ lookupGRE_Name rdr_env (dataConName con)+           ; return $ not con_in_scope }+      | otherwise+      = return True  -- | Solve a reflexive equality constraint canEqReflexive :: CtEvidence    -- ty ~ ty@@ -2406,13 +2434,10 @@                       -> TcS CtEvidence -- :: (lhs |> sym mco) ~ rhs                                         -- result is independent of SwapFlag rewriteCastedEquality ev eq_rel swapped lhs rhs mco-  = rewriteEqEvidence ev swapped new_lhs new_rhs lhs_co rhs_co+  = rewriteEqEvidence emptyRewriterSet ev swapped lhs_redn rhs_redn   where-    new_lhs = lhs `mkCastTyMCo` sym_mco-    lhs_co  = mkTcGReflLeftMCo role lhs sym_mco--    new_rhs = rhs-    rhs_co  = mkTcGReflRightMCo role rhs mco+    lhs_redn = mkGReflRightMRedn role lhs sym_mco+    rhs_redn = mkGReflLeftMRedn  role rhs mco      sym_mco = mkTcSymMCo mco     role    = eqRelRole eq_rel@@ -2428,78 +2453,38 @@    [X] (tv :: k1) ~ (rhs :: k2) -(where [X] is [G], [W], or [D]), we go to--  [noDerived X] co :: k2 ~ k1-  [X]           (tv :: k1) ~ ((rhs |> co) :: k1)--where+(where [X] is [G] or [W]), we go to -  noDerived G = G-  noDerived _ = W+  [X] co :: k2 ~ k1+  [X] (tv :: k1) ~ ((rhs |> co) :: k1) -For reasons described in Wrinkle (2) below, we want the [X] constraint to be "blocked";-that is, it should be put aside, and not used to rewrite any other constraint,-until the kind-equality on which it depends (namely 'co' above) is solved.-To achieve this-* The [X] constraint is a CIrredCan-* With a cc_reason of HoleBlockerReason bchs-* Where 'bchs' is the set of "blocking coercion holes".  The blocking coercion-  holes are the free coercion holes of [X]'s type-* When all the blocking coercion holes in the CIrredCan are filled (solved),-  we convert [X] to a CNonCanonical and put it in the work list.-All this is described in more detail in Wrinkle (2).+We carry on with the *kind equality*, not the type equality, because+solving the former may unlock the latter. This choice is made in+canEqCanLHSHetero. It is important: otherwise, T13135 loops.  Wrinkles: - (1) The noDerived step is because Derived equalities have no evidence.-     And yet we absolutely need evidence to be able to proceed here.-     Given evidence will use the KindCo coercion; Wanted evidence will-     be a coercion hole. Even a Derived hetero equality begets a Wanted-     kind equality.-- (2) Though it would be sound to do so, we must not mark the rewritten Wanted-       [W] (tv :: k1) ~ ((rhs |> co) :: k1)-     as canonical in the inert set. In particular, we must not unify tv.-     If we did, the Wanted becomes a Given (effectively), and then can-     rewrite other Wanteds. But that's bad: See Note [Wanteds do not rewrite Wanteds]-     in GHC.Tc.Types.Constraint. The problem is about poor error messages. See #11198 for-     tales of destruction.+ (1) When X is W, the new type-level wanted is effectively rewritten by the+     kind-level one. We thus include the kind-level wanted in the RewriterSet+     for the type-level one. See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint.+     This is done in canEqCanLHSHetero. -     So, we have an invariant on CEqCan (TyEq:H) that the RHS does not have-     any coercion holes. This is checked in checkTypeEq. Any equalities that-     have such an RHS are turned into CIrredCans with a HoleBlockerReason. We also-     must be sure to kick out any such CIrredCan constraints that mention coercion holes-     when those holes get filled in, so that the unification step can now proceed.+ (2) If we have [W] w :: alpha ~ (rhs |> co_hole), should we unify alpha? No.+     The problem is that the wanted w is effectively rewritten by another wanted,+     and unifying alpha effectively promotes this wanted to a given. Doing so+     means we lose track of the rewriter set associated with the wanted. -     The kicking out is done in kickOutAfterFillingCoercionHole, and the inerts-     are stored in the inert_blocked field of InertCans.+     On the other hand, w is perfectly suitable for rewriting, because of the+     way we carefully track rewriter sets. -     However, we must be careful: we kick out only when no coercion holes are-     left. The holes in the type are stored in the HoleBlockerReason CtIrredReason.-     The extra check that there are no more remaining holes avoids-     needless work when rewriting evidence (which fills coercion holes) and-     aids efficiency.+     We thus allow w to be a CEqCan, but we prevent unification. See+     Note [Unification preconditions] in GHC.Tc.Utils.Unify. -     Moreover, kicking out when there are remaining unfilled holes can-     cause a loop in the solver in this case:-          [W] w1 :: (ty1 :: F a) ~ (ty2 :: s)-     After canonicalisation, we discover that this equality is heterogeneous.-     So we emit-          [W] co_abc :: F a ~ s-     and preserve the original as-          [W] w2 :: (ty1 |> co_abc) ~ ty2    (blocked on co_abc)-     Then, co_abc comes becomes the work item. It gets swapped in-     canEqCanLHS2 and then back again in canEqTyVarFunEq. We thus get-     co_abc := sym co_abd, and then co_abd := sym co_abe, with-          [W] co_abe :: F a ~ s-     This process has filled in co_abc. Suppose w2 were kicked out.-     When it gets processed,-     would get this whole chain going again. The solution is to-     kick out a blocked constraint only when the result of filling-     in the blocking coercion involves no further blocking coercions.-     Alternatively, we could be careful not to do unnecessary swaps during-     canonicalisation, but that seems hard to do, in general.+     The only tricky part is that we must later indeed unify if/when the kind-level+     wanted gets solved. This is done in kickOutAfterFillingCoercionHole,+     which kicks out all equalities whose RHS mentions the filled-in coercion hole.+     Note that it looks for type family equalities, too, because of the use of+     unifyTest in canEqTyVarFunEq.   (3) Suppose we have [W] (a :: k1) ~ (rhs :: k2). We duly follow the      algorithm detailed here, producing [W] co :: k2 ~ k1, and adding@@ -2519,25 +2504,6 @@      cast appears opposite a tyvar. This is implemented in the cast case      of can_eq_nc'. - (4) Reporting an error for a constraint that is blocked with HoleBlockerReason-     is hard: what would we say to users? And we don't-     really need to report, because if a constraint is blocked, then-     there is unsolved wanted blocking it; that unsolved wanted will-     be reported. We thus push such errors to the bottom of the queue-     in the error-reporting code; they should never be printed.--     (4a) It would seem possible to do this filtering just based on the-          presence of a blocking coercion hole. However, this is no good,-          as it suppresses e.g. no-instance-found errors. We thus record-          a CtIrredReason in CIrredCan and filter based on this status.-          This happened in T14584. An alternative approach is to expressly-          look for *equalities* with blocking coercion holes, but actually-          recording the blockage in a status field seems nicer.--     (4b) The error message might be printed with -fdefer-type-errors,-          so it still must exist. This is the only reason why there is-          a message at all. Otherwise, we could simply do nothing.- Historical note:  We used to do this via emitting a Derived kind equality and then parking@@ -2597,7 +2563,7 @@ or (typecheck/should_compile/T19682b):    instance C (a -> b)-  *[WD] alpha ~ (Arg alpha -> Res alpha)+  *[W] alpha ~ (Arg alpha -> Res alpha)   [W] C alpha  or (typecheck/should_compile/T21515):@@ -2626,9 +2592,9 @@ or    instance C (a -> b)-  [WD] alpha ~ (cbv1 -> cbv2)-  [WD] Arg alpha ~ cbv1-  [WD] Res alpha ~ cbv2+  [W] alpha ~ (cbv1 -> cbv2)+  [W] Arg alpha ~ cbv1+  [W] Res alpha ~ cbv2   [W] C alpha  or@@ -2640,9 +2606,7 @@ This transformation (creating the new types and emitting new equality constraints) is done in breakTyEqCycle_maybe. -The details depend on whether we're working with a Given or a Derived.-(Note that the Wanteds are really WDs, above. This is because Wanteds-are not used for rewriting.)+The details depend on whether we're working with a Given or a Wanted.  Given -----@@ -2686,19 +2650,19 @@ * This fill-in is done when solving is complete, by restoreTyVarCycles   in nestImplicTcS and runTcSWithEvBinds. -Wanted/Derived---------------+Wanted+------ The fresh cycle-breaker variables here must actually be normal, touchable metavariables. That is, they are TauTvs. Nothing at all unusual. Repeating the example from above, we have -  *[WD] alpha ~ (Arg alpha -> Res alpha)+  *[W] alpha ~ (Arg alpha -> Res alpha)  and we turn this into -  *[WD] alpha ~ (cbv1 -> cbv2)-  [WD] Arg alpha ~ cbv1-  [WD] Res alpha ~ cbv2+  *[W] alpha ~ (cbv1 -> cbv2)+  [W] Arg alpha ~ cbv1+  [W] Res alpha ~ cbv2  where cbv1 and cbv2 are fresh TauTvs. Why TauTvs? See [Why TauTvs] below. @@ -2718,11 +2682,11 @@ Note):    instance C (a -> b)-  [WD] Arg (cbv1 -> cbv2) ~ cbv1-  [WD] Res (cbv1 -> cbv2) ~ cbv2+  [W] Arg (cbv1 -> cbv2) ~ cbv1+  [W] Res (cbv1 -> cbv2) ~ cbv2   [W] C (cbv1 -> cbv2) -The first two WD constraints reduce to reflexivity and are discarded,+The first two W constraints reduce to reflexivity and are discarded, and the last is easily soluble.  [Why TauTvs]:@@ -2740,43 +2704,43 @@     AllEqF '[]      '[]      = ()     AllEqF (x : xs) (y : ys) = (x ~ y, AllEq xs ys) -  [WD] alpha ~ (Head alpha : Tail alpha)-  [WD] AllEqF '[Bool] alpha+  [W] alpha ~ (Head alpha : Tail alpha)+  [W] AllEqF '[Bool] alpha  Without the logic detailed in this Note, we're stuck here, as AllEqF cannot reduce and alpha cannot unify. Let's instead apply our cycle-breaker approach, just as described above. We thus invent cbv1 and cbv2 and unify alpha := cbv1 -> cbv2, yielding (after zonking) -  [WD] Head (cbv1 : cbv2) ~ cbv1-  [WD] Tail (cbv1 : cbv2) ~ cbv2-  [WD] AllEqF '[Bool] (cbv1 : cbv2)+  [W] Head (cbv1 : cbv2) ~ cbv1+  [W] Tail (cbv1 : cbv2) ~ cbv2+  [W] AllEqF '[Bool] (cbv1 : cbv2) -The first two WD constraints simplify to reflexivity and are discarded.+The first two W constraints simplify to reflexivity and are discarded. But the last reduces: -  [WD] Bool ~ cbv1-  [WD] AllEq '[] cbv2+  [W] Bool ~ cbv1+  [W] AllEq '[] cbv2  The first of these is solved by unification: cbv1 := Bool. The second is solved by the instance for AllEq to become -  [WD] AllEqF '[] cbv2-  [WD] SameShapeAs '[] cbv2+  [W] AllEqF '[] cbv2+  [W] SameShapeAs '[] cbv2  While the first of these is stuck, the second makes progress, to lead to -  [WD] AllEqF '[] cbv2-  [WD] cbv2 ~ '[]+  [W] AllEqF '[] cbv2+  [W] cbv2 ~ '[]  This second constraint is solved by unification: cbv2 := '[]. We now have -  [WD] AllEqF '[] '[]+  [W] AllEqF '[] '[]  which reduces to -  [WD] ()+  [W] ()  which is trivially satisfiable. Hooray! @@ -2794,8 +2758,7 @@  - and a nominal equality  - and either     - a Given flavour (but see also Detail (7) below)-    - a Wanted/Derived or just plain Derived flavour, with a touchable metavariable-      on the left+    - a Wanted flavour, with a touchable metavariable on the left  We don't use this trick for representational equalities, as there is no concrete use case where it is helpful (unlike for nominal equalities).@@ -2858,7 +2821,8 @@   (4) The evidence for the produced Givens is all just reflexive, because      we will eventually set the cycle-breaker variable to be the type family,-     and then, after the zonk, all will be well.+     and then, after the zonk, all will be well. See also the notes at the+     end of the Given section of this Note.   (5) The approach here is inefficient because it replaces every (outermost)      type family application with a type variable, regardless of whether that@@ -2922,6 +2886,8 @@      We track these equalities by giving them a special CtOrigin,      CycleBreakerOrigin. This works for both Givens and Wanteds, as      we need the logic in the W case for e.g. typecheck/should_fail/T17139.+     Because this logic needs to work for Wanteds, too, we cannot+     simply look for a CycleBreakerTv on the left: Wanteds don't use them.   (8) We really want to do this all only when there is a soluble occurs-check      failure, not when other problems arise (such as an impredicative@@ -2967,9 +2933,10 @@            ContinueWith ct -> tcs2 ct } infixr 0 `andWhenContinue`    -- allow chaining with ($) -rewriteEvidence :: CtEvidence   -- old evidence-                -> TcPredType   -- new predicate-                -> TcCoercion   -- Of type :: new predicate ~ <type of old evidence>+rewriteEvidence :: RewriterSet  -- ^ See Note [Wanteds rewrite Wanteds]+                                -- in GHC.Tc.Types.Constraint+                -> CtEvidence   -- ^ old evidence+                -> Reduction    -- ^ new predicate + coercion, of type <type of old evidence> ~ new predicate                 -> TcS (StopOrContinue CtEvidence) -- Returns Just new_ev iff either (i)  'co' is reflexivity --                             or (ii) 'co' is not reflexivity, and 'new_pred' not cached@@ -2978,7 +2945,7 @@      rewriteEvidence old_ev new_pred co Main purpose: create new evidence for new_pred;               unless new_pred is cached already-* Returns a new_ev : new_pred, with same wanted/given/derived flag as old_ev+* Returns a new_ev : new_pred, with same wanted/given flag as old_ev * If old_ev was wanted, create a binding for old_ev, in terms of new_ev * If old_ev was given, AND not cached, create a binding for new_ev, in terms of old_ev * Returns Nothing if new_ev is already cached@@ -2987,7 +2954,7 @@         flavour                                        of same flavor         -------------------------------------------------------------------         Wanted          Already solved or in inert     Nothing-        or Derived      Not                            Just new_evidence+                        Not                            Just new_evidence          Given           Already in inert               Nothing                         Not                            Just new_evidence@@ -3002,96 +2969,95 @@  The rewriter preserves type synonyms, so they should appear in new_pred as well as in old_pred; that is important for good error messages.++If we are rewriting with Refl, then there are no new rewriters to add to+the rewriter set. We check this with an assertion.  -}  -rewriteEvidence old_ev@(CtDerived {}) new_pred _co-  = -- If derived, don't even look at the coercion.-    -- This is very important, DO NOT re-order the equations for-    -- rewriteEvidence to put the isTcReflCo test first!-    -- Why?  Because for *Derived* constraints, c, the coercion, which-    -- was produced by rewriting, may contain suspended calls to-    -- (ctEvExpr c), which fails for Derived constraints.-    -- (Getting this wrong caused #7384.)-    continueWith (old_ev { ctev_pred = new_pred })--rewriteEvidence old_ev new_pred co+rewriteEvidence rewriters old_ev (Reduction co new_pred)   | isTcReflCo co -- See Note [Rewriting with Refl]-  = continueWith (old_ev { ctev_pred = new_pred })+  = assert (isEmptyRewriterSet rewriters) $+    continueWith (setCtEvPredType old_ev new_pred) -rewriteEvidence ev@(CtGiven { ctev_evar = old_evar, ctev_loc = loc }) new_pred co-  = do { new_ev <- newGivenEvVar loc (new_pred, new_tm)+rewriteEvidence rewriters ev@(CtGiven { ctev_evar = old_evar, ctev_loc = loc })+                (Reduction co new_pred)+  = assert (isEmptyRewriterSet rewriters) $ -- this is a Given, not a wanted+    do { new_ev <- newGivenEvVar loc (new_pred, new_tm)        ; continueWith new_ev }   where     -- mkEvCast optimises ReflCo-    new_tm = mkEvCast (evId old_evar) (tcDowngradeRole Representational-                                                       (ctEvRole ev)-                                                       (mkTcSymCo co))+    new_tm = mkEvCast (evId old_evar)+                (tcDowngradeRole Representational (ctEvRole ev) co) -rewriteEvidence ev@(CtWanted { ctev_dest = dest-                             , ctev_nosh = si-                             , ctev_loc = loc }) new_pred co-  = do { mb_new_ev <- newWanted_SI si loc new_pred-               -- The "_SI" variant ensures that we make a new Wanted-               -- with the same shadow-info as the existing one-               -- with the same shadow-info as the existing one (#16735)-       ; MASSERT( tcCoercionRole co == ctEvRole ev )+rewriteEvidence new_rewriters+                ev@(CtWanted { ctev_dest = dest+                             , ctev_loc = loc+                             , ctev_rewriters = rewriters })+                (Reduction co new_pred)+  = do { mb_new_ev <- newWanted loc rewriters' new_pred+       ; massert (tcCoercionRole co == ctEvRole ev)        ; setWantedEvTerm dest             (mkEvCast (getEvExpr mb_new_ev)-                      (tcDowngradeRole Representational (ctEvRole ev) co))+                      (tcDowngradeRole Representational (ctEvRole ev) (mkSymCo co)))        ; case mb_new_ev of             Fresh  new_ev -> continueWith new_ev             Cached _      -> stopWith ev "Cached wanted" }+  where+    rewriters' = rewriters S.<> new_rewriters  -rewriteEqEvidence :: CtEvidence         -- Old evidence :: olhs ~ orhs (not swapped)+rewriteEqEvidence :: RewriterSet        -- New rewriters+                                        -- See GHC.Tc.Types.Constraint+                                        -- Note [Wanteds rewrite Wanteds]+                  -> CtEvidence         -- Old evidence :: olhs ~ orhs (not swapped)                                         --              or orhs ~ olhs (swapped)                   -> SwapFlag-                  -> TcType -> TcType   -- New predicate  nlhs ~ nrhs-                  -> TcCoercion         -- lhs_co, of type :: nlhs ~ olhs-                  -> TcCoercion         -- rhs_co, of type :: nrhs ~ orhs+                  -> Reduction          -- lhs_co :: olhs ~ nlhs+                  -> Reduction          -- rhs_co :: orhs ~ nrhs                   -> TcS CtEvidence     -- Of type nlhs ~ nrhs--- For (rewriteEqEvidence (Given g olhs orhs) False nlhs nrhs lhs_co rhs_co)--- we generate+-- With reductions (Reduction lhs_co nlhs) (Reduction rhs_co nrhs),+-- rewriteEqEvidence yields, for a given equality (Given g olhs orhs): -- If not swapped---      g1 : nlhs ~ nrhs = lhs_co ; g ; sym rhs_co--- If 'swapped'---      g1 : nlhs ~ nrhs = lhs_co ; Sym g ; sym rhs_co+--      g1 : nlhs ~ nrhs = sym lhs_co ; g ; rhs_co+-- If swapped+--      g1 : nlhs ~ nrhs = sym lhs_co ; Sym g ; rhs_co ----- For (Wanted w) we do the dual thing.+-- For a wanted equality (Wanted w), we do the dual thing: -- New  w1 : nlhs ~ nrhs -- If not swapped---      w : olhs ~ orhs = sym lhs_co ; w1 ; rhs_co+--      w : olhs ~ orhs = lhs_co ; w1 ; sym rhs_co -- If swapped---      w : orhs ~ olhs = sym rhs_co ; sym w1 ; lhs_co+--      w : orhs ~ olhs = rhs_co ; sym w1 ; sym lhs_co ----- It's all a form of rewwriteEvidence, specialised for equalities-rewriteEqEvidence old_ev swapped nlhs nrhs lhs_co rhs_co-  | CtDerived {} <- old_ev  -- Don't force the evidence for a Derived-  = return (old_ev { ctev_pred = new_pred })-+-- It's all a form of rewriteEvidence, specialised for equalities+rewriteEqEvidence new_rewriters old_ev swapped (Reduction lhs_co nlhs) (Reduction rhs_co nrhs)   | NotSwapped <- swapped   , isTcReflCo lhs_co      -- See Note [Rewriting with Refl]   , isTcReflCo rhs_co-  = return (old_ev { ctev_pred = new_pred })+  = return (setCtEvPredType old_ev new_pred)    | CtGiven { ctev_evar = old_evar } <- old_ev-  = do { let new_tm = evCoercion (lhs_co+  = do { let new_tm = evCoercion ( mkTcSymCo lhs_co                                   `mkTcTransCo` maybeTcSymCo swapped (mkTcCoVarCo old_evar)-                                  `mkTcTransCo` mkTcSymCo rhs_co)+                                  `mkTcTransCo` rhs_co)        ; newGivenEvVar loc' (new_pred, new_tm) } -  | CtWanted { ctev_dest = dest, ctev_nosh = si } <- old_ev-  = do { (new_ev, hole_co) <- newWantedEq_SI si loc'-                                             (ctEvRole old_ev) nlhs nrhs-               -- The "_SI" variant ensures that we make a new Wanted-               -- with the same shadow-info as the existing one (#16735)+  | CtWanted { ctev_dest = dest+             , ctev_rewriters = rewriters } <- old_ev+  , let rewriters' = rewriters S.<> new_rewriters+  = do { (new_ev, hole_co) <- newWantedEq loc' rewriters'+                                          (ctEvRole old_ev) nlhs nrhs        ; let co = maybeTcSymCo swapped $-                  mkSymCo lhs_co+                  lhs_co                   `mkTransCo` hole_co-                  `mkTransCo` rhs_co+                  `mkTransCo` mkTcSymCo rhs_co        ; setWantedEq dest co-       ; traceTcS "rewriteEqEvidence" (vcat [ppr old_ev, ppr nlhs, ppr nrhs, ppr co])+       ; traceTcS "rewriteEqEvidence" (vcat [ ppr old_ev+                                            , ppr nlhs+                                            , ppr nrhs+                                            , ppr co+                                            , ppr new_rewriters ])        ; return new_ev }  #if __GLASGOW_HASKELL__ <= 810@@ -3114,11 +3080,10 @@ *                                                                      * ************************************************************************ -Note [unifyWanted and unifyDerived]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [unifyWanted]+~~~~~~~~~~~~~~~~~~ When decomposing equalities we often create new wanted constraints for (s ~ t).  But what if s=t?  Then it'd be faster to return Refl right away.-Similar remarks apply for Derived.  Rather than making an equality test (which traverses the structure of the type, perhaps fruitlessly), unifyWanted traverses the common structure, and@@ -3127,32 +3092,32 @@ to reflect it. -} -unifyWanted :: CtLoc -> Role-            -> TcType -> TcType -> TcS Coercion+unifyWanted :: RewriterSet -> CtLoc+            -> Role -> TcType -> TcType -> TcS Coercion -- Return coercion witnessing the equality of the two types, -- emitting new work equalities where necessary to achieve that -- Very good short-cut when the two types are equal, or nearly so--- See Note [unifyWanted and unifyDerived]+-- See Note [unifyWanted] -- The returned coercion's role matches the input parameter-unifyWanted loc Phantom ty1 ty2-  = do { kind_co <- unifyWanted loc Nominal (tcTypeKind ty1) (tcTypeKind ty2)+unifyWanted rewriters loc Phantom ty1 ty2+  = do { kind_co <- unifyWanted rewriters loc Nominal (tcTypeKind ty1) (tcTypeKind ty2)        ; return (mkPhantomCo kind_co ty1 ty2) } -unifyWanted loc role orig_ty1 orig_ty2+unifyWanted rewriters loc role orig_ty1 orig_ty2   = go orig_ty1 orig_ty2   where     go ty1 ty2 | Just ty1' <- tcView ty1 = go ty1' ty2     go ty1 ty2 | Just ty2' <- tcView ty2 = go ty1 ty2'      go (FunTy _ w1 s1 t1) (FunTy _ w2 s2 t2)-      = do { co_s <- unifyWanted loc role s1 s2-           ; co_t <- unifyWanted loc role t1 t2-           ; co_w <- unifyWanted loc Nominal w1 w2+      = do { co_s <- unifyWanted rewriters loc role s1 s2+           ; co_t <- unifyWanted rewriters loc role t1 t2+           ; co_w <- unifyWanted rewriters loc Nominal w1 w2            ; return (mkFunCo role co_w co_s co_t) }     go (TyConApp tc1 tys1) (TyConApp tc2 tys2)       | tc1 == tc2, tys1 `equalLength` tys2       , isInjectiveTyCon tc1 role -- don't look under newtypes at Rep equality-      = do { cos <- zipWith3M (unifyWanted loc)+      = do { cos <- zipWith3M (unifyWanted rewriters loc)                               (tyConRolesX role tc1) tys1 tys2            ; return (mkTyConAppCo role tc1 cos) } @@ -3175,48 +3140,4 @@     bale_out ty1 ty2        | ty1 `tcEqType` ty2 = return (mkTcReflCo role ty1)         -- Check for equality; e.g. a ~ a, or (m a) ~ (m a)-       | otherwise = emitNewWantedEq loc role orig_ty1 orig_ty2--unifyDeriveds :: CtLoc -> [Role] -> [TcType] -> [TcType] -> TcS ()--- See Note [unifyWanted and unifyDerived]-unifyDeriveds loc roles tys1 tys2 = zipWith3M_ (unify_derived loc) roles tys1 tys2--unifyDerived :: CtLoc -> Role -> Pair TcType -> TcS ()--- See Note [unifyWanted and unifyDerived]-unifyDerived loc role (Pair ty1 ty2) = unify_derived loc role ty1 ty2--unify_derived :: CtLoc -> Role -> TcType -> TcType -> TcS ()--- Create new Derived and put it in the work list--- Should do nothing if the two types are equal--- See Note [unifyWanted and unifyDerived]-unify_derived _   Phantom _        _        = return ()-unify_derived loc role    orig_ty1 orig_ty2-  = go orig_ty1 orig_ty2-  where-    go ty1 ty2 | Just ty1' <- tcView ty1 = go ty1' ty2-    go ty1 ty2 | Just ty2' <- tcView ty2 = go ty1 ty2'--    go (FunTy _ w1 s1 t1) (FunTy _ w2 s2 t2)-      = do { unify_derived loc role s1 s2-           ; unify_derived loc role t1 t2-           ; unify_derived loc Nominal w1 w2 }-    go (TyConApp tc1 tys1) (TyConApp tc2 tys2)-      | tc1 == tc2, tys1 `equalLength` tys2-      , isInjectiveTyCon tc1 role-      = unifyDeriveds loc (tyConRolesX role tc1) tys1 tys2-    go ty1@(TyVarTy tv) ty2-      = do { mb_ty <- isFilledMetaTyVar_maybe tv-           ; case mb_ty of-                Just ty1' -> go ty1' ty2-                Nothing   -> bale_out ty1 ty2 }-    go ty1 ty2@(TyVarTy tv)-      = do { mb_ty <- isFilledMetaTyVar_maybe tv-           ; case mb_ty of-                Just ty2' -> go ty1 ty2'-                Nothing   -> bale_out ty1 ty2 }-    go ty1 ty2 = bale_out ty1 ty2--    bale_out ty1 ty2-       | ty1 `tcEqType` ty2 = return ()-        -- Check for equality; e.g. a ~ a, or (m a) ~ (m a)-       | otherwise = emitNewDerivedEq loc role orig_ty1 orig_ty2+       | otherwise = emitNewWantedEq loc rewriters role orig_ty1 orig_ty2
compiler/GHC/Tc/Solver/Interact.hs view
@@ -1,15 +1,12 @@-{-# LANGUAGE CPP #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}  module GHC.Tc.Solver.Interact (      solveSimpleGivens,   -- Solves [Ct]-     solveSimpleWanteds,  -- Solves Cts+     solveSimpleWanteds   -- Solves Cts   ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Types.Basic ( SwapFlag(..),                          infinity, IntWithInf, intGtLimit )@@ -19,6 +16,7 @@ import GHC.Core.InstEnv         ( DFunInstType )  import GHC.Types.Var+import GHC.Tc.Errors.Types import GHC.Tc.Utils.TcType import GHC.Builtin.Names ( coercibleTyConKey, heqTyConKey, eqTyConKey, ipClassKey ) import GHC.Core.Coercion.Axiom ( CoAxBranch (..), CoAxiom (..), TypeEqn, fromBranches, sfInteractInert, sfInteractTop )@@ -39,22 +37,25 @@ import GHC.Core.Predicate import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcMType( promoteMetaTyVarTo )+import GHC.Tc.Solver.Types+import GHC.Tc.Solver.InertSet import GHC.Tc.Solver.Monad import GHC.Data.Bag import GHC.Utils.Monad ( concatMapM, foldlM )  import GHC.Core-import Data.List( partition, deleteFirstsBy )+import Data.List( deleteFirstsBy )+import Data.Function ( on ) import GHC.Types.SrcLoc import GHC.Types.Var.Env +import qualified Data.Semigroup as S import Control.Monad import GHC.Data.Pair (Pair(..)) import GHC.Types.Unique( hasKey ) import GHC.Driver.Session import GHC.Utils.Misc import qualified GHC.LanguageExtensions as LangExt-import Data.List.NonEmpty ( NonEmpty(..) )  import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe@@ -118,12 +119,7 @@     go :: Int -> IntWithInf -> WantedConstraints -> TcS (Int, WantedConstraints)     go n limit wc       | n `intGtLimit` limit-      = failTcS (hang (text "solveSimpleWanteds: too many iterations"-                       <+> parens (text "limit =" <+> ppr limit))-                    2 (vcat [ text "Set limit with -fconstraint-solver-iterations=n; n=0 for no limit"-                            , text "Simples =" <+> ppr simples-                            , text "WC ="      <+> ppr wc ]))-+      = failTcS $ TcRnSimplifierTooManyIterations simples limit wc      | isEmptyBag (wc_simple wc)      = return (n,wc) @@ -144,13 +140,13 @@ -- Try solving these constraints -- Affects the unification state (of course) but not the inert set -- The result is not necessarily zonked-solve_simple_wanteds (WC { wc_simple = simples1, wc_impl = implics1, wc_holes = holes })+solve_simple_wanteds (WC { wc_simple = simples1, wc_impl = implics1, wc_errors = errs })   = nestTcS $     do { solveSimples simples1        ; (implics2, unsolved) <- getUnsolvedInerts        ; return (WC { wc_simple = unsolved                     , wc_impl   = implics1 `unionBags` implics2-                    , wc_holes  = holes }) }+                    , wc_errors = errs }) }  {- Note [The solveSimpleWanteds loop] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -187,13 +183,13 @@ -- into the main solver. runTcPluginsGiven :: TcS [Ct] runTcPluginsGiven-  = do { plugins <- getTcPlugins-       ; if null plugins then return [] else+  = do { solvers <- getTcPluginSolvers+       ; if null solvers then return [] else     do { givens <- getInertGivens        ; if null givens then return [] else-    do { p <- runTcPlugins plugins (givens,[],[])-       ; let (solved_givens, _, _) = pluginSolvedCts p-             insols                = pluginBadCts p+    do { p <- runTcPluginSolvers solvers (givens,[])+       ; let (solved_givens, _) = pluginSolvedCts p+             insols             = pluginBadCts p        ; updInertCans (removeInertCts solved_givens)        ; updInertIrreds (\irreds -> extendCtsList irreds insols)        ; return (pluginNewCts p) } } }@@ -208,26 +204,24 @@   | isEmptyBag simples1   = return (False, wc)   | otherwise-  = do { plugins <- getTcPlugins-       ; if null plugins then return (False, wc) else+  = do { solvers <- getTcPluginSolvers+       ; if null solvers then return (False, wc) else      do { given <- getInertGivens-       ; simples1 <- zonkSimples simples1    -- Plugin requires zonked inputs-       ; let (wanted, derived) = partition isWantedCt (bagToList simples1)-       ; p <- runTcPlugins plugins (given, derived, wanted)-       ; let (_, _,                solved_wanted)   = pluginSolvedCts p-             (_, unsolved_derived, unsolved_wanted) = pluginInputCts p+       ; wanted <- zonkSimples simples1    -- Plugin requires zonked inputs+       ; p <- runTcPluginSolvers solvers (given, bagToList wanted)+       ; let (_, solved_wanted)   = pluginSolvedCts p+             (_, unsolved_wanted) = pluginInputCts p              new_wanted                             = pluginNewCts p              insols                                 = pluginBadCts p  -- SLPJ: I'm deeply suspicious of this---       ; updInertCans (removeInertCts $ solved_givens ++ solved_deriveds)+--       ; updInertCans (removeInertCts $ solved_givens)         ; mapM_ setEv solved_wanted        ; return ( notNull (pluginNewCts p)                 , wc { wc_simple = listToBag new_wanted       `andCts`                                    listToBag unsolved_wanted  `andCts`-                                   listToBag unsolved_derived `andCts`                                    listToBag insols } ) } }   where     setEv :: (EvTerm,Ct) -> TcS ()@@ -235,11 +229,11 @@       CtWanted { ctev_dest = dest } -> setWantedEvTerm dest ev       _ -> panic "runTcPluginsWanted.setEv: attempt to solve non-wanted!" --- | A triple of (given, derived, wanted) constraints to pass to plugins-type SplitCts  = ([Ct], [Ct], [Ct])+-- | A pair of (given, wanted) constraints to pass to plugins+type SplitCts  = ([Ct], [Ct]) --- | A solved triple of constraints, with evidence for wanteds-type SolvedCts = ([Ct], [Ct], [(EvTerm,Ct)])+-- | A solved pair of constraints, with evidence for wanteds+type SolvedCts = ([Ct], [(EvTerm,Ct)])  -- | Represents collections of constraints generated by typechecker -- plugins@@ -255,11 +249,12 @@       -- ^ New constraints emitted by plugins     } -getTcPlugins :: TcS [TcPluginSolver]-getTcPlugins = do { tcg_env <- getGblEnv; return (tcg_tc_plugins tcg_env) }+getTcPluginSolvers :: TcS [TcPluginSolver]+getTcPluginSolvers+  = do { tcg_env <- getGblEnv; return (tcg_tc_plugin_solvers tcg_env) } --- | Starting from a triple of (given, derived, wanted) constraints,--- invoke each of the typechecker plugins in turn and return+-- | Starting from a pair of (given, wanted) constraints,+-- invoke each of the typechecker constraint-solving plugins in turn and return -- --  * the remaining unmodified constraints, --  * constraints that have been solved,@@ -271,31 +266,35 @@ -- re-invoked and they will see it later).  There is no check that new -- work differs from the original constraints supplied to the plugin: -- the plugin itself should perform this check if necessary.-runTcPlugins :: [TcPluginSolver] -> SplitCts -> TcS TcPluginProgress-runTcPlugins plugins all_cts-  = foldM do_plugin initialProgress plugins+runTcPluginSolvers :: [TcPluginSolver] -> SplitCts -> TcS TcPluginProgress+runTcPluginSolvers solvers all_cts+  = do { ev_binds_var <- getTcEvBindsVar+       ; foldM (do_plugin ev_binds_var) initialProgress solvers }   where-    do_plugin :: TcPluginProgress -> TcPluginSolver -> TcS TcPluginProgress-    do_plugin p solver = do-        result <- runTcPluginTcS (uncurry3 solver (pluginInputCts p))+    do_plugin :: EvBindsVar -> TcPluginProgress -> TcPluginSolver -> TcS TcPluginProgress+    do_plugin ev_binds_var p solver = do+        result <- runTcPluginTcS (uncurry (solver ev_binds_var) (pluginInputCts p))         return $ progress p result -    progress :: TcPluginProgress -> TcPluginResult -> TcPluginProgress-    progress p (TcPluginContradiction bad_cts) =-       p { pluginInputCts = discard bad_cts (pluginInputCts p)-         , pluginBadCts   = bad_cts ++ pluginBadCts p-         }-    progress p (TcPluginOk solved_cts new_cts) =-      p { pluginInputCts  = discard (map snd solved_cts) (pluginInputCts p)-        , pluginSolvedCts = add solved_cts (pluginSolvedCts p)-        , pluginNewCts    = new_cts ++ pluginNewCts p+    progress :: TcPluginProgress -> TcPluginSolveResult -> TcPluginProgress+    progress p+      (TcPluginSolveResult+        { tcPluginInsolubleCts = bad_cts+        , tcPluginSolvedCts    = solved_cts+        , tcPluginNewCts       = new_cts         }+      ) =+        p { pluginInputCts  = discard (bad_cts ++ map snd solved_cts) (pluginInputCts p)+          , pluginSolvedCts = add solved_cts (pluginSolvedCts p)+          , pluginNewCts    = new_cts ++ pluginNewCts p+          , pluginBadCts    = bad_cts ++ pluginBadCts p+          } -    initialProgress = TcPluginProgress all_cts ([], [], []) [] []+    initialProgress = TcPluginProgress all_cts ([], []) [] []      discard :: [Ct] -> SplitCts -> SplitCts-    discard cts (xs, ys, zs) =-        (xs `without` cts, ys `without` cts, zs `without` cts)+    discard cts (xs, ys) =+        (xs `without` cts, ys `without` cts)      without :: [Ct] -> [Ct] -> [Ct]     without = deleteFirstsBy eqCt@@ -308,10 +307,9 @@     add xs scs = foldl' addOne scs xs      addOne :: SolvedCts -> (EvTerm,Ct) -> SolvedCts-    addOne (givens, deriveds, wanteds) (ev,ct) = case ctEvidence ct of-      CtGiven  {} -> (ct:givens, deriveds, wanteds)-      CtDerived{} -> (givens, ct:deriveds, wanteds)-      CtWanted {} -> (givens, deriveds, (ev,ct):wanteds)+    addOne (givens, wanteds) (ev,ct) = case ctEvidence ct of+      CtGiven  {} -> (ct:givens, wanteds)+      CtWanted {} -> (givens, (ev,ct):wanteds)   type WorkItem = Ct@@ -414,7 +412,7 @@    then the inert item must Given or, equivalently,    If the work-item is Given,-   and the inert item is Wanted/Derived+   and the inert item is Wanted    then there is no reaction -} @@ -429,9 +427,9 @@   = do { inerts <- getTcSInerts        ; let ics = inert_cans inerts        ; case wi of-             CEqCan    {} -> interactEq    ics wi-             CIrredCan {} -> interactIrred ics wi-             CDictCan  {} -> interactDict  ics wi+             CEqCan       {} -> interactEq      ics wi+             CIrredCan    {} -> interactIrred   ics wi+             CDictCan     {} -> interactDict    ics wi              _ -> pprPanic "interactWithInerts" (ppr wi) }                 -- CNonCanonical have been canonicalised @@ -440,30 +438,10 @@                  -- (if the latter is Wanted; just discard it if not)    | KeepWork    -- Keep the work item, and solve the inert item from it -   | KeepBoth    -- See Note [KeepBoth]- instance Outputable InteractResult where-  ppr KeepBoth  = text "keep both"   ppr KeepInert = text "keep inert"   ppr KeepWork  = text "keep work-item" -{- Note [KeepBoth]-~~~~~~~~~~~~~~~~~~-Consider-   Inert:     [WD] C ty1 ty2-   Work item: [D]  C ty1 ty2--Here we can simply drop the work item. But what about-   Inert:     [W] C ty1 ty2-   Work item: [D] C ty1 ty2--Here we /cannot/ drop the work item, becuase we lose the [D] form, and-that is essential for e.g. fundeps, see isImprovable.  We could zap-the inert item to [WD], but the simplest thing to do is simply to keep-both. (They probably started as [WD] and got split; this is relatively-rare and it doesn't seem worth trying to put them back together again.)--}- solveOneFromTheOther :: CtEvidence  -- Inert    (Dict or Irred)                      -> CtEvidence  -- WorkItem (same predicate as inert)                      -> TcS InteractResult@@ -476,38 +454,23 @@ -- two wanteds into one by solving one from the other  solveOneFromTheOther ev_i ev_w-  | CtDerived {} <- ev_w         -- Work item is Derived-  = case ev_i of-      CtWanted { ctev_nosh = WOnly } -> return KeepBoth-      _                              -> return KeepInert--  | CtDerived {} <- ev_i         -- Inert item is Derived-  = case ev_w of-      CtWanted { ctev_nosh = WOnly } -> return KeepBoth-      _                              -> return KeepWork-              -- The ev_w is inert wrt earlier inert-set items,-              -- so it's safe to continue on from this point--  -- After this, neither ev_i or ev_w are Derived   | CtWanted { ctev_loc = loc_w } <- ev_w   , prohibitedSuperClassSolve loc_i loc_w   = -- inert must be Given     do { traceTcS "prohibitedClassSolve1" (ppr ev_i $$ ppr ev_w)        ; return KeepWork } -  | CtWanted { ctev_nosh = nosh_w } <- ev_w+  | CtWanted {} <- ev_w        -- Inert is Given or Wanted-  = case ev_i of-      CtWanted { ctev_nosh = WOnly }-          | WDeriv <- nosh_w           -> return KeepWork-      _                                -> return KeepInert-      -- Consider work  item [WD] C ty1 ty2-      --          inert item [W]  C ty1 ty2-      -- Then we must keep the work item.  But if the-      -- work item was       [W]  C ty1 ty2-      -- then we are free to discard the work item in favour of inert-      -- Remember, no Deriveds at this point+  = return $ case ev_i of+               CtWanted {} -> choose_better_loc+                 -- both are Wanted; choice of which to keep is+                 -- arbitrary. So we look at the context to choose+                 -- which would make a better error message +               _           -> KeepInert+                 -- work is Wanted; inert is Given: easy choice.+   -- From here on the work-item is Given    | CtWanted { ctev_loc = loc_i } <- ev_i@@ -535,6 +498,27 @@      lvl_i = ctLocLevel loc_i      lvl_w = ctLocLevel loc_w +     choose_better_loc+       -- if only one is a WantedSuperclassOrigin (arising from expanding+       -- a Wanted class constraint), keep the other: wanted superclasses+       -- may be unexpected by users+       | is_wanted_superclass_loc loc_i+       , not (is_wanted_superclass_loc loc_w) = KeepWork++       | not (is_wanted_superclass_loc loc_i)+       , is_wanted_superclass_loc loc_w = KeepInert++        -- otherwise, just choose the lower span+        -- reason: if we have something like (abs 1) (where the+        -- Num constraint cannot be satisfied), it's better to+        -- get an error about abs than about 1.+        -- This test might become more elaborate if we see an+        -- opportunity to improve the error messages+       | ((<) `on` ctLocSpan) loc_i loc_w = KeepInert+       | otherwise                        = KeepWork++     is_wanted_superclass_loc = isWantedSuperclassOrigin . ctLocOrigin+      different_level_strategy  -- Both Given        | isIPLikePred pred = if lvl_w > lvl_i then KeepWork  else KeepInert        | otherwise         = if lvl_w > lvl_i then KeepInert else KeepWork@@ -665,8 +649,6 @@                -- For insolubles, don't allow the constraint to be dropped                -- which can happen with solveOneFromTheOther, so that                -- we get distinct error messages with -fdefer-type-errors-               -- See Note [Do not add duplicate derived insolubles]-  , not (isDroppableCt workItem)   = continueWith workItem    | let (matching_irreds, others) = findMatchingIrreds (inert_irreds inerts) ev_w@@ -676,7 +658,6 @@   = do { what_next <- solveOneFromTheOther ev_i ev_w        ; traceTcS "iteractIrred" (ppr workItem $$ ppr what_next $$ ppr ct_i)        ; case what_next of-            KeepBoth  -> continueWith workItem             KeepInert -> do { setEvBindIfWanted ev_w (swap_me swap ev_i)                             ; return (Stop ev_w (text "Irred equal" <+> parens (ppr what_next))) }             KeepWork ->  do { setEvBindIfWanted ev_i (swap_me swap ev_w)@@ -735,56 +716,6 @@ lookup, findMatchingIrreds spots the equality case, and matches either way around. It has to return a swap-flag so we can generate evidence that is the right way round too.--Note [Do not add duplicate derived insolubles]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In general we *must* add an insoluble (Int ~ Bool) even if there is-one such there already, because they may come from distinct call-sites.  Not only do we want an error message for each, but with--fdefer-type-errors we must generate evidence for each.  But for-*derived* insolubles, we only want to report each one once.  Why?--(a) A constraint (C r s t) where r -> s, say, may generate the same fundep-    equality many times, as the original constraint is successively rewritten.--(b) Ditto the successive iterations of the main solver itself, as it traverses-    the constraint tree. See example below.--Also for *given* insolubles we may get repeated errors, as we-repeatedly traverse the constraint tree.  These are relatively rare-anyway, so removing duplicates seems ok.  (Alternatively we could take-the SrcLoc into account.)--Note that the test does not need to be particularly efficient because-it is only used if the program has a type error anyway.--Example of (b): assume a top-level class and instance declaration:--  class D a b | a -> b-  instance D [a] [a]--Assume we have started with an implication:--  forall c. Eq c => { wc_simple = [W] D [c] c }--which we have simplified to, with a Derived constraing coming from-D's functional dependency:--  forall c. Eq c => { wc_simple = [W] D [c] c [W]-                                  [D] (c ~ [c]) }--When iterating the solver, we might try to re-solve this-implication. If we do not do a dropDerivedWC, then we will end up-trying to solve the following constraints the second time:--  [W] (D [c] c)-  [D] (c ~ [c])--which will result in two Deriveds to end up in the insoluble set:--  wc_simple = [W] D [c] c-              [D] (c ~ [c])-              [D] (c ~ [c]) -}  {-@@ -999,6 +930,68 @@   and to solve G2 we may need H. If we don't spot this sharing we may   solve H twice; and if this pattern repeats we may get exponentially bad   behaviour.++Note [No Given/Given fundeps]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We do not create constraints from:+* Given/Given interactions via functional dependencies or type family+  injectivity annotations.+* Given/instance fundep interactions via functional dependencies or+  type family injectivity annotations.++In this Note, all these interactions are called just "fundeps".++We ingore such fundeps for several reasons:++1. These fundeps will never serve a purpose in accepting more+   programs: Given constraints do not contain metavariables that could+   be unified via exploring fundeps. They *could* be useful in+   discovering inaccessible code. However, the constraints will be+   Wanteds, and as such will cause errors (not just warnings) if they+   go unsolved. Maybe there is a clever way to get the right+   inaccessible code warnings, but the path forward is far from+   clear. #12466 has further commentary.++2. Furthermore, here is a case where a Given/instance interaction is actively+   harmful (from dependent/should_compile/RaeJobTalk):++       type family a == b :: Bool+       type family Not a = r | r -> a where+         Not False = True+         Not True  = False++       [G] Not (a == b) ~ True++   Reacting this Given with the equations for Not produces++      [W] a == b ~ False++   This is indeed a true consequence, and would make sense as a fresh Given.+   But we don't have a way to produce evidence for fundeps, as a Wanted it+   is /harmful/: we can't prove it, and so we'll report an error and reject+   the program. (Previously fundeps gave rise to Deriveds, which+   carried no evidence, so it didn't matter that they could not be proved.)++3. #20922 showed a subtle different problem with Given/instance fundeps.+      type family ZipCons (as :: [k]) (bssx :: [[k]]) = (r :: [[k]]) | r -> as bssx where+        ZipCons (a ': as) (bs ': bss) = (a ': bs) ': ZipCons as bss+        ...++      tclevel = 4+      [G] ZipCons is1 iss ~ (i : is2) : jss++   (The tclevel=4 means that this Given is at level 4.)  The fundep tells us that+   'iss' must be of form (is2 : beta[4]) where beta[4] is a fresh unification+   variable; we don't know what type it stands for. So we would emit+      [W] iss ~ is2 : beta++   Again we can't prove that equality; and worse we'll rewrite iss to+   (is2:beta) in deeply nested contraints inside this implication,+   where beta is untouchable (under other equality constraints), leading+   to other insoluble constraints.++The bottom line: since we have no evidence for them, we should ignore Given/Given+and Given/instance fundeps entirely. -}  interactDict :: InertCans -> Ct -> TcS (StopOrContinue Ct)@@ -1019,7 +1012,6 @@          what_next <- solveOneFromTheOther ev_i ev_w        ; traceTcS "lookupInertDict" (ppr what_next)        ; case what_next of-           KeepBoth  -> continueWith workItem            KeepInert -> do { setEvBindIfWanted ev_w (ctEvTerm ev_i)                            ; return $ Stop ev_w (text "Dict equal" <+> parens (ppr what_next)) }            KeepWork  -> do { setEvBindIfWanted ev_i (ctEvTerm ev_w)@@ -1062,7 +1054,7 @@  -- Enabled by the -fsolve-constant-dicts flag    = do { ev_binds_var <- getTcEvBindsVar-       ; ev_binds <- ASSERT2( not (isCoEvBindsVar ev_binds_var ), ppr ev_w )+       ; ev_binds <- assertPpr (not (isCoEvBindsVar ev_binds_var )) (ppr ev_w) $                      getTcEvBindsMap ev_binds_var        ; solved_dicts <- getSolvedDicts @@ -1108,7 +1100,7 @@                        ; lift $ checkReductionDepth loc' pred  -                       ; evc_vs <- mapM (new_wanted_cached loc' solved_dicts') preds+                       ; evc_vs <- mapM (new_wanted_cached ev loc' solved_dicts') preds                                   -- Emit work for subgoals but use our local cache                                   -- so we can solve recursive dictionaries. @@ -1127,50 +1119,45 @@     -- Use a local cache of solved dicts while emitting EvVars for new work     -- We bail out of the entire computation if we need to emit an EvVar for     -- a subgoal that isn't a ClassPred.-    new_wanted_cached :: CtLoc -> DictMap CtEvidence -> TcPredType -> MaybeT TcS MaybeNew-    new_wanted_cached loc cache pty+    new_wanted_cached :: CtEvidence -> CtLoc+                      -> DictMap CtEvidence -> TcPredType -> MaybeT TcS MaybeNew+    new_wanted_cached ev_w loc cache pty       | ClassPred cls tys <- classifyPredType pty       = lift $ case findDict cache loc_w cls tys of           Just ctev -> return $ Cached (ctEvExpr ctev)-          Nothing   -> Fresh <$> newWantedNC loc pty+          Nothing   -> Fresh <$> newWantedNC loc (ctEvRewriters ev_w) pty       | otherwise = mzero  addFunDepWork :: InertCans -> CtEvidence -> Class -> TcS ()--- Add derived constraints from type-class functional dependencies.+-- Add wanted constraints from type-class functional dependencies. addFunDepWork inerts work_ev cls-  | isImprovable work_ev   = mapBagM_ add_fds (findDictsByClass (inert_dicts inerts) cls)                -- No need to check flavour; fundeps work between                -- any pair of constraints, regardless of flavour                -- Importantly we don't throw workitem back in the                -- worklist because this can cause loops (see #5236)-  | otherwise-  = return ()   where     work_pred = ctEvPred work_ev     work_loc  = ctEvLoc work_ev      add_fds inert_ct-      | isImprovable inert_ev       = do { traceTcS "addFunDepWork" (vcat                 [ ppr work_ev                 , pprCtLoc work_loc, ppr (isGivenLoc work_loc)                 , pprCtLoc inert_loc, ppr (isGivenLoc inert_loc)-                , pprCtLoc derived_loc, ppr (isGivenLoc derived_loc) ]) ;+                , pprCtLoc derived_loc, ppr (isGivenLoc derived_loc) ]) -        emitFunDepDeriveds $-        improveFromAnother derived_loc inert_pred work_pred+           ; unless (isGiven work_ev && isGiven inert_ev) $+             emitFunDepWanteds (ctEvRewriters work_ev) $+             improveFromAnother (derived_loc, inert_rewriters) inert_pred work_pred                -- We don't really rewrite tys2, see below _rewritten_tys2, so that's ok-               -- NB: We do create FDs for given to report insoluble equations that arise-               -- from pairs of Givens, and also because of floating when we approximate-               -- implications. The relevant test is: typecheck/should_fail/FDsFromGivens.hs+               -- Do not create FDs from Given/Given interactions: See Note [No Given/Given fundeps]         }-      | otherwise-      = return ()       where         inert_ev   = ctEvidence inert_ct         inert_pred = ctEvPred inert_ev         inert_loc  = ctEvLoc inert_ev+        inert_rewriters = ctRewriters inert_ct         derived_loc = work_loc { ctl_depth  = ctl_depth work_loc `maxSubGoalDepth`                                               ctl_depth inert_loc                                , ctl_origin = FunDepOrigin1 work_pred@@ -1280,24 +1267,22 @@  improveLocalFunEqs :: CtEvidence -> InertCans -> TyCon -> [TcType] -> TcType                    -> TcS ()--- Generate derived improvement equalities, by comparing+-- Generate improvement equalities, by comparing -- the current work item with inert CFunEqs--- E.g.   x + y ~ z,   x + y' ~ z   =>   [D] y ~ y'+-- E.g.   x + y ~ z,   x + y' ~ z   =>   [W] y ~ y' -- -- See Note [FunDep and implicit parameter reactions]--- Precondition: isImprovable work_ev improveLocalFunEqs work_ev inerts fam_tc args rhs-  = ASSERT( isImprovable work_ev )-    unless (null improvement_eqns) $+  = unless (null improvement_eqns) $     do { traceTcS "interactFunEq improvements: " $                    vcat [ text "Eqns:" <+> ppr improvement_eqns                         , text "Candidates:" <+> ppr funeqs_for_tc                         , text "Inert eqs:" <+> ppr (inert_eqs inerts) ]-       ; emitFunDepDeriveds improvement_eqns }+       ; emitFunDepWanteds (ctEvRewriters work_ev) improvement_eqns }   where     funeqs        = inert_funeqs inerts-    funeqs_for_tc = [ funeq_ct | EqualCtList (funeq_ct :| _)-                                   <- findFunEqsByTyCon funeqs fam_tc+    funeqs_for_tc = [ funeq_ct | equal_ct_list <- findFunEqsByTyCon funeqs fam_tc+                               , funeq_ct <- equal_ct_list                                , NomEq == ctEqRel funeq_ct ]                                   -- representational equalities don't interact                                   -- with type family dependencies@@ -1306,7 +1291,7 @@     fam_inj_info  = tyConInjectivityInfo fam_tc      ---------------------    improvement_eqns :: [FunDepEqn CtLoc]+    improvement_eqns :: [FunDepEqn (CtLoc, RewriterSet)]     improvement_eqns       | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc       =    -- Try built-in families, notably for arithmethic@@ -1321,15 +1306,19 @@      --------------------     do_one_built_in ops rhs (CEqCan { cc_lhs = TyFamLHS _ iargs, cc_rhs = irhs, cc_ev = inert_ev })+      | not (isGiven inert_ev && isGiven work_ev)  -- See Note [No Given/Given fundeps]       = mk_fd_eqns inert_ev (sfInteractInert ops args rhs iargs irhs) +      | otherwise+      = []+     do_one_built_in _ _ _ = pprPanic "interactFunEq 1" (ppr fam_tc)      --------------------     -- See Note [Type inference for type families with injectivity]     do_one_injective inj_args rhs (CEqCan { cc_lhs = TyFamLHS _ inert_args                                           , cc_rhs = irhs, cc_ev = inert_ev })-      | isImprovable inert_ev+      | not (isGiven inert_ev && isGiven work_ev) -- See Note [No Given/Given fundeps]       , rhs `tcEqType` irhs       = mk_fd_eqns inert_ev $ [ Pair arg iarg                               | (arg, iarg, True) <- zip3 args inert_args inj_args ]@@ -1339,17 +1328,25 @@     do_one_injective _ _ _ = pprPanic "interactFunEq 2" (ppr fam_tc)      ---------------------    mk_fd_eqns :: CtEvidence -> [TypeEqn] -> [FunDepEqn CtLoc]+    mk_fd_eqns :: CtEvidence -> [TypeEqn] -> [FunDepEqn (CtLoc, RewriterSet)]     mk_fd_eqns inert_ev eqns       | null eqns  = []       | otherwise  = [ FDEqn { fd_qtvs = [], fd_eqs = eqns                              , fd_pred1 = work_pred-                             , fd_pred2 = ctEvPred inert_ev-                             , fd_loc   = loc } ]+                             , fd_pred2 = inert_pred+                             , fd_loc   = (loc, inert_rewriters) } ]       where-        inert_loc = ctEvLoc inert_ev-        loc = inert_loc { ctl_depth = ctl_depth inert_loc `maxSubGoalDepth`-                                      ctl_depth work_loc }+        initial_loc  -- start with the location of the Wanted involved+          | isGiven work_ev = inert_loc+          | otherwise       = work_loc+        eqn_orig        = InjTFOrigin1 work_pred (ctLocOrigin work_loc) (ctLocSpan work_loc)+                                       inert_pred (ctLocOrigin inert_loc) (ctLocSpan inert_loc)+        eqn_loc         = setCtLocOrigin initial_loc eqn_orig+        inert_pred      = ctEvPred inert_ev+        inert_loc       = ctEvLoc inert_ev+        inert_rewriters = ctEvRewriters inert_ev+        loc = eqn_loc { ctl_depth = ctl_depth inert_loc `maxSubGoalDepth`+                                    ctl_depth work_loc }  {- Note [Type inference for type families with injectivity] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1357,9 +1354,9 @@     type family F a b = r | r -> b  Then if we have an equality like F s1 t1 ~ F s2 t2,-we can use the injectivity to get a new Derived constraint on+we can use the injectivity to get a new Wanted constraint on the injective argument-  [D] t1 ~ t2+  [W] t1 ~ t2  That in turn can help GHC solve constraints that would otherwise require guessing.  For example, consider the ambiguity check for@@ -1379,15 +1376,15 @@ additional apartness check for the selected equation to check that the selected is guaranteed to fire for given LHS arguments. -These new constraints are simply *Derived* constraints; they have no evidence.+These new constraints are Wanted constraints, but we will not use the evidence. We could go further and offer evidence from decomposing injective type-function applications, but that would require new evidence forms, and an extension to FC, so we don't do that right now (Dec 14). -We generate these Deriveds in three places, depending on how we notice the+We generate these Wanteds in three places, depending on how we notice the injectivity. -1. When we have a [W/D] F tys1 ~ F tys2. This is handled in canEqCanLHS2, and+1. When we have a [W] F tys1 ~ F tys2. This is handled in canEqCanLHS2, and described in Note [Decomposing equality] in GHC.Tc.Solver.Canonical.  2. When we have [W] F tys1 ~ T and [W] F tys2 ~ T. Note that neither of these@@ -1454,10 +1451,7 @@ * We can only do g2 := g1 if g1 can discharge g2; that depends on   (a) the role and (b) the flavour.  E.g. a representational equality   cannot discharge a nominal one; a Wanted cannot discharge a Given.-  The predicate is eqCanDischargeFR.--* If the inert is [W] and the work-item is [WD] we don't want to-  forget the [D] part; hence the Bool result of inertsCanDischarge.+  The predicate is eqCanRewriteFR.  * Visibility. Suppose  S :: forall k. k -> Type, and consider unifying       S @Type (a::Type)  ~   S @(Type->Type) (b::Type->Type)@@ -1478,9 +1472,7 @@  inertsCanDischarge :: InertCans -> Ct                    -> Maybe ( CtEvidence  -- The evidence for the inert-                            , SwapFlag    -- Whether we need mkSymCo-                            , Bool)       -- True <=> keep a [D] version-                                          --          of the [WD] constraint+                            , SwapFlag )  -- Whether we need mkSymCo inertsCanDischarge inerts (CEqCan { cc_lhs = lhs_w, cc_rhs = rhs_w                                   , cc_ev = ev_w, cc_eq_rel = eq_rel })   | (ev_i : _) <- [ ev_i | CEqCan { cc_ev = ev_i, cc_rhs = rhs_i@@ -1490,7 +1482,7 @@                          , inert_beats_wanted ev_i eq_rel ]   =  -- Inert:     a ~ ty      -- Work item: a ~ ty-    Just (ev_i, NotSwapped, keep_deriv ev_i)+    Just (ev_i, NotSwapped)    | Just rhs_lhs <- canEqLHS_maybe rhs_w   , (ev_i : _) <- [ ev_i | CEqCan { cc_ev = ev_i, cc_rhs = rhs_i@@ -1500,7 +1492,7 @@                          , inert_beats_wanted ev_i eq_rel ]   =  -- Inert:     a ~ b      -- Work item: b ~ a-     Just (ev_i, IsSwapped, keep_deriv ev_i)+     Just (ev_i, IsSwapped)    where     loc_w  = ctEvLoc ev_w@@ -1508,22 +1500,14 @@     fr_w   = (flav_w, eq_rel)      inert_beats_wanted ev_i eq_rel-      = -- eqCanDischargeFR:    see second bullet of Note [Combining equalities]+      = -- eqCanRewriteFR:        see second bullet of Note [Combining equalities]         -- strictly_more_visible: see last bullet of Note [Combining equalities]-        fr_i`eqCanDischargeFR` fr_w+        fr_i `eqCanRewriteFR` fr_w         && not ((loc_w `strictly_more_visible` ctEvLoc ev_i)-                 && (fr_w `eqCanDischargeFR` fr_i))+                 && (fr_w `eqCanRewriteFR` fr_i))       where         fr_i = (ctEvFlavour ev_i, eq_rel) -    -- See Note [Combining equalities], third bullet-    keep_deriv ev_i-      | Wanted WOnly  <- ctEvFlavour ev_i  -- inert is [W]-      , Wanted WDeriv <- flav_w            -- work item is [WD]-      = True   -- Keep a derived version of the work item-      | otherwise-      = False  -- Work item is fully discharged-     -- See Note [Combining equalities], final bullet     strictly_more_visible loc1 loc2        = not (isVisibleOrigin (ctLocOrigin loc2)) &&@@ -1537,20 +1521,13 @@                                    , cc_rhs = rhs                                    , cc_ev = ev                                    , cc_eq_rel = eq_rel })-  | Just (ev_i, swapped, keep_deriv) <- inertsCanDischarge inerts workItem+  | Just (ev_i, swapped) <- inertsCanDischarge inerts workItem   = do { setEvBindIfWanted ev $          evCoercion (maybeTcSymCo swapped $                      tcDowngradeRole (eqRelRole eq_rel)                                      (ctEvRole ev_i)                                      (ctEvCoercion ev_i)) -       ; let deriv_ev = CtDerived { ctev_pred = ctEvPred ev-                                  , ctev_loc  = ctEvLoc  ev }-       ; when keep_deriv $-         emitWork [workItem { cc_ev = deriv_ev }]-         -- As a Derived it might not be fully rewritten,-         -- so we emit it as new work-        ; stopWith ev "Solved from inert" }    | ReprEq <- eq_rel   -- See Note [Do not unify representational equalities]@@ -1561,15 +1538,13 @@   = case lhs of        TyVarLHS tv -> tryToSolveByUnification workItem ev tv rhs -       TyFamLHS tc args -> do { when (isImprovable ev) $-                                 -- Try improvement, if possible-                                improveLocalFunEqs ev inerts tc args rhs+       TyFamLHS tc args -> do { improveLocalFunEqs ev inerts tc args rhs                               ; continueWith workItem }  interactEq _ wi = pprPanic "interactEq" (ppr wi)  ------------------------- We have a meta-tyvar on the left, and metaTyVarUpateOK has said "yes"+-- We have a meta-tyvar on the left, and metaTyVarUpdateOK has said "yes" -- So try to solve by unifying. -- Three reasons why not: --    Skolem escape@@ -1596,7 +1571,7 @@ solveByUnification :: CtEvidence -> TcTyVar -> Xi -> TcS (StopOrContinue Ct) -- Solve with the identity coercion -- Precondition: kind(xi) equals kind(tv)--- Precondition: CtEvidence is Wanted or Derived+-- Precondition: CtEvidence is Wanted -- Precondition: CtEvidence is nominal -- Returns: workItem where --        workItem = the new Given constraint@@ -1631,8 +1606,8 @@ At the end we spontaneously solve that guy, *reunifying*  [alpha := Int]  We avoid this problem by orienting the resulting given so that the unification-variable is on the left.  [Note that alternatively we could attempt to-enforce this at canonicalization]+variable is on the left (note that alternatively we could attempt to+enforce this at canonicalization).  See also Note [No touchables as FunEq RHS] in GHC.Tc.Solver.Monad; avoiding double unifications is the main reason we disallow touchable@@ -1709,7 +1684,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Currently, our story of interacting two dictionaries (or a dictionary and top-level instances) for functional dependencies, and implicit-parameters, is that we simply produce new Derived equalities.  So for example+parameters, is that we simply produce new Wanted equalities.  So for example          class D a b | a -> b where ...     Inert:@@ -1718,7 +1693,7 @@         d2 :w D Int alpha      We generate the extra work item-        cv :d alpha ~ Bool+        cv :w alpha ~ Bool     where 'cv' is currently unused.  However, this new item can perhaps be     spontaneously solved to become given and react with d2,     discharging it in favour of a new constraint d2' thus:@@ -1727,10 +1702,9 @@     Now d2' can be discharged from d1  We could be more aggressive and try to *immediately* solve the dictionary-using those extra equalities, but that requires those equalities to carry-evidence and derived do not carry evidence.+using those extra equalities. -If that were the case with the same inert set and work item we might dischard+If that were the case with the same inert set and work item we might discard d2 directly:          cv :w alpha ~ Bool@@ -1752,6 +1726,68 @@ It's exactly the same with implicit parameters, except that the "aggressive" approach would be much easier to implement. +Note [Fundeps with instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+doTopFundepImprovement compares the constraint with all the instance+declarations, to see if we can produce any equalities. E.g+   class C2 a b | a -> b+   instance C Int Bool+Then the constraint (C Int ty) generates the equality [W] ty ~ Bool.++There is a nasty corner in #19415 which led to the typechecker looping:+   class C s t b | s -> t+   instance ... => C (T kx x) (T ky y) Int+   T :: forall k. k -> Type++   work_item: dwrk :: C (T @ka (a::ka)) (T @kb0 (b0::kb0)) Char+      where kb0, b0 are unification vars+   ==> {fundeps against instance; k0, y0 fresh unification vars}+       [W] T kb0 (b0::kb0) ~ T k0 (y0::k0)+       Add dwrk to inert set+   ==> {solve that equality kb0 := k0, b0 := y0+   Now kick out dwrk, since it mentions kb0+   But now we are back to the start!  Loop!++NB1: this example relies on an instance that does not satisfy+the coverage condition (although it may satisfy the weak coverage+condition), which is known to lead to termination trouble++NB2: if the unification was the other way round, k0:=kb0, all would be+well.  It's a very delicate problem.++The ticket #19415 discusses various solutions, but the one we adopted+is very simple:++* There is a flag in CDictCan (cc_fundeps :: Bool)++* cc_fundeps = True means+    a) The class has fundeps+    b) We have not had a successful hit against instances yet++* In doTopFundepImprovement, if we emit some constraints we flip the flag+  to False, so that we won't try again with the same CDictCan.  In our+  example, dwrk will have its flag set to False.++* Not that if we have no "hits" we must /not/ flip the flag. We might have+      dwrk :: C alpha beta Char+  which does not yet trigger fundeps from the instance, but later we+  get alpha := T ka a.  We could be cleverer, and spot that the constraint+  is such that we will /never/ get any hits (no unifiers) but we don't do+  that yet.++Easy!  What could go wrong?+* Maybe the class has multiple fundeps, and we get hit with one but not+  the other.  Per-fundep flags?+* Maybe we get a hit against one instance with one fundep but, after+  the work-item is instantiated a bit more, we get a second hit+  against a second instance.  (This is a pretty strange and+  undesirable thing anyway, and can only happen with overlapping+  instances; one example is in Note [Weird fundeps].)++But both of these seem extremely exotic, and ignoring them threatens+completeness (fixable with some type signature), but not termination+(not fixable).  So for now we are just doing the simplest thing.+ Note [Weird fundeps] ~~~~~~~~~~~~~~~~~~~~ Consider   class Het a b | a -> b where@@ -1765,8 +1801,8 @@ although it's pretty strange.  So they are both accepted. Now try   [W] GHet (K Int) (K Bool) This triggers fundeps from both instance decls;-      [D] K Bool ~ K [a]-      [D] K Bool ~ K beta+      [W] K Bool ~ K [a]+      [W] K Bool ~ K beta And there's a risk of complaining about Bool ~ [a].  But in fact the Wanted matches the second instance, so we never get as far as the fundeps.@@ -1774,23 +1810,64 @@ #7875 is a case in point. -} -emitFunDepDeriveds :: [FunDepEqn CtLoc] -> TcS ()+doTopFundepImprovement :: Ct -> TcS (StopOrContinue Ct)+-- Try to functional-dependency improvement betweeen the constraint+-- and the top-level instance declarations+-- See Note [Fundeps with instances]+-- See also Note [Weird fundeps]+doTopFundepImprovement work_item@(CDictCan { cc_ev = ev, cc_class = cls+                                           , cc_tyargs = xis+                                           , cc_fundeps = has_fds })+  | has_fds+  = do { traceTcS "try_fundeps" (ppr work_item)+       ; instEnvs <- getInstEnvs+       ; let fundep_eqns = improveFromInstEnv instEnvs mk_ct_loc cls xis+       ; case fundep_eqns of+           [] -> continueWith work_item  -- No improvement+           _  -> do { emitFunDepWanteds (ctEvRewriters ev) fundep_eqns+                    ; continueWith (work_item { cc_fundeps = False }) } }+  | otherwise+  = continueWith work_item++  where+     dict_pred   = mkClassPred cls xis+     dict_loc    = ctEvLoc ev+     dict_origin = ctLocOrigin dict_loc++     mk_ct_loc :: PredType   -- From instance decl+               -> SrcSpan    -- also from instance deol+               -> (CtLoc, RewriterSet)+     mk_ct_loc inst_pred inst_loc+       = ( dict_loc { ctl_origin = FunDepOrigin2 dict_pred dict_origin+                                                 inst_pred inst_loc }+         , emptyRewriterSet )++doTopFundepImprovement work_item = pprPanic "doTopFundepImprovement" (ppr work_item)++emitFunDepWanteds :: RewriterSet  -- from the work item+                   -> [FunDepEqn (CtLoc, RewriterSet)] -> TcS () -- See Note [FunDep and implicit parameter reactions]-emitFunDepDeriveds fd_eqns+emitFunDepWanteds work_rewriters fd_eqns   = mapM_ do_one_FDEqn fd_eqns   where-    do_one_FDEqn (FDEqn { fd_qtvs = tvs, fd_eqs = eqs, fd_loc = loc })+    do_one_FDEqn (FDEqn { fd_qtvs = tvs, fd_eqs = eqs, fd_loc = (loc, rewriters) })      | null tvs  -- Common shortcut-     = do { traceTcS "emitFunDepDeriveds 1" (ppr (ctl_depth loc) $$ ppr eqs $$ ppr (isGivenLoc loc))-          ; mapM_ (unifyDerived loc Nominal) eqs }+     = do { traceTcS "emitFunDepWanteds 1" (ppr (ctl_depth loc) $$ ppr eqs $$ ppr (isGivenLoc loc))+          ; mapM_ (\(Pair ty1 ty2) -> unifyWanted all_rewriters loc Nominal ty1 ty2)+                  (reverse eqs) }+             -- See Note [Reverse order of fundep equations]+      | otherwise-     = do { traceTcS "emitFunDepDeriveds 2" (ppr (ctl_depth loc) $$ ppr tvs $$ ppr eqs)+     = do { traceTcS "emitFunDepWanteds 2" (ppr (ctl_depth loc) $$ ppr tvs $$ ppr eqs)           ; subst <- instFlexi tvs  -- Takes account of kind substitution-          ; mapM_ (do_one_eq loc subst) eqs }+          ; mapM_ (do_one_eq loc all_rewriters subst) (reverse eqs) }+               -- See Note [Reverse order of fundep equations]+     where+       all_rewriters = work_rewriters S.<> rewriters -    do_one_eq loc subst (Pair ty1 ty2)-       = unifyDerived loc Nominal $-         Pair (Type.substTyUnchecked subst ty1) (Type.substTyUnchecked subst ty2)+    do_one_eq loc rewriters subst (Pair ty1 ty2)+       = unifyWanted rewriters loc Nominal+                     (Type.substTyUnchecked subst ty1) (Type.substTyUnchecked subst ty2)  {- **********************************************************************@@ -1802,18 +1879,24 @@  topReactionsStage :: WorkItem -> TcS (StopOrContinue Ct) -- The work item does not react with the inert set,--- so try interaction with top-level instances. Note:+-- so try interaction with top-level instances. topReactionsStage work_item   = do { traceTcS "doTopReact" (ppr work_item)        ; case work_item of-           CDictCan {}  -> do { inerts <- getTcSInerts-                              ; doTopReactDict inerts work_item }-           CEqCan {}    -> doTopReactEq    work_item-           CIrredCan {} -> doTopReactOther work_item-           _  -> -- Any other work item does not react with any top-level equations-                 continueWith work_item  } +           CDictCan {} ->+             do { inerts <- getTcSInerts+                ; doTopReactDict inerts work_item } +           CEqCan {} ->+             doTopReactEq work_item++           CIrredCan {} ->+             doTopReactOther work_item++           -- Any other work item does not react with any top-level equations+           _  -> continueWith work_item }+ -------------------- doTopReactOther :: Ct -> TcS (StopOrContinue Ct) -- Try local quantified constraints for@@ -1840,6 +1923,12 @@     loc  = ctEvLoc ev     pred = ctEvPred ev +{-********************************************************************+*                                                                    *+          Top-level reaction for equality constraints (CEqCan)+*                                                                    *+********************************************************************-}+ doTopReactEqPred :: Ct -> EqRel -> TcType -> TcType -> TcS (StopOrContinue Ct) doTopReactEqPred work_item eq_rel t1 t2   -- See Note [Looking up primitive equalities in quantified constraints]@@ -1874,6 +1963,47 @@  * Note [Evidence for quantified constraints] in GHC.Core.Predicate  * Note [Equality superclasses in quantified constraints]    in GHC.Tc.Solver.Canonical++Note [Reverse order of fundep equations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this scenario (from dependent/should_fail/T13135_simple):++  type Sig :: Type -> Type+  data Sig a = SigFun a (Sig a)++  type SmartFun :: forall (t :: Type). Sig t -> Type+  type family SmartFun sig = r | r -> sig where+    SmartFun @Type (SigFun @Type a sig) = a -> SmartFun @Type sig++  [W] SmartFun @kappa sigma ~ (Int -> Bool)++The injectivity of SmartFun allows us to produce two new equalities:++  [W] w1 :: Type ~ kappa+  [W] w2 :: SigFun @Type Int beta ~ sigma++for some fresh (beta :: SigType). The second Wanted here is actually+heterogeneous: the LHS has type Sig Type while the RHS has type Sig kappa.+Of course, if we solve the first wanted first, the second becomes homogeneous.++When looking for injectivity-inspired equalities, we work left-to-right,+producing the two equalities in the order written above. However, these+equalities are then passed into unifyWanted, which will fail, adding these+to the work list. However, crucially, the work list operates like a *stack*.+So, because we add w1 and then w2, we process w2 first. This is silly: solving+w1 would unlock w2. So we make sure to add equalities to the work+list in left-to-right order, which requires a few key calls to 'reverse'.++This treatment is also used for class-based functional dependencies, although+we do not have a program yet known to exhibit a loop there. It just seems+like the right thing to do.++When this was originally conceived, it was necessary to avoid a loop in T13135.+That loop is now avoided by continuing with the kind equality (not the type+equality) in canEqCanLHSHetero (see Note [Equalities with incompatible kinds]+in GHC.Tc.Solver.Canonical). However, the idea of working left-to-right still+seems worthwhile, and so the calls to 'reverse' remain.+ -}  --------------------@@ -1887,7 +2017,7 @@ improveTopFunEqs :: CtEvidence -> TyCon -> [TcType] -> TcType -> TcS () -- See Note [FunDep and implicit parameter reactions] improveTopFunEqs ev fam_tc args rhs-  | not (isImprovable ev)+  | isGiven ev  -- See Note [No Given/Given fundeps]   = return ()    | otherwise@@ -1895,11 +2025,15 @@        ; eqns <- improve_top_fun_eqs fam_envs fam_tc args rhs        ; traceTcS "improveTopFunEqs" (vcat [ ppr fam_tc <+> ppr args <+> ppr rhs                                           , ppr eqns ])-       ; mapM_ (unifyDerived loc Nominal) eqns }+       ; mapM_ (\(Pair ty1 ty2) -> unifyWanted rewriters loc Nominal ty1 ty2)+               (reverse eqns) }+         -- Missing that `reverse` causes T13135 and T13135_simple to loop.+         -- See Note [Reverse order of fundep equations]   where     loc = bumpCtLocDepth (ctEvLoc ev)         -- ToDo: this location is wrong; it should be FunDepOrigin2         -- See #14778+    rewriters = ctEvRewriters ev  improve_top_fun_eqs :: FamInstEnvs                     -> TyCon -> [TcType] -> TcType@@ -1982,7 +2116,7 @@  Note [Improvement orientation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A very delicate point is the orientation of derived equalities+A very delicate point is the orientation of equalities arising from injectivity improvement (#12522).  Suppose we have   type family F x = t | t -> x   type instance F (a, Int) = (Int, G a)@@ -1991,10 +2125,10 @@   [W] TF (alpha, beta) ~ fuv   [W] fuv ~ (Int, <some type>) -The injectivity will give rise to derived constraints+The injectivity will give rise to constraints -  [D] gamma1 ~ alpha-  [D] Int ~ beta+  [W] gamma1 ~ alpha+  [W] Int ~ beta  The fresh unification variable gamma1 comes from the fact that we can only do "partial improvement" here; see Section 5.2 of@@ -2003,7 +2137,7 @@ Now, it's very important to orient the equations this way round, so that the fresh unification variable will be eliminated in favour of alpha.  If we instead had-   [D] alpha ~ gamma1+   [W] alpha ~ gamma1 then we would unify alpha := gamma1; and kick out the wanted constraint.  But when we grough it back in, it'd look like    [W] TF (gamma1, beta) ~ fuv@@ -2014,7 +2148,7 @@ actual argument (alpha, beta) partly matches the improvement template.  But that's a bit tricky, esp when we remember that the kinds much match too; so it's easier to let the normal machinery-handle it.  Instead we are careful to orient the new derived+handle it.  Instead we are careful to orient the new equality with the template on the left.  Delicate, but it works.  -}@@ -2030,14 +2164,14 @@ doTopReactDict inerts work_item@(CDictCan { cc_ev = ev, cc_class = cls                                           , cc_tyargs = xis })   | isGiven ev   -- Never use instances for Given constraints-  = do { try_fundep_improvement-       ; continueWith work_item }+  = continueWith work_item+     -- See Note [No Given/Given fundeps]    | Just solved_ev <- lookupSolvedDict inerts dict_loc cls xis   -- Cached   = do { setEvBindIfWanted ev (ctEvTerm solved_ev)        ; stopWith ev "Dict/Top (cached)" } -  | otherwise  -- Wanted or Derived, but not cached+  | otherwise  -- Wanted, but not cached    = do { dflags <- getDynFlags         ; lkup_res <- matchClassInst dflags inerts cls xis dict_loc         ; case lkup_res of@@ -2045,31 +2179,14 @@                   -> do { insertSafeOverlapFailureTcS what work_item                         ; addSolvedDict what ev cls xis                         ; chooseInstance work_item lkup_res }-               _  ->  -- NoInstance or NotSure-                     do { when (isImprovable ev) $-                          try_fundep_improvement-                        ; continueWith work_item } }+               _  -> -- NoInstance or NotSure+                     -- We didn't solve it; so try functional dependencies with+                     -- the instance environment, and return+                     doTopFundepImprovement work_item }    where-     dict_pred   = mkClassPred cls xis-     dict_loc    = ctEvLoc ev-     dict_origin = ctLocOrigin dict_loc+     dict_loc = ctEvLoc ev -     -- We didn't solve it; so try functional dependencies with-     -- the instance environment, and return-     -- See also Note [Weird fundeps]-     try_fundep_improvement-        = do { traceTcS "try_fundeps" (ppr work_item)-             ; instEnvs <- getInstEnvs-             ; emitFunDepDeriveds $-               improveFromInstEnv instEnvs mk_ct_loc dict_pred } -     mk_ct_loc :: PredType   -- From instance decl-               -> SrcSpan    -- also from instance deol-               -> CtLoc-     mk_ct_loc inst_pred inst_loc-       = dict_loc { ctl_origin = FunDepOrigin2 dict_pred dict_origin-                                               inst_pred inst_loc }- doTopReactDict _ w = pprPanic "doTopReactDict" (ppr w)  @@ -2080,32 +2197,16 @@                         , cir_mk_ev     = mk_ev })   = do { traceTcS "doTopReact/found instance for" $ ppr ev        ; deeper_loc <- checkInstanceOK loc what pred-       ; if isDerived ev-         then -- Use type-class instances for Deriveds, in the hope-              -- of generating some improvements-              -- C.f. Example 3 of Note [The improvement story]-              -- It's easy because no evidence is involved-           do { dflags <- getDynFlags-              ; unless (subGoalDepthExceeded dflags (ctLocDepth deeper_loc)) $-                emitNewDeriveds deeper_loc theta-                  -- If we have a runaway Derived, let's not issue a-                  -- "reduction stack overflow" error, which is not particularly-                  -- friendly. Instead, just drop the Derived.-              ; traceTcS "finish_derived" (ppr (ctl_depth deeper_loc))-              ; stopWith ev "Dict/Top (solved derived)" }--         else -- wanted-           do { checkReductionDepth deeper_loc pred-              ; evb <- getTcEvBindsVar-              ; if isCoEvBindsVar evb-                then continueWith work_item+       ; checkReductionDepth deeper_loc pred+       ; evb <- getTcEvBindsVar+       ; if isCoEvBindsVar evb+         then continueWith work_item                   -- See Note [Instances in no-evidence implications]--                else-           do { evc_vars <- mapM (newWanted deeper_loc) theta+         else+           do { evc_vars <- mapM (newWanted deeper_loc (ctRewriters work_item)) theta               ; setEvBindIfWanted ev (mk_ev (map getEvExpr evc_vars))               ; emitWorkNC (freshGoals evc_vars)-              ; stopWith ev "Dict/Top (solved wanted)" }}}+              ; stopWith ev "Dict/Top (solved wanted)" }}   where      ev         = ctEvidence work_item      pred       = ctEvPred ev@@ -2115,11 +2216,10 @@   = pprPanic "chooseInstance" (ppr work_item $$ ppr lookup_res)  checkInstanceOK :: CtLoc -> InstanceWhat -> TcPredType -> TcS CtLoc--- Check that it's OK to use this insstance:+-- Check that it's OK to use this instance: --    (a) the use is well staged in the Template Haskell sense -- Returns the CtLoc to used for sub-goals--- Probably also want to call checkReductionDepth, but this function--- does not do so to enable special handling for Deriveds in chooseInstance+-- Probably also want to call checkReductionDepth checkInstanceOK loc what pred   = do { checkWellStagedDFun loc what pred        ; return deeper_loc }@@ -2245,7 +2345,7 @@      - natural numbers      - Typeable -* See also Note [What might equal later?] in GHC.Tc.Solver.Monad.+* See also Note [What might equal later?] in GHC.Tc.Solver.InertSet.  * The given-overlap problem is arguably not easy to appear in practice   due to our aggressive prioritization of equality solving over other@@ -2310,7 +2410,7 @@  And less obviously to: -* Tuple classes.  For reasons described in GHC.Tc.Solver.Monad+* Tuple classes.  For reasons described in GHC.Tc.Solver.Types   Note [Tuples hiding implicit parameters], we may have a constraint      [W] (?x::Int, C a)   with an exactly-matching Given constraint.  We must decompose this@@ -2413,8 +2513,8 @@       = (match:matches, unif)        | otherwise-      = ASSERT2( disjointVarSet qtv_set (tyCoVarsOfType pred)-               , ppr qci $$ ppr pred )+      = assertPpr (disjointVarSet qtv_set (tyCoVarsOfType pred))+                  (ppr qci $$ ppr pred)             -- ASSERT: unification relies on the             -- quantified variables being fresh         (matches, unif `combine` this_unif)
compiler/GHC/Tc/Solver/Monad.hs view
@@ -1,4255 +1,1998 @@-{-# LANGUAGE CPP, DeriveFunctor, TypeFamilies, ScopedTypeVariables, TypeApplications,-             DerivingStrategies, GeneralizedNewtypeDeriving, ScopedTypeVariables, MultiWayIf, ViewPatterns #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates -Wno-incomplete-uni-patterns #-}---- | Type definitions for the constraint solver-module GHC.Tc.Solver.Monad (--    -- The work list-    WorkList(..), isEmptyWorkList, emptyWorkList,-    extendWorkListNonEq, extendWorkListCt,-    extendWorkListCts, extendWorkListEq,-    appendWorkList,-    selectNextWorkItem,-    workListSize,-    getWorkList, updWorkListTcS, pushLevelNoWorkList,--    -- The TcS monad-    TcS, runTcS, runTcSDeriveds, runTcSWithEvBinds, runTcSInerts,-    failTcS, warnTcS, addErrTcS, wrapTcS,-    runTcSEqualities,-    nestTcS, nestImplicTcS, setEvBindsTcS,-    emitImplicationTcS, emitTvImplicationTcS,--    runTcPluginTcS, addUsedGRE, addUsedGREs, keepAlive,-    matchGlobalInst, TcM.ClsInstResult(..),--    QCInst(..),--    -- Tracing etc-    panicTcS, traceTcS,-    traceFireTcS, bumpStepCountTcS, csTraceTcS,-    wrapErrTcS, wrapWarnTcS,-    resetUnificationFlag, setUnificationFlag,--    -- Evidence creation and transformation-    MaybeNew(..), freshGoals, isFresh, getEvExpr,--    newTcEvBinds, newNoTcEvBinds,-    newWantedEq, newWantedEq_SI, emitNewWantedEq,-    newWanted, newWanted_SI, newWantedEvVar,-    newWantedNC, newWantedEvVarNC,-    newDerivedNC,-    newBoundEvVarId,-    unifyTyVar, reportUnifications, touchabilityTest, TouchabilityTestResult(..),-    setEvBind, setWantedEq,-    setWantedEvTerm, setEvBindIfWanted,-    newEvVar, newGivenEvVar, newGivenEvVars,-    emitNewDeriveds, emitNewDerivedEq,-    checkReductionDepth,-    getSolvedDicts, setSolvedDicts,--    getInstEnvs, getFamInstEnvs,                -- Getting the environments-    getTopEnv, getGblEnv, getLclEnv,-    getTcEvBindsVar, getTcLevel,-    getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap,-    tcLookupClass, tcLookupId,--    -- Inerts-    InertSet(..), InertCans(..), emptyInert,-    updInertTcS, updInertCans, updInertDicts, updInertIrreds,-    getHasGivenEqs, setInertCans,-    getInertEqs, getInertCans, getInertGivens,-    getInertInsols, getInnermostGivenEqLevel,-    getTcSInerts, setTcSInerts,-    matchableGivens, prohibitedSuperClassSolve, mightEqualLater,-    getUnsolvedInerts,-    removeInertCts, getPendingGivenScs,-    addInertCan, insertFunEq, addInertForAll,-    emitWorkNC, emitWork,-    isImprovable,--    -- The Model-    kickOutAfterUnification,--    -- Inert Safe Haskell safe-overlap failures-    addInertSafehask, insertSafeOverlapFailureTcS, updInertSafehask,-    getSafeOverlapFailures,--    -- Inert CDictCans-    DictMap, emptyDictMap, lookupInertDict, findDictsByClass, addDict,-    addDictsByClass, delDict, foldDicts, filterDicts, findDict,--    -- Inert CEqCans-    EqualCtList(..), findTyEqs, foldTyEqs,-    findEq,--    -- Inert solved dictionaries-    addSolvedDict, lookupSolvedDict,--    -- Irreds-    foldIrreds,--    -- The family application cache-    lookupFamAppInert, lookupFamAppCache, extendFamAppCache,-    pprKicked,--    -- Inert function equalities-    findFunEq, findFunEqsByTyCon,--    instDFunType,                              -- Instantiation--    -- MetaTyVars-    newFlexiTcSTy, instFlexi, instFlexiX,-    cloneMetaTyVar,-    tcInstSkolTyVarsX,--    TcLevel,-    isFilledMetaTyVar_maybe, isFilledMetaTyVar,-    zonkTyCoVarsAndFV, zonkTcType, zonkTcTypes, zonkTcTyVar, zonkCo,-    zonkTyCoVarsAndFVList,-    zonkSimples, zonkWC,-    zonkTyCoVarKind,--    -- References-    newTcRef, readTcRef, writeTcRef, updTcRef,--    -- Misc-    getDefaultInfo, getDynFlags, getGlobalRdrEnvTcS,-    matchFam, matchFamTcM,-    checkWellStagedDFun,-    pprEq,                                   -- Smaller utils, re-exported from TcM-                                             -- TODO (DV): these are only really used in the-                                             -- instance matcher in GHC.Tc.Solver. I am wondering-                                             -- if the whole instance matcher simply belongs-                                             -- here--    breakTyEqCycle_maybe, rewriterView-) where--#include "GhclibHsVersions.h"--import GHC.Prelude--import GHC.Driver.Env--import qualified GHC.Tc.Utils.Instantiate as TcM-import GHC.Core.InstEnv-import GHC.Tc.Instance.Family as FamInst-import GHC.Core.FamInstEnv--import qualified GHC.Tc.Utils.Monad    as TcM-import qualified GHC.Tc.Utils.TcMType  as TcM-import qualified GHC.Tc.Instance.Class as TcM( matchGlobalInst, ClsInstResult(..) )-import qualified GHC.Tc.Utils.Env      as TcM-       ( checkWellStaged, tcGetDefaultTys, tcLookupClass, tcLookupId, topIdLvl )-import GHC.Tc.Instance.Class( InstanceWhat(..), safeOverlap, instanceReturnsDictCon )-import GHC.Tc.Utils.TcType-import GHC.Tc.Utils.Unify ( canSolveByUnification )-import GHC.Driver.Session-import GHC.Core.Type-import qualified GHC.Core.TyCo.Rep as Rep  -- this needs to be used only very locally-import GHC.Core.Coercion-import GHC.Core.Unify--import GHC.Tc.Types.Evidence-import GHC.Core.Class-import GHC.Core.TyCon-import GHC.Tc.Errors   ( solverDepthErrorTcS )--import GHC.Types.Name-import GHC.Types.TyThing-import GHC.Unit.Module ( HasModule, getModule )-import GHC.Types.Name.Reader ( GlobalRdrEnv, GlobalRdrElt )-import qualified GHC.Rename.Env as TcM-import GHC.Types.Var-import GHC.Types.Var.Env-import GHC.Types.Var.Set-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Utils.Logger-import GHC.Data.Bag as Bag-import GHC.Types.Unique.Supply-import GHC.Utils.Misc-import GHC.Tc.Types-import GHC.Tc.Types.Origin-import GHC.Tc.Types.Constraint-import GHC.Core.Predicate--import GHC.Types.Unique.Set-import GHC.Core.TyCon.Env-import GHC.Data.Maybe--import GHC.Core.Map.Type-import GHC.Data.TrieMap--import Control.Monad-import GHC.Utils.Monad-import Data.IORef-import GHC.Exts (oneShot)-import Data.List ( partition, mapAccumL )-import Data.List.NonEmpty ( NonEmpty(..), cons, toList, nonEmpty )-import qualified Data.List.NonEmpty as NE-import Control.Arrow ( first )--#if defined(DEBUG)-import GHC.Data.Graph.Directed-#endif--{--************************************************************************-*                                                                      *-*                            Worklists                                *-*  Canonical and non-canonical constraints that the simplifier has to  *-*  work on. Including their simplification depths.                     *-*                                                                      *-*                                                                      *-************************************************************************--Note [WorkList priorities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-A WorkList contains canonical and non-canonical items (of all flavours).-Notice that each Ct now has a simplification depth. We may-consider using this depth for prioritization as well in the future.--As a simple form of priority queue, our worklist separates out--* equalities (wl_eqs); see Note [Prioritise equalities]-* all the rest (wl_rest)--Note [Prioritise equalities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's very important to process equalities /first/:--* (Efficiency)  The general reason to do so is that if we process a-  class constraint first, we may end up putting it into the inert set-  and then kicking it out later.  That's extra work compared to just-  doing the equality first.--* (Avoiding fundep iteration) As #14723 showed, it's possible to-  get non-termination if we-      - Emit the Derived fundep equalities for a class constraint,-        generating some fresh unification variables.-      - That leads to some unification-      - Which kicks out the class constraint-      - Which isn't solved (because there are still some more Derived-        equalities in the work-list), but generates yet more fundeps-  Solution: prioritise derived equalities over class constraints--* (Class equalities) We need to prioritise equalities even if they-  are hidden inside a class constraint;-  see Note [Prioritise class equalities]--* (Kick-out) We want to apply this priority scheme to kicked-out-  constraints too (see the call to extendWorkListCt in kick_out_rewritable-  E.g. a CIrredCan can be a hetero-kinded (t1 ~ t2), which may become-  homo-kinded when kicked out, and hence we want to prioritise it.--* (Derived equalities) Originally we tried to postpone processing-  Derived equalities, in the hope that we might never need to deal-  with them at all; but in fact we must process Derived equalities-  eagerly, partly for the (Efficiency) reason, and more importantly-  for (Avoiding fundep iteration).--Note [Prioritise class equalities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We prioritise equalities in the solver (see selectWorkItem). But class-constraints like (a ~ b) and (a ~~ b) are actually equalities too;-see Note [The equality types story] in GHC.Builtin.Types.Prim.--Failing to prioritise these is inefficient (more kick-outs etc).-But, worse, it can prevent us spotting a "recursive knot" among-Wanted constraints.  See comment:10 of #12734 for a worked-out-example.--So we arrange to put these particular class constraints in the wl_eqs.--  NB: since we do not currently apply the substitution to the-  inert_solved_dicts, the knot-tying still seems a bit fragile.-  But this makes it better.---}---- See Note [WorkList priorities]-data WorkList-  = WL { wl_eqs     :: [Ct]  -- CEqCan, CDictCan, CIrredCan-                             -- Given, Wanted, and Derived-                       -- Contains both equality constraints and their-                       -- class-level variants (a~b) and (a~~b);-                       -- See Note [Prioritise equalities]-                       -- See Note [Prioritise class equalities]--       , wl_rest    :: [Ct]--       , wl_implics :: Bag Implication  -- See Note [Residual implications]-    }--appendWorkList :: WorkList -> WorkList -> WorkList-appendWorkList-    (WL { wl_eqs = eqs1, wl_rest = rest1-        , wl_implics = implics1 })-    (WL { wl_eqs = eqs2, wl_rest = rest2-        , wl_implics = implics2 })-   = WL { wl_eqs     = eqs1     ++ eqs2-        , wl_rest    = rest1    ++ rest2-        , wl_implics = implics1 `unionBags`   implics2 }--workListSize :: WorkList -> Int-workListSize (WL { wl_eqs = eqs, wl_rest = rest })-  = length eqs + length rest--extendWorkListEq :: Ct -> WorkList -> WorkList-extendWorkListEq ct wl = wl { wl_eqs = ct : wl_eqs wl }--extendWorkListNonEq :: Ct -> WorkList -> WorkList--- Extension by non equality-extendWorkListNonEq ct wl = wl { wl_rest = ct : wl_rest wl }--extendWorkListDeriveds :: [CtEvidence] -> WorkList -> WorkList-extendWorkListDeriveds evs wl-  = extendWorkListCts (map mkNonCanonical evs) wl--extendWorkListImplic :: Implication -> WorkList -> WorkList-extendWorkListImplic implic wl = wl { wl_implics = implic `consBag` wl_implics wl }--extendWorkListCt :: Ct -> WorkList -> WorkList--- Agnostic-extendWorkListCt ct wl- = case classifyPredType (ctPred ct) of-     EqPred {}-       -> extendWorkListEq ct wl--     ClassPred cls _  -- See Note [Prioritise class equalities]-       |  isEqPredClass cls-       -> extendWorkListEq ct wl--     _ -> extendWorkListNonEq ct wl--extendWorkListCts :: [Ct] -> WorkList -> WorkList--- Agnostic-extendWorkListCts cts wl = foldr extendWorkListCt wl cts--isEmptyWorkList :: WorkList -> Bool-isEmptyWorkList (WL { wl_eqs = eqs, wl_rest = rest, wl_implics = implics })-  = null eqs && null rest && isEmptyBag implics--emptyWorkList :: WorkList-emptyWorkList = WL { wl_eqs  = [], wl_rest = [], wl_implics = emptyBag }--selectWorkItem :: WorkList -> Maybe (Ct, WorkList)--- See Note [Prioritise equalities]-selectWorkItem wl@(WL { wl_eqs = eqs, wl_rest = rest })-  | ct:cts <- eqs  = Just (ct, wl { wl_eqs    = cts })-  | ct:cts <- rest = Just (ct, wl { wl_rest   = cts })-  | otherwise      = Nothing--getWorkList :: TcS WorkList-getWorkList = do { wl_var <- getTcSWorkListRef-                 ; wrapTcS (TcM.readTcRef wl_var) }--selectNextWorkItem :: TcS (Maybe Ct)--- Pick which work item to do next--- See Note [Prioritise equalities]-selectNextWorkItem-  = do { wl_var <- getTcSWorkListRef-       ; wl <- readTcRef wl_var-       ; case selectWorkItem wl of {-           Nothing -> return Nothing ;-           Just (ct, new_wl) ->-    do { -- checkReductionDepth (ctLoc ct) (ctPred ct)-         -- This is done by GHC.Tc.Solver.Interact.chooseInstance-       ; writeTcRef wl_var new_wl-       ; return (Just ct) } } }---- Pretty printing-instance Outputable WorkList where-  ppr (WL { wl_eqs = eqs, wl_rest = rest, wl_implics = implics })-   = text "WL" <+> (braces $-     vcat [ ppUnless (null eqs) $-            text "Eqs =" <+> vcat (map ppr eqs)-          , ppUnless (null rest) $-            text "Non-eqs =" <+> vcat (map ppr rest)-          , ppUnless (isEmptyBag implics) $-            ifPprDebug (text "Implics =" <+> vcat (map ppr (bagToList implics)))-                       (text "(Implics omitted)")-          ])---{- *********************************************************************-*                                                                      *-                InertSet: the inert set-*                                                                      *-*                                                                      *-********************************************************************* -}--type CycleBreakerVarStack = NonEmpty [(TcTyVar, TcType)]-   -- ^ a stack of (CycleBreakerTv, original family applications) lists-   -- first element in the stack corresponds to current implication;-   --   later elements correspond to outer implications-   -- used to undo the cycle-breaking needed to handle-   -- Note [Type equality cycles] in GHC.Tc.Solver.Canonical-   -- Why store the outer implications? For the use in mightEqualLater (only)--data InertSet-  = IS { inert_cans :: InertCans-              -- Canonical Given, Wanted, Derived-              -- Sometimes called "the inert set"--       , inert_cycle_breakers :: CycleBreakerVarStack--       , inert_famapp_cache :: FunEqMap (TcCoercion, TcType)-              -- Just a hash-cons cache for use when reducing family applications-              -- only-              ---              -- If    F tys :-> (co, rhs, flav),-              -- then  co :: rhs ~N F tys-              -- all evidence is from instances or Givens; no coercion holes here-              -- (We have no way of "kicking out" from the cache, so putting-              --  wanteds here means we can end up solving a Wanted with itself. Bad)--       , inert_solved_dicts   :: DictMap CtEvidence-              -- All Wanteds, of form ev :: C t1 .. tn-              -- See Note [Solved dictionaries]-              -- and Note [Do not add superclasses of solved dictionaries]-       }--instance Outputable InertSet where-  ppr (IS { inert_cans = ics-          , inert_solved_dicts = solved_dicts })-      = vcat [ ppr ics-             , ppUnless (null dicts) $-               text "Solved dicts =" <+> vcat (map ppr dicts) ]-         where-           dicts = bagToList (dictsToBag solved_dicts)--emptyInertCans :: InertCans-emptyInertCans-  = IC { inert_eqs          = emptyDVarEnv-       , inert_given_eq_lvl = topTcLevel-       , inert_given_eqs    = False-       , inert_dicts        = emptyDicts-       , inert_safehask     = emptyDicts-       , inert_funeqs       = emptyFunEqs-       , inert_insts        = []-       , inert_irreds       = emptyCts-       , inert_blocked      = emptyCts }--emptyInert :: InertSet-emptyInert-  = IS { inert_cans           = emptyInertCans-       , inert_cycle_breakers = [] :| []-       , inert_famapp_cache   = emptyFunEqs-       , inert_solved_dicts   = emptyDictMap }---{- Note [Solved dictionaries]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we apply a top-level instance declaration, we add the "solved"-dictionary to the inert_solved_dicts.  In general, we use it to avoid-creating a new EvVar when we have a new goal that we have solved in-the past.--But in particular, we can use it to create *recursive* dictionaries.-The simplest, degenerate case is-    instance C [a] => C [a] where ...-If we have-    [W] d1 :: C [x]-then we can apply the instance to get-    d1 = $dfCList d-    [W] d2 :: C [x]-Now 'd1' goes in inert_solved_dicts, and we can solve d2 directly from d1.-    d1 = $dfCList d-    d2 = d1--See Note [Example of recursive dictionaries]--VERY IMPORTANT INVARIANT:-- (Solved Dictionary Invariant)-    Every member of the inert_solved_dicts is the result-    of applying an instance declaration that "takes a step"--    An instance "takes a step" if it has the form-        dfunDList d1 d2 = MkD (...) (...) (...)-    That is, the dfun is lazy in its arguments, and guarantees to-    immediately return a dictionary constructor.  NB: all dictionary-    data constructors are lazy in their arguments.--    This property is crucial to ensure that all dictionaries are-    non-bottom, which in turn ensures that the whole "recursive-    dictionary" idea works at all, even if we get something like-        rec { d = dfunDList d dx }-    See Note [Recursive superclasses] in GHC.Tc.TyCl.Instance.-- Reason:-   - All instances, except two exceptions listed below, "take a step"-     in the above sense--   - Exception 1: local quantified constraints have no such guarantee;-     indeed, adding a "solved dictionary" when appling a quantified-     constraint led to the ability to define unsafeCoerce-     in #17267.--   - Exception 2: the magic built-in instance for (~) has no-     such guarantee.  It behaves as if we had-         class    (a ~# b) => (a ~ b) where {}-         instance (a ~# b) => (a ~ b) where {}-     The "dfun" for the instance is strict in the coercion.-     Anyway there's no point in recording a "solved dict" for-     (t1 ~ t2); it's not going to allow a recursive dictionary-     to be constructed.  Ditto (~~) and Coercible.--THEREFORE we only add a "solved dictionary"-  - when applying an instance declaration-  - subject to Exceptions 1 and 2 above--In implementation terms-  - GHC.Tc.Solver.Monad.addSolvedDict adds a new solved dictionary,-    conditional on the kind of instance--  - It is only called when applying an instance decl,-    in GHC.Tc.Solver.Interact.doTopReactDict--  - ClsInst.InstanceWhat says what kind of instance was-    used to solve the constraint.  In particular-      * LocalInstance identifies quantified constraints-      * BuiltinEqInstance identifies the strange built-in-        instances for equality.--  - ClsInst.instanceReturnsDictCon says which kind of-    instance guarantees to return a dictionary constructor--Other notes about solved dictionaries--* See also Note [Do not add superclasses of solved dictionaries]--* The inert_solved_dicts field is not rewritten by equalities,-  so it may get out of date.--* The inert_solved_dicts are all Wanteds, never givens--* We only cache dictionaries from top-level instances, not from-  local quantified constraints.  Reason: if we cached the latter-  we'd need to purge the cache when bringing new quantified-  constraints into scope, because quantified constraints "shadow"-  top-level instances.--Note [Do not add superclasses of solved dictionaries]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Every member of inert_solved_dicts is the result of applying a-dictionary function, NOT of applying superclass selection to anything.-Consider--        class Ord a => C a where-        instance Ord [a] => C [a] where ...--Suppose we are trying to solve-  [G] d1 : Ord a-  [W] d2 : C [a]--Then we'll use the instance decl to give--  [G] d1 : Ord a     Solved: d2 : C [a] = $dfCList d3-  [W] d3 : Ord [a]--We must not add d4 : Ord [a] to the 'solved' set (by taking the-superclass of d2), otherwise we'll use it to solve d3, without ever-using d1, which would be a catastrophe.--Solution: when extending the solved dictionaries, do not add superclasses.-That's why each element of the inert_solved_dicts is the result of applying-a dictionary function.--Note [Example of recursive dictionaries]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~---- Example 1--    data D r = ZeroD | SuccD (r (D r));--    instance (Eq (r (D r))) => Eq (D r) where-        ZeroD     == ZeroD     = True-        (SuccD a) == (SuccD b) = a == b-        _         == _         = False;--    equalDC :: D [] -> D [] -> Bool;-    equalDC = (==);--We need to prove (Eq (D [])). Here's how we go:--   [W] d1 : Eq (D [])-By instance decl of Eq (D r):-   [W] d2 : Eq [D []]      where   d1 = dfEqD d2-By instance decl of Eq [a]:-   [W] d3 : Eq (D [])      where   d2 = dfEqList d3-                                   d1 = dfEqD d2-Now this wanted can interact with our "solved" d1 to get:-    d3 = d1---- Example 2:-This code arises in the context of "Scrap Your Boilerplate with Class"--    class Sat a-    class Data ctx a-    instance  Sat (ctx Char)             => Data ctx Char       -- dfunData1-    instance (Sat (ctx [a]), Data ctx a) => Data ctx [a]        -- dfunData2--    class Data Maybe a => Foo a--    instance Foo t => Sat (Maybe t)                             -- dfunSat--    instance Data Maybe a => Foo a                              -- dfunFoo1-    instance Foo a        => Foo [a]                            -- dfunFoo2-    instance                 Foo [Char]                         -- dfunFoo3--Consider generating the superclasses of the instance declaration-         instance Foo a => Foo [a]--So our problem is this-    [G] d0 : Foo t-    [W] d1 : Data Maybe [t]   -- Desired superclass--We may add the given in the inert set, along with its superclasses-  Inert:-    [G] d0 : Foo t-    [G] d01 : Data Maybe t   -- Superclass of d0-  WorkList-    [W] d1 : Data Maybe [t]--Solve d1 using instance dfunData2; d1 := dfunData2 d2 d3-  Inert:-    [G] d0 : Foo t-    [G] d01 : Data Maybe t   -- Superclass of d0-  Solved:-        d1 : Data Maybe [t]-  WorkList:-    [W] d2 : Sat (Maybe [t])-    [W] d3 : Data Maybe t--Now, we may simplify d2 using dfunSat; d2 := dfunSat d4-  Inert:-    [G] d0 : Foo t-    [G] d01 : Data Maybe t   -- Superclass of d0-  Solved:-        d1 : Data Maybe [t]-        d2 : Sat (Maybe [t])-  WorkList:-    [W] d3 : Data Maybe t-    [W] d4 : Foo [t]--Now, we can just solve d3 from d01; d3 := d01-  Inert-    [G] d0 : Foo t-    [G] d01 : Data Maybe t   -- Superclass of d0-  Solved:-        d1 : Data Maybe [t]-        d2 : Sat (Maybe [t])-  WorkList-    [W] d4 : Foo [t]--Now, solve d4 using dfunFoo2;  d4 := dfunFoo2 d5-  Inert-    [G] d0  : Foo t-    [G] d01 : Data Maybe t   -- Superclass of d0-  Solved:-        d1 : Data Maybe [t]-        d2 : Sat (Maybe [t])-        d4 : Foo [t]-  WorkList:-    [W] d5 : Foo t--Now, d5 can be solved! d5 := d0--Result-   d1 := dfunData2 d2 d3-   d2 := dfunSat d4-   d3 := d01-   d4 := dfunFoo2 d5-   d5 := d0--}--{- *********************************************************************-*                                                                      *-                InertCans: the canonical inerts-*                                                                      *-*                                                                      *-********************************************************************* -}--data InertCans   -- See Note [Detailed InertCans Invariants] for more-  = IC { inert_eqs :: InertEqs-              -- See Note [inert_eqs: the inert equalities]-              -- All CEqCans with a TyVarLHS; index is the LHS tyvar-              -- Domain = skolems and untouchables; a touchable would be unified--       , inert_funeqs :: FunEqMap EqualCtList-              -- All CEqCans with a TyFamLHS; index is the whole family head type.-              -- LHS is fully rewritten (modulo eqCanRewrite constraints)-              --     wrt inert_eqs-              -- Can include all flavours, [G], [W], [WD], [D]--       , inert_dicts :: DictMap Ct-              -- Dictionaries only-              -- All fully rewritten (modulo flavour constraints)-              --     wrt inert_eqs--       , inert_insts :: [QCInst]--       , inert_safehask :: DictMap Ct-              -- Failed dictionary resolution due to Safe Haskell overlapping-              -- instances restriction. We keep this separate from inert_dicts-              -- as it doesn't cause compilation failure, just safe inference-              -- failure.-              ---              -- ^ See Note [Safe Haskell Overlapping Instances Implementation]-              -- in "GHC.Tc.Solver"--       , inert_irreds :: Cts-              -- Irreducible predicates that cannot be made canonical,-              --     and which don't interact with others (e.g.  (c a))-              -- and insoluble predicates (e.g.  Int ~ Bool, or a ~ [a])--       , inert_blocked :: Cts-              -- Equality predicates blocked on a coercion hole.-              -- Each Ct is a CIrredCan with cc_reason = HoleBlockerReason-              -- See Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical-              -- wrinkle (2)-              -- These are stored separately from inert_irreds because-              -- they get kicked out for different reasons---       , inert_given_eq_lvl :: TcLevel-              -- The TcLevel of the innermost implication that has a Given-              -- equality of the sort that make a unification variable untouchable-              -- (see Note [Unification preconditions] in GHC.Tc.Utils.Unify).-              -- See Note [Tracking Given equalities] below--       , inert_given_eqs :: Bool-              -- True <=> The inert Givens *at this level* (tcl_tclvl)-              --          could includes at least one equality /other than/ a-              --          let-bound skolem equality.-              -- Reason: report these givens when reporting a failed equality-              -- See Note [Tracking Given equalities]-       }--type InertEqs    = DTyVarEnv EqualCtList--newtype EqualCtList = EqualCtList (NonEmpty Ct)-  deriving newtype Outputable-  -- See Note [EqualCtList invariants]--unitEqualCtList :: Ct -> EqualCtList-unitEqualCtList ct = EqualCtList (ct :| [])--addToEqualCtList :: Ct -> EqualCtList -> EqualCtList--- NB: This function maintains the "derived-before-wanted" invariant of EqualCtList,--- but not the others. See Note [EqualCtList invariants]-addToEqualCtList ct (EqualCtList old_eqs)-  | isWantedCt ct-  , eq1 :| eqs <- old_eqs-  = EqualCtList (eq1 :| ct : eqs)-  | otherwise-  = EqualCtList (ct `cons` old_eqs)--filterEqualCtList :: (Ct -> Bool) -> EqualCtList -> Maybe EqualCtList-filterEqualCtList pred (EqualCtList cts)-  = fmap EqualCtList (nonEmpty $ NE.filter pred cts)--equalCtListToList :: EqualCtList -> [Ct]-equalCtListToList (EqualCtList cts) = toList cts--listToEqualCtList :: [Ct] -> Maybe EqualCtList--- NB: This does not maintain invariants other than having the EqualCtList be--- non-empty-listToEqualCtList cts = EqualCtList <$> nonEmpty cts--{- Note [Tracking Given equalities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For reasons described in (UNTOUCHABLE) in GHC.Tc.Utils.Unify-Note [Unification preconditions], we can't unify-   alpha[2] ~ Int-under a level-4 implication if there are any Given equalities-bound by the implications at level 3 of 4.  To that end, the-InertCans tracks--  inert_given_eq_lvl :: TcLevel-     -- The TcLevel of the innermost implication that has a Given-     -- equality of the sort that make a unification variable untouchable-     -- (see Note [Unification preconditions] in GHC.Tc.Utils.Unify).--We update inert_given_eq_lvl whenever we add a Given to the-inert set, in updateGivenEqs.--Then a unification variable alpha[n] is untouchable iff-    n < inert_given_eq_lvl-that is, if the unification variable was born outside an-enclosing Given equality.--Exactly which constraints should trigger (UNTOUCHABLE), and hence-should update inert_given_eq_lvl?--* We do /not/ need to worry about let-bound skolems, such ast-     forall[2] a. a ~ [b] => blah-  See Note [Let-bound skolems]--* Consider an implication-      forall[2]. beta[1] => alpha[1] ~ Int-  where beta is a unification variable that has already been unified-  to () in an outer scope.  Then alpha[1] is perfectly touchable and-  we can unify alpha := Int. So when deciding whether the givens contain-  an equality, we should canonicalise first, rather than just looking at-  the /original/ givens (#8644).-- * However, we must take account of *potential* equalities. Consider the-   same example again, but this time we have /not/ yet unified beta:-      forall[2] beta[1] => ...blah...--   Because beta might turn into an equality, updateGivenEqs conservatively-   treats it as a potential equality, and updates inert_give_eq_lvl-- * What about something like forall[2] a b. a ~ F b => [W] alpha[1] ~ X y z?--   That Given cannot affect the Wanted, because the Given is entirely-   *local*: it mentions only skolems bound in the very same-   implication. Such equalities need not make alpha untouchable. (Test-   case typecheck/should_compile/LocalGivenEqs has a real-life-   motivating example, with some detailed commentary.)-   Hence the 'mentionsOuterVar' test in updateGivenEqs.--   However, solely to support better error messages-   (see Note [HasGivenEqs] in GHC.Tc.Types.Constraint) we also track-   these "local" equalities in the boolean inert_given_eqs field.-   This field is used only to set the ic_given_eqs field to LocalGivenEqs;-   see the function getHasGivenEqs.--   Here is a simpler case that triggers this behaviour:--     data T where-       MkT :: F a ~ G b => a -> b -> T--     f (MkT _ _) = True--   Because of this behaviour around local equality givens, we can infer the-   type of f. This is typecheck/should_compile/LocalGivenEqs2.-- * We need not look at the equality relation involved (nominal vs-   representational), because representational equalities can still-   imply nominal ones. For example, if (G a ~R G b) and G's argument's-   role is nominal, then we can deduce a ~N b.--Note [Let-bound skolems]-~~~~~~~~~~~~~~~~~~~~~~~~-If   * the inert set contains a canonical Given CEqCan (a ~ ty)-and  * 'a' is a skolem bound in this very implication,--then:-a) The Given is pretty much a let-binding, like-      f :: (a ~ b->c) => a -> a-   Here the equality constraint is like saying-      let a = b->c in ...-   It is not adding any new, local equality  information,-   and hence can be ignored by has_given_eqs--b) 'a' will have been completely substituted out in the inert set,-   so we can safely discard it.--For an example, see #9211.--See also GHC.Tc.Utils.Unify Note [Deeper level on the left] for how we ensure-that the right variable is on the left of the equality when both are-tyvars.--You might wonder whether the skolem really needs to be bound "in the-very same implication" as the equuality constraint.-Consider this (c.f. #15009):--  data S a where-    MkS :: (a ~ Int) => S a--  g :: forall a. S a -> a -> blah-  g x y = let h = \z. ( z :: Int-                      , case x of-                           MkS -> [y,z])-          in ...--From the type signature for `g`, we get `y::a` .  Then when we-encounter the `\z`, we'll assign `z :: alpha[1]`, say.  Next, from the-body of the lambda we'll get--  [W] alpha[1] ~ Int                             -- From z::Int-  [W] forall[2]. (a ~ Int) => [W] alpha[1] ~ a   -- From [y,z]--Now, unify alpha := a.  Now we are stuck with an unsolved alpha~Int!-So we must treat alpha as untouchable under the forall[2] implication.--Note [Detailed InertCans Invariants]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The InertCans represents a collection of constraints with the following properties:--  * All canonical--  * No two dictionaries with the same head-  * No two CIrreds with the same type--  * Family equations inert wrt top-level family axioms--  * Dictionaries have no matching top-level instance--  * Given family or dictionary constraints don't mention touchable-    unification variables--  * Non-CEqCan constraints are fully rewritten with respect-    to the CEqCan equalities (modulo eqCanRewrite of course;-    eg a wanted cannot rewrite a given)--  * CEqCan equalities: see Note [inert_eqs: the inert equalities]-    Also see documentation in Constraint.Ct for a list of invariants--Note [EqualCtList invariants]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-    * All are equalities-    * All these equalities have the same LHS-    * The list is never empty-    * No element of the list can rewrite any other-    * Derived before Wanted--From the fourth invariant it follows that the list is-   - A single [G], or-   - Zero or one [D] or [WD], followed by any number of [W]--The Wanteds can't rewrite anything which is why we put them last--Note [inert_eqs: the inert equalities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Definition [Can-rewrite relation]-A "can-rewrite" relation between flavours, written f1 >= f2, is a-binary relation with the following properties--  (R1) >= is transitive-  (R2) If f1 >= f, and f2 >= f,-       then either f1 >= f2 or f2 >= f1-  (See Note [Why R2?].)--Lemma (L0). If f1 >= f then f1 >= f1-Proof.      By property (R2), with f1=f2--Definition [Generalised substitution]-A "generalised substitution" S is a set of triples (lhs -f-> t), where-  lhs is a type variable or an exactly-saturated type family application-    (that is, lhs is a CanEqLHS)-  t is a type-  f is a flavour-such that-  (WF1) if (lhs1 -f1-> t1) in S-           (lhs2 -f2-> t2) in S-        then (f1 >= f2) implies that lhs1 does not appear within lhs2-  (WF2) if (lhs -f-> t) is in S, then t /= lhs--Definition [Applying a generalised substitution]-If S is a generalised substitution-   S(f,t0) = t,  if (t0 -fs-> t) in S, and fs >= f-           = apply S to components of t0, otherwise-See also Note [Flavours with roles].--Theorem: S(f,t0) is well defined as a function.-Proof: Suppose (lhs -f1-> t1) and (lhs -f2-> t2) are both in S,-               and  f1 >= f and f2 >= f-       Then by (R2) f1 >= f2 or f2 >= f1, which contradicts (WF1)--Notation: repeated application.-  S^0(f,t)     = t-  S^(n+1)(f,t) = S(f, S^n(t))--Definition: terminating generalised substitution-A generalised substitution S is *terminating* iff--  (IG1) there is an n such that-        for every f,t, S^n(f,t) = S^(n+1)(f,t)--By (IG1) we define S*(f,t) to be the result of exahaustively-applying S(f,_) to t.--------------------------------------------------------------------------------Our main invariant:-   the CEqCans in inert_eqs should be a terminating generalised substitution--------------------------------------------------------------------------------Note that termination is not the same as idempotence.  To apply S to a-type, you may have to apply it recursively.  But termination does-guarantee that this recursive use will terminate.--Note [Why R2?]-~~~~~~~~~~~~~~-R2 states that, if we have f1 >= f and f2 >= f, then either f1 >= f2 or f2 >=-f1. If we do not have R2, we will easily fall into a loop.--To see why, imagine we have f1 >= f, f2 >= f, and that's it. Then, let our-inert set S = {a -f1-> b, b -f2-> a}. Computing S(f,a) does not terminate. And-yet, we have a hard time noticing an occurs-check problem when building S, as-the two equalities cannot rewrite one another.--R2 actually restricts our ability to accept user-written programs. See Note-[Deriveds do rewrite Deriveds] in GHC.Tc.Types.Constraint for an example.--Note [Rewritable]-~~~~~~~~~~~~~~~~~-This Note defines what it means for a type variable or type family application-(that is, a CanEqLHS) to be rewritable in a type. This definition is used-by the anyRewritableXXX family of functions and is meant to model the actual-behaviour in GHC.Tc.Solver.Rewrite.--Ignoring roles (for now): A CanEqLHS lhs is *rewritable* in a type t if the-lhs tree appears as a subtree within t without traversing any of the following-components of t:-  * coercions (whether they appear in casts CastTy or as arguments CoercionTy)-  * kinds of variable occurrences-The check for rewritability *does* look in kinds of the bound variable of a-ForAllTy.--Goal: If lhs is not rewritable in t, then t is a fixpoint of the generalised-substitution containing only {lhs -f*-> t'}, where f* is a flavour such that f* >= f-for all f.--The reason for this definition is that the rewriter does not rewrite in coercions-or variables' kinds. In turn, the rewriter does not need to rewrite there because-those places are never used for controlling the behaviour of the solver: these-places are not used in matching instances or in decomposing equalities.--There is one exception to the claim that non-rewritable parts of the tree do-not affect the solver: we sometimes do an occurs-check to decide e.g. how to-orient an equality. (See the comments on-GHC.Tc.Solver.Canonical.canEqTyVarFunEq.) Accordingly, the presence of a-variable in a kind or coercion just might influence the solver. Here is an-example:--  type family Const x y where-    Const x y = x--  AxConst :: forall x y. Const x y ~# x--  alpha :: Const Type Nat-  [W] alpha ~ Int |> (sym (AxConst Type alpha) ;;-                      AxConst Type alpha ;;-                      sym (AxConst Type Nat))--The cast is clearly ludicrous (it ties together a cast and its symmetric version),-but we can't quite rule it out. (See (EQ1) from-Note [Respecting definitional equality] in GHC.Core.TyCo.Rep to see why we need-the Const Type Nat bit.) And yet this cast will (quite rightly) prevent alpha-from unifying with the RHS. I (Richard E) don't have an example of where this-problem can arise from a Haskell program, but we don't have an air-tight argument-for why the definition of *rewritable* given here is correct.--Taking roles into account: we must consider a rewrite at a given role. That is,-a rewrite arises from some equality, and that equality has a role associated-with it. As we traverse a type, we track what role we are allowed to rewrite with.--For example, suppose we have an inert [G] b ~R# Int. Then b is rewritable in-Maybe b but not in F b, where F is a type function. This role-aware logic is-present in both the anyRewritableXXX functions and in the rewriter.-See also Note [anyRewritableTyVar must be role-aware] in GHC.Tc.Utils.TcType.--Note [Extending the inert equalities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Main Theorem [Stability under extension]-   Suppose we have a "work item"-       lhs -fw-> t-   and a terminating generalised substitution S,-   THEN the extended substitution T = S+(lhs -fw-> t)-        is a terminating generalised substitution-   PROVIDED-      (T1) S(fw,lhs) = lhs   -- LHS of work-item is a fixpoint of S(fw,_)-      (T2) S(fw,t)   = t     -- RHS of work-item is a fixpoint of S(fw,_)-      (T3) lhs not in t      -- No occurs check in the work item-          -- If lhs is a type family application, we require only that-          -- lhs is not *rewritable* in t. See Note [Rewritable] and-          -- Note [CEqCan occurs check] in GHC.Tc.Types.Constraint.--      AND, for every (lhs1 -fs-> s) in S:-           (K0) not (fw >= fs)-                Reason: suppose we kick out (lhs1 -fs-> s),-                        and add (lhs -fw-> t) to the inert set.-                        The latter can't rewrite the former,-                        so the kick-out achieved nothing--              -- From here, we can assume fw >= fs-           OR (K4) lhs1 is a tyvar AND fs >= fw--           OR { (K1) lhs is not rewritable in lhs1. See Note [Rewritable].-                     Reason: if fw >= fs, WF1 says we can't have both-                             lhs0 -fw-> t  and  F lhs0 -fs-> s--                AND (K2): guarantees termination of the new substitution-                    {  (K2a) not (fs >= fs)-                    OR (K2b) lhs not in s }--                AND (K3) See Note [K3: completeness of solving]-                    { (K3a) If the role of fs is nominal: s /= lhs-                      (K3b) If the role of fs is representational:-                            s is not of form (lhs t1 .. tn) } }---Conditions (T1-T3) are established by the canonicaliser-Conditions (K1-K3) are established by GHC.Tc.Solver.Monad.kickOutRewritable--The idea is that-* T1 and T2 are guaranteed by exhaustively rewriting the work-item-  with S(fw,_).--* T3 is guaranteed by an occurs-check on the work item.-  This is done during canonicalisation, in checkTypeEq; invariant-  (TyEq:OC) of CEqCan. See also Note [CEqCan occurs check] in GHC.Tc.Types.Constraint.--* (K1-3) are the "kick-out" criteria.  (As stated, they are really the-  "keep" criteria.) If the current inert S contains a triple that does-  not satisfy (K1-3), then we remove it from S by "kicking it out",-  and re-processing it.--* Note that kicking out is a Bad Thing, because it means we have to-  re-process a constraint.  The less we kick out, the better.-  TODO: Make sure that kicking out really *is* a Bad Thing. We've assumed-  this but haven't done the empirical study to check.--* Assume we have  G>=G, G>=W and that's all.  Then, when performing-  a unification we add a new given  a -G-> ty.  But doing so does NOT require-  us to kick out an inert wanted that mentions a, because of (K2a).  This-  is a common case, hence good not to kick out. See also (K2a) below.--* Lemma (L2): if not (fw >= fw), then K0 holds and we kick out nothing-  Proof: using Definition [Can-rewrite relation], fw can't rewrite anything-         and so K0 holds.  Intuitively, since fw can't rewrite anything (Lemma (L0)),-         adding it cannot cause any loops-  This is a common case, because Wanteds cannot rewrite Wanteds.-  It's used to avoid even looking for constraint to kick out.--* Lemma (L1): The conditions of the Main Theorem imply that there is no-              (lhs -fs-> t) in S, s.t.  (fs >= fw).-  Proof. Suppose the contrary (fs >= fw).  Then because of (T1),-  S(fw,lhs)=lhs.  But since fs>=fw, S(fw,lhs) = t, hence t=lhs.  But now we-  have (lhs -fs-> lhs) in S, which contradicts (WF2).--* The extended substitution satisfies (WF1) and (WF2)-  - (K1) plus (L1) guarantee that the extended substitution satisfies (WF1).-  - (T3) guarantees (WF2).--* (K2) and (K4) are about termination.  Intuitively, any infinite chain S^0(f,t),-  S^1(f,t), S^2(f,t).... must pass through the new work item infinitely-  often, since the substitution without the work item is terminating; and must-  pass through at least one of the triples in S infinitely often.--  - (K2a): if not(fs>=fs) then there is no f that fs can rewrite (fs>=f)-    (this is Lemma (L0)), and hence this triple never plays a role in application S(f,t).-    It is always safe to extend S with such a triple.--    (NB: we could strengten K1) in this way too, but see K3.--  - (K2b): if lhs not in s, we have no further opportunity to apply the-    work item--  - (K4): See Note [K4]--* Lemma (L3). Suppose we have f* such that, for all f, f* >= f. Then-  if we are adding lhs -fw-> t (where T1, T2, and T3 hold), we will keep a -f*-> s.-  Proof. K4 holds; thus, we keep.--Key lemma to make it watertight.-  Under the conditions of the Main Theorem,-  forall f st fw >= f, a is not in S^k(f,t), for any k--Also, consider roles more carefully. See Note [Flavours with roles]--Note [K4]-~~~~~~~~~-K4 is a "keep" condition of Note [Extending the inert equalities].-Here is the scenario:--* We are considering adding (lhs -fw-> t) to the inert set S.-* S already has (lhs1 -fs-> s).-* We know S(fw, lhs) = lhs, S(fw, t) = t, and lhs is not rewritable in t.-  See Note [Rewritable]. These are (T1), (T2), and (T3).-* We further know fw >= fs. (If not, then we short-circuit via (K0).)--K4 says that we may keep lhs1 -fs-> s in S if:-  lhs1 is a tyvar AND fs >= fw--Why K4 guarantees termination:-  * If fs >= fw, we know a is not rewritable in t, because of (T2).-  * We further know lhs /= a, because of (T1).-  * Accordingly, a use of the new inert item lhs -fw-> t cannot create the conditions-    for a use of a -fs-> s (precisely because t does not mention a), and hence,-    the extended substitution (with lhs -fw-> t in it) is a terminating-    generalised substitution.--Recall that the termination generalised substitution includes only mappings that-pass an occurs check. This is (T3). At one point, we worried that the-argument here would fail if s mentioned a, but (T3) rules out this possibility.-Put another way: the terminating generalised substitution considers only the inert_eqs,-not other parts of the inert set (such as the irreds).--Can we liberalise K4? No.--Why we cannot drop the (fs >= fw) condition:-  * Suppose not (fs >= fw). It might be the case that t mentions a, and this-    can cause a loop. Example:--      Work:  [G] b ~ a-      Inert: [D] a ~ b--    (where G >= G, G >= D, and D >= D)-    If we don't kick out the inert, then we get a loop on e.g. [D] a ~ Int.--  * Note that the above example is different if the inert is a Given G, because-    (T1) won't hold.--Why we cannot drop the tyvar condition:-  * Presume fs >= fw. Thus, F tys is not rewritable in t, because of (T2).-  * Can the use of lhs -fw-> t create the conditions for a use of F tys -fs-> s?-    Yes! This can happen if t appears within tys.--    Here is an example:--      Work:  [G] a ~ Int-      Inert: [G] F Int ~ F a--    Now, if we have [W] F a ~ Bool, we will rewrite ad infinitum on the left-hand-    side. The key reason why K2b works in the tyvar case is that tyvars are atomic:-    if the right-hand side of an equality does not mention a variable a, then it-    cannot allow an equality with an LHS of a to fire. This is not the case for-    type family applications.--Bottom line: K4 can keep only inerts with tyvars on the left. Put differently,-K4 will never prevent an inert with a type family on the left from being kicked-out.--Consequence: We never kick out a Given/Nominal equality with a tyvar on the left.-This is Lemma (L3) of Note [Extending the inert equalities]. It is good because-it means we can effectively model the mutable filling of metavariables with-Given/Nominal equalities. That is: it should be the case that we could rewrite-our solver never to fill in a metavariable; instead, it would "solve" a wanted-like alpha ~ Int by turning it into a Given, allowing it to be used in rewriting.-We would want the solver to behave the same whether it uses metavariables or-Givens. And (L3) says that no Given/Nominals over tyvars are ever kicked out,-just like we never unfill a metavariable. Nice.--Getting this wrong (that is, allowing K4 to apply to situations with the type-family on the left) led to #19042. (At that point, K4 was known as K2b.)--Originally, this condition was part of K2, but #17672 suggests it should be-a top-level K condition.--Note [K3: completeness of solving]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-(K3) is not necessary for the extended substitution-to be terminating.  In fact K1 could be made stronger by saying-   ... then (not (fw >= fs) or not (fs >= fs))-But it's not enough for S to be terminating; we also want completeness.-That is, we want to be able to solve all soluble wanted equalities.-Suppose we have--   work-item   b -G-> a-   inert-item  a -W-> b--Assuming (G >= W) but not (W >= W), this fulfills all the conditions,-so we could extend the inerts, thus:--   inert-items   b -G-> a-                 a -W-> b--But if we kicked-out the inert item, we'd get--   work-item     a -W-> b-   inert-item    b -G-> a--Then rewrite the work-item gives us (a -W-> a), which is soluble via Refl.-So we add one more clause to the kick-out criteria--Another way to understand (K3) is that we treat an inert item-        a -f-> b-in the same way as-        b -f-> a-So if we kick out one, we should kick out the other.  The orientation-is somewhat accidental.--When considering roles, we also need the second clause (K3b). Consider--  work-item    c -G/N-> a-  inert-item   a -W/R-> b c--The work-item doesn't get rewritten by the inert, because (>=) doesn't hold.-But we don't kick out the inert item because not (W/R >= W/R).  So we just-add the work item. But then, consider if we hit the following:--  work-item    b -G/N-> Id-  inert-items  a -W/R-> b c-               c -G/N-> a-where-  newtype Id x = Id x--For similar reasons, if we only had (K3a), we wouldn't kick the-representational inert out. And then, we'd miss solving the inert, which-now reduced to reflexivity.--The solution here is to kick out representational inerts whenever the-lhs of a work item is "exposed", where exposed means being at the-head of the top-level application chain (lhs t1 .. tn).  See-is_can_eq_lhs_head. This is encoded in (K3b).--Beware: if we make this test succeed too often, we kick out too much,-and the solver might loop.  Consider (#14363)-  work item:   [G] a ~R f b-  inert item:  [G] b ~R f a-In GHC 8.2 the completeness tests more aggressive, and kicked out-the inert item; but no rewriting happened and there was an infinite-loop.  All we need is to have the tyvar at the head.--Note [Flavours with roles]-~~~~~~~~~~~~~~~~~~~~~~~~~~-The system described in Note [inert_eqs: the inert equalities]-discusses an abstract-set of flavours. In GHC, flavours have two components: the flavour proper,-taken from {Wanted, Derived, Given} and the equality relation (often called-role), taken from {NomEq, ReprEq}.-When substituting w.r.t. the inert set,-as described in Note [inert_eqs: the inert equalities],-we must be careful to respect all components of a flavour.-For example, if we have--  inert set: a -G/R-> Int-             b -G/R-> Bool--  type role T nominal representational--and we wish to compute S(W/R, T a b), the correct answer is T a Bool, NOT-T Int Bool. The reason is that T's first parameter has a nominal role, and-thus rewriting a to Int in T a b is wrong. Indeed, this non-congruence of-substitution means that the proof in Note [The inert equalities] may need-to be revisited, but we don't think that the end conclusion is wrong.--}--instance Outputable InertCans where-  ppr (IC { inert_eqs = eqs-          , inert_funeqs = funeqs-          , inert_dicts = dicts-          , inert_safehask = safehask-          , inert_irreds = irreds-          , inert_blocked = blocked-          , inert_given_eq_lvl = ge_lvl-          , inert_given_eqs = given_eqs-          , inert_insts = insts })--    = braces $ vcat-      [ ppUnless (isEmptyDVarEnv eqs) $-        text "Equalities:"-          <+> pprCts (foldDVarEnv folder emptyCts eqs)-      , ppUnless (isEmptyTcAppMap funeqs) $-        text "Type-function equalities =" <+> pprCts (foldFunEqs folder funeqs emptyCts)-      , ppUnless (isEmptyTcAppMap dicts) $-        text "Dictionaries =" <+> pprCts (dictsToBag dicts)-      , ppUnless (isEmptyTcAppMap safehask) $-        text "Safe Haskell unsafe overlap =" <+> pprCts (dictsToBag safehask)-      , ppUnless (isEmptyCts irreds) $-        text "Irreds =" <+> pprCts irreds-      , ppUnless (isEmptyCts blocked) $-        text "Blocked =" <+> pprCts blocked-      , ppUnless (null insts) $-        text "Given instances =" <+> vcat (map ppr insts)-      , text "Innermost given equalities =" <+> ppr ge_lvl-      , text "Given eqs at this level =" <+> ppr given_eqs-      ]-    where-      folder (EqualCtList eqs) rest = nonEmptyToBag eqs `andCts` rest--{- *********************************************************************-*                                                                      *-             Shadow constraints and improvement-*                                                                      *-************************************************************************--Note [The improvement story and derived shadows]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Because Wanteds cannot rewrite Wanteds (see Note [Wanteds do not-rewrite Wanteds] in GHC.Tc.Types.Constraint), we may miss some opportunities for-solving.  Here's a classic example (indexed-types/should_fail/T4093a)--    Ambiguity check for f: (Foo e ~ Maybe e) => Foo e--    We get [G] Foo e ~ Maybe e    (CEqCan)-           [W] Foo ee ~ Foo e     (CEqCan)       -- ee is a unification variable-           [W] Foo ee ~ Maybe ee  (CEqCan)--    The first Wanted gets rewritten to--           [W] Foo ee ~ Maybe e--    But now we appear to be stuck, since we don't rewrite Wanteds with-    Wanteds.  This is silly because we can see that ee := e is the-    only solution.--The basic plan is-  * generate Derived constraints that shadow Wanted constraints-  * allow Derived to rewrite Derived-  * in order to cause some unifications to take place-  * that in turn solve the original Wanteds--The ONLY reason for all these Derived equalities is to tell us how to-unify a variable: that is, what Mark Jones calls "improvement".--The same idea is sometimes also called "saturation"; find all the-equalities that must hold in any solution.--Or, equivalently, you can think of the derived shadows as implementing-the "model": a non-idempotent but no-occurs-check substitution,-reflecting *all* *Nominal* equalities (a ~N ty) that are not-immediately soluble by unification.--More specifically, here's how it works (Oct 16):--* Wanted constraints are born as [WD]; this behaves like a-  [W] and a [D] paired together.--* When we are about to add a [WD] to the inert set, if it can-  be rewritten by a [D] a ~ ty, then we split it into [W] and [D],-  putting the latter into the work list (see maybeEmitShadow).--In the example above, we get to the point where we are stuck:-    [WD] Foo ee ~ Foo e-    [WD] Foo ee ~ Maybe ee--But now when [WD] Foo ee ~ Maybe ee is about to be added, we'll-split it into [W] and [D], since the inert [WD] Foo ee ~ Foo e-can rewrite it.  Then:-    work item: [D] Foo ee ~ Maybe ee-    inert:     [W] Foo ee ~ Maybe ee-               [WD] Foo ee ~ Maybe e--See Note [Splitting WD constraints].  Now the work item is rewritten-by the [WD] and we soon get ee := e.--Additional notes:--  * The derived shadow equalities live in inert_eqs, along with-    the Givens and Wanteds; see Note [EqualCtList invariants].--  * We make Derived shadows only for Wanteds, not Givens.  So we-    have only [G], not [GD] and [G] plus splitting.  See-    Note [Add derived shadows only for Wanteds]--  * We also get Derived equalities from functional dependencies-    and type-function injectivity; see calls to unifyDerived.--  * It's worth having [WD] rather than just [W] and [D] because-    * efficiency: silly to process the same thing twice-    * inert_dicts is a finite map keyed by-      the type; it's inconvenient for it to map to TWO constraints--Another example requiring Deriveds is in-Note [Put touchable variables on the left] in GHC.Tc.Solver.Canonical.--Note [Splitting WD constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We are about to add a [WD] constraint to the inert set; and we-know that the inert set has fully rewritten it.  Should we split-it into [W] and [D], and put the [D] in the work list for further-work?--* CDictCan (C tys):-  Yes if the inert set could rewrite tys to make the class constraint,-  or type family, fire.  That is, yes if the inert_eqs intersects-  with the free vars of tys.  For this test we use-  (anyRewritableTyVar True) which ignores casts and coercions in tys,-  because rewriting the casts or coercions won't make the thing fire-  more often.--* CEqCan (lhs ~ ty): Yes if the inert set could rewrite 'lhs' or 'ty'.-  We need to check both 'lhs' and 'ty' against the inert set:-    - Inert set contains  [D] a ~ ty2-      Then we want to put [D] a ~ ty in the worklist, so we'll-      get [D] ty ~ ty2 with consequent good things--    - Inert set contains [D] b ~ a, where b is in ty.-      We can't just add [WD] a ~ ty[b] to the inert set, because-      that breaks the inert-set invariants.  If we tried to-      canonicalise another [D] constraint mentioning 'a', we'd-      get an infinite loop--  Moreover we must use (anyRewritableTyVar False) for the RHS,-  because even tyvars in the casts and coercions could give-  an infinite loop if we don't expose it--* CIrredCan: Yes if the inert set can rewrite the constraint.-  We used to think splitting irreds was unnecessary, but-  see Note [Splitting Irred WD constraints]--* Others: nothing is gained by splitting.--Note [Splitting Irred WD constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Splitting Irred constraints can make a difference. Here is the-scenario:--  a[sk] :: F v     -- F is a type family-  beta :: alpha--  work item: [WD] a ~ beta--This is heterogeneous, so we emit a kind equality and make the work item an-inert Irred.--  work item: [D] F v ~ alpha-  inert: [WD] (a |> co) ~ beta (CIrredCan)--Can't make progress on the work item. Add to inert set. This kicks out the-old inert, because a [D] can rewrite a [WD].--  work item: [WD] (a |> co) ~ beta-  inert: [D] F v ~ alpha (CEqCan)--Can't make progress on this work item either (although GHC tries by-decomposing the cast and rewriting... but that doesn't make a difference),-which is still hetero. Emit a new kind equality and add to inert set. But,-critically, we split the Irred.--  work list:-   [D] F v ~ alpha (CEqCan)-   [D] (a |> co) ~ beta (CIrred) -- this one was split off-  inert:-   [W] (a |> co) ~ beta-   [D] F v ~ alpha--We quickly solve the first work item, as it's the same as an inert.--  work item: [D] (a |> co) ~ beta-  inert:-   [W] (a |> co) ~ beta-   [D] F v ~ alpha--We decompose the cast, yielding--  [D] a ~ beta--We then rewrite the kinds. The lhs kind is F v, which flattens to alpha.--  co' :: F v ~ alpha-  [D] (a |> co') ~ beta--Now this equality is homo-kinded. So we swizzle it around to--  [D] beta ~ (a |> co')--and set beta := a |> co', and go home happy.--If we don't split the Irreds, we loop. This is all dangerously subtle.--This is triggered by test case typecheck/should_compile/SplitWD.--Note [Add derived shadows only for Wanteds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We only add shadows for Wanted constraints. That is, we have-[WD] but not [GD]; and maybeEmitShaodw looks only at [WD]-constraints.--It does just possibly make sense ot add a derived shadow for a-Given. If we created a Derived shadow of a Given, it could be-rewritten by other Deriveds, and that could, conceivably, lead to a-useful unification.--But (a) I have been unable to come up with an example of this-        happening-    (b) see #12660 for how adding the derived shadows-        of a Given led to an infinite loop.-    (c) It's unlikely that rewriting derived Givens will lead-        to a unification because Givens don't mention touchable-        unification variables--For (b) there may be other ways to solve the loop, but simply-reraining from adding derived shadows of Givens is particularly-simple.  And it's more efficient too!--Still, here's one possible reason for adding derived shadows-for Givens.  Consider-           work-item [G] a ~ [b], inerts has [D] b ~ a.-If we added the derived shadow (into the work list)-         [D] a ~ [b]-When we process it, we'll rewrite to a ~ [a] and get an-occurs check.  Without it we'll miss the occurs check (reporting-inaccessible code); but that's probably OK.--Note [Keep CDictCan shadows as CDictCan]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have-  class C a => D a b-and [G] D a b, [G] C a in the inert set.  Now we insert-[D] b ~ c.  We want to kick out a derived shadow for [D] D a b,-so we can rewrite it with the new constraint, and perhaps get-instance reduction or other consequences.--BUT we do not want to kick out a *non-canonical* (D a b). If we-did, we would do this:-  - rewrite it to [D] D a c, with pend_sc = True-  - use expandSuperClasses to add C a-  - go round again, which solves C a from the givens-This loop goes on for ever and triggers the simpl_loop limit.--Solution: kick out the CDictCan which will have pend_sc = False,-because we've already added its superclasses.  So we won't re-add-them.  If we forget the pend_sc flag, our cunning scheme for avoiding-generating superclasses repeatedly will fail.--See #11379 for a case of this.--Note [Do not do improvement for WOnly]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We do improvement between two constraints (e.g. for injectivity-or functional dependencies) only if both are "improvable". And-we improve a constraint wrt the top-level instances only if-it is improvable.--Improvable:     [G] [WD] [D}-Not improvable: [W]--Reasons:--* It's less work: fewer pairs to compare--* Every [W] has a shadow [D] so nothing is lost--* Consider [WD] C Int b,  where 'b' is a skolem, and-    class C a b | a -> b-    instance C Int Bool-  We'll do a fundep on it and emit [D] b ~ Bool-  That will kick out constraint [WD] C Int b-  Then we'll split it to [W] C Int b (keep in inert)-                     and [D] C Int b (in work list)-  When processing the latter we'll rewrite it to-        [D] C Int Bool-  At that point it would be /stupid/ to interact it-  with the inert [W] C Int b in the inert set; after all,-  it's the very constraint from which the [D] C Int Bool-  was split!  We can avoid this by not doing improvement-  on [W] constraints. This came up in #12860.--}--maybeEmitShadow :: InertCans -> Ct -> TcS Ct--- See Note [The improvement story and derived shadows]-maybeEmitShadow ics ct-  | let ev = ctEvidence ct-  , CtWanted { ctev_pred = pred, ctev_loc = loc-             , ctev_nosh = WDeriv } <- ev-  , shouldSplitWD (inert_eqs ics) (inert_funeqs ics) ct-  = do { traceTcS "Emit derived shadow" (ppr ct)-       ; let derived_ev = CtDerived { ctev_pred = pred-                                    , ctev_loc  = loc }-             shadow_ct = ct { cc_ev = derived_ev }-               -- Te shadow constraint keeps the canonical shape.-               -- This just saves work, but is sometimes important;-               -- see Note [Keep CDictCan shadows as CDictCan]-       ; emitWork [shadow_ct]--       ; let ev' = ev { ctev_nosh = WOnly }-             ct' = ct { cc_ev = ev' }-                 -- Record that it now has a shadow-                 -- This is /the/ place we set the flag to WOnly-       ; return ct' }--  | otherwise-  = return ct--shouldSplitWD :: InertEqs -> FunEqMap EqualCtList -> Ct -> Bool--- Precondition: 'ct' is [WD], and is inert--- True <=> we should split ct ito [W] and [D] because---          the inert_eqs can make progress on the [D]--- See Note [Splitting WD constraints]--shouldSplitWD inert_eqs fun_eqs (CDictCan { cc_tyargs = tys })-  = should_split_match_args inert_eqs fun_eqs tys-    -- NB True: ignore coercions-    -- See Note [Splitting WD constraints]--shouldSplitWD inert_eqs fun_eqs (CEqCan { cc_lhs = TyVarLHS tv, cc_rhs = ty-                                        , cc_eq_rel = eq_rel })-  =  tv `elemDVarEnv` inert_eqs-  || anyRewritableCanEqLHS eq_rel (canRewriteTv inert_eqs) (canRewriteTyFam fun_eqs) ty-  -- NB False: do not ignore casts and coercions-  -- See Note [Splitting WD constraints]--shouldSplitWD inert_eqs fun_eqs (CEqCan { cc_ev = ev, cc_eq_rel = eq_rel })-  = anyRewritableCanEqLHS eq_rel (canRewriteTv inert_eqs) (canRewriteTyFam fun_eqs)-                          (ctEvPred ev)--shouldSplitWD inert_eqs fun_eqs (CIrredCan { cc_ev = ev })-  = anyRewritableCanEqLHS (ctEvEqRel ev) (canRewriteTv inert_eqs)-                          (canRewriteTyFam fun_eqs) (ctEvPred ev)--shouldSplitWD _ _ _ = False   -- No point in splitting otherwise--should_split_match_args :: InertEqs -> FunEqMap EqualCtList -> [TcType] -> Bool--- True if the inert_eqs can rewrite anything in the argument types-should_split_match_args inert_eqs fun_eqs tys-  = any (anyRewritableCanEqLHS NomEq (canRewriteTv inert_eqs) (canRewriteTyFam fun_eqs)) tys-    -- See Note [Splitting WD constraints]--canRewriteTv :: InertEqs -> EqRel -> TyVar -> Bool-canRewriteTv inert_eqs eq_rel tv-  | Just (EqualCtList (ct :| _)) <- lookupDVarEnv inert_eqs tv-  , CEqCan { cc_eq_rel = eq_rel1 } <- ct-  = eq_rel1 `eqCanRewrite` eq_rel-  | otherwise-  = False--canRewriteTyFam :: FunEqMap EqualCtList -> EqRel -> TyCon -> [Type] -> Bool-canRewriteTyFam fun_eqs eq_rel tf args-  | Just (EqualCtList (ct :| _)) <- findFunEq fun_eqs tf args-  , CEqCan { cc_eq_rel = eq_rel1 } <- ct-  = eq_rel1 `eqCanRewrite` eq_rel-  | otherwise-  = False--isImprovable :: CtEvidence -> Bool--- See Note [Do not do improvement for WOnly]-isImprovable (CtWanted { ctev_nosh = WOnly }) = False-isImprovable _                                = True---{- *********************************************************************-*                                                                      *-                   Inert equalities-*                                                                      *-********************************************************************* -}--addTyEq :: InertEqs -> TcTyVar -> Ct -> InertEqs-addTyEq old_eqs tv ct-  = extendDVarEnv_C add_eq old_eqs tv (unitEqualCtList ct)-  where-    add_eq old_eqs _ = addToEqualCtList ct old_eqs--addCanFunEq :: FunEqMap EqualCtList -> TyCon -> [TcType] -> Ct-            -> FunEqMap EqualCtList-addCanFunEq old_eqs fun_tc fun_args ct-  = alterTcApp old_eqs fun_tc fun_args upd-  where-    upd (Just old_equal_ct_list) = Just $ addToEqualCtList ct old_equal_ct_list-    upd Nothing                  = Just $ unitEqualCtList ct--foldTyEqs :: (Ct -> b -> b) -> InertEqs -> b -> b-foldTyEqs k eqs z-  = foldDVarEnv (\(EqualCtList cts) z -> foldr k z cts) z eqs--findTyEqs :: InertCans -> TyVar -> [Ct]-findTyEqs icans tv = maybe [] id (fmap @Maybe equalCtListToList $-                                  lookupDVarEnv (inert_eqs icans) tv)--delEq :: InertCans -> CanEqLHS -> TcType -> InertCans-delEq ic lhs rhs = case lhs of-    TyVarLHS tv-      -> ic { inert_eqs = alterDVarEnv upd (inert_eqs ic) tv }-    TyFamLHS tf args-      -> ic { inert_funeqs = alterTcApp (inert_funeqs ic) tf args upd }-  where-    isThisOne :: Ct -> Bool-    isThisOne (CEqCan { cc_rhs = t1 }) = tcEqTypeNoKindCheck rhs t1-    isThisOne other = pprPanic "delEq" (ppr lhs $$ ppr ic $$ ppr other)--    upd :: Maybe EqualCtList -> Maybe EqualCtList-    upd (Just eq_ct_list) = filterEqualCtList (not . isThisOne) eq_ct_list-    upd Nothing           = Nothing--findEq :: InertCans -> CanEqLHS -> [Ct]-findEq icans (TyVarLHS tv) = findTyEqs icans tv-findEq icans (TyFamLHS fun_tc fun_args)-  = maybe [] id (fmap @Maybe equalCtListToList $-                 findFunEq (inert_funeqs icans) fun_tc fun_args)--{- *********************************************************************-*                                                                      *-                   Inert instances: inert_insts-*                                                                      *-********************************************************************* -}--addInertForAll :: QCInst -> TcS ()--- Add a local Given instance, typically arising from a type signature-addInertForAll new_qci-  = do { ics  <- getInertCans-       ; ics1 <- add_qci ics--       -- Update given equalities. C.f updateGivenEqs-       ; tclvl <- getTcLevel-       ; let pred         = qci_pred new_qci-             not_equality = isClassPred pred && not (isEqPred pred)-                  -- True <=> definitely not an equality-                  -- A qci_pred like (f a) might be an equality--             ics2 | not_equality = ics1-                  | otherwise    = ics1 { inert_given_eq_lvl = tclvl-                                        , inert_given_eqs    = True }--       ; setInertCans ics2 }-  where-    add_qci :: InertCans -> TcS InertCans-    -- See Note [Do not add duplicate quantified instances]-    add_qci ics@(IC { inert_insts = qcis })-      | any same_qci qcis-      = do { traceTcS "skipping duplicate quantified instance" (ppr new_qci)-           ; return ics }--      | otherwise-      = do { traceTcS "adding new inert quantified instance" (ppr new_qci)-           ; return (ics { inert_insts = new_qci : qcis }) }--    same_qci old_qci = tcEqType (ctEvPred (qci_ev old_qci))-                                (ctEvPred (qci_ev new_qci))--{- Note [Do not add duplicate quantified instances]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this (#15244):--  f :: (C g, D g) => ....-  class S g => C g where ...-  class S g => D g where ...-  class (forall a. Eq a => Eq (g a)) => S g where ...--Then in f's RHS there are two identical quantified constraints-available, one via the superclasses of C and one via the superclasses-of D.  The two are identical, and it seems wrong to reject the program-because of that. But without doing duplicate-elimination we will have-two matching QCInsts when we try to solve constraints arising from f's-RHS.--The simplest thing is simply to eliminate duplicates, which we do here.--}--{- *********************************************************************-*                                                                      *-                  Adding an inert-*                                                                      *-************************************************************************--Note [Adding an equality to the InertCans]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When adding an equality to the inerts:--* Split [WD] into [W] and [D] if the inerts can rewrite the latter;-  done by maybeEmitShadow.--* Kick out any constraints that can be rewritten by the thing-  we are adding.  Done by kickOutRewritable.--* Note that unifying a:=ty, is like adding [G] a~ty; just use-  kickOutRewritable with Nominal, Given.  See kickOutAfterUnification.--}--addInertCan :: Ct -> TcS ()--- Precondition: item /is/ canonical--- See Note [Adding an equality to the InertCans]-addInertCan ct-  = do { traceTcS "addInertCan {" $-         text "Trying to insert new inert item:" <+> ppr ct--       ; ics <- getInertCans-       ; ct  <- maybeEmitShadow ics ct-       ; ics <- maybeKickOut ics ct-       ; tclvl <- getTcLevel-       ; setInertCans (add_item tclvl ics ct)--       ; traceTcS "addInertCan }" $ empty }--maybeKickOut :: InertCans -> Ct -> TcS InertCans--- For a CEqCan, kick out any inert that can be rewritten by the CEqCan-maybeKickOut ics ct-  | CEqCan { cc_lhs = lhs, cc_ev = ev, cc_eq_rel = eq_rel } <- ct-  = do { (_, ics') <- kickOutRewritable (ctEvFlavour ev, eq_rel) lhs ics-       ; return ics' }-  | otherwise-  = return ics--add_item :: TcLevel -> InertCans -> Ct -> InertCans-add_item tc_lvl-         ics@(IC { inert_funeqs = funeqs, inert_eqs = eqs })-         item@(CEqCan { cc_lhs = lhs })-  = updateGivenEqs tc_lvl item $-    case lhs of-       TyFamLHS tc tys -> ics { inert_funeqs = addCanFunEq funeqs tc tys item }-       TyVarLHS tv     -> ics { inert_eqs    = addTyEq eqs tv item }--add_item tc_lvl ics@(IC { inert_blocked = blocked })-         item@(CIrredCan { cc_reason = HoleBlockerReason {}})-  = updateGivenEqs tc_lvl item $  -- this item is always an equality-    ics { inert_blocked = blocked `snocBag` item }--add_item tc_lvl ics@(IC { inert_irreds = irreds }) item@(CIrredCan {})-  = updateGivenEqs tc_lvl item $   -- An Irred might turn out to be an-                                 -- equality, so we play safe-    ics { inert_irreds = irreds `Bag.snocBag` item }--add_item _ ics item@(CDictCan { cc_class = cls, cc_tyargs = tys })-  = ics { inert_dicts = addDictCt (inert_dicts ics) cls tys item }--add_item _ _ item-  = pprPanic "upd_inert set: can't happen! Inserting " $-    ppr item   -- Can't be CNonCanonical because they only land in inert_irreds--updateGivenEqs :: TcLevel -> Ct -> InertCans -> InertCans--- Set the inert_given_eq_level to the current level (tclvl)--- if the constraint is a given equality that should prevent--- filling in an outer unification variable.--- See See Note [Tracking Given equalities]-updateGivenEqs tclvl ct inerts@(IC { inert_given_eq_lvl = ge_lvl })-  | not (isGivenCt ct) = inerts-  | not_equality ct    = inerts -- See Note [Let-bound skolems]-  | otherwise          = inerts { inert_given_eq_lvl = ge_lvl'-                                , inert_given_eqs    = True }-  where-    ge_lvl' | mentionsOuterVar tclvl (ctEvidence ct)-              -- Includes things like (c a), which *might* be an equality-            = tclvl-            | otherwise-            = ge_lvl--    not_equality :: Ct -> Bool-    -- True <=> definitely not an equality of any kind-    --          except for a let-bound skolem, which doesn't count-    --          See Note [Let-bound skolems]-    -- NB: no need to spot the boxed CDictCan (a ~ b) because its-    --     superclass (a ~# b) will be a CEqCan-    not_equality (CEqCan { cc_lhs = TyVarLHS tv }) = not (isOuterTyVar tclvl tv)-    not_equality (CDictCan {})                     = True-    not_equality _                                 = False--------------------------------------------kickOutRewritable  :: CtFlavourRole  -- Flavour/role of the equality that-                                      -- is being added to the inert set-                   -> CanEqLHS        -- The new equality is lhs ~ ty-                   -> InertCans-                   -> TcS (Int, InertCans)-kickOutRewritable new_fr new_lhs ics-  = do { let (kicked_out, ics') = kick_out_rewritable new_fr new_lhs ics-             n_kicked = workListSize kicked_out--       ; unless (n_kicked == 0) $-         do { updWorkListTcS (appendWorkList kicked_out)--              -- The famapp-cache contains Given evidence from the inert set.-              -- If we're kicking out Givens, we need to remove this evidence-              -- from the cache, too.-            ; let kicked_given_ev_vars =-                    [ ev_var | ct <- wl_eqs kicked_out-                             , CtGiven { ctev_evar = ev_var } <- [ctEvidence ct] ]-            ; when (new_fr `eqCanRewriteFR` (Given, NomEq) &&-                   -- if this isn't true, no use looking through the constraints-                    not (null kicked_given_ev_vars)) $-              do { traceTcS "Given(s) have been kicked out; drop from famapp-cache"-                            (ppr kicked_given_ev_vars)-                 ; dropFromFamAppCache (mkVarSet kicked_given_ev_vars) }--            ; csTraceTcS $-              hang (text "Kick out, lhs =" <+> ppr new_lhs)-                 2 (vcat [ text "n-kicked =" <+> int n_kicked-                         , text "kicked_out =" <+> ppr kicked_out-                         , text "Residual inerts =" <+> ppr ics' ]) }--       ; return (n_kicked, ics') }--kick_out_rewritable :: CtFlavourRole  -- Flavour/role of the equality that-                                      -- is being added to the inert set-                    -> CanEqLHS       -- The new equality is lhs ~ ty-                    -> InertCans-                    -> (WorkList, InertCans)--- See Note [kickOutRewritable]-kick_out_rewritable new_fr new_lhs-                    ics@(IC { inert_eqs      = tv_eqs-                            , inert_dicts    = dictmap-                            , inert_funeqs   = funeqmap-                            , inert_irreds   = irreds-                            , inert_insts    = old_insts })-  | not (new_fr `eqMayRewriteFR` new_fr)-  = (emptyWorkList, ics)-        -- If new_fr can't rewrite itself, it can't rewrite-        -- anything else, so no need to kick out anything.-        -- (This is a common case: wanteds can't rewrite wanteds)-        -- Lemma (L2) in Note [Extending the inert equalities]--  | otherwise-  = (kicked_out, inert_cans_in)-  where-    -- inert_safehask stays unchanged; is that right?-    inert_cans_in = ics { inert_eqs      = tv_eqs_in-                        , inert_dicts    = dicts_in-                        , inert_funeqs   = feqs_in-                        , inert_irreds   = irs_in-                        , inert_insts    = insts_in }--    kicked_out :: WorkList-    -- NB: use extendWorkList to ensure that kicked-out equalities get priority-    -- See Note [Prioritise equalities] (Kick-out).-    -- The irreds may include non-canonical (hetero-kinded) equality-    -- constraints, which perhaps may have become soluble after new_lhs-    -- is substituted; ditto the dictionaries, which may include (a~b)-    -- or (a~~b) constraints.-    kicked_out = foldr extendWorkListCt-                          (emptyWorkList { wl_eqs = tv_eqs_out ++ feqs_out })-                          ((dicts_out `andCts` irs_out)-                            `extendCtsList` insts_out)--    (tv_eqs_out, tv_eqs_in) = foldDVarEnv (kick_out_eqs extend_tv_eqs)-                                          ([], emptyDVarEnv) tv_eqs-    (feqs_out,   feqs_in)   = foldFunEqs  (kick_out_eqs extend_fun_eqs)-                                          funeqmap ([], emptyFunEqs)-    (dicts_out,  dicts_in)  = partitionDicts   kick_out_ct dictmap-    (irs_out,    irs_in)    = partitionBag     kick_out_ct irreds-      -- Kick out even insolubles: See Note [Rewrite insolubles]-      -- Of course we must kick out irreducibles like (c a), in case-      -- we can rewrite 'c' to something more useful--    -- Kick-out for inert instances-    -- See Note [Quantified constraints] in GHC.Tc.Solver.Canonical-    insts_out :: [Ct]-    insts_in  :: [QCInst]-    (insts_out, insts_in)-       | fr_may_rewrite (Given, NomEq)  -- All the insts are Givens-       = partitionWith kick_out_qci old_insts-       | otherwise-       = ([], old_insts)-    kick_out_qci qci-      | let ev = qci_ev qci-      , fr_can_rewrite_ty NomEq (ctEvPred (qci_ev qci))-      = Left (mkNonCanonical ev)-      | otherwise-      = Right qci--    (_, new_role) = new_fr--    fr_tv_can_rewrite_ty :: TyVar -> EqRel -> Type -> Bool-    fr_tv_can_rewrite_ty new_tv role ty-      = anyRewritableTyVar True role can_rewrite ty-                  -- True: ignore casts and coercions-      where-        can_rewrite :: EqRel -> TyVar -> Bool-        can_rewrite old_role tv = new_role `eqCanRewrite` old_role && tv == new_tv--    fr_tf_can_rewrite_ty :: TyCon -> [TcType] -> EqRel -> Type -> Bool-    fr_tf_can_rewrite_ty new_tf new_tf_args role ty-      = anyRewritableTyFamApp role can_rewrite ty-      where-        can_rewrite :: EqRel -> TyCon -> [TcType] -> Bool-        can_rewrite old_role old_tf old_tf_args-          = new_role `eqCanRewrite` old_role &&-            tcEqTyConApps new_tf new_tf_args old_tf old_tf_args-              -- it's possible for old_tf_args to have too many. This is fine;-              -- we'll only check what we need to.--    {-# INLINE fr_can_rewrite_ty #-}   -- perform the check here only once-    fr_can_rewrite_ty :: EqRel -> Type -> Bool-    fr_can_rewrite_ty = case new_lhs of-      TyVarLHS new_tv             -> fr_tv_can_rewrite_ty new_tv-      TyFamLHS new_tf new_tf_args -> fr_tf_can_rewrite_ty new_tf new_tf_args--    fr_may_rewrite :: CtFlavourRole -> Bool-    fr_may_rewrite fs = new_fr `eqMayRewriteFR` fs-        -- Can the new item rewrite the inert item?--    {-# INLINE kick_out_ct #-}   -- perform case on new_lhs here only once-    kick_out_ct :: Ct -> Bool-    -- Kick it out if the new CEqCan can rewrite the inert one-    -- See Note [kickOutRewritable]-    kick_out_ct = case new_lhs of-      TyVarLHS new_tv -> \ct -> let fs@(_,role) = ctFlavourRole ct in-                                fr_may_rewrite fs-                             && fr_tv_can_rewrite_ty new_tv role (ctPred ct)-      TyFamLHS new_tf new_tf_args-        -> \ct -> let fs@(_, role) = ctFlavourRole ct in-                  fr_may_rewrite fs-               && fr_tf_can_rewrite_ty new_tf new_tf_args role (ctPred ct)--    extend_tv_eqs :: InertEqs -> CanEqLHS -> EqualCtList -> InertEqs-    extend_tv_eqs eqs (TyVarLHS tv) cts = extendDVarEnv eqs tv cts-    extend_tv_eqs eqs other _cts = pprPanic "extend_tv_eqs" (ppr eqs $$ ppr other)--    extend_fun_eqs :: FunEqMap EqualCtList -> CanEqLHS -> EqualCtList-                   -> FunEqMap EqualCtList-    extend_fun_eqs eqs (TyFamLHS fam_tc fam_args) cts-      = insertTcApp eqs fam_tc fam_args cts-    extend_fun_eqs eqs other _cts = pprPanic "extend_fun_eqs" (ppr eqs $$ ppr other)--    kick_out_eqs :: (container -> CanEqLHS -> EqualCtList -> container)-                 -> EqualCtList -> ([Ct], container)-                 -> ([Ct], container)-    kick_out_eqs extend eqs (acc_out, acc_in)-      = (eqs_out `chkAppend` acc_out, case listToEqualCtList eqs_in of-            Nothing -> acc_in-            Just eqs_in_ecl@(EqualCtList (eq1 :| _))-                    -> extend acc_in (cc_lhs eq1) eqs_in_ecl)-      where-        (eqs_out, eqs_in) = partition kick_out_eq (equalCtListToList eqs)--    -- Implements criteria K1-K3 in Note [Extending the inert equalities]-    kick_out_eq (CEqCan { cc_lhs = lhs, cc_rhs = rhs_ty-                        , cc_ev = ev, cc_eq_rel = eq_rel })-      | not (fr_may_rewrite fs)-      = False  -- (K0) Keep it in the inert set if the new thing can't rewrite it--      -- Below here (fr_may_rewrite fs) is True--      | TyVarLHS _ <- lhs-      , fs `eqMayRewriteFR` new_fr-      = False  -- (K4) Keep it in the inert set if the LHS is a tyvar and-               -- it can rewrite the work item. See Note [K4]--      | fr_can_rewrite_ty eq_rel (canEqLHSType lhs)-      = True   -- (K1)-         -- The above check redundantly checks the role & flavour,-         -- but it's very convenient--      | kick_out_for_inertness    = True   -- (K2)-      | kick_out_for_completeness = True   -- (K3)-      | otherwise                 = False--      where-        fs = (ctEvFlavour ev, eq_rel)-        kick_out_for_inertness-          =    (fs `eqMayRewriteFR` fs)           -- (K2a)-            && fr_can_rewrite_ty eq_rel rhs_ty    -- (K2b)--        kick_out_for_completeness  -- (K3) and Note [K3: completeness of solving]-          = case eq_rel of-              NomEq  -> rhs_ty `eqType` canEqLHSType new_lhs -- (K3a)-              ReprEq -> is_can_eq_lhs_head new_lhs rhs_ty    -- (K3b)--    kick_out_eq ct = pprPanic "keep_eq" (ppr ct)--    is_can_eq_lhs_head (TyVarLHS tv) = go-      where-        go (Rep.TyVarTy tv')   = tv == tv'-        go (Rep.AppTy fun _)   = go fun-        go (Rep.CastTy ty _)   = go ty-        go (Rep.TyConApp {})   = False-        go (Rep.LitTy {})      = False-        go (Rep.ForAllTy {})   = False-        go (Rep.FunTy {})      = False-        go (Rep.CoercionTy {}) = False-    is_can_eq_lhs_head (TyFamLHS fun_tc fun_args) = go-      where-        go (Rep.TyVarTy {})       = False-        go (Rep.AppTy {})         = False  -- no TyConApp to the left of an AppTy-        go (Rep.CastTy ty _)      = go ty-        go (Rep.TyConApp tc args) = tcEqTyConApps fun_tc fun_args tc args-        go (Rep.LitTy {})         = False-        go (Rep.ForAllTy {})      = False-        go (Rep.FunTy {})         = False-        go (Rep.CoercionTy {})    = False--kickOutAfterUnification :: TcTyVar -> TcS Int-kickOutAfterUnification new_tv-  = do { ics <- getInertCans-       ; (n_kicked, ics2) <- kickOutRewritable (Given,NomEq)-                                                 (TyVarLHS new_tv) ics-                     -- Given because the tv := xi is given; NomEq because-                     -- only nominal equalities are solved by unification--       ; setInertCans ics2-       ; return n_kicked }---- See Wrinkle (2) in Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical-kickOutAfterFillingCoercionHole :: CoercionHole -> Coercion -> TcS ()-kickOutAfterFillingCoercionHole hole filled_co-  = do { ics <- getInertCans-       ; let (kicked_out, ics') = kick_out ics-             n_kicked           = workListSize kicked_out--       ; unless (n_kicked == 0) $-         do { updWorkListTcS (appendWorkList kicked_out)-            ; csTraceTcS $-              hang (text "Kick out, hole =" <+> ppr hole)-                 2 (vcat [ text "n-kicked =" <+> int n_kicked-                         , text "kicked_out =" <+> ppr kicked_out-                         , text "Residual inerts =" <+> ppr ics' ]) }--       ; setInertCans ics' }-  where-    holes_of_co = coercionHolesOfCo filled_co--    kick_out :: InertCans -> (WorkList, InertCans)-    kick_out ics@(IC { inert_blocked = blocked })-      = let (to_kick, to_keep) = partitionBagWith kick_ct blocked--            kicked_out = extendWorkListCts (bagToList to_kick) emptyWorkList-            ics'       = ics { inert_blocked = to_keep }-        in-        (kicked_out, ics')--    kick_ct :: Ct -> Either Ct Ct-         -- Left: kick out; Right: keep. But even if we keep, we may need-         -- to update the set of blocking holes-    kick_ct ct@(CIrredCan { cc_reason = HoleBlockerReason holes })-      | hole `elementOfUniqSet` holes-      = let new_holes = holes `delOneFromUniqSet` hole-                              `unionUniqSets` holes_of_co-            updated_ct = ct { cc_reason = HoleBlockerReason new_holes }-        in-        if isEmptyUniqSet new_holes-        then Left updated_ct-        else Right updated_ct--      | otherwise-      = Right ct--    kick_ct other = pprPanic "kickOutAfterFillingCoercionHole" (ppr other)--{- Note [kickOutRewritable]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-See also Note [inert_eqs: the inert equalities].--When we add a new inert equality (lhs ~N ty) to the inert set,-we must kick out any inert items that could be rewritten by the-new equality, to maintain the inert-set invariants.--  - We want to kick out an existing inert constraint if-    a) the new constraint can rewrite the inert one-    b) 'lhs' is free in the inert constraint (so that it *will*)-       rewrite it if we kick it out.--    For (b) we use anyRewritableCanLHS, which examines the types /and-    kinds/ that are directly visible in the type. Hence-    we will have exposed all the rewriting we care about to make the-    most precise kinds visible for matching classes etc. No need to-    kick out constraints that mention type variables whose kinds-    contain this LHS!--  - A Derived equality can kick out [D] constraints in inert_eqs,-    inert_dicts, inert_irreds etc.--  - We don't kick out constraints from inert_solved_dicts, and-    inert_solved_funeqs optimistically. But when we lookup we have to-    take the substitution into account--NB: we could in principle avoid kick-out:-  a) When unifying a meta-tyvar from an outer level, because-     then the entire implication will be iterated; see-     Note [The Unification Level Flag]--  b) For Givens, after a unification.  By (GivenInv) in GHC.Tc.Utils.TcType-     Note [TcLevel invariants], a Given can't include a meta-tyvar from-     its own level, so it falls under (a).  Of course, we must still-     kick out Givens when adding a new non-unification Given.--But kicking out more vigorously may lead to earlier unification and fewer-iterations, so we don't take advantage of these possibilities.--Note [Rewrite insolubles]-~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have an insoluble alpha ~ [alpha], which is insoluble-because an occurs check.  And then we unify alpha := [Int].  Then we-really want to rewrite the insoluble to [Int] ~ [[Int]].  Now it can-be decomposed.  Otherwise we end up with a "Can't match [Int] ~-[[Int]]" which is true, but a bit confusing because the outer type-constructors match.--Hence:- * In the main simplifier loops in GHC.Tc.Solver (solveWanteds,-   simpl_loop), we feed the insolubles in solveSimpleWanteds,-   so that they get rewritten (albeit not solved).-- * We kick insolubles out of the inert set, if they can be-   rewritten (see GHC.Tc.Solver.Monad.kick_out_rewritable)-- * We rewrite those insolubles in GHC.Tc.Solver.Canonical.-   See Note [Make sure that insolubles are fully rewritten]--}-------------------addInertSafehask :: InertCans -> Ct -> InertCans-addInertSafehask ics item@(CDictCan { cc_class = cls, cc_tyargs = tys })-  = ics { inert_safehask = addDictCt (inert_dicts ics) cls tys item }--addInertSafehask _ item-  = pprPanic "addInertSafehask: can't happen! Inserting " $ ppr item--insertSafeOverlapFailureTcS :: InstanceWhat -> Ct -> TcS ()--- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver-insertSafeOverlapFailureTcS what item-  | safeOverlap what = return ()-  | otherwise        = updInertCans (\ics -> addInertSafehask ics item)--getSafeOverlapFailures :: TcS Cts--- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver-getSafeOverlapFailures- = do { IC { inert_safehask = safehask } <- getInertCans-      ; return $ foldDicts consCts safehask emptyCts }-----------------addSolvedDict :: InstanceWhat -> CtEvidence -> Class -> [Type] -> TcS ()--- Conditionally add a new item in the solved set of the monad--- See Note [Solved dictionaries]-addSolvedDict what item cls tys-  | isWanted item-  , instanceReturnsDictCon what-  = do { traceTcS "updSolvedSetTcs:" $ ppr item-       ; updInertTcS $ \ ics ->-             ics { inert_solved_dicts = addDict (inert_solved_dicts ics) cls tys item } }-  | otherwise-  = return ()--getSolvedDicts :: TcS (DictMap CtEvidence)-getSolvedDicts = do { ics <- getTcSInerts; return (inert_solved_dicts ics) }--setSolvedDicts :: DictMap CtEvidence -> TcS ()-setSolvedDicts solved_dicts-  = updInertTcS $ \ ics ->-    ics { inert_solved_dicts = solved_dicts }---{- *********************************************************************-*                                                                      *-                  Other inert-set operations-*                                                                      *-********************************************************************* -}--updInertTcS :: (InertSet -> InertSet) -> TcS ()--- Modify the inert set with the supplied function-updInertTcS upd_fn-  = do { is_var <- getTcSInertsRef-       ; wrapTcS (do { curr_inert <- TcM.readTcRef is_var-                     ; TcM.writeTcRef is_var (upd_fn curr_inert) }) }--getInertCans :: TcS InertCans-getInertCans = do { inerts <- getTcSInerts; return (inert_cans inerts) }--setInertCans :: InertCans -> TcS ()-setInertCans ics = updInertTcS $ \ inerts -> inerts { inert_cans = ics }--updRetInertCans :: (InertCans -> (a, InertCans)) -> TcS a--- Modify the inert set with the supplied function-updRetInertCans upd_fn-  = do { is_var <- getTcSInertsRef-       ; wrapTcS (do { inerts <- TcM.readTcRef is_var-                     ; let (res, cans') = upd_fn (inert_cans inerts)-                     ; TcM.writeTcRef is_var (inerts { inert_cans = cans' })-                     ; return res }) }--updInertCans :: (InertCans -> InertCans) -> TcS ()--- Modify the inert set with the supplied function-updInertCans upd_fn-  = updInertTcS $ \ inerts -> inerts { inert_cans = upd_fn (inert_cans inerts) }--updInertDicts :: (DictMap Ct -> DictMap Ct) -> TcS ()--- Modify the inert set with the supplied function-updInertDicts upd_fn-  = updInertCans $ \ ics -> ics { inert_dicts = upd_fn (inert_dicts ics) }--updInertSafehask :: (DictMap Ct -> DictMap Ct) -> TcS ()--- Modify the inert set with the supplied function-updInertSafehask upd_fn-  = updInertCans $ \ ics -> ics { inert_safehask = upd_fn (inert_safehask ics) }--updInertIrreds :: (Cts -> Cts) -> TcS ()--- Modify the inert set with the supplied function-updInertIrreds upd_fn-  = updInertCans $ \ ics -> ics { inert_irreds = upd_fn (inert_irreds ics) }--getInertEqs :: TcS (DTyVarEnv EqualCtList)-getInertEqs = do { inert <- getInertCans; return (inert_eqs inert) }--getInnermostGivenEqLevel :: TcS TcLevel-getInnermostGivenEqLevel = do { inert <- getInertCans-                              ; return (inert_given_eq_lvl inert) }--getInertInsols :: TcS Cts--- Returns insoluble equality constraints--- specifically including Givens-getInertInsols = do { inert <- getInertCans-                    ; return (filterBag insolubleEqCt (inert_irreds inert)) }--getInertGivens :: TcS [Ct]--- Returns the Given constraints in the inert set-getInertGivens-  = do { inerts <- getInertCans-       ; let all_cts = foldDicts (:) (inert_dicts inerts)-                     $ foldFunEqs (\ecl out -> equalCtListToList ecl ++ out)-                                  (inert_funeqs inerts)-                     $ concatMap equalCtListToList (dVarEnvElts (inert_eqs inerts))-       ; return (filter isGivenCt all_cts) }--getPendingGivenScs :: TcS [Ct]--- Find all inert Given dictionaries, or quantified constraints,---     whose cc_pend_sc flag is True---     and that belong to the current level--- Set their cc_pend_sc flag to False in the inert set, and return that Ct-getPendingGivenScs = do { lvl <- getTcLevel-                        ; updRetInertCans (get_sc_pending lvl) }--get_sc_pending :: TcLevel -> InertCans -> ([Ct], InertCans)-get_sc_pending this_lvl ic@(IC { inert_dicts = dicts, inert_insts = insts })-  = ASSERT2( all isGivenCt sc_pending, ppr sc_pending )-       -- When getPendingScDics is called,-       -- there are never any Wanteds in the inert set-    (sc_pending, ic { inert_dicts = dicts', inert_insts = insts' })-  where-    sc_pending = sc_pend_insts ++ sc_pend_dicts--    sc_pend_dicts = foldDicts get_pending dicts []-    dicts' = foldr add dicts sc_pend_dicts--    (sc_pend_insts, insts') = mapAccumL get_pending_inst [] insts--    get_pending :: Ct -> [Ct] -> [Ct]  -- Get dicts with cc_pend_sc = True-                                       -- but flipping the flag-    get_pending dict dicts-        | Just dict' <- isPendingScDict dict-        , belongs_to_this_level (ctEvidence dict)-        = dict' : dicts-        | otherwise-        = dicts--    add :: Ct -> DictMap Ct -> DictMap Ct-    add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) dicts-        = addDictCt dicts cls tys ct-    add ct _ = pprPanic "getPendingScDicts" (ppr ct)--    get_pending_inst :: [Ct] -> QCInst -> ([Ct], QCInst)-    get_pending_inst cts qci@(QCI { qci_ev = ev })-       | Just qci' <- isPendingScInst qci-       , belongs_to_this_level ev-       = (CQuantCan qci' : cts, qci')-       | otherwise-       = (cts, qci)--    belongs_to_this_level ev = ctLocLevel (ctEvLoc ev) == this_lvl-    -- We only want Givens from this level; see (3a) in-    -- Note [The superclass story] in GHC.Tc.Solver.Canonical--getUnsolvedInerts :: TcS ( Bag Implication-                         , Cts )   -- All simple constraints--- Return all the unsolved [Wanted] or [Derived] constraints------ Post-condition: the returned simple constraints are all fully zonked---                     (because they come from the inert set)---                 the unsolved implics may not be-getUnsolvedInerts- = do { IC { inert_eqs     = tv_eqs-           , inert_funeqs  = fun_eqs-           , inert_irreds  = irreds-           , inert_blocked = blocked-           , inert_dicts   = idicts-           } <- getInertCans--      ; let unsolved_tv_eqs  = foldTyEqs add_if_unsolved tv_eqs emptyCts-            unsolved_fun_eqs = foldFunEqs add_if_unsolveds fun_eqs emptyCts-            unsolved_irreds  = Bag.filterBag is_unsolved irreds-            unsolved_blocked = blocked  -- all blocked equalities are W/D-            unsolved_dicts   = foldDicts add_if_unsolved idicts emptyCts-            unsolved_others  = unionManyBags [ unsolved_irreds-                                             , unsolved_dicts-                                             , unsolved_blocked ]--      ; implics <- getWorkListImplics--      ; traceTcS "getUnsolvedInerts" $-        vcat [ text " tv eqs =" <+> ppr unsolved_tv_eqs-             , text "fun eqs =" <+> ppr unsolved_fun_eqs-             , text "others =" <+> ppr unsolved_others-             , text "implics =" <+> ppr implics ]--      ; return ( implics, unsolved_tv_eqs `unionBags`-                          unsolved_fun_eqs `unionBags`-                          unsolved_others) }-  where-    add_if_unsolved :: Ct -> Cts -> Cts-    add_if_unsolved ct cts | is_unsolved ct = ct `consCts` cts-                           | otherwise      = cts--    add_if_unsolveds :: EqualCtList -> Cts -> Cts-    add_if_unsolveds new_cts old_cts = foldr add_if_unsolved old_cts-                                             (equalCtListToList new_cts)--    is_unsolved ct = not (isGivenCt ct)   -- Wanted or Derived--getHasGivenEqs :: TcLevel           -- TcLevel of this implication-               -> TcS ( HasGivenEqs -- are there Given equalities?-                      , Cts )       -- Insoluble equalities arising from givens--- See Note [Tracking Given equalities]-getHasGivenEqs tclvl-  = do { inerts@(IC { inert_irreds       = irreds-                    , inert_given_eqs    = given_eqs-                    , inert_given_eq_lvl = ge_lvl })-              <- getInertCans-       ; let insols = filterBag insolubleEqCt irreds-                      -- Specifically includes ones that originated in some-                      -- outer context but were refined to an insoluble by-                      -- a local equality; so do /not/ add ct_given_here.--             -- See Note [HasGivenEqs] in GHC.Tc.Types.Constraint, and-             -- Note [Tracking Given equalities] in this module-             has_ge | ge_lvl == tclvl = MaybeGivenEqs-                    | given_eqs       = LocalGivenEqs-                    | otherwise       = NoGivenEqs--       ; traceTcS "getHasGivenEqs" $-         vcat [ text "given_eqs:" <+> ppr given_eqs-              , text "ge_lvl:" <+> ppr ge_lvl-              , text "ambient level:" <+> ppr tclvl-              , text "Inerts:" <+> ppr inerts-              , text "Insols:" <+> ppr insols]-       ; return (has_ge, insols) }--mentionsOuterVar :: TcLevel -> CtEvidence -> Bool-mentionsOuterVar tclvl ev-  = anyFreeVarsOfType (isOuterTyVar tclvl) $-    ctEvPred ev--isOuterTyVar :: TcLevel -> TyCoVar -> Bool--- True of a type variable that comes from a--- shallower level than the ambient level (tclvl)-isOuterTyVar tclvl tv-  | isTyVar tv = ASSERT2( not (isTouchableMetaTyVar tclvl tv), ppr tv <+> ppr tclvl  )-                 tclvl `strictlyDeeperThan` tcTyVarLevel tv-    -- ASSERT: we are dealing with Givens here, and invariant (GivenInv) from-    -- Note Note [TcLevel invariants] in GHC.Tc.Utils.TcType ensures that there can't-    -- be a touchable meta tyvar.   If this wasn't true, you might worry that,-    -- at level 3, a meta-tv alpha[3] gets unified with skolem b[2], and thereby-    -- becomes "outer" even though its level numbers says it isn't.-  | otherwise  = False  -- Coercion variables; doesn't much matter---- | Returns Given constraints that might,--- potentially, match the given pred. This is used when checking to see if a--- Given might overlap with an instance. See Note [Instance and Given overlap]--- in "GHC.Tc.Solver.Interact"-matchableGivens :: CtLoc -> PredType -> InertSet -> Cts-matchableGivens loc_w pred_w inerts@(IS { inert_cans = inert_cans })-  = filterBag matchable_given all_relevant_givens-  where-    -- just look in class constraints and irreds. matchableGivens does get called-    -- for ~R constraints, but we don't need to look through equalities, because-    -- canonical equalities are used for rewriting. We'll only get caught by-    -- non-canonical -- that is, irreducible -- equalities.-    all_relevant_givens :: Cts-    all_relevant_givens-      | Just (clas, _) <- getClassPredTys_maybe pred_w-      = findDictsByClass (inert_dicts inert_cans) clas-        `unionBags` inert_irreds inert_cans-      | otherwise-      = inert_irreds inert_cans--    matchable_given :: Ct -> Bool-    matchable_given ct-      | CtGiven { ctev_loc = loc_g, ctev_pred = pred_g } <- ctEvidence ct-      = mightEqualLater inerts pred_g loc_g pred_w loc_w--      | otherwise-      = False--mightEqualLater :: InertSet -> TcPredType -> CtLoc -> TcPredType -> CtLoc -> Bool--- See Note [What might equal later?]--- Used to implement logic in Note [Instance and Given overlap] in GHC.Tc.Solver.Interact-mightEqualLater inert_set given_pred given_loc wanted_pred wanted_loc-  | prohibitedSuperClassSolve given_loc wanted_loc-  = False--  | otherwise-  = case tcUnifyTysFG bind_fun [flattened_given] [flattened_wanted] of-      SurelyApart              -> False  -- types that are surely apart do not equal later-      MaybeApart MARInfinite _ -> False  -- see Example 7 in the Note.-      _                        -> True--  where-    in_scope  = mkInScopeSet $ tyCoVarsOfTypes [given_pred, wanted_pred]--    -- NB: flatten both at the same time, so that we can share mappings-    -- from type family applications to variables, and also to guarantee-    -- that the fresh variables are really fresh between the given and-    -- the wanted. Flattening both at the same time is needed to get-    -- Example 10 from the Note.-    ([flattened_given, flattened_wanted], var_mapping)-      = flattenTysX in_scope [given_pred, wanted_pred]--    bind_fun :: BindFun-    bind_fun tv rhs_ty-      | isMetaTyVar tv-      , can_unify tv (metaTyVarInfo tv) rhs_ty-         -- this checks for CycleBreakerTvs and TyVarTvs; forgetting-         -- the latter was #19106.-      = BindMe--         -- See Examples 4, 5, and 6 from the Note-      | Just (_fam_tc, fam_args) <- lookupVarEnv var_mapping tv-      , anyFreeVarsOfTypes mentions_meta_ty_var fam_args-      = BindMe--      | otherwise-      = Apart--    -- True for TauTv and TyVarTv (and RuntimeUnkTv) meta-tyvars-    -- (as they can be unified)-    -- and also for CycleBreakerTvs that mentions meta-tyvars-    mentions_meta_ty_var :: TyVar -> Bool-    mentions_meta_ty_var tv-      | isMetaTyVar tv-      = case metaTyVarInfo tv of-          -- See Examples 8 and 9 in the Note-          CycleBreakerTv-            -> anyFreeVarsOfType mentions_meta_ty_var-                 (lookupCycleBreakerVar tv inert_set)-          _ -> True-      | otherwise-      = False--    -- like canSolveByUnification, but allows cbv variables to unify-    can_unify :: TcTyVar -> MetaInfo -> Type -> Bool-    can_unify _lhs_tv TyVarTv rhs_ty  -- see Example 3 from the Note-      | Just rhs_tv <- tcGetTyVar_maybe rhs_ty-      = case tcTyVarDetails rhs_tv of-          MetaTv { mtv_info = TyVarTv } -> True-          MetaTv {}                     -> False  -- could unify with anything-          SkolemTv {}                   -> True-          RuntimeUnk                    -> True-      | otherwise  -- not a var on the RHS-      = False-    can_unify lhs_tv _other _rhs_ty = mentions_meta_ty_var lhs_tv--prohibitedSuperClassSolve :: CtLoc -> CtLoc -> Bool--- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance-prohibitedSuperClassSolve from_loc solve_loc-  | InstSCOrigin _ given_size <- ctLocOrigin from_loc-  , ScOrigin wanted_size <- ctLocOrigin solve_loc-  = given_size >= wanted_size-  | otherwise-  = False--{- *********************************************************************-*                                                                      *-    Cycle breakers-*                                                                      *-********************************************************************* -}---- | Return the type family application a CycleBreakerTv maps to.-lookupCycleBreakerVar :: TcTyVar    -- ^ cbv, must be a CycleBreakerTv-                      -> InertSet-                      -> TcType     -- ^ type family application the cbv maps to-lookupCycleBreakerVar cbv (IS { inert_cycle_breakers = cbvs_stack })--- This function looks at every environment in the stack. This is necessary--- to avoid #20231. This function (and its one usage site) is the only reason--- that we store a stack instead of just the top environment.-  | Just tyfam_app <- ASSERT( (isCycleBreakerTyVar cbv) )-                      firstJusts (NE.map (lookup cbv) cbvs_stack)-  = tyfam_app-  | otherwise-  = pprPanic "lookupCycleBreakerVar found an unbound cycle breaker" (ppr cbv $$ ppr cbvs_stack)---- | Push a fresh environment onto the cycle-breaker var stack. Useful--- when entering a nested implication.-pushCycleBreakerVarStack :: CycleBreakerVarStack -> CycleBreakerVarStack-pushCycleBreakerVarStack = ([] NE.<|)---- | Add a new cycle-breaker binding to the top environment on the stack.-insertCycleBreakerBinding :: TcTyVar   -- ^ cbv, must be a CycleBreakerTv-                          -> TcType    -- ^ cbv's expansion-                          -> CycleBreakerVarStack -> CycleBreakerVarStack-insertCycleBreakerBinding cbv expansion (top_env :| rest_envs)-  = ASSERT( (isCycleBreakerTyVar cbv) )-    ((cbv, expansion) : top_env) :| rest_envs---- | Perform a monadic operation on all pairs in the top environment--- in the stack.-forAllCycleBreakerBindings_ :: Monad m-                            => CycleBreakerVarStack-                            -> (TcTyVar -> TcType -> m ()) -> m ()-forAllCycleBreakerBindings_ (top_env :| _rest_envs) action-  = forM_ top_env (uncurry action)-{-# INLINABLE forAllCycleBreakerBindings_ #-}  -- to allow SPECIALISE later---{- Note [Unsolved Derived equalities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In getUnsolvedInerts, we return a derived equality from the inert_eqs-because it is a candidate for floating out of this implication.  We-only float equalities with a meta-tyvar on the left, so we only pull-those out here.--Note [What might equal later?]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We must determine whether a Given might later equal a Wanted. We-definitely need to account for the possibility that any metavariable-might be arbitrarily instantiated. Yet we do *not* want-to allow skolems in to be instantiated, as we've already rewritten-with respect to any Givens. (We're solving a Wanted here, and so-all Givens have already been processed.)--This is best understood by example.--1. C alpha  ~?  C Int--   That given certainly might match later.--2. C a  ~?  C Int--   No. No new givens are going to arise that will get the `a` to rewrite-   to Int.--3. C alpha[tv]   ~?  C Int--   That alpha[tv] is a TyVarTv, unifiable only with other type variables.-   It cannot equal later.--4. C (F alpha)   ~?   C Int--   Sure -- that can equal later, if we learn something useful about alpha.--5. C (F alpha[tv])  ~?  C Int--   This, too, might equal later. Perhaps we have [G] F b ~ Int elsewhere.-   Or maybe we have C (F alpha[tv] beta[tv]), these unify with each other,-   and F x x = Int. Remember: returning True doesn't commit ourselves to-   anything.--6. C (F a)  ~?  C a--   No, this won't match later. If we could rewrite (F a) or a, we would-   have by now.--7. C (Maybe alpha)  ~?  C alpha--   We say this cannot equal later, because it would require-   alpha := Maybe (Maybe (Maybe ...)). While such a type can be contrived,-   we choose not to worry about it. See Note [Infinitary substitution in lookup]-   in GHC.Core.InstEnv. Getting this wrong let to #19107, tested in-   typecheck/should_compile/T19107.--8. C cbv   ~?  C Int-   where cbv = F a--   The cbv is a cycle-breaker var which stands for F a. See-   Note [Type equality cycles] in GHC.Tc.Solver.Canonical.-   This is just like case 6, and we say "no". Saying "no" here is-   essential in getting the parser to type-check, with its use of DisambECP.--9. C cbv   ~?   C Int-   where cbv = F alpha--   Here, we might indeed equal later. Distinguishing between-   this case and Example 8 is why we need the InertSet in mightEqualLater.--10. C (F alpha, Int)  ~?  C (Bool, F alpha)--   This cannot equal later, because F a would have to equal both Bool and-   Int.--To deal with type family applications, we use the Core flattener. See-Note [Flattening type-family applications when matching instances] in GHC.Core.Unify.-The Core flattener replaces all type family applications with-fresh variables. The next question: should we allow these fresh-variables in the domain of a unifying substitution?--A type family application that mentions only skolems (example 6) is settled:-any skolems would have been rewritten w.r.t. Givens by now. These type family-applications match only themselves. A type family application that mentions-metavariables, on the other hand, can match anything. So, if the original type-family application contains a metavariable, we use BindMe to tell the unifier-to allow it in the substitution. On the other hand, a type family application-with only skolems is considered rigid.--This treatment fixes #18910 and is tested in-typecheck/should_compile/InstanceGivenOverlap{,2}--}--removeInertCts :: [Ct] -> InertCans -> InertCans--- ^ Remove inert constraints from the 'InertCans', for use when a--- typechecker plugin wishes to discard a given.-removeInertCts cts icans = foldl' removeInertCt icans cts--removeInertCt :: InertCans -> Ct -> InertCans-removeInertCt is ct =-  case ct of--    CDictCan  { cc_class = cl, cc_tyargs = tys } ->-      is { inert_dicts = delDict (inert_dicts is) cl tys }--    CEqCan    { cc_lhs  = lhs, cc_rhs = rhs } -> delEq is lhs rhs--    CQuantCan {}     -> panic "removeInertCt: CQuantCan"-    CIrredCan {}     -> panic "removeInertCt: CIrredEvCan"-    CNonCanonical {} -> panic "removeInertCt: CNonCanonical"---- | Looks up a family application in the inerts; returned coercion--- is oriented input ~ output-lookupFamAppInert :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType, CtFlavourRole))-lookupFamAppInert fam_tc tys-  = do { IS { inert_cans = IC { inert_funeqs = inert_funeqs } } <- getTcSInerts-       ; return (lookup_inerts inert_funeqs) }-  where-    lookup_inerts inert_funeqs-      | Just (EqualCtList (CEqCan { cc_ev = ctev, cc_rhs = rhs } :| _))-          <- findFunEq inert_funeqs fam_tc tys-      = Just (ctEvCoercion ctev, rhs, ctEvFlavourRole ctev)-      | otherwise = Nothing--lookupInInerts :: CtLoc -> TcPredType -> TcS (Maybe CtEvidence)--- Is this exact predicate type cached in the solved or canonicals of the InertSet?-lookupInInerts loc pty-  | ClassPred cls tys <- classifyPredType pty-  = do { inerts <- getTcSInerts-       ; return (lookupSolvedDict inerts loc cls tys `mplus`-                 fmap ctEvidence (lookupInertDict (inert_cans inerts) loc cls tys)) }-  | otherwise -- NB: No caching for equalities, IPs, holes, or errors-  = return Nothing---- | Look up a dictionary inert.-lookupInertDict :: InertCans -> CtLoc -> Class -> [Type] -> Maybe Ct-lookupInertDict (IC { inert_dicts = dicts }) loc cls tys-  = case findDict dicts loc cls tys of-      Just ct -> Just ct-      _       -> Nothing---- | Look up a solved inert.-lookupSolvedDict :: InertSet -> CtLoc -> Class -> [Type] -> Maybe CtEvidence--- Returns just if exactly this predicate type exists in the solved.-lookupSolvedDict (IS { inert_solved_dicts = solved }) loc cls tys-  = case findDict solved loc cls tys of-      Just ev -> Just ev-      _       -> Nothing------------------------------lookupFamAppCache :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType))-lookupFamAppCache fam_tc tys-  = do { IS { inert_famapp_cache = famapp_cache } <- getTcSInerts-       ; case findFunEq famapp_cache fam_tc tys of-           result@(Just (co, ty)) ->-             do { traceTcS "famapp_cache hit" (vcat [ ppr (mkTyConApp fam_tc tys)-                                                    , ppr ty-                                                    , ppr co ])-                ; return result }-           Nothing -> return Nothing }--extendFamAppCache :: TyCon -> [Type] -> (TcCoercion, TcType) -> TcS ()--- NB: co :: rhs ~ F tys, to match expectations of rewriter-extendFamAppCache tc xi_args stuff@(_, ty)-  = do { dflags <- getDynFlags-       ; when (gopt Opt_FamAppCache dflags) $-    do { traceTcS "extendFamAppCache" (vcat [ ppr tc <+> ppr xi_args-                                            , ppr ty ])-            -- 'co' can be bottom, in the case of derived items-       ; updInertTcS $ \ is@(IS { inert_famapp_cache = fc }) ->-            is { inert_famapp_cache = insertFunEq fc tc xi_args stuff } } }---- Remove entries from the cache whose evidence mentions variables in the--- supplied set-dropFromFamAppCache :: VarSet -> TcS ()-dropFromFamAppCache varset-  = do { inerts@(IS { inert_famapp_cache = famapp_cache }) <- getTcSInerts-       ; let filtered = filterTcAppMap check famapp_cache-       ; setTcSInerts $ inerts { inert_famapp_cache = filtered } }-  where-    check :: (TcCoercion, TcType) -> Bool-    check (co, _) = not (anyFreeVarsOfCo (`elemVarSet` varset) co)--{- *********************************************************************-*                                                                      *-                   Irreds-*                                                                      *-********************************************************************* -}--foldIrreds :: (Ct -> b -> b) -> Cts -> b -> b-foldIrreds k irreds z = foldr k z irreds---{- *********************************************************************-*                                                                      *-                   TcAppMap-*                                                                      *-************************************************************************--Note [Use loose types in inert set]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Whenever we are looking up an inert dictionary (CDictCan) or function-equality (CEqCan), we use a TcAppMap, which uses the Unique of the-class/type family tycon and then a trie which maps the arguments. This-trie does *not* need to match the kinds of the arguments; this Note-explains why.--Consider the types ty0 = (T ty1 ty2 ty3 ty4) and ty0' = (T ty1' ty2' ty3' ty4'),-where ty4 and ty4' have different kinds. Let's further assume that both types-ty0 and ty0' are well-typed. Because the kind of T is closed, it must be that-one of the ty1..ty3 does not match ty1'..ty3' (and that the kind of the fourth-argument to T is dependent on whichever one changed). Since we are matching-all arguments, during the inert-set lookup, we know that ty1..ty3 do indeed-match ty1'..ty3'. Therefore, the kind of ty4 and ty4' must match, too ---without ever looking at it.--Accordingly, we use LooseTypeMap, which skips the kind check when looking-up a type. I (Richard E) believe this is just an optimization, and that-looking at kinds would be harmless.---}--type TcAppMap a = DTyConEnv (ListMap LooseTypeMap a)-    -- Indexed by tycon then the arg types, using "loose" matching, where-    -- we don't require kind equality. This allows, for example, (a |> co)-    -- to match (a).-    -- See Note [Use loose types in inert set]-    -- Used for types and classes; hence UniqDFM-    -- See Note [foldTM determinism] in GHC.Data.TrieMap for why we use DTyConEnv here--isEmptyTcAppMap :: TcAppMap a -> Bool-isEmptyTcAppMap m = isEmptyDTyConEnv m--emptyTcAppMap :: TcAppMap a-emptyTcAppMap = emptyDTyConEnv--findTcApp :: TcAppMap a -> TyCon -> [Type] -> Maybe a-findTcApp m tc tys = do { tys_map <- lookupDTyConEnv m tc-                        ; lookupTM tys tys_map }--delTcApp :: TcAppMap a -> TyCon -> [Type] -> TcAppMap a-delTcApp m tc tys = adjustDTyConEnv (deleteTM tys) m tc--insertTcApp :: TcAppMap a -> TyCon -> [Type] -> a -> TcAppMap a-insertTcApp m tc tys ct = alterDTyConEnv alter_tm m tc-  where-    alter_tm mb_tm = Just (insertTM tys ct (mb_tm `orElse` emptyTM))--alterTcApp :: forall a. TcAppMap a -> TyCon -> [Type] -> XT a -> TcAppMap a-alterTcApp m tc tys upd = alterDTyConEnv alter_tm m tc-  where-    alter_tm :: Maybe (ListMap LooseTypeMap a) -> Maybe (ListMap LooseTypeMap a)-    alter_tm m_elt = Just (alterTM tys upd (m_elt `orElse` emptyTM))--filterTcAppMap :: forall a. (a -> Bool) -> TcAppMap a -> TcAppMap a-filterTcAppMap f m = mapMaybeDTyConEnv one_tycon m-  where-    one_tycon :: ListMap LooseTypeMap a -> Maybe (ListMap LooseTypeMap a)-    one_tycon tm-      | isEmptyTM filtered_tm = Nothing-      | otherwise             = Just filtered_tm-      where-        filtered_tm = filterTM f tm--tcAppMapToBag :: TcAppMap a -> Bag a-tcAppMapToBag m = foldTcAppMap consBag m emptyBag--foldTcAppMap :: (a -> b -> b) -> TcAppMap a -> b -> b-foldTcAppMap k m z = foldDTyConEnv (foldTM k) z m---{- *********************************************************************-*                                                                      *-                   DictMap-*                                                                      *-********************************************************************* -}---{- Note [Tuples hiding implicit parameters]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-   f,g :: (?x::Int, C a) => a -> a-   f v = let ?x = 4 in g v--The call to 'g' gives rise to a Wanted constraint (?x::Int, C a).-We must /not/ solve this from the Given (?x::Int, C a), because of-the intervening binding for (?x::Int).  #14218.--We deal with this by arranging that we always fail when looking up a-tuple constraint that hides an implicit parameter. Not that this applies-  * both to the inert_dicts (lookupInertDict)-  * and to the solved_dicts (looukpSolvedDict)-An alternative would be not to extend these sets with such tuple-constraints, but it seemed more direct to deal with the lookup.--Note [Solving CallStack constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose f :: HasCallStack => blah.  Then--* Each call to 'f' gives rise to-    [W] s1 :: IP "callStack" CallStack    -- CtOrigin = OccurrenceOf f-  with a CtOrigin that says "OccurrenceOf f".-  Remember that HasCallStack is just shorthand for-    IP "callStack CallStack-  See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence--* We cannonicalise such constraints, in GHC.Tc.Solver.Canonical.canClassNC, by-  pushing the call-site info on the stack, and changing the CtOrigin-  to record that has been done.-   Bind:  s1 = pushCallStack <site-info> s2-   [W] s2 :: IP "callStack" CallStack   -- CtOrigin = IPOccOrigin--* Then, and only then, we can solve the constraint from an enclosing-  Given.--So we must be careful /not/ to solve 's1' from the Givens.  Again,-we ensure this by arranging that findDict always misses when looking-up souch constraints.--}--type DictMap a = TcAppMap a--emptyDictMap :: DictMap a-emptyDictMap = emptyTcAppMap--findDict :: DictMap a -> CtLoc -> Class -> [Type] -> Maybe a-findDict m loc cls tys-  | hasIPSuperClasses cls tys -- See Note [Tuples hiding implicit parameters]-  = Nothing--  | Just {} <- isCallStackPred cls tys-  , OccurrenceOf {} <- ctLocOrigin loc-  = Nothing             -- See Note [Solving CallStack constraints]--  | otherwise-  = findTcApp m (classTyCon cls) tys--findDictsByClass :: DictMap a -> Class -> Bag a-findDictsByClass m cls-  | Just tm <- lookupDTyConEnv m (classTyCon cls) = foldTM consBag tm emptyBag-  | otherwise                                     = emptyBag--delDict :: DictMap a -> Class -> [Type] -> DictMap a-delDict m cls tys = delTcApp m (classTyCon cls) tys--addDict :: DictMap a -> Class -> [Type] -> a -> DictMap a-addDict m cls tys item = insertTcApp m (classTyCon cls) tys item--addDictCt :: DictMap Ct -> Class -> [Type] -> Ct -> DictMap Ct--- Like addDict, but combines [W] and [D] to [WD]--- See Note [KeepBoth] in GHC.Tc.Solver.Interact-addDictCt m cls tys new_ct = alterTcApp m (classTyCon cls) tys xt_ct-  where-    new_ct_ev = ctEvidence new_ct--    xt_ct :: Maybe Ct -> Maybe Ct-    xt_ct (Just old_ct)-      | CtWanted { ctev_nosh = WOnly } <- old_ct_ev-      , CtDerived {} <- new_ct_ev-      = Just (old_ct { cc_ev = old_ct_ev { ctev_nosh = WDeriv }})-      | CtDerived {} <- old_ct_ev-      , CtWanted { ctev_nosh = WOnly } <- new_ct_ev-      = Just (new_ct { cc_ev = new_ct_ev { ctev_nosh = WDeriv }})-      where-        old_ct_ev = ctEvidence old_ct--    xt_ct _ = Just new_ct--addDictsByClass :: DictMap Ct -> Class -> Bag Ct -> DictMap Ct-addDictsByClass m cls items-  = extendDTyConEnv m (classTyCon cls) (foldr add emptyTM items)-  where-    add ct@(CDictCan { cc_tyargs = tys }) tm = insertTM tys ct tm-    add ct _ = pprPanic "addDictsByClass" (ppr ct)--filterDicts :: (Ct -> Bool) -> DictMap Ct -> DictMap Ct-filterDicts f m = filterTcAppMap f m--partitionDicts :: (Ct -> Bool) -> DictMap Ct -> (Bag Ct, DictMap Ct)-partitionDicts f m = foldTcAppMap k m (emptyBag, emptyDicts)-  where-    k ct (yeses, noes) | f ct      = (ct `consBag` yeses, noes)-                       | otherwise = (yeses,              add ct noes)-    add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) m-      = addDict m cls tys ct-    add ct _ = pprPanic "partitionDicts" (ppr ct)--dictsToBag :: DictMap a -> Bag a-dictsToBag = tcAppMapToBag--foldDicts :: (a -> b -> b) -> DictMap a -> b -> b-foldDicts = foldTcAppMap--emptyDicts :: DictMap a-emptyDicts = emptyTcAppMap---{- *********************************************************************-*                                                                      *-                   FunEqMap-*                                                                      *-********************************************************************* -}--type FunEqMap a = TcAppMap a  -- A map whose key is a (TyCon, [Type]) pair--emptyFunEqs :: TcAppMap a-emptyFunEqs = emptyTcAppMap--findFunEq :: FunEqMap a -> TyCon -> [Type] -> Maybe a-findFunEq m tc tys = findTcApp m tc tys--findFunEqsByTyCon :: FunEqMap a -> TyCon -> [a]--- Get inert function equation constraints that have the given tycon--- in their head.  Not that the constraints remain in the inert set.--- We use this to check for derived interactions with built-in type-function--- constructors.-findFunEqsByTyCon m tc-  | Just tm <- lookupDTyConEnv m tc = foldTM (:) tm []-  | otherwise                       = []--foldFunEqs :: (a -> b -> b) -> FunEqMap a -> b -> b-foldFunEqs = foldTcAppMap--insertFunEq :: FunEqMap a -> TyCon -> [Type] -> a -> FunEqMap a-insertFunEq m tc tys val = insertTcApp m tc tys val--{--************************************************************************-*                                                                      *-*              The TcS solver monad                                    *-*                                                                      *-************************************************************************--Note [The TcS monad]-~~~~~~~~~~~~~~~~~~~~-The TcS monad is a weak form of the main Tc monad--All you can do is-    * fail-    * allocate new variables-    * fill in evidence variables--Filling in a dictionary evidence variable means to create a binding-for it, so TcS carries a mutable location where the binding can be-added.  This is initialised from the innermost implication constraint.--}--data TcSEnv-  = TcSEnv {-      tcs_ev_binds    :: EvBindsVar,--      tcs_unified     :: IORef Int,-         -- The number of unification variables we have filled-         -- The important thing is whether it is non-zero--      tcs_unif_lvl  :: IORef (Maybe TcLevel),-         -- The Unification Level Flag-         -- Outermost level at which we have unified a meta tyvar-         -- Starts at Nothing, then (Just i), then (Just j) where j<i-         -- See Note [The Unification Level Flag]--      tcs_count     :: IORef Int, -- Global step count--      tcs_inerts    :: IORef InertSet, -- Current inert set--      -- See Note [WorkList priorities] and-      tcs_worklist  :: IORef WorkList -- Current worklist-    }------------------newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a } deriving (Functor)---- | Smart constructor for 'TcS', as describe in Note [The one-shot state--- monad trick] in "GHC.Utils.Monad".-mkTcS :: (TcSEnv -> TcM a) -> TcS a-mkTcS f = TcS (oneShot f)--instance Applicative TcS where-  pure x = mkTcS $ \_ -> return x-  (<*>) = ap--instance Monad TcS where-  m >>= k   = mkTcS $ \ebs -> do-    unTcS m ebs >>= (\r -> unTcS (k r) ebs)--instance MonadFail TcS where-  fail err  = mkTcS $ \_ -> fail err--instance MonadUnique TcS where-   getUniqueSupplyM = wrapTcS getUniqueSupplyM--instance HasModule TcS where-   getModule = wrapTcS getModule--instance MonadThings TcS where-   lookupThing n = wrapTcS (lookupThing n)---- Basic functionality--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-wrapTcS :: TcM a -> TcS a--- Do not export wrapTcS, because it promotes an arbitrary TcM to TcS,--- and TcS is supposed to have limited functionality-wrapTcS action = mkTcS $ \_env -> action -- a TcM action will not use the TcEvBinds--wrapErrTcS :: TcM a -> TcS a--- The thing wrapped should just fail--- There's no static check; it's up to the user--- Having a variant for each error message is too painful-wrapErrTcS = wrapTcS--wrapWarnTcS :: TcM a -> TcS a--- The thing wrapped should just add a warning, or no-op--- There's no static check; it's up to the user-wrapWarnTcS = wrapTcS--failTcS, panicTcS  :: SDoc -> TcS a-warnTcS   :: WarningFlag -> SDoc -> TcS ()-addErrTcS :: SDoc -> TcS ()-failTcS      = wrapTcS . TcM.failWith-warnTcS flag = wrapTcS . TcM.addWarn (Reason flag)-addErrTcS    = wrapTcS . TcM.addErr-panicTcS doc = pprPanic "GHC.Tc.Solver.Canonical" doc--traceTcS :: String -> SDoc -> TcS ()-traceTcS herald doc = wrapTcS (TcM.traceTc herald doc)-{-# INLINE traceTcS #-}  -- see Note [INLINE conditional tracing utilities]--runTcPluginTcS :: TcPluginM a -> TcS a-runTcPluginTcS m = wrapTcS . runTcPluginM m =<< getTcEvBindsVar--instance HasDynFlags TcS where-    getDynFlags = wrapTcS getDynFlags--getGlobalRdrEnvTcS :: TcS GlobalRdrEnv-getGlobalRdrEnvTcS = wrapTcS TcM.getGlobalRdrEnv--bumpStepCountTcS :: TcS ()-bumpStepCountTcS = mkTcS $ \env ->-  do { let ref = tcs_count env-     ; n <- TcM.readTcRef ref-     ; TcM.writeTcRef ref (n+1) }--csTraceTcS :: SDoc -> TcS ()-csTraceTcS doc-  = wrapTcS $ csTraceTcM (return doc)-{-# INLINE csTraceTcS #-}  -- see Note [INLINE conditional tracing utilities]--traceFireTcS :: CtEvidence -> SDoc -> TcS ()--- Dump a rule-firing trace-traceFireTcS ev doc-  = mkTcS $ \env -> csTraceTcM $-    do { n <- TcM.readTcRef (tcs_count env)-       ; tclvl <- TcM.getTcLevel-       ; return (hang (text "Step" <+> int n-                       <> brackets (text "l:" <> ppr tclvl <> comma <>-                                    text "d:" <> ppr (ctLocDepth (ctEvLoc ev)))-                       <+> doc <> colon)-                     4 (ppr ev)) }-{-# INLINE traceFireTcS #-}  -- see Note [INLINE conditional tracing utilities]--csTraceTcM :: TcM SDoc -> TcM ()--- Constraint-solver tracing, -ddump-cs-trace-csTraceTcM mk_doc-  = do { dflags <- getDynFlags-       ; when (  dopt Opt_D_dump_cs_trace dflags-                  || dopt Opt_D_dump_tc_trace dflags )-              ( do { msg <- mk_doc-                   ; TcM.dumpTcRn False-                       Opt_D_dump_cs_trace-                       "" FormatText-                       msg }) }-{-# INLINE csTraceTcM #-}  -- see Note [INLINE conditional tracing utilities]--runTcS :: TcS a                -- What to run-       -> TcM (a, EvBindMap)-runTcS tcs-  = do { ev_binds_var <- TcM.newTcEvBinds-       ; res <- runTcSWithEvBinds ev_binds_var tcs-       ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var-       ; return (res, ev_binds) }--- | This variant of 'runTcS' will keep solving, even when only Deriveds--- are left around. It also doesn't return any evidence, as callers won't--- need it.-runTcSDeriveds :: TcS a -> TcM a-runTcSDeriveds tcs-  = do { ev_binds_var <- TcM.newTcEvBinds-       ; runTcSWithEvBinds ev_binds_var tcs }---- | This can deal only with equality constraints.-runTcSEqualities :: TcS a -> TcM a-runTcSEqualities thing_inside-  = do { ev_binds_var <- TcM.newNoTcEvBinds-       ; runTcSWithEvBinds ev_binds_var thing_inside }---- | A variant of 'runTcS' that takes and returns an 'InertSet' for--- later resumption of the 'TcS' session.-runTcSInerts :: InertSet -> TcS a -> TcM (a, InertSet)-runTcSInerts inerts tcs = do-  ev_binds_var <- TcM.newTcEvBinds-  runTcSWithEvBinds' False ev_binds_var $ do-    setTcSInerts inerts-    a <- tcs-    new_inerts <- getTcSInerts-    return (a, new_inerts)--runTcSWithEvBinds :: EvBindsVar-                  -> TcS a-                  -> TcM a-runTcSWithEvBinds = runTcSWithEvBinds' True--runTcSWithEvBinds' :: Bool -- ^ Restore type equality cycles afterwards?-                           -- Don't if you want to reuse the InertSet.-                           -- See also Note [Type equality cycles]-                           -- in GHC.Tc.Solver.Canonical-                   -> EvBindsVar-                   -> TcS a-                   -> TcM a-runTcSWithEvBinds' restore_cycles ev_binds_var tcs-  = do { unified_var <- TcM.newTcRef 0-       ; step_count <- TcM.newTcRef 0-       ; inert_var <- TcM.newTcRef emptyInert-       ; wl_var <- TcM.newTcRef emptyWorkList-       ; unif_lvl_var <- TcM.newTcRef Nothing-       ; let env = TcSEnv { tcs_ev_binds      = ev_binds_var-                          , tcs_unified       = unified_var-                          , tcs_unif_lvl      = unif_lvl_var-                          , tcs_count         = step_count-                          , tcs_inerts        = inert_var-                          , tcs_worklist      = wl_var }--             -- Run the computation-       ; res <- unTcS tcs env--       ; count <- TcM.readTcRef step_count-       ; when (count > 0) $-         csTraceTcM $ return (text "Constraint solver steps =" <+> int count)--       ; when restore_cycles $-         do { inert_set <- TcM.readTcRef inert_var-            ; restoreTyVarCycles inert_set }--#if defined(DEBUG)-       ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var-       ; checkForCyclicBinds ev_binds-#endif--       ; return res }-------------------------------#if defined(DEBUG)-checkForCyclicBinds :: EvBindMap -> TcM ()-checkForCyclicBinds ev_binds_map-  | null cycles-  = return ()-  | null coercion_cycles-  = TcM.traceTc "Cycle in evidence binds" $ ppr cycles-  | otherwise-  = pprPanic "Cycle in coercion bindings" $ ppr coercion_cycles-  where-    ev_binds = evBindMapBinds ev_binds_map--    cycles :: [[EvBind]]-    cycles = [c | CyclicSCC c <- stronglyConnCompFromEdgedVerticesUniq edges]--    coercion_cycles = [c | c <- cycles, any is_co_bind c]-    is_co_bind (EvBind { eb_lhs = b }) = isEqPrimPred (varType b)--    edges :: [ Node EvVar EvBind ]-    edges = [ DigraphNode bind bndr (nonDetEltsUniqSet (evVarsOfTerm rhs))-            | bind@(EvBind { eb_lhs = bndr, eb_rhs = rhs}) <- bagToList ev_binds ]-            -- It's OK to use nonDetEltsUFM here as-            -- stronglyConnCompFromEdgedVertices is still deterministic even-            -- if the edges are in nondeterministic order as explained in-            -- Note [Deterministic SCC] in GHC.Data.Graph.Directed.-#endif-------------------------------setEvBindsTcS :: EvBindsVar -> TcS a -> TcS a-setEvBindsTcS ref (TcS thing_inside)- = TcS $ \ env -> thing_inside (env { tcs_ev_binds = ref })--nestImplicTcS :: EvBindsVar-              -> TcLevel -> TcS a-              -> TcS a-nestImplicTcS ref inner_tclvl (TcS thing_inside)-  = TcS $ \ TcSEnv { tcs_unified       = unified_var-                   , tcs_inerts        = old_inert_var-                   , tcs_count         = count-                   , tcs_unif_lvl      = unif_lvl-                   } ->-    do { inerts <- TcM.readTcRef old_inert_var-       ; let nest_inert = inerts { inert_cycle_breakers = pushCycleBreakerVarStack-                                                            (inert_cycle_breakers inerts)-                                 , inert_cans = (inert_cans inerts)-                                                   { inert_given_eqs = False } }-                 -- All other InertSet fields are inherited-       ; new_inert_var <- TcM.newTcRef nest_inert-       ; new_wl_var    <- TcM.newTcRef emptyWorkList-       ; let nest_env = TcSEnv { tcs_count         = count     -- Inherited-                               , tcs_unif_lvl      = unif_lvl  -- Inherited-                               , tcs_ev_binds      = ref-                               , tcs_unified       = unified_var-                               , tcs_inerts        = new_inert_var-                               , tcs_worklist      = new_wl_var }-       ; res <- TcM.setTcLevel inner_tclvl $-                thing_inside nest_env--       ; out_inert_set <- TcM.readTcRef new_inert_var-       ; restoreTyVarCycles out_inert_set--#if defined(DEBUG)-       -- Perform a check that the thing_inside did not cause cycles-       ; ev_binds <- TcM.getTcEvBindsMap ref-       ; checkForCyclicBinds ev_binds-#endif-       ; return res }--nestTcS ::  TcS a -> TcS a--- Use the current untouchables, augmenting the current--- evidence bindings, and solved dictionaries--- But have no effect on the InertCans, or on the inert_famapp_cache--- (we want to inherit the latter from processing the Givens)-nestTcS (TcS thing_inside)-  = TcS $ \ env@(TcSEnv { tcs_inerts = inerts_var }) ->-    do { inerts <- TcM.readTcRef inerts_var-       ; new_inert_var <- TcM.newTcRef inerts-       ; new_wl_var    <- TcM.newTcRef emptyWorkList-       ; let nest_env = env { tcs_inerts   = new_inert_var-                            , tcs_worklist = new_wl_var }--       ; res <- thing_inside nest_env--       ; new_inerts <- TcM.readTcRef new_inert_var--       -- we want to propagate the safe haskell failures-       ; let old_ic = inert_cans inerts-             new_ic = inert_cans new_inerts-             nxt_ic = old_ic { inert_safehask = inert_safehask new_ic }--       ; TcM.writeTcRef inerts_var  -- See Note [Propagate the solved dictionaries]-                        (inerts { inert_solved_dicts = inert_solved_dicts new_inerts-                                , inert_cans = nxt_ic })--       ; return res }--emitImplicationTcS :: TcLevel -> SkolemInfo-                   -> [TcTyVar]        -- Skolems-                   -> [EvVar]          -- Givens-                   -> Cts              -- Wanteds-                   -> TcS TcEvBinds--- Add an implication to the TcS monad work-list-emitImplicationTcS new_tclvl skol_info skol_tvs givens wanteds-  = do { let wc = emptyWC { wc_simple = wanteds }-       ; imp <- wrapTcS $-                do { ev_binds_var <- TcM.newTcEvBinds-                   ; imp <- TcM.newImplication-                   ; return (imp { ic_tclvl  = new_tclvl-                                 , ic_skols  = skol_tvs-                                 , ic_given  = givens-                                 , ic_wanted = wc-                                 , ic_binds  = ev_binds_var-                                 , ic_info   = skol_info }) }--       ; emitImplication imp-       ; return (TcEvBinds (ic_binds imp)) }--emitTvImplicationTcS :: TcLevel -> SkolemInfo-                     -> [TcTyVar]        -- Skolems-                     -> Cts              -- Wanteds-                     -> TcS ()--- Just like emitImplicationTcS but no givens and no bindings-emitTvImplicationTcS new_tclvl skol_info skol_tvs wanteds-  = do { let wc = emptyWC { wc_simple = wanteds }-       ; imp <- wrapTcS $-                do { ev_binds_var <- TcM.newNoTcEvBinds-                   ; imp <- TcM.newImplication-                   ; return (imp { ic_tclvl  = new_tclvl-                                 , ic_skols  = skol_tvs-                                 , ic_wanted = wc-                                 , ic_binds  = ev_binds_var-                                 , ic_info   = skol_info }) }--       ; emitImplication imp }---{- Note [Propagate the solved dictionaries]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's really quite important that nestTcS does not discard the solved-dictionaries from the thing_inside.-Consider-   Eq [a]-   forall b. empty =>  Eq [a]-We solve the simple (Eq [a]), under nestTcS, and then turn our attention to-the implications.  It's definitely fine to use the solved dictionaries on-the inner implications, and it can make a significant performance difference-if you do so.--}---- Getters and setters of GHC.Tc.Utils.Env fields--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~---- Getter of inerts and worklist-getTcSInertsRef :: TcS (IORef InertSet)-getTcSInertsRef = TcS (return . tcs_inerts)--getTcSWorkListRef :: TcS (IORef WorkList)-getTcSWorkListRef = TcS (return . tcs_worklist)--getTcSInerts :: TcS InertSet-getTcSInerts = getTcSInertsRef >>= readTcRef--setTcSInerts :: InertSet -> TcS ()-setTcSInerts ics = do { r <- getTcSInertsRef; writeTcRef r ics }--getWorkListImplics :: TcS (Bag Implication)-getWorkListImplics-  = do { wl_var <- getTcSWorkListRef-       ; wl_curr <- readTcRef wl_var-       ; return (wl_implics wl_curr) }--pushLevelNoWorkList :: SDoc -> TcS a -> TcS (TcLevel, a)--- Push the level and run thing_inside--- However, thing_inside should not generate any work items-#if defined(DEBUG)-pushLevelNoWorkList err_doc (TcS thing_inside)-  = TcS (\env -> TcM.pushTcLevelM $-                 thing_inside (env { tcs_worklist = wl_panic })-        )-  where-    wl_panic  = pprPanic "GHC.Tc.Solver.Monad.buildImplication" err_doc-                         -- This panic checks that the thing-inside-                         -- does not emit any work-list constraints-#else-pushLevelNoWorkList _ (TcS thing_inside)-  = TcS (\env -> TcM.pushTcLevelM (thing_inside env))  -- Don't check-#endif--updWorkListTcS :: (WorkList -> WorkList) -> TcS ()-updWorkListTcS f-  = do { wl_var <- getTcSWorkListRef-       ; updTcRef wl_var f }--emitWorkNC :: [CtEvidence] -> TcS ()-emitWorkNC evs-  | null evs-  = return ()-  | otherwise-  = emitWork (map mkNonCanonical evs)--emitWork :: [Ct] -> TcS ()-emitWork [] = return ()   -- avoid printing, among other work-emitWork cts-  = do { traceTcS "Emitting fresh work" (vcat (map ppr cts))-       ; updWorkListTcS (extendWorkListCts cts) }--emitImplication :: Implication -> TcS ()-emitImplication implic-  = updWorkListTcS (extendWorkListImplic implic)--newTcRef :: a -> TcS (TcRef a)-newTcRef x = wrapTcS (TcM.newTcRef x)--readTcRef :: TcRef a -> TcS a-readTcRef ref = wrapTcS (TcM.readTcRef ref)--writeTcRef :: TcRef a -> a -> TcS ()-writeTcRef ref val = wrapTcS (TcM.writeTcRef ref val)--updTcRef :: TcRef a -> (a->a) -> TcS ()-updTcRef ref upd_fn = wrapTcS (TcM.updTcRef ref upd_fn)--getTcEvBindsVar :: TcS EvBindsVar-getTcEvBindsVar = TcS (return . tcs_ev_binds)--getTcLevel :: TcS TcLevel-getTcLevel = wrapTcS TcM.getTcLevel--getTcEvTyCoVars :: EvBindsVar -> TcS TyCoVarSet-getTcEvTyCoVars ev_binds_var-  = wrapTcS $ TcM.getTcEvTyCoVars ev_binds_var--getTcEvBindsMap :: EvBindsVar -> TcS EvBindMap-getTcEvBindsMap ev_binds_var-  = wrapTcS $ TcM.getTcEvBindsMap ev_binds_var--setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcS ()-setTcEvBindsMap ev_binds_var binds-  = wrapTcS $ TcM.setTcEvBindsMap ev_binds_var binds--unifyTyVar :: TcTyVar -> TcType -> TcS ()--- Unify a meta-tyvar with a type--- We keep track of how many unifications have happened in tcs_unified,------ We should never unify the same variable twice!-unifyTyVar tv ty-  = ASSERT2( isMetaTyVar tv, ppr tv )-    TcS $ \ env ->-    do { TcM.traceTc "unifyTyVar" (ppr tv <+> text ":=" <+> ppr ty)-       ; TcM.writeMetaTyVar tv ty-       ; TcM.updTcRef (tcs_unified env) (+1) }--reportUnifications :: TcS a -> TcS (Int, a)-reportUnifications (TcS thing_inside)-  = TcS $ \ env ->-    do { inner_unified <- TcM.newTcRef 0-       ; res <- thing_inside (env { tcs_unified = inner_unified })-       ; n_unifs <- TcM.readTcRef inner_unified-       ; TcM.updTcRef (tcs_unified env) (+ n_unifs)-       ; return (n_unifs, res) }--data TouchabilityTestResult-  -- See Note [Solve by unification] in GHC.Tc.Solver.Interact-  -- which points out that having TouchableSameLevel is just an optimisation;-  -- we could manage with TouchableOuterLevel alone (suitably renamed)-  = TouchableSameLevel-  | TouchableOuterLevel [TcTyVar]   -- Promote these-                        TcLevel     -- ..to this level-  | Untouchable--instance Outputable TouchabilityTestResult where-  ppr TouchableSameLevel            = text "TouchableSameLevel"-  ppr (TouchableOuterLevel tvs lvl) = text "TouchableOuterLevel" <> parens (ppr lvl <+> ppr tvs)-  ppr Untouchable                   = text "Untouchable"--touchabilityTest :: CtFlavour -> TcTyVar -> TcType -> TcS TouchabilityTestResult--- This is the key test for untouchability:--- See Note [Unification preconditions] in GHC.Tc.Utils.Unify--- and Note [Solve by unification] in GHC.Tc.Solver.Interact-touchabilityTest flav tv1 rhs-  | flav /= Given  -- See Note [Do not unify Givens]-  , MetaTv { mtv_tclvl = tv_lvl, mtv_info = info } <- tcTyVarDetails tv1-  , canSolveByUnification info rhs-  = do { ambient_lvl  <- getTcLevel-       ; given_eq_lvl <- getInnermostGivenEqLevel--       ; if | tv_lvl `sameDepthAs` ambient_lvl-            -> return TouchableSameLevel--            | tv_lvl `deeperThanOrSame` given_eq_lvl   -- No intervening given equalities-            , all (does_not_escape tv_lvl) free_skols  -- No skolem escapes-            -> return (TouchableOuterLevel free_metas tv_lvl)--            | otherwise-            -> return Untouchable }-  | otherwise-  = return Untouchable-  where-     (free_metas, free_skols) = partition isPromotableMetaTyVar $-                                nonDetEltsUniqSet               $-                                tyCoVarsOfType rhs--     does_not_escape tv_lvl fv-       | isTyVar fv = tv_lvl `deeperThanOrSame` tcTyVarLevel fv-       | otherwise  = True-       -- Coercion variables are not an escape risk-       -- If an implication binds a coercion variable, it'll have equalities,-       -- so the "intervening given equalities" test above will catch it-       -- Coercion holes get filled with coercions, so again no problem.--{- Note [Do not unify Givens]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this GADT match-   data T a where-      T1 :: T Int-      ...--   f x = case x of-           T1 -> True-           ...--So we get f :: T alpha[1] -> beta[1]-          x :: T alpha[1]-and from the T1 branch we get the implication-   forall[2] (alpha[1] ~ Int) => beta[1] ~ Bool--Now, clearly we don't want to unify alpha:=Int!  Yet at the moment we-process [G] alpha[1] ~ Int, we don't have any given-equalities in the-inert set, and hence there are no given equalities to make alpha untouchable.--NB: if it were alpha[2] ~ Int, this argument wouldn't hold.  But that-never happens: invariant (GivenInv) in Note [TcLevel invariants]-in GHC.Tc.Utils.TcType.--Simple solution: never unify in Givens!--}--getDefaultInfo ::  TcS ([Type], (Bool, Bool))-getDefaultInfo = wrapTcS TcM.tcGetDefaultTys---- Just get some environments needed for instance looking up and matching--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--getInstEnvs :: TcS InstEnvs-getInstEnvs = wrapTcS $ TcM.tcGetInstEnvs--getFamInstEnvs :: TcS (FamInstEnv, FamInstEnv)-getFamInstEnvs = wrapTcS $ FamInst.tcGetFamInstEnvs--getTopEnv :: TcS HscEnv-getTopEnv = wrapTcS $ TcM.getTopEnv--getGblEnv :: TcS TcGblEnv-getGblEnv = wrapTcS $ TcM.getGblEnv--getLclEnv :: TcS TcLclEnv-getLclEnv = wrapTcS $ TcM.getLclEnv--tcLookupClass :: Name -> TcS Class-tcLookupClass c = wrapTcS $ TcM.tcLookupClass c--tcLookupId :: Name -> TcS Id-tcLookupId n = wrapTcS $ TcM.tcLookupId n---- Setting names as used (used in the deriving of Coercible evidence)--- Too hackish to expose it to TcS? In that case somehow extract the used--- constructors from the result of solveInteract-addUsedGREs :: [GlobalRdrElt] -> TcS ()-addUsedGREs gres = wrapTcS  $ TcM.addUsedGREs gres--addUsedGRE :: Bool -> GlobalRdrElt -> TcS ()-addUsedGRE warn_if_deprec gre = wrapTcS $ TcM.addUsedGRE warn_if_deprec gre--keepAlive :: Name -> TcS ()-keepAlive = wrapTcS . TcM.keepAlive---- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--checkWellStagedDFun :: CtLoc -> InstanceWhat -> PredType -> TcS ()--- Check that we do not try to use an instance before it is available.  E.g.---    instance Eq T where ...---    f x = $( ... (\(p::T) -> p == p)... )--- Here we can't use the equality function from the instance in the splice--checkWellStagedDFun loc what pred-  | TopLevInstance { iw_dfun_id = dfun_id } <- what-  , let bind_lvl = TcM.topIdLvl dfun_id-  , bind_lvl > impLevel-  = wrapTcS $ TcM.setCtLocM loc $-    do { use_stage <- TcM.getStage-       ; TcM.checkWellStaged pp_thing bind_lvl (thLevel use_stage) }--  | otherwise-  = return ()    -- Fast path for common case-  where-    pp_thing = text "instance for" <+> quotes (ppr pred)--pprEq :: TcType -> TcType -> SDoc-pprEq ty1 ty2 = pprParendType ty1 <+> char '~' <+> pprParendType ty2--isFilledMetaTyVar_maybe :: TcTyVar -> TcS (Maybe Type)-isFilledMetaTyVar_maybe tv = wrapTcS (TcM.isFilledMetaTyVar_maybe tv)--isFilledMetaTyVar :: TcTyVar -> TcS Bool-isFilledMetaTyVar tv = wrapTcS (TcM.isFilledMetaTyVar tv)--zonkTyCoVarsAndFV :: TcTyCoVarSet -> TcS TcTyCoVarSet-zonkTyCoVarsAndFV tvs = wrapTcS (TcM.zonkTyCoVarsAndFV tvs)--zonkTyCoVarsAndFVList :: [TcTyCoVar] -> TcS [TcTyCoVar]-zonkTyCoVarsAndFVList tvs = wrapTcS (TcM.zonkTyCoVarsAndFVList tvs)--zonkCo :: Coercion -> TcS Coercion-zonkCo = wrapTcS . TcM.zonkCo--zonkTcType :: TcType -> TcS TcType-zonkTcType ty = wrapTcS (TcM.zonkTcType ty)--zonkTcTypes :: [TcType] -> TcS [TcType]-zonkTcTypes tys = wrapTcS (TcM.zonkTcTypes tys)--zonkTcTyVar :: TcTyVar -> TcS TcType-zonkTcTyVar tv = wrapTcS (TcM.zonkTcTyVar tv)--zonkSimples :: Cts -> TcS Cts-zonkSimples cts = wrapTcS (TcM.zonkSimples cts)--zonkWC :: WantedConstraints -> TcS WantedConstraints-zonkWC wc = wrapTcS (TcM.zonkWC wc)--zonkTyCoVarKind :: TcTyCoVar -> TcS TcTyCoVar-zonkTyCoVarKind tv = wrapTcS (TcM.zonkTyCoVarKind tv)-------------------------------pprKicked :: Int -> SDoc-pprKicked 0 = empty-pprKicked n = parens (int n <+> text "kicked out")--{- *********************************************************************-*                                                                      *-*              The Unification Level Flag                              *-*                                                                      *-********************************************************************* -}--{- Note [The Unification Level Flag]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider a deep tree of implication constraints-   forall[1] a.                              -- Outer-implic-      C alpha[1]                               -- Simple-      forall[2] c. ....(C alpha[1])....        -- Implic-1-      forall[2] b. ....(alpha[1] ~ Int)....    -- Implic-2--The (C alpha) is insoluble until we know alpha.  We solve alpha-by unifying alpha:=Int somewhere deep inside Implic-2. But then we-must try to solve the Outer-implic all over again. This time we can-solve (C alpha) both in Outer-implic, and nested inside Implic-1.--When should we iterate solving a level-n implication?-Answer: if any unification of a tyvar at level n takes place-        in the ic_implics of that implication.--* What if a unification takes place at level n-1? Then don't iterate-  level n, because we'll iterate level n-1, and that will in turn iterate-  level n.--* What if a unification takes place at level n, in the ic_simples of-  level n?  No need to track this, because the kick-out mechanism deals-  with it.  (We can't drop kick-out in favour of iteration, because kick-out-  works for skolem-equalities, not just unifications.)--So the monad-global Unification Level Flag, kept in tcs_unif_lvl keeps-track of-  - Whether any unifications at all have taken place (Nothing => no unifications)-  - If so, what is the outermost level that has seen a unification (Just lvl)--The iteration done in the simplify_loop/maybe_simplify_again loop in GHC.Tc.Solver.--It helpful not to iterate unless there is a chance of progress.  #8474 is-an example:--  * There's a deeply-nested chain of implication constraints.-       ?x:alpha => ?y1:beta1 => ... ?yn:betan => [W] ?x:Int--  * From the innermost one we get a [D] alpha[1] ~ Int,-    so we can unify.--  * It's better not to iterate the inner implications, but go all the-    way out to level 1 before iterating -- because iterating level 1-    will iterate the inner levels anyway.--(In the olden days when we "floated" thse Derived constraints, this was-much, much more important -- we got exponential behaviour, as each iteration-produced the same Derived constraint.)--}---resetUnificationFlag :: TcS Bool--- We are at ambient level i--- If the unification flag = Just i, reset it to Nothing and return True--- Otherwise leave it unchanged and return False-resetUnificationFlag-  = TcS $ \env ->-    do { let ref = tcs_unif_lvl env-       ; ambient_lvl <- TcM.getTcLevel-       ; mb_lvl <- TcM.readTcRef ref-       ; TcM.traceTc "resetUnificationFlag" $-         vcat [ text "ambient:" <+> ppr ambient_lvl-              , text "unif_lvl:" <+> ppr mb_lvl ]-       ; case mb_lvl of-           Nothing       -> return False-           Just unif_lvl | ambient_lvl `strictlyDeeperThan` unif_lvl-                         -> return False-                         | otherwise-                         -> do { TcM.writeTcRef ref Nothing-                               ; return True } }--setUnificationFlag :: TcLevel -> TcS ()--- (setUnificationFlag i) sets the unification level to (Just i)--- unless it already is (Just j) where j <= i-setUnificationFlag lvl-  = TcS $ \env ->-    do { let ref = tcs_unif_lvl env-       ; mb_lvl <- TcM.readTcRef ref-       ; case mb_lvl of-           Just unif_lvl | lvl `deeperThanOrSame` unif_lvl-                         -> return ()-           _ -> TcM.writeTcRef ref (Just lvl) }---{- *********************************************************************-*                                                                      *-*                Instantiation etc.-*                                                                      *-********************************************************************* -}---- Instantiations--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--instDFunType :: DFunId -> [DFunInstType] -> TcS ([TcType], TcThetaType)-instDFunType dfun_id inst_tys-  = wrapTcS $ TcM.instDFunType dfun_id inst_tys--newFlexiTcSTy :: Kind -> TcS TcType-newFlexiTcSTy knd = wrapTcS (TcM.newFlexiTyVarTy knd)--cloneMetaTyVar :: TcTyVar -> TcS TcTyVar-cloneMetaTyVar tv = wrapTcS (TcM.cloneMetaTyVar tv)--instFlexi :: [TKVar] -> TcS TCvSubst-instFlexi = instFlexiX emptyTCvSubst--instFlexiX :: TCvSubst -> [TKVar] -> TcS TCvSubst-instFlexiX subst tvs-  = wrapTcS (foldlM instFlexiHelper subst tvs)--instFlexiHelper :: TCvSubst -> TKVar -> TcM TCvSubst-instFlexiHelper subst tv-  = do { uniq <- TcM.newUnique-       ; details <- TcM.newMetaDetails TauTv-       ; let name = setNameUnique (tyVarName tv) uniq-             kind = substTyUnchecked subst (tyVarKind tv)-             ty'  = mkTyVarTy (mkTcTyVar name kind details)-       ; TcM.traceTc "instFlexi" (ppr ty')-       ; return (extendTvSubst subst tv ty') }--matchGlobalInst :: DynFlags-                -> Bool      -- True <=> caller is the short-cut solver-                             -- See Note [Shortcut solving: overlap]-                -> Class -> [Type] -> TcS TcM.ClsInstResult-matchGlobalInst dflags short_cut cls tys-  = wrapTcS (TcM.matchGlobalInst dflags short_cut cls tys)--tcInstSkolTyVarsX :: TCvSubst -> [TyVar] -> TcS (TCvSubst, [TcTyVar])-tcInstSkolTyVarsX subst tvs = wrapTcS $ TcM.tcInstSkolTyVarsX subst tvs---- Creating and setting evidence variables and CtFlavors--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--data MaybeNew = Fresh CtEvidence | Cached EvExpr--isFresh :: MaybeNew -> Bool-isFresh (Fresh {})  = True-isFresh (Cached {}) = False--freshGoals :: [MaybeNew] -> [CtEvidence]-freshGoals mns = [ ctev | Fresh ctev <- mns ]--getEvExpr :: MaybeNew -> EvExpr-getEvExpr (Fresh ctev) = ctEvExpr ctev-getEvExpr (Cached evt) = evt--setEvBind :: EvBind -> TcS ()-setEvBind ev_bind-  = do { evb <- getTcEvBindsVar-       ; wrapTcS $ TcM.addTcEvBind evb ev_bind }---- | Mark variables as used filling a coercion hole-useVars :: CoVarSet -> TcS ()-useVars co_vars-  = do { ev_binds_var <- getTcEvBindsVar-       ; let ref = ebv_tcvs ev_binds_var-       ; wrapTcS $-         do { tcvs <- TcM.readTcRef ref-            ; let tcvs' = tcvs `unionVarSet` co_vars-            ; TcM.writeTcRef ref tcvs' } }---- | Equalities only-setWantedEq :: TcEvDest -> Coercion -> TcS ()-setWantedEq (HoleDest hole) co-  = do { useVars (coVarsOfCo co)-       ; fillCoercionHole hole co }-setWantedEq (EvVarDest ev) _ = pprPanic "setWantedEq" (ppr ev)---- | Good for both equalities and non-equalities-setWantedEvTerm :: TcEvDest -> EvTerm -> TcS ()-setWantedEvTerm (HoleDest hole) tm-  | Just co <- evTermCoercion_maybe tm-  = do { useVars (coVarsOfCo co)-       ; fillCoercionHole hole co }-  | otherwise-  = -- See Note [Yukky eq_sel for a HoleDest]-    do { let co_var = coHoleCoVar hole-       ; setEvBind (mkWantedEvBind co_var tm)-       ; fillCoercionHole hole (mkTcCoVarCo co_var) }--setWantedEvTerm (EvVarDest ev_id) tm-  = setEvBind (mkWantedEvBind ev_id tm)--{- Note [Yukky eq_sel for a HoleDest]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-How can it be that a Wanted with HoleDest gets evidence that isn't-just a coercion? i.e. evTermCoercion_maybe returns Nothing.--Consider [G] forall a. blah => a ~ T-         [W] S ~# T--Then doTopReactEqPred carefully looks up the (boxed) constraint (S ~-T) in the quantified constraints, and wraps the (boxed) evidence it-gets back in an eq_sel to extract the unboxed (S ~# T).  We can't put-that term into a coercion, so we add a value binding-    h = eq_sel (...)-and the coercion variable h to fill the coercion hole.-We even re-use the CoHole's Id for this binding!--Yuk!--}--fillCoercionHole :: CoercionHole -> Coercion -> TcS ()-fillCoercionHole hole co-  = do { wrapTcS $ TcM.fillCoercionHole hole co-       ; kickOutAfterFillingCoercionHole hole co }--setEvBindIfWanted :: CtEvidence -> EvTerm -> TcS ()-setEvBindIfWanted ev tm-  = case ev of-      CtWanted { ctev_dest = dest } -> setWantedEvTerm dest tm-      _                             -> return ()--newTcEvBinds :: TcS EvBindsVar-newTcEvBinds = wrapTcS TcM.newTcEvBinds--newNoTcEvBinds :: TcS EvBindsVar-newNoTcEvBinds = wrapTcS TcM.newNoTcEvBinds--newEvVar :: TcPredType -> TcS EvVar-newEvVar pred = wrapTcS (TcM.newEvVar pred)--newGivenEvVar :: CtLoc -> (TcPredType, EvTerm) -> TcS CtEvidence--- Make a new variable of the given PredType,--- immediately bind it to the given term--- and return its CtEvidence--- See Note [Bind new Givens immediately] in GHC.Tc.Types.Constraint-newGivenEvVar loc (pred, rhs)-  = do { new_ev <- newBoundEvVarId pred rhs-       ; return (CtGiven { ctev_pred = pred, ctev_evar = new_ev, ctev_loc = loc }) }---- | Make a new 'Id' of the given type, bound (in the monad's EvBinds) to the--- given term-newBoundEvVarId :: TcPredType -> EvTerm -> TcS EvVar-newBoundEvVarId pred rhs-  = do { new_ev <- newEvVar pred-       ; setEvBind (mkGivenEvBind new_ev rhs)-       ; return new_ev }--newGivenEvVars :: CtLoc -> [(TcPredType, EvTerm)] -> TcS [CtEvidence]-newGivenEvVars loc pts = mapM (newGivenEvVar loc) pts--emitNewWantedEq :: CtLoc -> Role -> TcType -> TcType -> TcS Coercion--- | Emit a new Wanted equality into the work-list-emitNewWantedEq loc role ty1 ty2-  = do { (ev, co) <- newWantedEq loc role ty1 ty2-       ; updWorkListTcS (extendWorkListEq (mkNonCanonical ev))-       ; return co }---- | Make a new equality CtEvidence-newWantedEq :: CtLoc -> Role -> TcType -> TcType-            -> TcS (CtEvidence, Coercion)-newWantedEq = newWantedEq_SI WDeriv--newWantedEq_SI :: ShadowInfo -> CtLoc -> Role-               -> TcType -> TcType-               -> TcS (CtEvidence, Coercion)-newWantedEq_SI si loc role ty1 ty2-  = do { hole <- wrapTcS $ TcM.newCoercionHole pty-       ; traceTcS "Emitting new coercion hole" (ppr hole <+> dcolon <+> ppr pty)-       ; return ( CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole-                           , ctev_nosh = si-                           , ctev_loc = loc}-                , mkHoleCo hole ) }-  where-    pty = mkPrimEqPredRole role ty1 ty2---- no equalities here. Use newWantedEq instead-newWantedEvVarNC :: CtLoc -> TcPredType -> TcS CtEvidence-newWantedEvVarNC = newWantedEvVarNC_SI WDeriv--newWantedEvVarNC_SI :: ShadowInfo -> CtLoc -> TcPredType -> TcS CtEvidence--- Don't look up in the solved/inerts; we know it's not there-newWantedEvVarNC_SI si loc pty-  = do { new_ev <- newEvVar pty-       ; traceTcS "Emitting new wanted" (ppr new_ev <+> dcolon <+> ppr pty $$-                                         pprCtLoc loc)-       ; return (CtWanted { ctev_pred = pty, ctev_dest = EvVarDest new_ev-                          , ctev_nosh = si-                          , ctev_loc = loc })}--newWantedEvVar :: CtLoc -> TcPredType -> TcS MaybeNew-newWantedEvVar = newWantedEvVar_SI WDeriv--newWantedEvVar_SI :: ShadowInfo -> CtLoc -> TcPredType -> TcS MaybeNew--- For anything except ClassPred, this is the same as newWantedEvVarNC-newWantedEvVar_SI si loc pty-  = do { mb_ct <- lookupInInerts loc pty-       ; case mb_ct of-            Just ctev-              | not (isDerived ctev)-              -> do { traceTcS "newWantedEvVar/cache hit" $ ppr ctev-                    ; return $ Cached (ctEvExpr ctev) }-            _ -> do { ctev <- newWantedEvVarNC_SI si loc pty-                    ; return (Fresh ctev) } }--newWanted :: CtLoc -> PredType -> TcS MaybeNew--- Deals with both equalities and non equalities. Tries to look--- up non-equalities in the cache-newWanted = newWanted_SI WDeriv--newWanted_SI :: ShadowInfo -> CtLoc -> PredType -> TcS MaybeNew-newWanted_SI si loc pty-  | Just (role, ty1, ty2) <- getEqPredTys_maybe pty-  = Fresh . fst <$> newWantedEq_SI si loc role ty1 ty2-  | otherwise-  = newWantedEvVar_SI si loc pty---- deals with both equalities and non equalities. Doesn't do any cache lookups.-newWantedNC :: CtLoc -> PredType -> TcS CtEvidence-newWantedNC loc pty-  | Just (role, ty1, ty2) <- getEqPredTys_maybe pty-  = fst <$> newWantedEq loc role ty1 ty2-  | otherwise-  = newWantedEvVarNC loc pty--emitNewDeriveds :: CtLoc -> [TcPredType] -> TcS ()-emitNewDeriveds loc preds-  | null preds-  = return ()-  | otherwise-  = do { evs <- mapM (newDerivedNC loc) preds-       ; traceTcS "Emitting new deriveds" (ppr evs)-       ; updWorkListTcS (extendWorkListDeriveds evs) }--emitNewDerivedEq :: CtLoc -> Role -> TcType -> TcType -> TcS ()--- Create new equality Derived and put it in the work list--- There's no caching, no lookupInInerts-emitNewDerivedEq loc role ty1 ty2-  = do { ev <- newDerivedNC loc (mkPrimEqPredRole role ty1 ty2)-       ; traceTcS "Emitting new derived equality" (ppr ev $$ pprCtLoc loc)-       ; updWorkListTcS (extendWorkListEq (mkNonCanonical ev)) }-         -- Very important: put in the wl_eqs-         -- See Note [Prioritise equalities] (Avoiding fundep iteration)--newDerivedNC :: CtLoc -> TcPredType -> TcS CtEvidence-newDerivedNC loc pred-  = return $ CtDerived { ctev_pred = pred, ctev_loc = loc }---- --------- Check done in GHC.Tc.Solver.Interact.selectNewWorkItem???? ------------ | Checks if the depth of the given location is too much. Fails if--- it's too big, with an appropriate error message.-checkReductionDepth :: CtLoc -> TcType   -- ^ type being reduced-                    -> TcS ()-checkReductionDepth loc ty-  = do { dflags <- getDynFlags-       ; when (subGoalDepthExceeded dflags (ctLocDepth loc)) $-         wrapErrTcS $-         solverDepthErrorTcS loc ty }--matchFam :: TyCon -> [Type] -> TcS (Maybe (CoercionN, TcType))--- Given (F tys) return (ty, co), where co :: ty ~N F tys-matchFam tycon args = fmap (fmap (first mkTcSymCo)) $ wrapTcS $ matchFamTcM tycon args--matchFamTcM :: TyCon -> [Type] -> TcM (Maybe (CoercionN, TcType))--- Given (F tys) return (ty, co), where co :: F tys ~N ty-matchFamTcM tycon args-  = do { fam_envs <- FamInst.tcGetFamInstEnvs-       ; let match_fam_result-              = reduceTyFamApp_maybe fam_envs Nominal tycon args-       ; TcM.traceTc "matchFamTcM" $-         vcat [ text "Matching:" <+> ppr (mkTyConApp tycon args)-              , ppr_res match_fam_result ]-       ; return match_fam_result }-  where-    ppr_res Nothing        = text "Match failed"-    ppr_res (Just (co,ty)) = hang (text "Match succeeded:")-                                2 (vcat [ text "Rewrites to:" <+> ppr ty-                                        , text "Coercion:" <+> ppr co ])--{--Note [Residual implications]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The wl_implics in the WorkList are the residual implication-constraints that are generated while solving or canonicalising the-current worklist.  Specifically, when canonicalising-   (forall a. t1 ~ forall a. t2)-from which we get the implication-   (forall a. t1 ~ t2)-See GHC.Tc.Solver.Monad.deferTcSForAllEq--}--{--************************************************************************-*                                                                      *-              Breaking type equality cycles-*                                                                      *-************************************************************************--}---- | Conditionally replace all type family applications in the RHS with fresh--- variables, emitting givens that relate the type family application to the--- variable. See Note [Type equality cycles] in GHC.Tc.Solver.Canonical.--- This only works under conditions as described in the Note; otherwise, returns--- Nothing.-breakTyEqCycle_maybe :: CtEvidence-                      -> CheckTyEqResult   -- result of checkTypeEq-                      -> CanEqLHS-                      -> TcType     -- RHS-                      -> TcS (Maybe (CoercionN, TcType))-                         -- new RHS that doesn't have any type families-                         -- co :: new type ~N old type-                         -- TcTyVar is the LHS tv; convenient for the caller-breakTyEqCycle_maybe (ctLocOrigin . ctEvLoc -> CycleBreakerOrigin _) _ _ _-  -- see Detail (7) of Note-  = return Nothing--breakTyEqCycle_maybe ev cte_result lhs rhs-  | NomEq <- eq_rel--  , cte_result `cterHasOnlyProblem` cteSolubleOccurs-     -- only do this if the only problem is a soluble occurs-check-     -- See Detail (8) of the Note.--  = do { should_break <- final_check-       ; if should_break then do { (co, new_rhs) <- go rhs-                                 ; return (Just (co, new_rhs)) }-                         else return Nothing }-  where-    flavour = ctEvFlavour ev-    eq_rel  = ctEvEqRel ev--    final_check-      | Given <- flavour-      = return True-      | ctFlavourContainsDerived flavour-      , TyVarLHS lhs_tv <- lhs-      = do { result <- touchabilityTest Derived lhs_tv rhs-           ; return $ case result of-               Untouchable -> False-               _           -> True }-      | otherwise-      = return False--    -- This could be considerably more efficient. See Detail (5) of Note.-    go :: TcType -> TcS (CoercionN, TcType)-    go ty | Just ty' <- rewriterView ty = go ty'-    go (Rep.TyConApp tc tys)-      | isTypeFamilyTyCon tc  -- worried about whether this type family is not actually-                              -- causing trouble? See Detail (5) of Note.-      = do { let (fun_args, extra_args) = splitAt (tyConArity tc) tys-                 fun_app                = mkTyConApp tc fun_args-                 fun_app_kind           = tcTypeKind fun_app-           ; (co, new_ty) <- emit_work fun_app_kind fun_app-           ; (extra_args_cos, extra_args') <- mapAndUnzipM go extra_args-           ; return (mkAppCos co extra_args_cos, mkAppTys new_ty extra_args') }-              -- Worried that this substitution will change kinds?-              -- See Detail (3) of Note--      | otherwise-      = do { (cos, tys) <- mapAndUnzipM go tys-           ; return (mkTyConAppCo Nominal tc cos, mkTyConApp tc tys) }--    go (Rep.AppTy ty1 ty2)-      = do { (co1, ty1') <- go ty1-           ; (co2, ty2') <- go ty2-           ; return (mkAppCo co1 co2, mkAppTy ty1' ty2') }-    go (Rep.FunTy vis w arg res)-      = do { (co_w, w') <- go w-           ; (co_arg, arg') <- go arg-           ; (co_res, res') <- go res-           ; return (mkFunCo Nominal co_w co_arg co_res, mkFunTy vis w' arg' res') }-    go (Rep.CastTy ty cast_co)-      = do { (co, ty') <- go ty-             -- co :: ty' ~N ty-             -- return_co :: (ty' |> cast_co) ~ (ty |> cast_co)-           ; return (castCoercionKind1 co Nominal ty' ty cast_co, mkCastTy ty' cast_co) }--    go ty@(Rep.TyVarTy {})    = skip ty-    go ty@(Rep.LitTy {})      = skip ty-    go ty@(Rep.ForAllTy {})   = skip ty  -- See Detail (1) of Note-    go ty@(Rep.CoercionTy {}) = skip ty  -- See Detail (2) of Note--    skip ty = return (mkNomReflCo ty, ty)--    emit_work :: TcKind                   -- of the function application-              -> TcType                   -- original function application-              -> TcS (CoercionN, TcType)  -- rewritten type (the fresh tyvar)-    emit_work fun_app_kind fun_app = case flavour of-      Given ->-        do { new_tv <- wrapTcS (TcM.newCycleBreakerTyVar fun_app_kind)-           ; let new_ty     = mkTyVarTy new_tv-                 given_pred = mkHeteroPrimEqPred fun_app_kind fun_app_kind-                                                 fun_app new_ty-                 given_term = evCoercion $ mkNomReflCo new_ty  -- See Detail (4) of Note-           ; new_given <- newGivenEvVar new_loc (given_pred, given_term)-           ; traceTcS "breakTyEqCycle replacing type family in Given" (ppr new_given)-           ; emitWorkNC [new_given]-           ; updInertTcS $ \is ->-               is { inert_cycle_breakers = insertCycleBreakerBinding new_tv fun_app-                                             (inert_cycle_breakers is) }-           ; return (mkNomReflCo new_ty, new_ty) }-                -- Why reflexive? See Detail (4) of the Note--      _derived_or_wd ->-        do { new_tv <- wrapTcS (TcM.newFlexiTyVar fun_app_kind)-           ; let new_ty = mkTyVarTy new_tv-           ; co <- emitNewWantedEq new_loc Nominal new_ty fun_app-           ; return (co, new_ty) }+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates -Wno-orphans #-}++-- | Monadic definitions for the constraint solver+module GHC.Tc.Solver.Monad (++    -- The TcS monad+    TcS, runTcS, runTcSEarlyAbort, runTcSWithEvBinds, runTcSInerts,+    failTcS, warnTcS, addErrTcS, wrapTcS,+    runTcSEqualities,+    nestTcS, nestImplicTcS, setEvBindsTcS,+    emitImplicationTcS, emitTvImplicationTcS,++    selectNextWorkItem,+    getWorkList,+    updWorkListTcS,+    pushLevelNoWorkList,++    runTcPluginTcS, addUsedGRE, addUsedGREs, keepAlive,+    matchGlobalInst, TcM.ClsInstResult(..),++    QCInst(..),++    -- Tracing etc+    panicTcS, traceTcS,+    traceFireTcS, bumpStepCountTcS, csTraceTcS,+    wrapErrTcS, wrapWarnTcS,+    resetUnificationFlag, setUnificationFlag,++    -- Evidence creation and transformation+    MaybeNew(..), freshGoals, isFresh, getEvExpr,++    newTcEvBinds, newNoTcEvBinds,+    newWantedEq, emitNewWantedEq,+    newWanted,+    newWantedNC, newWantedEvVarNC,+    newBoundEvVarId,+    unifyTyVar, reportUnifications, touchabilityTest, TouchabilityTestResult(..),+    setEvBind, setWantedEq,+    setWantedEvTerm, setEvBindIfWanted,+    newEvVar, newGivenEvVar, newGivenEvVars,+    checkReductionDepth,+    getSolvedDicts, setSolvedDicts,++    getInstEnvs, getFamInstEnvs,                -- Getting the environments+    getTopEnv, getGblEnv, getLclEnv, setLclEnv,+    getTcEvBindsVar, getTcLevel,+    getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap,+    tcLookupClass, tcLookupId,++    -- Inerts+    updInertTcS, updInertCans, updInertDicts, updInertIrreds,+    getHasGivenEqs, setInertCans,+    getInertEqs, getInertCans, getInertGivens,+    getInertInsols, getInnermostGivenEqLevel,+    getTcSInerts, setTcSInerts,+    getUnsolvedInerts,+    removeInertCts, getPendingGivenScs,+    addInertCan, insertFunEq, addInertForAll,+    emitWorkNC, emitWork,+    lookupInertDict,++    -- The Model+    kickOutAfterUnification,++    -- Inert Safe Haskell safe-overlap failures+    addInertSafehask, insertSafeOverlapFailureTcS, updInertSafehask,+    getSafeOverlapFailures,++    -- Inert solved dictionaries+    addSolvedDict, lookupSolvedDict,++    -- Irreds+    foldIrreds,++    -- The family application cache+    lookupFamAppInert, lookupFamAppCache, extendFamAppCache,+    pprKicked,++    instDFunType,                              -- Instantiation++    -- MetaTyVars+    newFlexiTcSTy, instFlexi, instFlexiX,+    cloneMetaTyVar,+    tcInstSkolTyVarsX,++    TcLevel,+    isFilledMetaTyVar_maybe, isFilledMetaTyVar,+    zonkTyCoVarsAndFV, zonkTcType, zonkTcTypes, zonkTcTyVar, zonkCo,+    zonkTyCoVarsAndFVList,+    zonkSimples, zonkWC,+    zonkTyCoVarKind,++    -- References+    newTcRef, readTcRef, writeTcRef, updTcRef,++    -- Misc+    getDefaultInfo, getDynFlags, getGlobalRdrEnvTcS,+    matchFam, matchFamTcM,+    checkWellStagedDFun,+    pprEq,                                   -- Smaller utils, re-exported from TcM+                                             -- TODO (DV): these are only really used in the+                                             -- instance matcher in GHC.Tc.Solver. I am wondering+                                             -- if the whole instance matcher simply belongs+                                             -- here++    breakTyEqCycle_maybe, rewriterView+) where++import GHC.Prelude++import GHC.Driver.Env++import qualified GHC.Tc.Utils.Instantiate as TcM+import GHC.Core.InstEnv+import GHC.Tc.Instance.Family as FamInst+import GHC.Core.FamInstEnv++import qualified GHC.Tc.Utils.Monad    as TcM+import qualified GHC.Tc.Utils.TcMType  as TcM+import qualified GHC.Tc.Instance.Class as TcM( matchGlobalInst, ClsInstResult(..) )+import qualified GHC.Tc.Utils.Env      as TcM+       ( checkWellStaged, tcGetDefaultTys, tcLookupClass, tcLookupId, topIdLvl+       , tcInitTidyEnv )+import GHC.Tc.Instance.Class( InstanceWhat(..), safeOverlap, instanceReturnsDictCon )+import GHC.Tc.Utils.TcType+import GHC.Driver.Session+import GHC.Core.Type+import qualified GHC.Core.TyCo.Rep as Rep  -- this needs to be used only very locally+import GHC.Core.Coercion+import GHC.Core.Reduction++import GHC.Tc.Solver.Types+import GHC.Tc.Solver.InertSet++import GHC.Tc.Types.Evidence+import GHC.Core.Class+import GHC.Core.TyCon+import GHC.Tc.Errors.Types+import GHC.Types.Error ( mkPlainError, noHints )++import GHC.Types.Name+import GHC.Types.TyThing+import GHC.Unit.Module ( HasModule, getModule, extractModule )+import GHC.Types.Name.Reader ( GlobalRdrEnv, GlobalRdrElt )+import qualified GHC.Rename.Env as TcM+import GHC.Types.Var+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Logger+import GHC.Utils.Misc (HasDebugCallStack)+import GHC.Data.Bag as Bag+import GHC.Types.Unique.Supply+import GHC.Tc.Types+import GHC.Tc.Types.Origin+import GHC.Tc.Types.Constraint+import GHC.Tc.Utils.Unify+import GHC.Core.Predicate+import GHC.Types.Unique.Set (nonDetEltsUniqSet)++import Control.Monad+import GHC.Utils.Monad+import Data.IORef+import GHC.Exts (oneShot)+import Data.List ( mapAccumL, partition, find )++#if defined(DEBUG)+import GHC.Data.Graph.Directed+#endif++{- *********************************************************************+*                                                                      *+                   Inert instances: inert_insts+*                                                                      *+********************************************************************* -}++addInertForAll :: QCInst -> TcS ()+-- Add a local Given instance, typically arising from a type signature+addInertForAll new_qci+  = do { ics  <- getInertCans+       ; ics1 <- add_qci ics++       -- Update given equalities. C.f updateGivenEqs+       ; tclvl <- getTcLevel+       ; let pred         = qci_pred new_qci+             not_equality = isClassPred pred && not (isEqPred pred)+                  -- True <=> definitely not an equality+                  -- A qci_pred like (f a) might be an equality++             ics2 | not_equality = ics1+                  | otherwise    = ics1 { inert_given_eq_lvl = tclvl+                                        , inert_given_eqs    = True }++       ; setInertCans ics2 }+  where+    add_qci :: InertCans -> TcS InertCans+    -- See Note [Do not add duplicate quantified instances]+    add_qci ics@(IC { inert_insts = qcis })+      | any same_qci qcis+      = do { traceTcS "skipping duplicate quantified instance" (ppr new_qci)+           ; return ics }++      | otherwise+      = do { traceTcS "adding new inert quantified instance" (ppr new_qci)+           ; return (ics { inert_insts = new_qci : qcis }) }++    same_qci old_qci = tcEqType (ctEvPred (qci_ev old_qci))+                                (ctEvPred (qci_ev new_qci))++{- Note [Do not add duplicate quantified instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this (#15244):++  f :: (C g, D g) => ....+  class S g => C g where ...+  class S g => D g where ...+  class (forall a. Eq a => Eq (g a)) => S g where ...++Then in f's RHS there are two identical quantified constraints+available, one via the superclasses of C and one via the superclasses+of D.  The two are identical, and it seems wrong to reject the program+because of that. But without doing duplicate-elimination we will have+two matching QCInsts when we try to solve constraints arising from f's+RHS.++The simplest thing is simply to eliminate duplicates, which we do here.+-}++{- *********************************************************************+*                                                                      *+                  Adding an inert+*                                                                      *+************************************************************************++Note [Adding an equality to the InertCans]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When adding an equality to the inerts:++* Kick out any constraints that can be rewritten by the thing+  we are adding.  Done by kickOutRewritable.++* Note that unifying a:=ty, is like adding [G] a~ty; just use+  kickOutRewritable with Nominal, Given.  See kickOutAfterUnification.++Note [Kick out existing binding for implicit parameter]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have (typecheck/should_compile/ImplicitParamFDs)+  flub :: (?x :: Int) => (Int, Integer)+  flub = (?x, let ?x = 5 in ?x)+When we are checking the last ?x occurrence, we guess its type+to be a fresh unification variable alpha and emit an (IP "x" alpha)+constraint. But the given (?x :: Int) has been translated to an+IP "x" Int constraint, which has a functional dependency from the+name to the type. So fundep interaction tells us that alpha ~ Int,+and we get a type error. This is bad.++Instead, we wish to excise any old given for an IP when adding a+new one. We also must make sure not to float out+any IP constraints outside an implication that binds an IP of+the same name; see GHC.Tc.Solver.floatConstraints.+-}++addInertCan :: Ct -> TcS ()+-- Precondition: item /is/ canonical+-- See Note [Adding an equality to the InertCans]+addInertCan ct =+    do { traceTcS "addInertCan {" $+         text "Trying to insert new inert item:" <+> ppr ct+       ; mkTcS (\TcSEnv{tcs_abort_on_insoluble=abort_flag} ->+                 when (abort_flag && insolubleEqCt ct) TcM.failM)+       ; ics <- getInertCans+       ; ics <- maybeKickOut ics ct+       ; tclvl <- getTcLevel+       ; setInertCans (addInertItem tclvl ics ct)++       ; traceTcS "addInertCan }" $ empty }++maybeKickOut :: InertCans -> Ct -> TcS InertCans+-- For a CEqCan, kick out any inert that can be rewritten by the CEqCan+maybeKickOut ics ct+  | CEqCan { cc_lhs = lhs, cc_ev = ev, cc_eq_rel = eq_rel } <- ct+  = do { (_, ics') <- kickOutRewritable (ctEvFlavour ev, eq_rel) lhs ics+       ; return ics' }++     -- See [Kick out existing binding for implicit parameter]+  | isGivenCt ct+  , CDictCan { cc_class = cls, cc_tyargs = [ip_name_strty, _ip_ty] } <- ct+  , isIPClass cls+  , Just ip_name <- isStrLitTy ip_name_strty+     -- Would this be more efficient if we used findDictsByClass and then delDict?+  = let dict_map = inert_dicts ics+        dict_map' = filterDicts doesn't_match_ip_name dict_map++        doesn't_match_ip_name :: Ct -> Bool+        doesn't_match_ip_name ct+          | Just (inert_ip_name, _inert_ip_ty) <- isIPPred_maybe (ctPred ct)+          = inert_ip_name /= ip_name++          | otherwise+          = True++    in+    return (ics { inert_dicts = dict_map' })++  | otherwise+  = return ics++-----------------------------------------+kickOutRewritable  :: CtFlavourRole  -- Flavour/role of the equality that+                                      -- is being added to the inert set+                   -> CanEqLHS        -- The new equality is lhs ~ ty+                   -> InertCans+                   -> TcS (Int, InertCans)+kickOutRewritable new_fr new_lhs ics+  = do { let (kicked_out, ics') = kickOutRewritableLHS new_fr new_lhs ics+             n_kicked = workListSize kicked_out++       ; unless (n_kicked == 0) $+         do { updWorkListTcS (appendWorkList kicked_out)++              -- The famapp-cache contains Given evidence from the inert set.+              -- If we're kicking out Givens, we need to remove this evidence+              -- from the cache, too.+            ; let kicked_given_ev_vars =+                    [ ev_var | ct <- wl_eqs kicked_out+                             , CtGiven { ctev_evar = ev_var } <- [ctEvidence ct] ]+            ; when (new_fr `eqCanRewriteFR` (Given, NomEq) &&+                   -- if this isn't true, no use looking through the constraints+                    not (null kicked_given_ev_vars)) $+              do { traceTcS "Given(s) have been kicked out; drop from famapp-cache"+                            (ppr kicked_given_ev_vars)+                 ; dropFromFamAppCache (mkVarSet kicked_given_ev_vars) }++            ; csTraceTcS $+              hang (text "Kick out, lhs =" <+> ppr new_lhs)+                 2 (vcat [ text "n-kicked =" <+> int n_kicked+                         , text "kicked_out =" <+> ppr kicked_out+                         , text "Residual inerts =" <+> ppr ics' ]) }++       ; return (n_kicked, ics') }++kickOutAfterUnification :: TcTyVar -> TcS Int+kickOutAfterUnification new_tv+  = do { ics <- getInertCans+       ; (n_kicked, ics2) <- kickOutRewritable (Given,NomEq)+                                                 (TyVarLHS new_tv) ics+                     -- Given because the tv := xi is given; NomEq because+                     -- only nominal equalities are solved by unification++       ; setInertCans ics2+       ; return n_kicked }++-- See Wrinkle (2) in Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical+-- It's possible that this could just go ahead and unify, but could there be occurs-check+-- problems? Seems simpler just to kick out.+kickOutAfterFillingCoercionHole :: CoercionHole -> TcS ()+kickOutAfterFillingCoercionHole hole+  = do { ics <- getInertCans+       ; let (kicked_out, ics') = kick_out ics+             n_kicked           = workListSize kicked_out++       ; unless (n_kicked == 0) $+         do { updWorkListTcS (appendWorkList kicked_out)+            ; csTraceTcS $+              hang (text "Kick out, hole =" <+> ppr hole)+                 2 (vcat [ text "n-kicked =" <+> int n_kicked+                         , text "kicked_out =" <+> ppr kicked_out+                         , text "Residual inerts =" <+> ppr ics' ]) }++       ; setInertCans ics' }+  where+    kick_out :: InertCans -> (WorkList, InertCans)+    kick_out ics@(IC { inert_eqs = eqs, inert_funeqs = funeqs })+      = (kicked_out, ics { inert_eqs = eqs_to_keep, inert_funeqs = funeqs_to_keep })+      where+        (eqs_to_kick, eqs_to_keep)       = partitionInertEqs kick_ct eqs+        (funeqs_to_kick, funeqs_to_keep) = partitionFunEqs kick_ct funeqs+        kicked_out = extendWorkListCts (eqs_to_kick ++ funeqs_to_kick) emptyWorkList++    kick_ct :: Ct -> Bool+         -- True: kick out; False: keep.+    kick_ct (CEqCan { cc_rhs = rhs, cc_ev = ctev })+      = isWanted ctev &&    -- optimisation: givens don't have coercion holes anyway+        rhs `hasThisCoercionHoleTy` hole+    kick_ct other = pprPanic "kick_ct (coercion hole)" (ppr other)++--------------+addInertSafehask :: InertCans -> Ct -> InertCans+addInertSafehask ics item@(CDictCan { cc_class = cls, cc_tyargs = tys })+  = ics { inert_safehask = addDict (inert_dicts ics) cls tys item }++addInertSafehask _ item+  = pprPanic "addInertSafehask: can't happen! Inserting " $ ppr item++insertSafeOverlapFailureTcS :: InstanceWhat -> Ct -> TcS ()+-- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver+insertSafeOverlapFailureTcS what item+  | safeOverlap what = return ()+  | otherwise        = updInertCans (\ics -> addInertSafehask ics item)++getSafeOverlapFailures :: TcS Cts+-- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver+getSafeOverlapFailures+ = do { IC { inert_safehask = safehask } <- getInertCans+      ; return $ foldDicts consCts safehask emptyCts }++--------------+addSolvedDict :: InstanceWhat -> CtEvidence -> Class -> [Type] -> TcS ()+-- Conditionally add a new item in the solved set of the monad+-- See Note [Solved dictionaries] in GHC.Tc.Solver.InertSet+addSolvedDict what item cls tys+  | isWanted item+  , instanceReturnsDictCon what+  = do { traceTcS "updSolvedSetTcs:" $ ppr item+       ; updInertTcS $ \ ics ->+             ics { inert_solved_dicts = addDict (inert_solved_dicts ics) cls tys item } }+  | otherwise+  = return ()++getSolvedDicts :: TcS (DictMap CtEvidence)+getSolvedDicts = do { ics <- getTcSInerts; return (inert_solved_dicts ics) }++setSolvedDicts :: DictMap CtEvidence -> TcS ()+setSolvedDicts solved_dicts+  = updInertTcS $ \ ics ->+    ics { inert_solved_dicts = solved_dicts }++{- *********************************************************************+*                                                                      *+                  Other inert-set operations+*                                                                      *+********************************************************************* -}++updInertTcS :: (InertSet -> InertSet) -> TcS ()+-- Modify the inert set with the supplied function+updInertTcS upd_fn+  = do { is_var <- getTcSInertsRef+       ; wrapTcS (do { curr_inert <- TcM.readTcRef is_var+                     ; TcM.writeTcRef is_var (upd_fn curr_inert) }) }++getInertCans :: TcS InertCans+getInertCans = do { inerts <- getTcSInerts; return (inert_cans inerts) }++setInertCans :: InertCans -> TcS ()+setInertCans ics = updInertTcS $ \ inerts -> inerts { inert_cans = ics }++updRetInertCans :: (InertCans -> (a, InertCans)) -> TcS a+-- Modify the inert set with the supplied function+updRetInertCans upd_fn+  = do { is_var <- getTcSInertsRef+       ; wrapTcS (do { inerts <- TcM.readTcRef is_var+                     ; let (res, cans') = upd_fn (inert_cans inerts)+                     ; TcM.writeTcRef is_var (inerts { inert_cans = cans' })+                     ; return res }) }++updInertCans :: (InertCans -> InertCans) -> TcS ()+-- Modify the inert set with the supplied function+updInertCans upd_fn+  = updInertTcS $ \ inerts -> inerts { inert_cans = upd_fn (inert_cans inerts) }++updInertDicts :: (DictMap Ct -> DictMap Ct) -> TcS ()+-- Modify the inert set with the supplied function+updInertDicts upd_fn+  = updInertCans $ \ ics -> ics { inert_dicts = upd_fn (inert_dicts ics) }++updInertSafehask :: (DictMap Ct -> DictMap Ct) -> TcS ()+-- Modify the inert set with the supplied function+updInertSafehask upd_fn+  = updInertCans $ \ ics -> ics { inert_safehask = upd_fn (inert_safehask ics) }++updInertIrreds :: (Cts -> Cts) -> TcS ()+-- Modify the inert set with the supplied function+updInertIrreds upd_fn+  = updInertCans $ \ ics -> ics { inert_irreds = upd_fn (inert_irreds ics) }++getInertEqs :: TcS InertEqs+getInertEqs = do { inert <- getInertCans; return (inert_eqs inert) }++getInnermostGivenEqLevel :: TcS TcLevel+getInnermostGivenEqLevel = do { inert <- getInertCans+                              ; return (inert_given_eq_lvl inert) }++getInertInsols :: TcS Cts+-- Returns insoluble equality constraints and TypeError constraints,+-- specifically including Givens.+--+-- Note that this function only inspects irreducible constraints;+-- a DictCan constraint such as 'Eq (TypeError msg)' is not+-- considered to be an insoluble constraint by this function.+--+-- See Note [Pattern match warnings with insoluble Givens] in GHC.Tc.Solver.+getInertInsols = do { inert <- getInertCans+                    ; return $ filterBag insolubleCt (inert_irreds inert) }++getInertGivens :: TcS [Ct]+-- Returns the Given constraints in the inert set+getInertGivens+  = do { inerts <- getInertCans+       ; let all_cts = foldIrreds (:) (inert_irreds inerts)+                     $ foldDicts (:) (inert_dicts inerts)+                     $ foldFunEqs (++) (inert_funeqs inerts)+                     $ foldDVarEnv (++) [] (inert_eqs inerts)+       ; return (filter isGivenCt all_cts) }++getPendingGivenScs :: TcS [Ct]+-- Find all inert Given dictionaries, or quantified constraints,+--     whose cc_pend_sc flag is True+--     and that belong to the current level+-- Set their cc_pend_sc flag to False in the inert set, and return that Ct+getPendingGivenScs = do { lvl <- getTcLevel+                        ; updRetInertCans (get_sc_pending lvl) }++get_sc_pending :: TcLevel -> InertCans -> ([Ct], InertCans)+get_sc_pending this_lvl ic@(IC { inert_dicts = dicts, inert_insts = insts })+  = assertPpr (all isGivenCt sc_pending) (ppr sc_pending)+       -- When getPendingScDics is called,+       -- there are never any Wanteds in the inert set+    (sc_pending, ic { inert_dicts = dicts', inert_insts = insts' })+  where+    sc_pending = sc_pend_insts ++ sc_pend_dicts++    sc_pend_dicts = foldDicts get_pending dicts []+    dicts' = foldr add dicts sc_pend_dicts++    (sc_pend_insts, insts') = mapAccumL get_pending_inst [] insts++    get_pending :: Ct -> [Ct] -> [Ct]  -- Get dicts with cc_pend_sc = True+                                       -- but flipping the flag+    get_pending dict dicts+        | Just dict' <- isPendingScDict dict+        , belongs_to_this_level (ctEvidence dict)+        = dict' : dicts+        | otherwise+        = dicts++    add :: Ct -> DictMap Ct -> DictMap Ct+    add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) dicts+        = addDict dicts cls tys ct+    add ct _ = pprPanic "getPendingScDicts" (ppr ct)++    get_pending_inst :: [Ct] -> QCInst -> ([Ct], QCInst)+    get_pending_inst cts qci@(QCI { qci_ev = ev })+       | Just qci' <- isPendingScInst qci+       , belongs_to_this_level ev+       = (CQuantCan qci' : cts, qci')+       | otherwise+       = (cts, qci)++    belongs_to_this_level ev = ctLocLevel (ctEvLoc ev) == this_lvl+    -- We only want Givens from this level; see (3a) in+    -- Note [The superclass story] in GHC.Tc.Solver.Canonical++getUnsolvedInerts :: TcS ( Bag Implication+                         , Cts )   -- All simple constraints+-- Return all the unsolved [Wanted] constraints+--+-- Post-condition: the returned simple constraints are all fully zonked+--                     (because they come from the inert set)+--                 the unsolved implics may not be+getUnsolvedInerts+ = do { IC { inert_eqs     = tv_eqs+           , inert_funeqs  = fun_eqs+           , inert_irreds  = irreds+           , inert_dicts   = idicts+           } <- getInertCans++      ; let unsolved_tv_eqs  = foldTyEqs add_if_unsolved tv_eqs emptyCts+            unsolved_fun_eqs = foldFunEqs add_if_unsolveds fun_eqs emptyCts+            unsolved_irreds  = Bag.filterBag isWantedCt irreds+            unsolved_dicts   = foldDicts add_if_unsolved idicts emptyCts+            unsolved_others  = unionManyBags [ unsolved_irreds+                                             , unsolved_dicts ]++      ; implics <- getWorkListImplics++      ; traceTcS "getUnsolvedInerts" $+        vcat [ text " tv eqs =" <+> ppr unsolved_tv_eqs+             , text "fun eqs =" <+> ppr unsolved_fun_eqs+             , text "others =" <+> ppr unsolved_others+             , text "implics =" <+> ppr implics ]++      ; return ( implics, unsolved_tv_eqs `unionBags`+                          unsolved_fun_eqs `unionBags`+                          unsolved_others) }+  where+    add_if_unsolved :: Ct -> Cts -> Cts+    add_if_unsolved ct cts | isWantedCt ct = ct `consCts` cts+                           | otherwise     = cts++    add_if_unsolveds :: EqualCtList -> Cts -> Cts+    add_if_unsolveds new_cts old_cts = foldr add_if_unsolved old_cts new_cts++getHasGivenEqs :: TcLevel           -- TcLevel of this implication+               -> TcS ( HasGivenEqs -- are there Given equalities?+                      , Cts )       -- Insoluble equalities arising from givens+-- See Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet+getHasGivenEqs tclvl+  = do { inerts@(IC { inert_irreds       = irreds+                    , inert_given_eqs    = given_eqs+                    , inert_given_eq_lvl = ge_lvl })+              <- getInertCans+       ; let given_insols = filterBag insoluble_given_equality irreds+                      -- Specifically includes ones that originated in some+                      -- outer context but were refined to an insoluble by+                      -- a local equality; so no level-check needed++             -- See Note [HasGivenEqs] in GHC.Tc.Types.Constraint, and+             -- Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet+             has_ge | ge_lvl == tclvl = MaybeGivenEqs+                    | given_eqs       = LocalGivenEqs+                    | otherwise       = NoGivenEqs++       ; traceTcS "getHasGivenEqs" $+         vcat [ text "given_eqs:" <+> ppr given_eqs+              , text "ge_lvl:" <+> ppr ge_lvl+              , text "ambient level:" <+> ppr tclvl+              , text "Inerts:" <+> ppr inerts+              , text "Insols:" <+> ppr given_insols]+       ; return (has_ge, given_insols) }+  where+    insoluble_given_equality ct+       = insolubleEqCt ct && isGivenCt ct++removeInertCts :: [Ct] -> InertCans -> InertCans+-- ^ Remove inert constraints from the 'InertCans', for use when a+-- typechecker plugin wishes to discard a given.+removeInertCts cts icans = foldl' removeInertCt icans cts++removeInertCt :: InertCans -> Ct -> InertCans+removeInertCt is ct =+  case ct of++    CDictCan  { cc_class = cl, cc_tyargs = tys } ->+      is { inert_dicts = delDict (inert_dicts is) cl tys }++    CEqCan    { cc_lhs  = lhs, cc_rhs = rhs } -> delEq is lhs rhs++    CIrredCan {}     -> is { inert_irreds = filterBag (not . eqCt ct) $ inert_irreds is }++    CQuantCan {}     -> panic "removeInertCt: CQuantCan"+    CNonCanonical {} -> panic "removeInertCt: CNonCanonical"++eqCt :: Ct -> Ct -> Bool+-- Equality via ctEvId+eqCt c c' = ctEvId c == ctEvId c'++-- | Looks up a family application in the inerts.+lookupFamAppInert :: (CtFlavourRole -> Bool)  -- can it rewrite the target?+                  -> TyCon -> [Type] -> TcS (Maybe (Reduction, CtFlavourRole))+lookupFamAppInert rewrite_pred fam_tc tys+  = do { IS { inert_cans = IC { inert_funeqs = inert_funeqs } } <- getTcSInerts+       ; return (lookup_inerts inert_funeqs) }+  where+    lookup_inerts inert_funeqs+      | Just ecl <- findFunEq inert_funeqs fam_tc tys+      , Just (CEqCan { cc_ev = ctev, cc_rhs = rhs })+          <- find (rewrite_pred . ctFlavourRole) ecl+      = Just (mkReduction (ctEvCoercion ctev) rhs, ctEvFlavourRole ctev)+      | otherwise = Nothing++lookupInInerts :: CtLoc -> TcPredType -> TcS (Maybe CtEvidence)+-- Is this exact predicate type cached in the solved or canonicals of the InertSet?+lookupInInerts loc pty+  | ClassPred cls tys <- classifyPredType pty+  = do { inerts <- getTcSInerts+       ; return (lookupSolvedDict inerts loc cls tys `mplus`+                 fmap ctEvidence (lookupInertDict (inert_cans inerts) loc cls tys)) }+  | otherwise -- NB: No caching for equalities, IPs, holes, or errors+  = return Nothing++-- | Look up a dictionary inert.+lookupInertDict :: InertCans -> CtLoc -> Class -> [Type] -> Maybe Ct+lookupInertDict (IC { inert_dicts = dicts }) loc cls tys+  = case findDict dicts loc cls tys of+      Just ct -> Just ct+      _       -> Nothing++-- | Look up a solved inert.+lookupSolvedDict :: InertSet -> CtLoc -> Class -> [Type] -> Maybe CtEvidence+-- Returns just if exactly this predicate type exists in the solved.+lookupSolvedDict (IS { inert_solved_dicts = solved }) loc cls tys+  = case findDict solved loc cls tys of+      Just ev -> Just ev+      _       -> Nothing++---------------------------+lookupFamAppCache :: TyCon -> [Type] -> TcS (Maybe Reduction)+lookupFamAppCache fam_tc tys+  = do { IS { inert_famapp_cache = famapp_cache } <- getTcSInerts+       ; case findFunEq famapp_cache fam_tc tys of+           result@(Just redn) ->+             do { traceTcS "famapp_cache hit" (vcat [ ppr (mkTyConApp fam_tc tys)+                                                    , ppr redn ])+                ; return result }+           Nothing -> return Nothing }++extendFamAppCache :: TyCon -> [Type] -> Reduction -> TcS ()+-- NB: co :: rhs ~ F tys, to match expectations of rewriter+extendFamAppCache tc xi_args stuff@(Reduction _ ty)+  = do { dflags <- getDynFlags+       ; when (gopt Opt_FamAppCache dflags) $+    do { traceTcS "extendFamAppCache" (vcat [ ppr tc <+> ppr xi_args+                                            , ppr ty ])+       ; updInertTcS $ \ is@(IS { inert_famapp_cache = fc }) ->+            is { inert_famapp_cache = insertFunEq fc tc xi_args stuff } } }++-- Remove entries from the cache whose evidence mentions variables in the+-- supplied set+dropFromFamAppCache :: VarSet -> TcS ()+dropFromFamAppCache varset+  = do { inerts@(IS { inert_famapp_cache = famapp_cache }) <- getTcSInerts+       ; let filtered = filterTcAppMap check famapp_cache+       ; setTcSInerts $ inerts { inert_famapp_cache = filtered } }+  where+    check :: Reduction -> Bool+    check redn+      = not (anyFreeVarsOfCo (`elemVarSet` varset) $ reductionCoercion redn)++{- *********************************************************************+*                                                                      *+                   Irreds+*                                                                      *+********************************************************************* -}++foldIrreds :: (Ct -> b -> b) -> Cts -> b -> b+foldIrreds k irreds z = foldr k z irreds++{-+************************************************************************+*                                                                      *+*              The TcS solver monad                                    *+*                                                                      *+************************************************************************++Note [The TcS monad]+~~~~~~~~~~~~~~~~~~~~+The TcS monad is a weak form of the main Tc monad++All you can do is+    * fail+    * allocate new variables+    * fill in evidence variables++Filling in a dictionary evidence variable means to create a binding+for it, so TcS carries a mutable location where the binding can be+added.  This is initialised from the innermost implication constraint.+-}++data TcSEnv+  = TcSEnv {+      tcs_ev_binds    :: EvBindsVar,++      tcs_unified     :: IORef Int,+         -- The number of unification variables we have filled+         -- The important thing is whether it is non-zero++      tcs_unif_lvl  :: IORef (Maybe TcLevel),+         -- The Unification Level Flag+         -- Outermost level at which we have unified a meta tyvar+         -- Starts at Nothing, then (Just i), then (Just j) where j<i+         -- See Note [The Unification Level Flag]++      tcs_count     :: IORef Int, -- Global step count++      tcs_inerts    :: IORef InertSet, -- Current inert set++      -- Whether to throw an exception if we come across an insoluble constraint.+      -- Used to fail-fast when checking for hole-fits. See Note [Speeding up+      -- valid hole-fits].+      tcs_abort_on_insoluble :: Bool,++      -- See Note [WorkList priorities] in GHC.Tc.Solver.InertSet+      tcs_worklist  :: IORef WorkList -- Current worklist+    }++---------------+newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a } deriving (Functor)++-- | Smart constructor for 'TcS', as describe in Note [The one-shot state+-- monad trick] in "GHC.Utils.Monad".+mkTcS :: (TcSEnv -> TcM a) -> TcS a+mkTcS f = TcS (oneShot f)++instance Applicative TcS where+  pure x = mkTcS $ \_ -> return x+  (<*>) = ap++instance Monad TcS where+  m >>= k   = mkTcS $ \ebs -> do+    unTcS m ebs >>= (\r -> unTcS (k r) ebs)++instance MonadIO TcS where+  liftIO act = TcS $ \_env -> liftIO act++instance MonadFail TcS where+  fail err  = mkTcS $ \_ -> fail err++instance MonadUnique TcS where+   getUniqueSupplyM = wrapTcS getUniqueSupplyM++instance HasModule TcS where+   getModule = wrapTcS getModule++instance MonadThings TcS where+   lookupThing n = wrapTcS (lookupThing n)++-- Basic functionality+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+wrapTcS :: TcM a -> TcS a+-- Do not export wrapTcS, because it promotes an arbitrary TcM to TcS,+-- and TcS is supposed to have limited functionality+wrapTcS action = mkTcS $ \_env -> action -- a TcM action will not use the TcEvBinds++wrap2TcS :: (TcM a -> TcM a) -> TcS a -> TcS a+wrap2TcS fn (TcS thing) = mkTcS $ \env -> fn (thing env)++wrapErrTcS :: TcM a -> TcS a+-- The thing wrapped should just fail+-- There's no static check; it's up to the user+-- Having a variant for each error message is too painful+wrapErrTcS = wrapTcS++wrapWarnTcS :: TcM a -> TcS a+-- The thing wrapped should just add a warning, or no-op+-- There's no static check; it's up to the user+wrapWarnTcS = wrapTcS++panicTcS  :: SDoc -> TcS a+failTcS   :: TcRnMessage -> TcS a+warnTcS, addErrTcS :: TcRnMessage -> TcS ()+failTcS      = wrapTcS . TcM.failWith+warnTcS msg  = wrapTcS (TcM.addDiagnostic msg)+addErrTcS    = wrapTcS . TcM.addErr+panicTcS doc = pprPanic "GHC.Tc.Solver.Canonical" doc++traceTcS :: String -> SDoc -> TcS ()+traceTcS herald doc = wrapTcS (TcM.traceTc herald doc)+{-# INLINE traceTcS #-}  -- see Note [INLINE conditional tracing utilities]++runTcPluginTcS :: TcPluginM a -> TcS a+runTcPluginTcS = wrapTcS . runTcPluginM++instance HasDynFlags TcS where+    getDynFlags = wrapTcS getDynFlags++getGlobalRdrEnvTcS :: TcS GlobalRdrEnv+getGlobalRdrEnvTcS = wrapTcS TcM.getGlobalRdrEnv++bumpStepCountTcS :: TcS ()+bumpStepCountTcS = mkTcS $ \env ->+  do { let ref = tcs_count env+     ; n <- TcM.readTcRef ref+     ; TcM.writeTcRef ref (n+1) }++csTraceTcS :: SDoc -> TcS ()+csTraceTcS doc+  = wrapTcS $ csTraceTcM (return doc)+{-# INLINE csTraceTcS #-}  -- see Note [INLINE conditional tracing utilities]++traceFireTcS :: CtEvidence -> SDoc -> TcS ()+-- Dump a rule-firing trace+traceFireTcS ev doc+  = mkTcS $ \env -> csTraceTcM $+    do { n <- TcM.readTcRef (tcs_count env)+       ; tclvl <- TcM.getTcLevel+       ; return (hang (text "Step" <+> int n+                       <> brackets (text "l:" <> ppr tclvl <> comma <>+                                    text "d:" <> ppr (ctLocDepth (ctEvLoc ev)))+                       <+> doc <> colon)+                     4 (ppr ev)) }+{-# INLINE traceFireTcS #-}  -- see Note [INLINE conditional tracing utilities]++csTraceTcM :: TcM SDoc -> TcM ()+-- Constraint-solver tracing, -ddump-cs-trace+csTraceTcM mk_doc+  = do { logger <- getLogger+       ; when (  logHasDumpFlag logger Opt_D_dump_cs_trace+                  || logHasDumpFlag logger Opt_D_dump_tc_trace)+              ( do { msg <- mk_doc+                   ; TcM.dumpTcRn False+                       Opt_D_dump_cs_trace+                       "" FormatText+                       msg }) }+{-# INLINE csTraceTcM #-}  -- see Note [INLINE conditional tracing utilities]++runTcS :: TcS a                -- What to run+       -> TcM (a, EvBindMap)+runTcS tcs+  = do { ev_binds_var <- TcM.newTcEvBinds+       ; res <- runTcSWithEvBinds ev_binds_var tcs+       ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var+       ; return (res, ev_binds) }++-- | This variant of 'runTcS' will immediatley fail upon encountering an+-- insoluble ct. See Note [Speeding up valid hole-fits]. Its one usage+-- site does not need the ev_binds, so we do not return them.+runTcSEarlyAbort :: TcS a -> TcM a+runTcSEarlyAbort tcs+  = do { ev_binds_var <- TcM.newTcEvBinds+       ; runTcSWithEvBinds' True True ev_binds_var tcs }++-- | This can deal only with equality constraints.+runTcSEqualities :: TcS a -> TcM a+runTcSEqualities thing_inside+  = do { ev_binds_var <- TcM.newNoTcEvBinds+       ; runTcSWithEvBinds ev_binds_var thing_inside }++-- | A variant of 'runTcS' that takes and returns an 'InertSet' for+-- later resumption of the 'TcS' session.+runTcSInerts :: InertSet -> TcS a -> TcM (a, InertSet)+runTcSInerts inerts tcs = do+  ev_binds_var <- TcM.newTcEvBinds+  runTcSWithEvBinds' False False ev_binds_var $ do+    setTcSInerts inerts+    a <- tcs+    new_inerts <- getTcSInerts+    return (a, new_inerts)++runTcSWithEvBinds :: EvBindsVar+                  -> TcS a+                  -> TcM a+runTcSWithEvBinds = runTcSWithEvBinds' True False++runTcSWithEvBinds' :: Bool -- ^ Restore type variable cycles afterwards?+                           -- Don't if you want to reuse the InertSet.+                           -- See also Note [Type equality cycles]+                           -- in GHC.Tc.Solver.Canonical+                   -> Bool+                   -> EvBindsVar+                   -> TcS a+                   -> TcM a+runTcSWithEvBinds' restore_cycles abort_on_insoluble ev_binds_var tcs+  = do { unified_var <- TcM.newTcRef 0+       ; step_count <- TcM.newTcRef 0+       ; inert_var <- TcM.newTcRef emptyInert+       ; wl_var <- TcM.newTcRef emptyWorkList+       ; unif_lvl_var <- TcM.newTcRef Nothing+       ; let env = TcSEnv { tcs_ev_binds           = ev_binds_var+                          , tcs_unified            = unified_var+                          , tcs_unif_lvl           = unif_lvl_var+                          , tcs_count              = step_count+                          , tcs_inerts             = inert_var+                          , tcs_abort_on_insoluble = abort_on_insoluble+                          , tcs_worklist           = wl_var }++             -- Run the computation+       ; res <- unTcS tcs env++       ; count <- TcM.readTcRef step_count+       ; when (count > 0) $+         csTraceTcM $ return (text "Constraint solver steps =" <+> int count)++       ; when restore_cycles $+         do { inert_set <- TcM.readTcRef inert_var+            ; restoreTyVarCycles inert_set }++#if defined(DEBUG)+       ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var+       ; checkForCyclicBinds ev_binds+#endif++       ; return res }++----------------------------+#if defined(DEBUG)+checkForCyclicBinds :: EvBindMap -> TcM ()+checkForCyclicBinds ev_binds_map+  | null cycles+  = return ()+  | null coercion_cycles+  = TcM.traceTc "Cycle in evidence binds" $ ppr cycles+  | otherwise+  = pprPanic "Cycle in coercion bindings" $ ppr coercion_cycles+  where+    ev_binds = evBindMapBinds ev_binds_map++    cycles :: [[EvBind]]+    cycles = [c | CyclicSCC c <- stronglyConnCompFromEdgedVerticesUniq edges]++    coercion_cycles = [c | c <- cycles, any is_co_bind c]+    is_co_bind (EvBind { eb_lhs = b }) = isEqPrimPred (varType b)++    edges :: [ Node EvVar EvBind ]+    edges = [ DigraphNode bind bndr (nonDetEltsUniqSet (evVarsOfTerm rhs))+            | bind@(EvBind { eb_lhs = bndr, eb_rhs = rhs}) <- bagToList ev_binds ]+            -- It's OK to use nonDetEltsUFM here as+            -- stronglyConnCompFromEdgedVertices is still deterministic even+            -- if the edges are in nondeterministic order as explained in+            -- Note [Deterministic SCC] in GHC.Data.Graph.Directed.+#endif++----------------------------+setEvBindsTcS :: EvBindsVar -> TcS a -> TcS a+setEvBindsTcS ref (TcS thing_inside)+ = TcS $ \ env -> thing_inside (env { tcs_ev_binds = ref })++nestImplicTcS :: EvBindsVar+              -> TcLevel -> TcS a+              -> TcS a+nestImplicTcS ref inner_tclvl (TcS thing_inside)+  = TcS $ \ TcSEnv { tcs_unified            = unified_var+                   , tcs_inerts             = old_inert_var+                   , tcs_count              = count+                   , tcs_unif_lvl           = unif_lvl+                   , tcs_abort_on_insoluble = abort_on_insoluble+                   } ->+    do { inerts <- TcM.readTcRef old_inert_var+       ; let nest_inert = inerts { inert_cycle_breakers = pushCycleBreakerVarStack+                                                            (inert_cycle_breakers inerts)+                                 , inert_cans = (inert_cans inerts)+                                                   { inert_given_eqs = False } }+                 -- All other InertSet fields are inherited+       ; new_inert_var <- TcM.newTcRef nest_inert+       ; new_wl_var    <- TcM.newTcRef emptyWorkList+       ; let nest_env = TcSEnv { tcs_count              = count     -- Inherited+                               , tcs_unif_lvl           = unif_lvl  -- Inherited+                               , tcs_ev_binds           = ref+                               , tcs_unified            = unified_var+                               , tcs_inerts             = new_inert_var+                               , tcs_abort_on_insoluble = abort_on_insoluble+                               , tcs_worklist           = new_wl_var }+       ; res <- TcM.setTcLevel inner_tclvl $+                thing_inside nest_env++       ; out_inert_set <- TcM.readTcRef new_inert_var+       ; restoreTyVarCycles out_inert_set++#if defined(DEBUG)+       -- Perform a check that the thing_inside did not cause cycles+       ; ev_binds <- TcM.getTcEvBindsMap ref+       ; checkForCyclicBinds ev_binds+#endif+       ; return res }++nestTcS ::  TcS a -> TcS a+-- Use the current untouchables, augmenting the current+-- evidence bindings, and solved dictionaries+-- But have no effect on the InertCans, or on the inert_famapp_cache+-- (we want to inherit the latter from processing the Givens)+nestTcS (TcS thing_inside)+  = TcS $ \ env@(TcSEnv { tcs_inerts = inerts_var }) ->+    do { inerts <- TcM.readTcRef inerts_var+       ; new_inert_var <- TcM.newTcRef inerts+       ; new_wl_var    <- TcM.newTcRef emptyWorkList+       ; let nest_env = env { tcs_inerts   = new_inert_var+                            , tcs_worklist = new_wl_var }++       ; res <- thing_inside nest_env++       ; new_inerts <- TcM.readTcRef new_inert_var++       -- we want to propagate the safe haskell failures+       ; let old_ic = inert_cans inerts+             new_ic = inert_cans new_inerts+             nxt_ic = old_ic { inert_safehask = inert_safehask new_ic }++       ; TcM.writeTcRef inerts_var  -- See Note [Propagate the solved dictionaries]+                        (inerts { inert_solved_dicts = inert_solved_dicts new_inerts+                                , inert_cans = nxt_ic })++       ; return res }++emitImplicationTcS :: TcLevel -> SkolemInfoAnon+                   -> [TcTyVar]        -- Skolems+                   -> [EvVar]          -- Givens+                   -> Cts              -- Wanteds+                   -> TcS TcEvBinds+-- Add an implication to the TcS monad work-list+emitImplicationTcS new_tclvl skol_info skol_tvs givens wanteds+  = do { let wc = emptyWC { wc_simple = wanteds }+       ; imp <- wrapTcS $+                do { ev_binds_var <- TcM.newTcEvBinds+                   ; imp <- TcM.newImplication+                   ; return (imp { ic_tclvl  = new_tclvl+                                 , ic_skols  = skol_tvs+                                 , ic_given  = givens+                                 , ic_wanted = wc+                                 , ic_binds  = ev_binds_var+                                 , ic_info   = skol_info }) }++       ; emitImplication imp+       ; return (TcEvBinds (ic_binds imp)) }++emitTvImplicationTcS :: TcLevel -> SkolemInfoAnon+                     -> [TcTyVar]        -- Skolems+                     -> Cts              -- Wanteds+                     -> TcS ()+-- Just like emitImplicationTcS but no givens and no bindings+emitTvImplicationTcS new_tclvl skol_info skol_tvs wanteds+  = do { let wc = emptyWC { wc_simple = wanteds }+       ; imp <- wrapTcS $+                do { ev_binds_var <- TcM.newNoTcEvBinds+                   ; imp <- TcM.newImplication+                   ; return (imp { ic_tclvl  = new_tclvl+                                 , ic_skols  = skol_tvs+                                 , ic_wanted = wc+                                 , ic_binds  = ev_binds_var+                                 , ic_info   = skol_info }) }++       ; emitImplication imp }+++{- Note [Propagate the solved dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's really quite important that nestTcS does not discard the solved+dictionaries from the thing_inside.+Consider+   Eq [a]+   forall b. empty =>  Eq [a]+We solve the simple (Eq [a]), under nestTcS, and then turn our attention to+the implications.  It's definitely fine to use the solved dictionaries on+the inner implications, and it can make a significant performance difference+if you do so.+-}++-- Getters and setters of GHC.Tc.Utils.Env fields+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++-- Getter of inerts and worklist+getTcSInertsRef :: TcS (IORef InertSet)+getTcSInertsRef = TcS (return . tcs_inerts)++getTcSWorkListRef :: TcS (IORef WorkList)+getTcSWorkListRef = TcS (return . tcs_worklist)++getTcSInerts :: TcS InertSet+getTcSInerts = getTcSInertsRef >>= readTcRef++setTcSInerts :: InertSet -> TcS ()+setTcSInerts ics = do { r <- getTcSInertsRef; writeTcRef r ics }++getWorkListImplics :: TcS (Bag Implication)+getWorkListImplics+  = do { wl_var <- getTcSWorkListRef+       ; wl_curr <- readTcRef wl_var+       ; return (wl_implics wl_curr) }++pushLevelNoWorkList :: SDoc -> TcS a -> TcS (TcLevel, a)+-- Push the level and run thing_inside+-- However, thing_inside should not generate any work items+#if defined(DEBUG)+pushLevelNoWorkList err_doc (TcS thing_inside)+  = TcS (\env -> TcM.pushTcLevelM $+                 thing_inside (env { tcs_worklist = wl_panic })+        )+  where+    wl_panic  = pprPanic "GHC.Tc.Solver.Monad.buildImplication" err_doc+                         -- This panic checks that the thing-inside+                         -- does not emit any work-list constraints+#else+pushLevelNoWorkList _ (TcS thing_inside)+  = TcS (\env -> TcM.pushTcLevelM (thing_inside env))  -- Don't check+#endif++updWorkListTcS :: (WorkList -> WorkList) -> TcS ()+updWorkListTcS f+  = do { wl_var <- getTcSWorkListRef+       ; updTcRef wl_var f }++emitWorkNC :: [CtEvidence] -> TcS ()+emitWorkNC evs+  | null evs+  = return ()+  | otherwise+  = emitWork (map mkNonCanonical evs)++emitWork :: [Ct] -> TcS ()+emitWork [] = return ()   -- avoid printing, among other work+emitWork cts+  = do { traceTcS "Emitting fresh work" (vcat (map ppr cts))+       ; updWorkListTcS (extendWorkListCts cts) }++emitImplication :: Implication -> TcS ()+emitImplication implic+  = updWorkListTcS (extendWorkListImplic implic)++newTcRef :: a -> TcS (TcRef a)+newTcRef x = wrapTcS (TcM.newTcRef x)++readTcRef :: TcRef a -> TcS a+readTcRef ref = wrapTcS (TcM.readTcRef ref)++writeTcRef :: TcRef a -> a -> TcS ()+writeTcRef ref val = wrapTcS (TcM.writeTcRef ref val)++updTcRef :: TcRef a -> (a->a) -> TcS ()+updTcRef ref upd_fn = wrapTcS (TcM.updTcRef ref upd_fn)++getTcEvBindsVar :: TcS EvBindsVar+getTcEvBindsVar = TcS (return . tcs_ev_binds)++getTcLevel :: TcS TcLevel+getTcLevel = wrapTcS TcM.getTcLevel++getTcEvTyCoVars :: EvBindsVar -> TcS TyCoVarSet+getTcEvTyCoVars ev_binds_var+  = wrapTcS $ TcM.getTcEvTyCoVars ev_binds_var++getTcEvBindsMap :: EvBindsVar -> TcS EvBindMap+getTcEvBindsMap ev_binds_var+  = wrapTcS $ TcM.getTcEvBindsMap ev_binds_var++setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcS ()+setTcEvBindsMap ev_binds_var binds+  = wrapTcS $ TcM.setTcEvBindsMap ev_binds_var binds++unifyTyVar :: TcTyVar -> TcType -> TcS ()+-- Unify a meta-tyvar with a type+-- We keep track of how many unifications have happened in tcs_unified,+--+-- We should never unify the same variable twice!+unifyTyVar tv ty+  = assertPpr (isMetaTyVar tv) (ppr tv) $+    TcS $ \ env ->+    do { TcM.traceTc "unifyTyVar" (ppr tv <+> text ":=" <+> ppr ty)+       ; TcM.writeMetaTyVar tv ty+       ; TcM.updTcRef (tcs_unified env) (+1) }++reportUnifications :: TcS a -> TcS (Int, a)+reportUnifications (TcS thing_inside)+  = TcS $ \ env ->+    do { inner_unified <- TcM.newTcRef 0+       ; res <- thing_inside (env { tcs_unified = inner_unified })+       ; n_unifs <- TcM.readTcRef inner_unified+       ; TcM.updTcRef (tcs_unified env) (+ n_unifs)+       ; return (n_unifs, res) }++data TouchabilityTestResult+  -- See Note [Solve by unification] in GHC.Tc.Solver.Interact+  -- which points out that having TouchableSameLevel is just an optimisation;+  -- we could manage with TouchableOuterLevel alone (suitably renamed)+  = TouchableSameLevel+  | TouchableOuterLevel [TcTyVar]   -- Promote these+                        TcLevel     -- ..to this level+  | Untouchable++instance Outputable TouchabilityTestResult where+  ppr TouchableSameLevel            = text "TouchableSameLevel"+  ppr (TouchableOuterLevel tvs lvl) = text "TouchableOuterLevel" <> parens (ppr lvl <+> ppr tvs)+  ppr Untouchable                   = text "Untouchable"++touchabilityTest :: CtFlavour -> TcTyVar -> TcType -> TcS TouchabilityTestResult+-- This is the key test for untouchability:+-- See Note [Unification preconditions] in GHC.Tc.Utils.Unify+-- and Note [Solve by unification] in GHC.Tc.Solver.Interact+touchabilityTest flav tv1 rhs+  | flav /= Given  -- See Note [Do not unify Givens]+  , MetaTv { mtv_tclvl = tv_lvl, mtv_info = info } <- tcTyVarDetails tv1+  = do { can_continue_solving <- wrapTcS $ startSolvingByUnification info rhs+       ; if not can_continue_solving+         then return Untouchable+         else+    do { ambient_lvl  <- getTcLevel+       ; given_eq_lvl <- getInnermostGivenEqLevel++       ; if | tv_lvl `sameDepthAs` ambient_lvl+            -> return TouchableSameLevel++            | tv_lvl `deeperThanOrSame` given_eq_lvl   -- No intervening given equalities+            , all (does_not_escape tv_lvl) free_skols  -- No skolem escapes+            -> return (TouchableOuterLevel free_metas tv_lvl)++            | otherwise+            -> return Untouchable } }+  | otherwise+  = return Untouchable+  where+     (free_metas, free_skols) = partition isPromotableMetaTyVar $+                                nonDetEltsUniqSet               $+                                tyCoVarsOfType rhs++     does_not_escape tv_lvl fv+       | isTyVar fv = tv_lvl `deeperThanOrSame` tcTyVarLevel fv+       | otherwise  = True+       -- Coercion variables are not an escape risk+       -- If an implication binds a coercion variable, it'll have equalities,+       -- so the "intervening given equalities" test above will catch it+       -- Coercion holes get filled with coercions, so again no problem.++{- Note [Do not unify Givens]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this GADT match+   data T a where+      T1 :: T Int+      ...++   f x = case x of+           T1 -> True+           ...++So we get f :: T alpha[1] -> beta[1]+          x :: T alpha[1]+and from the T1 branch we get the implication+   forall[2] (alpha[1] ~ Int) => beta[1] ~ Bool++Now, clearly we don't want to unify alpha:=Int!  Yet at the moment we+process [G] alpha[1] ~ Int, we don't have any given-equalities in the+inert set, and hence there are no given equalities to make alpha untouchable.++NB: if it were alpha[2] ~ Int, this argument wouldn't hold.  But that+never happens: invariant (GivenInv) in Note [TcLevel invariants]+in GHC.Tc.Utils.TcType.++Simple solution: never unify in Givens!+-}++getDefaultInfo ::  TcS ([Type], (Bool, Bool))+getDefaultInfo = wrapTcS TcM.tcGetDefaultTys++getWorkList :: TcS WorkList+getWorkList = do { wl_var <- getTcSWorkListRef+                 ; wrapTcS (TcM.readTcRef wl_var) }++selectNextWorkItem :: TcS (Maybe Ct)+-- Pick which work item to do next+-- See Note [Prioritise equalities]+selectNextWorkItem+  = do { wl_var <- getTcSWorkListRef+       ; wl <- readTcRef wl_var+       ; case selectWorkItem wl of {+           Nothing -> return Nothing ;+           Just (ct, new_wl) ->+    do { -- checkReductionDepth (ctLoc ct) (ctPred ct)+         -- This is done by GHC.Tc.Solver.Interact.chooseInstance+       ; writeTcRef wl_var new_wl+       ; return (Just ct) } } }++-- Just get some environments needed for instance looking up and matching+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++getInstEnvs :: TcS InstEnvs+getInstEnvs = wrapTcS $ TcM.tcGetInstEnvs++getFamInstEnvs :: TcS (FamInstEnv, FamInstEnv)+getFamInstEnvs = wrapTcS $ FamInst.tcGetFamInstEnvs++getTopEnv :: TcS HscEnv+getTopEnv = wrapTcS $ TcM.getTopEnv++getGblEnv :: TcS TcGblEnv+getGblEnv = wrapTcS $ TcM.getGblEnv++getLclEnv :: TcS TcLclEnv+getLclEnv = wrapTcS $ TcM.getLclEnv++setLclEnv :: TcLclEnv -> TcS a -> TcS a+setLclEnv env = wrap2TcS (TcM.setLclEnv env)++tcLookupClass :: Name -> TcS Class+tcLookupClass c = wrapTcS $ TcM.tcLookupClass c++tcLookupId :: Name -> TcS Id+tcLookupId n = wrapTcS $ TcM.tcLookupId n++-- Setting names as used (used in the deriving of Coercible evidence)+-- Too hackish to expose it to TcS? In that case somehow extract the used+-- constructors from the result of solveInteract+addUsedGREs :: [GlobalRdrElt] -> TcS ()+addUsedGREs gres = wrapTcS  $ TcM.addUsedGREs gres++addUsedGRE :: Bool -> GlobalRdrElt -> TcS ()+addUsedGRE warn_if_deprec gre = wrapTcS $ TcM.addUsedGRE warn_if_deprec gre++keepAlive :: Name -> TcS ()+keepAlive = wrapTcS . TcM.keepAlive++-- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++checkWellStagedDFun :: CtLoc -> InstanceWhat -> PredType -> TcS ()+-- Check that we do not try to use an instance before it is available.  E.g.+--    instance Eq T where ...+--    f x = $( ... (\(p::T) -> p == p)... )+-- Here we can't use the equality function from the instance in the splice++checkWellStagedDFun loc what pred+  = do+      mbind_lvl <- checkWellStagedInstanceWhat what+      case mbind_lvl of+        Just bind_lvl | bind_lvl > impLevel ->+          wrapTcS $ TcM.setCtLocM loc $ do+              { use_stage <- TcM.getStage+              ; TcM.checkWellStaged pp_thing bind_lvl (thLevel use_stage) }+        _ ->+          return ()+  where+    pp_thing = text "instance for" <+> quotes (ppr pred)++-- | Returns the ThLevel of evidence for the solved constraint (if it has evidence)+-- See Note [Well-staged instance evidence]+checkWellStagedInstanceWhat :: InstanceWhat -> TcS (Maybe ThLevel)+checkWellStagedInstanceWhat what+  | TopLevInstance { iw_dfun_id = dfun_id } <- what+    = return $ Just (TcM.topIdLvl dfun_id)+  | BuiltinTypeableInstance tc <- what+    = do+        cur_mod <- extractModule <$> getGblEnv+        return $ Just (if nameIsLocalOrFrom cur_mod (tyConName tc)+                        then outerLevel+                        else impLevel)+  | otherwise = return Nothing++{-+Note [Well-staged instance evidence]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Evidence for instances must obey the same level restrictions as normal bindings.+In particular, it is forbidden to use an instance in a top-level splice in the+module which the instance is defined. This is because the evidence is bound at+the top-level and top-level definitions are forbidden from being using in top-level splices in+the same module.++For example, suppose you have a function..  foo :: Show a => Code Q a -> Code Q ()+then the following program is disallowed,++```+data T a = T a deriving (Show)++main :: IO ()+main =+  let x = $$(foo [|| T () ||])+  in return ()+```++because the `foo` function (used in a top-level splice) requires `Show T` evidence,+which is defined at the top-level and therefore fails with an error that we have violated+the stage restriction.++```+Main.hs:12:14: error:+    • GHC stage restriction:+        instance for ‘Show+                        (T ())’ is used in a top-level splice, quasi-quote, or annotation,+        and must be imported, not defined locally+    • In the expression: foo [|| T () ||]+      In the Template Haskell splice $$(foo [|| T () ||])+      In the expression: $$(foo [|| T () ||])+   |+12 |   let x = $$(foo [|| T () ||])+   |+```++Solving a `Typeable (T t1 ...tn)` constraint generates code that relies on+`$tcT`, the `TypeRep` for `T`; and we must check that this reference to `$tcT`+is well staged.  It's easy to know the stage of `$tcT`: for imported TyCons it+will be `impLevel`, and for local TyCons it will be `toplevel`.++Therefore the `InstanceWhat` type had to be extended with+a special case for `Typeable`, which recorded the TyCon the evidence was for and+could them be used to check that we were not attempting to evidence in a stage incorrect+manner.++-}++pprEq :: TcType -> TcType -> SDoc+pprEq ty1 ty2 = pprParendType ty1 <+> char '~' <+> pprParendType ty2++isFilledMetaTyVar_maybe :: TcTyVar -> TcS (Maybe Type)+isFilledMetaTyVar_maybe tv = wrapTcS (TcM.isFilledMetaTyVar_maybe tv)++isFilledMetaTyVar :: TcTyVar -> TcS Bool+isFilledMetaTyVar tv = wrapTcS (TcM.isFilledMetaTyVar tv)++zonkTyCoVarsAndFV :: TcTyCoVarSet -> TcS TcTyCoVarSet+zonkTyCoVarsAndFV tvs = wrapTcS (TcM.zonkTyCoVarsAndFV tvs)++zonkTyCoVarsAndFVList :: [TcTyCoVar] -> TcS [TcTyCoVar]+zonkTyCoVarsAndFVList tvs = wrapTcS (TcM.zonkTyCoVarsAndFVList tvs)++zonkCo :: Coercion -> TcS Coercion+zonkCo = wrapTcS . TcM.zonkCo++zonkTcType :: TcType -> TcS TcType+zonkTcType ty = wrapTcS (TcM.zonkTcType ty)++zonkTcTypes :: [TcType] -> TcS [TcType]+zonkTcTypes tys = wrapTcS (TcM.zonkTcTypes tys)++zonkTcTyVar :: TcTyVar -> TcS TcType+zonkTcTyVar tv = wrapTcS (TcM.zonkTcTyVar tv)++zonkSimples :: Cts -> TcS Cts+zonkSimples cts = wrapTcS (TcM.zonkSimples cts)++zonkWC :: WantedConstraints -> TcS WantedConstraints+zonkWC wc = wrapTcS (TcM.zonkWC wc)++zonkTyCoVarKind :: TcTyCoVar -> TcS TcTyCoVar+zonkTyCoVarKind tv = wrapTcS (TcM.zonkTyCoVarKind tv)++----------------------------+pprKicked :: Int -> SDoc+pprKicked 0 = empty+pprKicked n = parens (int n <+> text "kicked out")++{- *********************************************************************+*                                                                      *+*              The Unification Level Flag                              *+*                                                                      *+********************************************************************* -}++{- Note [The Unification Level Flag]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider a deep tree of implication constraints+   forall[1] a.                              -- Outer-implic+      C alpha[1]                               -- Simple+      forall[2] c. ....(C alpha[1])....        -- Implic-1+      forall[2] b. ....(alpha[1] ~ Int)....    -- Implic-2++The (C alpha) is insoluble until we know alpha.  We solve alpha+by unifying alpha:=Int somewhere deep inside Implic-2. But then we+must try to solve the Outer-implic all over again. This time we can+solve (C alpha) both in Outer-implic, and nested inside Implic-1.++When should we iterate solving a level-n implication?+Answer: if any unification of a tyvar at level n takes place+        in the ic_implics of that implication.++* What if a unification takes place at level n-1? Then don't iterate+  level n, because we'll iterate level n-1, and that will in turn iterate+  level n.++* What if a unification takes place at level n, in the ic_simples of+  level n?  No need to track this, because the kick-out mechanism deals+  with it.  (We can't drop kick-out in favour of iteration, because kick-out+  works for skolem-equalities, not just unifications.)++So the monad-global Unification Level Flag, kept in tcs_unif_lvl keeps+track of+  - Whether any unifications at all have taken place (Nothing => no unifications)+  - If so, what is the outermost level that has seen a unification (Just lvl)++The iteration done in the simplify_loop/maybe_simplify_again loop in GHC.Tc.Solver.++It helpful not to iterate unless there is a chance of progress.  #8474 is+an example:++  * There's a deeply-nested chain of implication constraints.+       ?x:alpha => ?y1:beta1 => ... ?yn:betan => [W] ?x:Int++  * From the innermost one we get a [W] alpha[1] ~ Int,+    so we can unify.++  * It's better not to iterate the inner implications, but go all the+    way out to level 1 before iterating -- because iterating level 1+    will iterate the inner levels anyway.++(In the olden days when we "floated" thse Derived constraints, this was+much, much more important -- we got exponential behaviour, as each iteration+produced the same Derived constraint.)+-}+++resetUnificationFlag :: TcS Bool+-- We are at ambient level i+-- If the unification flag = Just i, reset it to Nothing and return True+-- Otherwise leave it unchanged and return False+resetUnificationFlag+  = TcS $ \env ->+    do { let ref = tcs_unif_lvl env+       ; ambient_lvl <- TcM.getTcLevel+       ; mb_lvl <- TcM.readTcRef ref+       ; TcM.traceTc "resetUnificationFlag" $+         vcat [ text "ambient:" <+> ppr ambient_lvl+              , text "unif_lvl:" <+> ppr mb_lvl ]+       ; case mb_lvl of+           Nothing       -> return False+           Just unif_lvl | ambient_lvl `strictlyDeeperThan` unif_lvl+                         -> return False+                         | otherwise+                         -> do { TcM.writeTcRef ref Nothing+                               ; return True } }++setUnificationFlag :: TcLevel -> TcS ()+-- (setUnificationFlag i) sets the unification level to (Just i)+-- unless it already is (Just j) where j <= i+setUnificationFlag lvl+  = TcS $ \env ->+    do { let ref = tcs_unif_lvl env+       ; mb_lvl <- TcM.readTcRef ref+       ; case mb_lvl of+           Just unif_lvl | lvl `deeperThanOrSame` unif_lvl+                         -> return ()+           _ -> TcM.writeTcRef ref (Just lvl) }+++{- *********************************************************************+*                                                                      *+*                Instantiation etc.+*                                                                      *+********************************************************************* -}++-- Instantiations+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++instDFunType :: DFunId -> [DFunInstType] -> TcS ([TcType], TcThetaType)+instDFunType dfun_id inst_tys+  = wrapTcS $ TcM.instDFunType dfun_id inst_tys++newFlexiTcSTy :: Kind -> TcS TcType+newFlexiTcSTy knd = wrapTcS (TcM.newFlexiTyVarTy knd)++cloneMetaTyVar :: TcTyVar -> TcS TcTyVar+cloneMetaTyVar tv = wrapTcS (TcM.cloneMetaTyVar tv)++instFlexi :: [TKVar] -> TcS TCvSubst+instFlexi = instFlexiX emptyTCvSubst++instFlexiX :: TCvSubst -> [TKVar] -> TcS TCvSubst+instFlexiX subst tvs+  = wrapTcS (foldlM instFlexiHelper subst tvs)++instFlexiHelper :: TCvSubst -> TKVar -> TcM TCvSubst+instFlexiHelper subst tv+  = do { uniq <- TcM.newUnique+       ; details <- TcM.newMetaDetails TauTv+       ; let name = setNameUnique (tyVarName tv) uniq+             kind = substTyUnchecked subst (tyVarKind tv)+             ty'  = mkTyVarTy (mkTcTyVar name kind details)+       ; TcM.traceTc "instFlexi" (ppr ty')+       ; return (extendTvSubst subst tv ty') }++matchGlobalInst :: DynFlags+                -> Bool      -- True <=> caller is the short-cut solver+                             -- See Note [Shortcut solving: overlap]+                -> Class -> [Type] -> TcS TcM.ClsInstResult+matchGlobalInst dflags short_cut cls tys+  = wrapTcS (TcM.matchGlobalInst dflags short_cut cls tys)++tcInstSkolTyVarsX :: SkolemInfo -> TCvSubst -> [TyVar] -> TcS (TCvSubst, [TcTyVar])+tcInstSkolTyVarsX skol_info subst tvs = wrapTcS $ TcM.tcInstSkolTyVarsX skol_info subst tvs++-- Creating and setting evidence variables and CtFlavors+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++data MaybeNew = Fresh CtEvidence | Cached EvExpr++isFresh :: MaybeNew -> Bool+isFresh (Fresh {})  = True+isFresh (Cached {}) = False++freshGoals :: [MaybeNew] -> [CtEvidence]+freshGoals mns = [ ctev | Fresh ctev <- mns ]++getEvExpr :: MaybeNew -> EvExpr+getEvExpr (Fresh ctev) = ctEvExpr ctev+getEvExpr (Cached evt) = evt++setEvBind :: EvBind -> TcS ()+setEvBind ev_bind+  = do { evb <- getTcEvBindsVar+       ; wrapTcS $ TcM.addTcEvBind evb ev_bind }++-- | Mark variables as used filling a coercion hole+useVars :: CoVarSet -> TcS ()+useVars co_vars+  = do { ev_binds_var <- getTcEvBindsVar+       ; let ref = ebv_tcvs ev_binds_var+       ; wrapTcS $+         do { tcvs <- TcM.readTcRef ref+            ; let tcvs' = tcvs `unionVarSet` co_vars+            ; TcM.writeTcRef ref tcvs' } }++-- | Equalities only+setWantedEq :: HasDebugCallStack => TcEvDest -> Coercion -> TcS ()+setWantedEq (HoleDest hole) co+  = do { useVars (coVarsOfCo co)+       ; fillCoercionHole hole co }+setWantedEq (EvVarDest ev) _ = pprPanic "setWantedEq: EvVarDest" (ppr ev)++-- | Good for both equalities and non-equalities+setWantedEvTerm :: TcEvDest -> EvTerm -> TcS ()+setWantedEvTerm (HoleDest hole) tm+  | Just co <- evTermCoercion_maybe tm+  = do { useVars (coVarsOfCo co)+       ; fillCoercionHole hole co }+  | otherwise+  = -- See Note [Yukky eq_sel for a HoleDest]+    do { let co_var = coHoleCoVar hole+       ; setEvBind (mkWantedEvBind co_var tm)+       ; fillCoercionHole hole (mkTcCoVarCo co_var) }++setWantedEvTerm (EvVarDest ev_id) tm+  = setEvBind (mkWantedEvBind ev_id tm)++{- Note [Yukky eq_sel for a HoleDest]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+How can it be that a Wanted with HoleDest gets evidence that isn't+just a coercion? i.e. evTermCoercion_maybe returns Nothing.++Consider [G] forall a. blah => a ~ T+         [W] S ~# T++Then doTopReactEqPred carefully looks up the (boxed) constraint (S ~+T) in the quantified constraints, and wraps the (boxed) evidence it+gets back in an eq_sel to extract the unboxed (S ~# T).  We can't put+that term into a coercion, so we add a value binding+    h = eq_sel (...)+and the coercion variable h to fill the coercion hole.+We even re-use the CoHole's Id for this binding!++Yuk!+-}++fillCoercionHole :: CoercionHole -> Coercion -> TcS ()+fillCoercionHole hole co+  = do { wrapTcS $ TcM.fillCoercionHole hole co+       ; kickOutAfterFillingCoercionHole hole }++setEvBindIfWanted :: CtEvidence -> EvTerm -> TcS ()+setEvBindIfWanted ev tm+  = case ev of+      CtWanted { ctev_dest = dest } -> setWantedEvTerm dest tm+      _                             -> return ()++newTcEvBinds :: TcS EvBindsVar+newTcEvBinds = wrapTcS TcM.newTcEvBinds++newNoTcEvBinds :: TcS EvBindsVar+newNoTcEvBinds = wrapTcS TcM.newNoTcEvBinds++newEvVar :: TcPredType -> TcS EvVar+newEvVar pred = wrapTcS (TcM.newEvVar pred)++newGivenEvVar :: CtLoc -> (TcPredType, EvTerm) -> TcS CtEvidence+-- Make a new variable of the given PredType,+-- immediately bind it to the given term+-- and return its CtEvidence+-- See Note [Bind new Givens immediately] in GHC.Tc.Types.Constraint+newGivenEvVar loc (pred, rhs)+  = do { new_ev <- newBoundEvVarId pred rhs+       ; return (CtGiven { ctev_pred = pred, ctev_evar = new_ev, ctev_loc = loc }) }++-- | Make a new 'Id' of the given type, bound (in the monad's EvBinds) to the+-- given term+newBoundEvVarId :: TcPredType -> EvTerm -> TcS EvVar+newBoundEvVarId pred rhs+  = do { new_ev <- newEvVar pred+       ; setEvBind (mkGivenEvBind new_ev rhs)+       ; return new_ev }++newGivenEvVars :: CtLoc -> [(TcPredType, EvTerm)] -> TcS [CtEvidence]+newGivenEvVars loc pts = mapM (newGivenEvVar loc) pts++emitNewWantedEq :: CtLoc -> RewriterSet -> Role -> TcType -> TcType -> TcS Coercion+-- | Emit a new Wanted equality into the work-list+emitNewWantedEq loc rewriters role ty1 ty2+  = do { (ev, co) <- newWantedEq loc rewriters role ty1 ty2+       ; updWorkListTcS (extendWorkListEq (mkNonCanonical ev))+       ; return co }++-- | Create a new Wanted constraint holding a coercion hole+-- for an equality between the two types at the given 'Role'.+newWantedEq :: CtLoc -> RewriterSet -> Role -> TcType -> TcType+            -> TcS (CtEvidence, Coercion)+newWantedEq loc rewriters role ty1 ty2+  = do { hole <- wrapTcS $ TcM.newCoercionHole pty+       ; traceTcS "Emitting new coercion hole" (ppr hole <+> dcolon <+> ppr pty)+       ; return ( CtWanted { ctev_pred      = pty+                           , ctev_dest      = HoleDest hole+                           , ctev_loc       = loc+                           , ctev_rewriters = rewriters }+                , mkHoleCo hole ) }+  where+    pty = mkPrimEqPredRole role ty1 ty2++-- | Create a new Wanted constraint holding an evidence variable.+--+-- Don't use this for equality constraints: use 'newWantedEq' instead.+newWantedEvVarNC :: CtLoc -> RewriterSet+                 -> TcPredType -> TcS CtEvidence+-- Don't look up in the solved/inerts; we know it's not there+newWantedEvVarNC loc rewriters pty+  = do { new_ev <- newEvVar pty+       ; traceTcS "Emitting new wanted" (ppr new_ev <+> dcolon <+> ppr pty $$+                                         pprCtLoc loc)+       ; return (CtWanted { ctev_pred      = pty+                          , ctev_dest      = EvVarDest new_ev+                          , ctev_loc       = loc+                          , ctev_rewriters = rewriters })}++-- | Like 'newWantedEvVarNC', except it might look up in the inert set+-- to see if an inert already exists, and uses that instead of creating+-- a new Wanted constraint.+--+-- Don't use this for equality constraints: this function is only for+-- constraints with 'EvVarDest'.+newWantedEvVar :: CtLoc -> RewriterSet+               -> TcPredType -> TcS MaybeNew+-- For anything except ClassPred, this is the same as newWantedEvVarNC+newWantedEvVar loc rewriters pty+  = assertPpr (not (isEqPrimPred pty))+      (vcat [ text "newWantedEvVar: HoleDestPred"+            , text "pty:" <+> ppr pty ]) $+    do { mb_ct <- lookupInInerts loc pty+       ; case mb_ct of+            Just ctev+              -> do { traceTcS "newWantedEvVar/cache hit" $ ppr ctev+                    ; return $ Cached (ctEvExpr ctev) }+            _ -> do { ctev <- newWantedEvVarNC loc rewriters pty+                    ; return (Fresh ctev) } }++-- | Create a new Wanted constraint, potentially looking up+-- non-equality constraints in the cache instead of creating+-- a new one from scratch.+--+-- Deals with both equality and non-equality constraints.+newWanted :: CtLoc -> RewriterSet -> PredType -> TcS MaybeNew+newWanted loc rewriters pty+  | Just (role, ty1, ty2) <- getEqPredTys_maybe pty+  = Fresh . fst <$> newWantedEq loc rewriters role ty1 ty2+  | otherwise+  = newWantedEvVar loc rewriters pty++-- | Create a new Wanted constraint.+--+-- Deals with both equality and non-equality constraints.+--+-- Does not attempt to re-use non-equality constraints that already+-- exist in the inert set.+newWantedNC :: CtLoc -> RewriterSet -> PredType -> TcS CtEvidence+newWantedNC loc rewriters pty+  | Just (role, ty1, ty2) <- getEqPredTys_maybe pty+  = fst <$> newWantedEq loc rewriters role ty1 ty2+  | otherwise+  = newWantedEvVarNC loc rewriters pty++-- --------- Check done in GHC.Tc.Solver.Interact.selectNewWorkItem???? ---------+-- | Checks if the depth of the given location is too much. Fails if+-- it's too big, with an appropriate error message.+checkReductionDepth :: CtLoc -> TcType   -- ^ type being reduced+                    -> TcS ()+checkReductionDepth loc ty+  = do { dflags <- getDynFlags+       ; when (subGoalDepthExceeded dflags (ctLocDepth loc)) $+         wrapErrTcS $ solverDepthError loc ty }++matchFam :: TyCon -> [Type] -> TcS (Maybe ReductionN)+matchFam tycon args = wrapTcS $ matchFamTcM tycon args++matchFamTcM :: TyCon -> [Type] -> TcM (Maybe ReductionN)+-- Given (F tys) return (ty, co), where co :: F tys ~N ty+matchFamTcM tycon args+  = do { fam_envs <- FamInst.tcGetFamInstEnvs+       ; let match_fam_result+              = reduceTyFamApp_maybe fam_envs Nominal tycon args+       ; TcM.traceTc "matchFamTcM" $+         vcat [ text "Matching:" <+> ppr (mkTyConApp tycon args)+              , ppr_res match_fam_result ]+       ; return match_fam_result }+  where+    ppr_res Nothing = text "Match failed"+    ppr_res (Just (Reduction co ty))+      = hang (text "Match succeeded:")+          2 (vcat [ text "Rewrites to:" <+> ppr ty+                  , text "Coercion:" <+> ppr co ])++solverDepthError :: CtLoc -> TcType -> TcM a+solverDepthError loc ty+  = TcM.setCtLocM loc $+    do { ty <- TcM.zonkTcType ty+       ; env0 <- TcM.tcInitTidyEnv+       ; let tidy_env     = tidyFreeTyCoVars env0 (tyCoVarsOfTypeList ty)+             tidy_ty      = tidyType tidy_env ty+             msg = TcRnUnknownMessage $ mkPlainError noHints $+               vcat [ text "Reduction stack overflow; size =" <+> ppr depth+                      , hang (text "When simplifying the following type:")+                           2 (ppr tidy_ty)+                      , note ]+       ; TcM.failWithTcM (tidy_env, msg) }+  where+    depth = ctLocDepth loc+    note = vcat+      [ text "Use -freduction-depth=0 to disable this check"+      , text "(any upper bound you could choose might fail unpredictably with"+      , text " minor updates to GHC, so disabling the check is recommended if"+      , text " you're sure that type checking should terminate)" ]+++{-+************************************************************************+*                                                                      *+              Breaking type variable cycles+*                                                                      *+************************************************************************+-}++-- | Conditionally replace all type family applications in the RHS with fresh+-- variables, emitting givens that relate the type family application to the+-- variable. See Note [Type equality cycles] in GHC.Tc.Solver.Canonical.+-- This only works under conditions as described in the Note; otherwise, returns+-- Nothing.+breakTyEqCycle_maybe :: CtEvidence+                     -> CheckTyEqResult   -- result of checkTypeEq+                     -> CanEqLHS+                     -> TcType     -- RHS+                     -> TcS (Maybe ReductionN)+                         -- new RHS that doesn't have any type families+breakTyEqCycle_maybe (ctLocOrigin . ctEvLoc -> CycleBreakerOrigin _) _ _ _+  -- see Detail (7) of Note+  = return Nothing++breakTyEqCycle_maybe ev cte_result lhs rhs+  | NomEq <- eq_rel++  , cte_result `cterHasOnlyProblem` cteSolubleOccurs+     -- only do this if the only problem is a soluble occurs-check+     -- See Detail (8) of the Note.++  = do { should_break <- final_check+       ; if should_break then do { redn <- go rhs+                                 ; return (Just redn) }+                         else return Nothing }+  where+    flavour = ctEvFlavour ev+    eq_rel  = ctEvEqRel ev++    final_check = case flavour of+      Given  -> return True+      Wanted    -- Wanteds work only with a touchable tyvar on the left+                -- See "Wanted" section of the Note.+        | TyVarLHS lhs_tv <- lhs ->+          do { result <- touchabilityTest Wanted lhs_tv rhs+             ; return $ case result of+                          Untouchable -> False+                          _           -> True }+        | otherwise -> return False++    -- This could be considerably more efficient. See Detail (5) of Note.+    go :: TcType -> TcS ReductionN+    go ty | Just ty' <- rewriterView ty = go ty'+    go (Rep.TyConApp tc tys)+      | isTypeFamilyTyCon tc  -- worried about whether this type family is not actually+                              -- causing trouble? See Detail (5) of Note.+      = do { let (fun_args, extra_args) = splitAt (tyConArity tc) tys+                 fun_app                = mkTyConApp tc fun_args+                 fun_app_kind           = tcTypeKind fun_app+           ; fun_redn <- emit_work fun_app_kind fun_app+           ; arg_redns <- unzipRedns <$> mapM go extra_args+           ; return $ mkAppRedns fun_redn arg_redns }+              -- Worried that this substitution will change kinds?+              -- See Detail (3) of Note++      | otherwise+      = do { arg_redns <- unzipRedns <$> mapM go tys+           ; return $ mkTyConAppRedn Nominal tc arg_redns }++    go (Rep.AppTy ty1 ty2)+      = mkAppRedn <$> go ty1 <*> go ty2+    go (Rep.FunTy vis w arg res)+      = mkFunRedn Nominal vis <$> go w <*> go arg <*> go res+    go (Rep.CastTy ty cast_co)+      = mkCastRedn1 Nominal ty cast_co <$> go ty+    go ty@(Rep.TyVarTy {})    = skip ty+    go ty@(Rep.LitTy {})      = skip ty+    go ty@(Rep.ForAllTy {})   = skip ty  -- See Detail (1) of Note+    go ty@(Rep.CoercionTy {}) = skip ty  -- See Detail (2) of Note++    skip ty = return $ mkReflRedn Nominal ty++    emit_work :: TcKind         -- of the function application+              -> TcType         -- original function application+              -> TcS ReductionN -- rewritten type (the fresh tyvar)+    emit_work fun_app_kind fun_app = case flavour of+      Given ->+        do { new_tv <- wrapTcS (TcM.newCycleBreakerTyVar fun_app_kind)+           ; let new_ty     = mkTyVarTy new_tv+                 given_pred = mkHeteroPrimEqPred fun_app_kind fun_app_kind+                                                 fun_app new_ty+                 given_term = evCoercion $ mkNomReflCo new_ty  -- See Detail (4) of Note+           ; new_given <- newGivenEvVar new_loc (given_pred, given_term)+           ; traceTcS "breakTyEqCycle replacing type family in Given" (ppr new_given)+           ; emitWorkNC [new_given]+           ; updInertTcS $ \is ->+               is { inert_cycle_breakers = insertCycleBreakerBinding new_tv fun_app+                                             (inert_cycle_breakers is) }+           ; return $ mkReflRedn Nominal new_ty }+                -- Why reflexive? See Detail (4) of the Note++      Wanted ->+        do { new_tv <- wrapTcS (TcM.newFlexiTyVar fun_app_kind)+           ; let new_ty = mkTyVarTy new_tv+           ; co <- emitNewWantedEq new_loc (ctEvRewriters ev) Nominal new_ty fun_app+           ; return $ mkReduction (mkSymCo co) new_ty }        -- See Detail (7) of the Note     new_loc = updateCtLocOrigin (ctEvLoc ev) CycleBreakerOrigin
compiler/GHC/Tc/Solver/Rewrite.hs view
@@ -1,19 +1,21 @@ {-# LANGUAGE BangPatterns  #-}-{-# LANGUAGE CPP           #-}+ {-# LANGUAGE DeriveFunctor #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}  module GHC.Tc.Solver.Rewrite(-   rewrite, rewriteKind, rewriteArgsNom,+   rewrite, rewriteArgsNom,    rewriteType  ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Core.TyCo.Ppr ( pprTyVar )+import GHC.Tc.Types ( TcGblEnv(tcg_tc_plugin_rewriters),+                      TcPluginRewriter, TcPluginRewriteResult(..),+                      RewriteEnv(..),+                      runTcPluginM ) import GHC.Tc.Types.Constraint import GHC.Core.Predicate import GHC.Tc.Utils.TcType@@ -22,23 +24,24 @@ import GHC.Core.TyCon import GHC.Core.TyCo.Rep   -- performs delicate algorithm on types import GHC.Core.Coercion+import GHC.Core.Reduction+import GHC.Types.Unique.FM import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Driver.Session import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Tc.Solver.Monad as TcS  import GHC.Utils.Misc import GHC.Data.Maybe import GHC.Exts (oneShot)-import Data.Bifunctor import Control.Monad-import GHC.Utils.Monad ( zipWith3M )-import Data.List.NonEmpty ( NonEmpty(..) ) import Control.Applicative (liftA3) import GHC.Builtin.Types.Prim (tYPETyCon)+import Data.List ( find )  {- ************************************************************************@@ -49,12 +52,6 @@ ************************************************************************ -} -data RewriteEnv-  = FE { fe_loc     :: !CtLoc             -- See Note [Rewriter CtLoc]-       , fe_flavour :: !CtFlavour-       , fe_eq_rel  :: !EqRel             -- See Note [Rewriter EqRels]-       }- -- | The 'RewriteM' monad is a wrapper around 'TcS' with a 'RewriteEnv' newtype RewriteM a   = RewriteM { runRewriteM :: RewriteEnv -> TcS a }@@ -84,35 +81,44 @@  -- convenient wrapper when you have a CtEvidence describing -- the rewriting operation-runRewriteCtEv :: CtEvidence -> RewriteM a -> TcS a+runRewriteCtEv :: CtEvidence -> RewriteM a -> TcS (a, RewriterSet) runRewriteCtEv ev   = runRewrite (ctEvLoc ev) (ctEvFlavour ev) (ctEvEqRel ev)  -- Run thing_inside (which does the rewriting)-runRewrite :: CtLoc -> CtFlavour -> EqRel -> RewriteM a -> TcS a+-- Also returns the set of Wanteds which rewrote a Wanted;+-- See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint+runRewrite :: CtLoc -> CtFlavour -> EqRel -> RewriteM a -> TcS (a, RewriterSet) runRewrite loc flav eq_rel thing_inside-  = runRewriteM thing_inside fmode-  where-    fmode = FE { fe_loc  = loc-               , fe_flavour = flav-               , fe_eq_rel = eq_rel }+  = do { rewriters_ref <- newTcRef emptyRewriterSet+       ; let fmode = RE { re_loc  = loc+                        , re_flavour = flav+                        , re_eq_rel = eq_rel+                        , re_rewriters = rewriters_ref }+       ; res <- runRewriteM thing_inside fmode+       ; rewriters <- readTcRef rewriters_ref+       ; return (res, rewriters) }  traceRewriteM :: String -> SDoc -> RewriteM () traceRewriteM herald doc = liftTcS $ traceTcS herald doc {-# INLINE traceRewriteM #-}  -- see Note [INLINE conditional tracing utilities] +getRewriteEnv :: RewriteM RewriteEnv+getRewriteEnv+  = mkRewriteM $ \env -> return env+ getRewriteEnvField :: (RewriteEnv -> a) -> RewriteM a getRewriteEnvField accessor   = mkRewriteM $ \env -> return (accessor env)  getEqRel :: RewriteM EqRel-getEqRel = getRewriteEnvField fe_eq_rel+getEqRel = getRewriteEnvField re_eq_rel  getRole :: RewriteM Role getRole = eqRelRole <$> getEqRel  getFlavour :: RewriteM CtFlavour-getFlavour = getRewriteEnvField fe_flavour+getFlavour = getRewriteEnvField re_flavour  getFlavourRole :: RewriteM CtFlavourRole getFlavourRole@@ -121,7 +127,7 @@        ; return (flavour, eq_rel) }  getLoc :: RewriteM CtLoc-getLoc = getRewriteEnvField fe_loc+getLoc = getRewriteEnvField re_loc  checkStackDepth :: Type -> RewriteM () checkStackDepth ty@@ -132,38 +138,32 @@ setEqRel :: EqRel -> RewriteM a -> RewriteM a setEqRel new_eq_rel thing_inside   = mkRewriteM $ \env ->-    if new_eq_rel == fe_eq_rel env+    if new_eq_rel == re_eq_rel env     then runRewriteM thing_inside env-    else runRewriteM thing_inside (env { fe_eq_rel = new_eq_rel })+    else runRewriteM thing_inside (env { re_eq_rel = new_eq_rel }) {-# INLINE setEqRel #-} --- | Make sure that rewriting actually produces a coercion (in other--- words, make sure our flavour is not Derived)--- Note [No derived kind equalities]-noBogusCoercions :: RewriteM a -> RewriteM a-noBogusCoercions thing_inside-  = mkRewriteM $ \env ->-    -- No new thunk is made if the flavour hasn't changed (note the bang).-    let !env' = case fe_flavour env of-          Derived -> env { fe_flavour = Wanted WDeriv }-          _       -> env-    in-    runRewriteM thing_inside env'- bumpDepth :: RewriteM a -> RewriteM a bumpDepth (RewriteM thing_inside)   = mkRewriteM $ \env -> do       -- bumpDepth can be called a lot during rewriting so we force the       -- new env to avoid accumulating thunks.-      { let !env' = env { fe_loc = bumpCtLocDepth (fe_loc env) }+      { let !env' = env { re_loc = bumpCtLocDepth (re_loc env) }       ; thing_inside env' } +-- See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint+-- Precondition: the CtEvidence is a CtWanted of an equality+recordRewriter :: CtEvidence -> RewriteM ()+recordRewriter (CtWanted { ctev_dest = HoleDest hole })+  = RewriteM $ \env -> updTcRef (re_rewriters env) (`addRewriterSet` hole)+recordRewriter other = pprPanic "recordRewriter" (ppr other)+ {- Note [Rewriter EqRels] ~~~~~~~~~~~~~~~~~~~~~~~ When rewriting, we need to know which equality relation -- nominal or representation -- we should be respecting. The only difference is-that we rewrite variables by representational equalities when fe_eq_rel+that we rewrite variables by representational equalities when re_eq_rel is ReprEq, and that we unwrap newtypes when rewriting w.r.t. representational equality. @@ -201,14 +201,6 @@ canonicaliser will emit an insoluble, in which case we get a better error message anyway.) -Note [No derived kind equalities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A kind-level coercion can appear in types, via mkCastTy. So, whenever-we are generating a coercion in a dependent context (in other words,-in a kind) we need to make sure that our flavour is never Derived-(as Derived constraints have no evidence). The noBogusCoercions function-changes the flavour from Derived just for this purpose.- -}  {- *********************************************************************@@ -219,31 +211,21 @@ -}  -- | See Note [Rewriting].--- If (xi, co) <- rewrite mode ev ty, then co :: xi ~r ty+-- If (xi, co, rewriters) <- rewrite mode ev ty, then co :: xi ~r ty -- where r is the role in @ev@.+-- rewriters is the set of coercion holes that have been used to rewrite+-- See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint rewrite :: CtEvidence -> TcType-        -> TcS (Xi, TcCoercion)+        -> TcS (Reduction, RewriterSet) rewrite ev ty   = do { traceTcS "rewrite {" (ppr ty)-       ; (ty', co) <- runRewriteCtEv ev (rewrite_one ty)-       ; traceTcS "rewrite }" (ppr ty')-       ; return (ty', co) }---- specialized to rewriting kinds: never Derived, always Nominal--- See Note [No derived kind equalities]--- See Note [Rewriting]-rewriteKind :: CtLoc -> CtFlavour -> TcType -> TcS (Xi, TcCoercionN)-rewriteKind loc flav ty-  = do { traceTcS "rewriteKind {" (ppr flav <+> ppr ty)-       ; let flav' = case flav of-                       Derived -> Wanted WDeriv  -- the WDeriv/WOnly choice matters not-                       _       -> flav-       ; (ty', co) <- runRewrite loc flav' NomEq (rewrite_one ty)-       ; traceTcS "rewriteKind }" (ppr ty' $$ ppr co) -- co is never a panic-       ; return (ty', co) }+       ; result@(redn, _) <- runRewriteCtEv ev (rewrite_one ty)+       ; traceTcS "rewrite }" (ppr $ reductionReducedType redn)+       ; return result }  -- See Note [Rewriting]-rewriteArgsNom :: CtEvidence -> TyCon -> [TcType] -> TcS ([Xi], [TcCoercion])+rewriteArgsNom :: CtEvidence -> TyCon -> [TcType]+               -> TcS (Reductions, RewriterSet) -- Externally-callable, hence runRewrite -- Rewrite a vector of types all at once; in fact they are -- always the arguments of type family or class, so@@ -252,15 +234,15 @@ -- The kind passed in is the kind of the type family or class, call it T -- The kind of T args must be constant (i.e. not depend on the args) ----- For Derived constraints the returned coercion may be undefined--- because rewriting may use a Derived equality ([D] a ~ ty)+-- Final return value returned which Wanteds rewrote another Wanted+-- See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint rewriteArgsNom ev tc tys   = do { traceTcS "rewrite_args {" (vcat (map ppr tys))-       ; (tys', cos, kind_co)+       ; (ArgsReductions redns@(Reductions _ tys') kind_co, rewriters)            <- runRewriteCtEv ev (rewrite_args_tc tc Nothing tys)-       ; MASSERT( isReflMCo kind_co )+       ; massert (isReflMCo kind_co)        ; traceTcS "rewrite }" (vcat (map ppr tys'))-       ; return (tys', cos) }+       ; return (redns, rewriters) }  -- | Rewrite a type w.r.t. nominal equality. This is useful to rewrite -- a type w.r.t. any givens. It does not do type-family reduction. This@@ -268,13 +250,13 @@ -- only givens. rewriteType :: CtLoc -> TcType -> TcS TcType rewriteType loc ty-  = do { (xi, _) <- runRewrite loc Given NomEq $-                    rewrite_one ty+  = do { (redn, _) <- runRewrite loc Given NomEq $+                       rewrite_one ty                      -- use Given flavor so that it is rewritten-                     -- only w.r.t. Givens, never Wanteds/Deriveds+                     -- only w.r.t. Givens, never Wanteds                      -- (Shouldn't matter, if only Givens are present                      -- anyway)-       ; return xi }+       ; return $ reductionReducedType redn }  {- ********************************************************************* *                                                                      *@@ -284,15 +266,15 @@  {- Note [Rewriting] ~~~~~~~~~~~~~~~~~~~~-  rewrite ty  ==>   (xi, co)+  rewrite ty  ==>  Reduction co xi     where       xi has no reducible type functions          has no skolems that are mapped in the inert set          has no filled-in metavariables-      co :: xi ~ ty+      co :: ty ~ xi (coercions in reductions are always left-to-right)  Key invariants:-  (F0) co :: xi ~ zonk(ty')    where zonk(ty') ~ zonk(ty)+  (F0) co :: zonk(ty') ~ xi   where zonk(ty') ~ zonk(ty)   (F1) tcTypeKind(xi) succeeds and returns a fully zonked kind   (F2) tcTypeKind(xi) `eqType` zonk(tcTypeKind(ty)) @@ -303,18 +285,17 @@   * applies the substitution embodied in the inert set  Because rewriting zonks and the returned coercion ("co" above) is also-zonked, it's possible that (co :: xi ~ ty) isn't quite true. So, instead,+zonked, it's possible that (co :: ty ~ xi) isn't quite true. So, instead, we can rely on this fact: -  (F0) co :: xi ~ zonk(ty'), where zonk(ty') ~ zonk(ty)+  (F0) co :: zonk(ty') ~ xi, where zonk(ty') ~ zonk(ty) -Note that the left-hand type of co is *always* precisely xi. The right-hand+Note that the right-hand type of co is *always* precisely xi. The left-hand type may or may not be ty, however: if ty has unzonked filled-in metavariables,-then the right-hand type of co will be the zonk-equal to ty.-It is for this reason that we-occasionally have to explicitly zonk, when (co :: xi ~ ty) is important-even before we zonk the whole program. For example, see the RTRNotFollowed-case in rewriteTyVar.+then the left-hand type of co will be the zonk-equal to ty.+It is for this reason that we occasionally have to explicitly zonk,+when (co :: ty ~ xi) is important even before we zonk the whole program.+For example, see the RTRNotFollowed case in rewriteTyVar.  Why have these invariants on rewriting? Because we sometimes use tcTypeKind during canonicalisation, and we want this kind to be zonked (e.g., see@@ -323,7 +304,7 @@ Rewriting is always homogeneous. That is, the kind of the result of rewriting is always the same as the kind of the input, modulo zonking. More formally: -  (F2) tcTypeKind(xi) `eqType` zonk(tcTypeKind(ty))+  (F2) zonk(tcTypeKind(ty)) `eqType` tcTypeKind(xi)  This invariant means that the kind of a rewritten type might not itself be rewritten. @@ -335,7 +316,7 @@ unexpanded synonym. See also Note [Rewriting synonyms].  Where do we actually perform rewriting within a type? See Note [Rewritable] in-GHC.Tc.Solver.Monad.+GHC.Tc.Solver.InertSet.  Note [rewrite_args performance] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -389,17 +370,15 @@   :: TyCon         -- T   -> Maybe [Role]  -- Nothing: ambient role is Nominal; all args are Nominal                    -- Otherwise: no assumptions; use roles provided-  -> [Type]        -- Arg types [t1,..,tn]-  -> RewriteM ( [Xi]  -- List of rewritten args [x1,..,xn]-                   -- 1-1 corresp with [t1,..,tn]-           , [Coercion]  -- List of arg coercions [co1,..,con]-                         -- 1-1 corresp with [t1,..,tn]-                         --    coi :: xi ~r ti-           , MCoercionN) -- Result coercion, rco-                         --    rco : (T t1..tn) ~N (T (x1 |> co1) .. (xn |> con))+  -> [Type]+  -> RewriteM ArgsReductions -- See the commentary on rewrite_args rewrite_args_tc tc = rewrite_args all_bndrs any_named_bndrs inner_ki emptyVarSet   -- NB: TyCon kinds are always closed   where+  -- There are many bang patterns in here. It's been observed that they+  -- greatly improve performance of an optimized build.+  -- The T9872 test cases are good witnesses of this fact.+     (bndrs, named)       = ty_con_binders_ty_binders' (tyConBinders tc)     -- it's possible that the result kind has arrows (for, e.g., a type family)@@ -415,13 +394,15 @@              -> Kind -> TcTyCoVarSet -- function kind; kind's free vars              -> Maybe [Role] -> [Type]    -- these are in 1-to-1 correspondence                                           -- Nothing: use all Nominal-             -> RewriteM ([Xi], [Coercion], MCoercionN)--- Coercions :: Xi ~ Type, at roles given--- Third coercion :: tcTypeKind(fun xis) ~N tcTypeKind(fun tys)--- That is, the third coercion relates the kind of some function (whose kind is--- passed as the first parameter) instantiated at xis to the kind of that--- function instantiated at the tys. This is useful in keeping rewriting--- homoegeneous. The list of roles must be at least as long as the list of+             -> RewriteM ArgsReductions+-- This function returns ArgsReductions (Reductions cos xis) res_co+--   coercions: co_i :: ty_i ~ xi_i, at roles given+--   types:     xi_i+--   coercion:  res_co :: tcTypeKind(fun tys) ~N tcTypeKind(fun xis)+-- That is, the result coercion relates the kind of some function (whose kind is+-- passed as the first parameter) instantiated at tys to the kind of that+-- function instantiated at the xis. This is useful in keeping rewriting+-- homogeneous. The list of roles must be at least as long as the list of -- types. rewrite_args orig_binders              any_named_bndrs@@ -437,78 +418,55 @@ {-# INLINE rewrite_args_fast #-} -- | fast path rewrite_args, in which none of the binders are named and -- therefore we can avoid tracking a lifting context.--- There are many bang patterns in here. It's been observed that they--- greatly improve performance of an optimized build.--- The T9872 test cases are good witnesses of this fact.-rewrite_args_fast :: [Type]-                  -> RewriteM ([Xi], [Coercion], MCoercionN)+rewrite_args_fast :: [Type] -> RewriteM ArgsReductions rewrite_args_fast orig_tys   = fmap finish (iterate orig_tys)   where -    iterate :: [Type]-            -> RewriteM ([Xi], [Coercion])-    iterate (ty:tys) = do-      (xi, co)   <- rewrite_one ty-      (xis, cos) <- iterate tys-      pure (xi : xis, co : cos)-    iterate [] = pure ([], [])+    iterate :: [Type] -> RewriteM Reductions+    iterate (ty : tys) = do+      Reduction  co  xi  <- rewrite_one ty+      Reductions cos xis <- iterate tys+      pure $ Reductions (co : cos) (xi : xis)+    iterate [] = pure $ Reductions [] []      {-# INLINE finish #-}-    finish :: ([Xi], [Coercion]) -> ([Xi], [Coercion], MCoercionN)-    finish (xis, cos) = (xis, cos, MRefl)+    finish :: Reductions -> ArgsReductions+    finish redns = ArgsReductions redns MRefl  {-# INLINE rewrite_args_slow #-} -- | Slow path, compared to rewrite_args_fast, because this one must track -- a lifting context. rewrite_args_slow :: [TyCoBinder] -> Kind -> TcTyCoVarSet                   -> [Role] -> [Type]-                  -> RewriteM ([Xi], [Coercion], MCoercionN)+                  -> RewriteM ArgsReductions rewrite_args_slow binders inner_ki fvs roles tys--- Arguments used dependently must be rewritten with proper coercions, but--- we're not guaranteed to get a proper coercion when rewriting with the--- "Derived" flavour. So we must call noBogusCoercions when rewriting arguments--- corresponding to binders that are dependent. However, we might legitimately--- have *more* arguments than binders, in the case that the inner_ki is a variable--- that gets instantiated with a Π-type. We conservatively choose not to produce--- bogus coercions for these, too. Note that this might miss an opportunity for--- a Derived rewriting a Derived. The solution would be to generate evidence for--- Deriveds, thus avoiding this whole noBogusCoercions idea. See also--- Note [No derived kind equalities]-  = do { rewritten_args <- zipWith3M rw (map isNamedBinder binders ++ repeat True)-                                        roles tys+  = do { rewritten_args <- zipWithM rw roles tys        ; return (simplifyArgsWorker binders inner_ki fvs roles rewritten_args) }   where     {-# INLINE rw #-}-    rw :: Bool   -- must we ensure to produce a real coercion here?-                 -- see comment at top of function-       -> Role -> Type -> RewriteM (Xi, Coercion)-    rw True  r ty = noBogusCoercions $ rw1 r ty-    rw False r ty =                    rw1 r ty--    {-# INLINE rw1 #-}-    rw1 :: Role -> Type -> RewriteM (Xi, Coercion)-    rw1 Nominal ty+    rw :: Role -> Type -> RewriteM Reduction+    rw Nominal ty       = setEqRel NomEq $         rewrite_one ty -    rw1 Representational ty+    rw Representational ty       = setEqRel ReprEq $         rewrite_one ty -    rw1 Phantom ty+    rw Phantom ty     -- See Note [Phantoms in the rewriter]       = do { ty <- liftTcS $ zonkTcType ty-           ; return (ty, mkReflCo Phantom ty) }+           ; return $ mkReflRedn Phantom ty }  -------------------rewrite_one :: TcType -> RewriteM (Xi, Coercion)+rewrite_one :: TcType -> RewriteM Reduction -- Rewrite a type to get rid of type function applications, returning -- the new type-function-free type, and a collection of new equality -- constraints.  See Note [Rewriting] for more detail. ----- Postcondition: Coercion :: Xi ~ TcType--- The role on the result coercion matches the EqRel in the RewriteEnv+-- Postcondition:+-- the role on the result coercion matches the EqRel in the RewriteEnv  rewrite_one ty   | Just ty' <- rewriterView ty  -- See Note [Rewriting synonyms]@@ -516,7 +474,7 @@  rewrite_one xi@(LitTy {})   = do { role <- getRole-       ; return (xi, mkReflCo role xi) }+       ; return $ mkReflRedn role xi }  rewrite_one (TyVarTy tv)   = rewriteTyVar tv@@ -536,14 +494,14 @@   = rewrite_ty_con_app tc tys  rewrite_one (FunTy { ft_af = vis, ft_mult = mult, ft_arg = ty1, ft_res = ty2 })-  = do { (arg_xi,arg_co) <- rewrite_one ty1-       ; (res_xi,res_co) <- rewrite_one ty2+  = do { arg_redn <- rewrite_one ty1+       ; res_redn <- rewrite_one ty2          -- Important: look at the *reduced* type, so that any unzonked variables         -- in kinds are gone and the getRuntimeRep succeeds.         -- cf. Note [Decomposing FunTy] in GHC.Tc.Solver.Canonical.-       ; let arg_rep = getRuntimeRep arg_xi-             res_rep = getRuntimeRep res_xi+       ; let arg_rep = getRuntimeRep (reductionReducedType arg_redn)+             res_rep = getRuntimeRep (reductionReducedType res_redn)         ; (w_redn, arg_rep_redn, res_rep_redn) <- setEqRel NomEq $            liftA3 (,,) (rewrite_one mult)@@ -551,31 +509,22 @@                        (rewrite_one res_rep)        ; role <- getRole -       ; let arg_rep_co = mkSymCo (snd arg_rep_redn)+       ; let arg_rep_co = reductionCoercion arg_rep_redn                 -- :: arg_rep ~ arg_rep_xi              arg_ki_co  = mkTyConAppCo Nominal tYPETyCon [arg_rep_co]                 -- :: TYPE arg_rep ~ TYPE arg_rep_xi-             casted_arg_redn =-                 ( mkCastTy arg_xi arg_ki_co-                 , mkCoherenceLeftCo role arg_xi arg_ki_co arg_co-                 )+             casted_arg_redn = mkCoherenceRightRedn role arg_redn arg_ki_co                 -- :: ty1 ~> arg_xi |> arg_ki_co -             res_ki_co  = mkTyConAppCo Nominal tYPETyCon [mkSymCo $ snd res_rep_redn]-             casted_res_redn =-                ( mkCastTy res_xi res_ki_co-                , mkCoherenceLeftCo role res_xi res_ki_co res_co-                )+             res_rep_co = reductionCoercion res_rep_redn+             res_ki_co  = mkTyConAppCo Nominal tYPETyCon [res_rep_co]+             casted_res_redn = mkCoherenceRightRedn role res_redn res_ki_co            -- We must rewrite the representations, because that's what would           -- be done if we used TyConApp instead of FunTy. These rewritten           -- representations are seen only in casts of the arg and res, below.           -- Forgetting this caused #19677.-       ; return-            ( mkFunTy vis (fst w_redn) (fst casted_arg_redn) (fst casted_res_redn)-            , mkFunCo role (snd w_redn) (snd casted_arg_redn) (snd casted_res_redn)-            )-       }+       ; return $ mkFunRedn role vis w_redn casted_arg_redn casted_res_redn }  rewrite_one ty@(ForAllTy {}) -- TODO (RAE): This is inadequate, as it doesn't rewrite the kind of@@ -585,126 +534,116 @@ -- We allow for-alls when, but only when, no type function -- applications inside the forall involve the bound type variables.   = do { let (bndrs, rho) = tcSplitForAllTyVarBinders ty-             tvs           = binderVars bndrs-       ; (rho', co) <- rewrite_one rho-       ; return (mkForAllTys bndrs rho', mkHomoForAllCos tvs co) }+       ; redn <- rewrite_one rho+       ; return $ mkHomoForAllRedn bndrs redn }  rewrite_one (CastTy ty g)-  = do { (xi, co) <- rewrite_one ty-       ; (g', _)  <- rewrite_co g+  = do { redn <- rewrite_one ty+       ; g'   <- rewrite_co g        ; role <- getRole-       ; return (mkCastTy xi g', castCoercionKind1 co role xi ty g') }-         -- It makes a /big/ difference to call castCoercionKind1 not-         -- the more general castCoercionKind2.-         -- See Note [castCoercionKind1] in GHC.Core.Coercion+       ; return $ mkCastRedn1 role ty g' redn }+      -- This calls castCoercionKind1.+      -- It makes a /big/ difference to call castCoercionKind1 not+      -- the more general castCoercionKind2.+      -- See Note [castCoercionKind1] in GHC.Core.Coercion -rewrite_one (CoercionTy co) = first mkCoercionTy <$> rewrite_co co+rewrite_one (CoercionTy co)+  = do { co' <- rewrite_co co+       ; role <- getRole+       ; return $ mkReflCoRedn role co' }  -- | "Rewrite" a coercion. Really, just zonk it so we can uphold -- (F1) of Note [Rewriting]-rewrite_co :: Coercion -> RewriteM (Coercion, Coercion)-rewrite_co co-  = do { co <- liftTcS $ zonkCo co-       ; env_role <- getRole-       ; let co' = mkTcReflCo env_role (mkCoercionTy co)-       ; return (co, co') }+rewrite_co :: Coercion -> RewriteM Coercion+rewrite_co co = liftTcS $ zonkCo co +-- | Rewrite a reduction, composing the resulting coercions.+rewrite_reduction :: Reduction -> RewriteM Reduction+rewrite_reduction (Reduction co xi)+  = do { redn <- bumpDepth $ rewrite_one xi+       ; return $ co `mkTransRedn` redn }+ -- rewrite (nested) AppTys-rewrite_app_tys :: Type -> [Type] -> RewriteM (Xi, Coercion)+rewrite_app_tys :: Type -> [Type] -> RewriteM Reduction -- commoning up nested applications allows us to look up the function's kind -- only once. Without commoning up like this, we would spend a quadratic amount -- of time looking up functions' types rewrite_app_tys (AppTy ty1 ty2) tys = rewrite_app_tys ty1 (ty2:tys) rewrite_app_tys fun_ty arg_tys-  = do { (fun_xi, fun_co) <- rewrite_one fun_ty-       ; rewrite_app_ty_args fun_xi fun_co arg_tys }+  = do { redn <- rewrite_one fun_ty+       ; rewrite_app_ty_args redn arg_tys }  -- Given a rewritten function (with the coercion produced by rewriting) and -- a bunch of unrewritten arguments, rewrite the arguments and apply. -- The coercion argument's role matches the role stored in the RewriteM monad. -- -- The bang patterns used here were observed to improve performance. If you--- wish to remove them, be sure to check for regeressions in allocations.-rewrite_app_ty_args :: Xi -> Coercion -> [Type] -> RewriteM (Xi, Coercion)-rewrite_app_ty_args fun_xi fun_co []+-- wish to remove them, be sure to check for regressions in allocations.+rewrite_app_ty_args :: Reduction -> [Type] -> RewriteM Reduction+rewrite_app_ty_args redn []   -- this will be a common case when called from rewrite_fam_app, so shortcut-  = return (fun_xi, fun_co)-rewrite_app_ty_args fun_xi fun_co arg_tys-  = do { (xi, co, kind_co) <- case tcSplitTyConApp_maybe fun_xi of+  = return redn+rewrite_app_ty_args fun_redn@(Reduction fun_co fun_xi) arg_tys+  = do { het_redn <- case tcSplitTyConApp_maybe fun_xi of            Just (tc, xis) ->              do { let tc_roles  = tyConRolesRepresentational tc                       arg_roles = dropList xis tc_roles-                ; (arg_xis, arg_cos, kind_co)+                ; ArgsReductions (Reductions arg_cos arg_xis) kind_co                     <- rewrite_vector (tcTypeKind fun_xi) arg_roles arg_tys -                  -- Here, we have fun_co :: T xi1 xi2 ~ ty-                  -- and we need to apply fun_co to the arg_cos. The problem is+                  -- We start with a reduction of the form+                  --   fun_co :: ty ~ T xi_1 ... xi_n+                  -- and further arguments a_1, ..., a_m.+                  -- We rewrite these arguments, and obtain coercions:+                  --   arg_co_i :: a_i ~ zeta_i+                  -- Now, we need to apply fun_co to the arg_cos. The problem is                   -- that using mkAppCo is wrong because that function expects                   -- its second coercion to be Nominal, and the arg_cos might                   -- not be. The solution is to use transitivity:-                  -- T <xi1> <xi2> arg_cos ;; fun_co <arg_tys>+                  -- fun_co <a_1> ... <a_m> ;; T <xi_1> .. <xi_n> arg_co_1 ... arg_co_m                 ; eq_rel <- getEqRel                 ; let app_xi = mkTyConApp tc (xis ++ arg_xis)                       app_co = case eq_rel of                         NomEq  -> mkAppCos fun_co arg_cos-                        ReprEq -> mkTcTyConAppCo Representational tc-                                    (zipWith mkReflCo tc_roles xis ++ arg_cos)+                        ReprEq -> mkAppCos fun_co (map mkNomReflCo arg_tys)                                   `mkTcTransCo`-                                  mkAppCos fun_co (map mkNomReflCo arg_tys)-                ; return (app_xi, app_co, kind_co) }+                                  mkTcTyConAppCo Representational tc+                                    (zipWith mkReflCo tc_roles xis ++ arg_cos)++                ; return $+                    mkHetReduction+                      (mkReduction app_co app_xi )+                      kind_co }            Nothing ->-             do { (arg_xis, arg_cos, kind_co)+             do { ArgsReductions redns kind_co                     <- rewrite_vector (tcTypeKind fun_xi) (repeat Nominal) arg_tys-                ; let arg_xi = mkAppTys fun_xi arg_xis-                      arg_co = mkAppCos fun_co arg_cos-                ; return (arg_xi, arg_co, kind_co) }+                ; return $ mkHetReduction (mkAppRedns fun_redn redns) kind_co }         ; role <- getRole-       ; return (homogenise_result xi co role kind_co) }+       ; return (homogeniseHetRedn role het_redn) } -rewrite_ty_con_app :: TyCon -> [TcType] -> RewriteM (Xi, Coercion)+rewrite_ty_con_app :: TyCon -> [TcType] -> RewriteM Reduction rewrite_ty_con_app tc tys   = do { role <- getRole        ; let m_roles | Nominal <- role = Nothing                      | otherwise       = Just $ tyConRolesX role tc-       ; (xis, cos, kind_co) <- rewrite_args_tc tc m_roles tys-       ; let tyconapp_xi = mkTyConApp tc xis-             tyconapp_co = mkTyConAppCo role tc cos-       ; return (homogenise_result tyconapp_xi tyconapp_co role kind_co) }---- Make the result of rewriting homogeneous (Note [Rewriting] (F2))-homogenise_result :: Xi              -- a rewritten type-                  -> Coercion        -- :: xi ~r original ty-                  -> Role            -- r-                  -> MCoercionN      -- kind_co :: tcTypeKind(xi) ~N tcTypeKind(ty)-                  -> (Xi, Coercion)  -- (xi |> kind_co, (xi |> kind_co)-                                     --   ~r original ty)-homogenise_result xi co _ MRefl = (xi, co)-homogenise_result xi co r mco@(MCo kind_co)-  = (xi `mkCastTy` kind_co, (mkSymCo $ GRefl r xi mco) `mkTransCo` co)-{-# INLINE homogenise_result #-}+       ; ArgsReductions redns kind_co <- rewrite_args_tc tc m_roles tys+       ; let tyconapp_redn+                = mkHetReduction+                    (mkTyConAppRedn role tc redns)+                    kind_co+       ; return $ homogeniseHetRedn role tyconapp_redn }  -- Rewrite a vector (list of arguments). rewrite_vector :: Kind   -- of the function being applied to these arguments-               -> [Role] -- If we're rewrite w.r.t. ReprEq, what roles do the+               -> [Role] -- If we're rewriting w.r.t. ReprEq, what roles do the                          -- args have?                -> [Type] -- the args to rewrite-               -> RewriteM ([Xi], [Coercion], MCoercionN)+               -> RewriteM ArgsReductions rewrite_vector ki roles tys   = do { eq_rel <- getEqRel-       ; case eq_rel of-           NomEq  -> rewrite_args bndrs-                                  any_named_bndrs-                                  inner_ki-                                  fvs-                                  Nothing-                                  tys-           ReprEq -> rewrite_args bndrs-                                  any_named_bndrs-                                  inner_ki-                                  fvs-                                  (Just roles)-                                  tys+       ; let mb_roles = case eq_rel of { NomEq -> Nothing; ReprEq -> Just roles }+       ; rewrite_args bndrs any_named_bndrs inner_ki fvs mb_roles tys        }   where     (bndrs, inner_ki, any_named_bndrs) = split_pi_tys' ki@@ -751,9 +690,16 @@ Given an exactly saturated family application, how should we normalise it? This Note spells out the algorithm and its reasoning. -STEP 1. Try the famapp-cache. If we get a cache hit, jump to FINISH.+First, we attempt to directly rewrite the type family application,+without simplifying any of the arguments first, in an attempt to avoid+doing unnecessary work. -STEP 2. Try top-level instances. Note that we haven't simplified the arguments+STEP 1a. Call the rewriting plugins. If any plugin rewrites the type family+application, jump to FINISH.++STEP 1b. Try the famapp-cache. If we get a cache hit, jump to FINISH.++STEP 1c. Try top-level instances. Remember: we haven't simplified the arguments   yet. Example:     type instance F (Maybe a) = Int     target: F (Maybe (G Bool))@@ -762,27 +708,31 @@    If an instance is found, jump to FINISH. -STEP 3. Rewrite all arguments. This might expose more information so that we-  can use a top-level instance.--  Continue to the next step.+STEP 2: At this point we rewrite all arguments. This might expose more+  information, which might allow plugins to make progress, or allow us to+  pick up a top-level instance. -STEP 4. Try the inerts. Note that we try the inerts *after* rewriting the+STEP 3. Try the inerts. Note that we try the inerts *after* rewriting the   arguments, because the inerts will have rewritten LHSs.    If an inert is found, jump to FINISH. -STEP 5. Try the famapp-cache again. Now that we've revealed more information-  in the arguments, the cache might be helpful.+Next, we try STEP 1 again, as we might be able to make further progress after+having rewritten the arguments: +STEP 4a. Query the rewriting plugins again.++  If any plugin supplies a rewriting, jump to FINISH.++STEP 4b. Try the famapp-cache again.+   If we get a cache hit, jump to FINISH. -STEP 6. Try top-level instances, which might trigger now that we know more-  about the argumnents.+STEP 4c. Try top-level instances again.    If an instance is found, jump to FINISH. -STEP 7. No progress to be made. Return what we have. (Do not do FINISH.)+STEP 5: GIVEUP. No progress to be made. Return what we have. (Do not FINISH.)  FINISH 1. We've made a reduction, but the new type may still have more   work to do. So rewrite the new type.@@ -790,142 +740,194 @@ FINISH 2. Add the result to the famapp-cache, connecting the type we started   with to the one we ended with. -Because STEP 1/2 and STEP 5/6 happen the same way, they are abstracted into+Because STEP 1{a,b,c} and STEP 4{a,b,c} happen the same way, they are abstracted into try_to_reduce.  FINISH is naturally implemented in `finish`. But, Note [rewrite_exact_fam_app performance]-tells us that we should not add to the famapp-cache after STEP 1/2. So `finish`+tells us that we should not add to the famapp-cache after STEP 1. So `finish` is inlined in that case, and only FINISH 1 is performed.  -} -rewrite_fam_app :: TyCon -> [TcType] -> RewriteM (Xi, Coercion)+rewrite_fam_app :: TyCon -> [TcType] -> RewriteM Reduction   --   rewrite_fam_app            can be over-saturated   --   rewrite_exact_fam_app      lifts out the application to top level   -- Postcondition: Coercion :: Xi ~ F tys rewrite_fam_app tc tys  -- Can be over-saturated-    = ASSERT2( tys `lengthAtLeast` tyConArity tc-             , ppr tc $$ ppr (tyConArity tc) $$ ppr tys)+    = assertPpr (tys `lengthAtLeast` tyConArity tc)+                (ppr tc $$ ppr (tyConArity tc) $$ ppr tys) $                   -- Type functions are saturated                  -- The type function might be *over* saturated                  -- in which case the remaining arguments should                  -- be dealt with by AppTys       do { let (tys1, tys_rest) = splitAt (tyConArity tc) tys-         ; (xi1, co1) <- rewrite_exact_fam_app tc tys1-               -- co1 :: xi1 ~ F tys1--         ; rewrite_app_ty_args xi1 co1 tys_rest }+         ; redn <- rewrite_exact_fam_app tc tys1+         ; rewrite_app_ty_args redn tys_rest }  -- the [TcType] exactly saturate the TyCon -- See Note [How to normalise a family application]-rewrite_exact_fam_app :: TyCon -> [TcType] -> RewriteM (Xi, Coercion)+rewrite_exact_fam_app :: TyCon -> [TcType] -> RewriteM Reduction rewrite_exact_fam_app tc tys   = do { checkStackDepth (mkTyConApp tc tys) -       -- STEP 1/2. Try to reduce without reducing arguments first.-       ; result1 <- try_to_reduce tc tys+       -- Query the typechecking plugins for all their rewriting functions+       -- which apply to a type family application headed by the TyCon 'tc'.+       ; tc_rewriters <- getTcPluginRewritersForTyCon tc++       -- STEP 1. Try to reduce without reducing arguments first.+       ; result1 <- try_to_reduce tc tys tc_rewriters        ; case result1 of              -- Don't use the cache;              -- See Note [rewrite_exact_fam_app performance]-         { Just (co, xi) -> finish False (xi, co)+         { Just redn -> finish False redn          ; Nothing -> -        -- That didn't work. So reduce the arguments, in STEP 3.+        -- That didn't work. So reduce the arguments, in STEP 2.     do { eq_rel <- getEqRel-           -- checking eq_rel == NomEq saves ~0.5% in T9872a-       ; (xis, cos, kind_co) <- if eq_rel == NomEq-                                then rewrite_args_tc tc Nothing tys-                                else setEqRel NomEq $-                                     rewrite_args_tc tc Nothing tys-           -- kind_co :: tcTypeKind(F xis) ~N tcTypeKind(F tys)+          -- checking eq_rel == NomEq saves ~0.5% in T9872a+       ; ArgsReductions (Reductions cos xis) kind_co <-+            if eq_rel == NomEq+            then rewrite_args_tc tc Nothing tys+            else setEqRel NomEq $+                 rewrite_args_tc tc Nothing tys -       ; let role    = eqRelRole eq_rel-             args_co = mkTyConAppCo role tc cos-           -- args_co :: F xis ~r F tys+         -- If we manage to rewrite the type family application after+         -- rewriting the arguments, we will need to compose these+         -- reductions.+         --+         -- We have:+         --+         --   arg_co_i :: ty_i ~ xi_i+         --   fam_co :: F xi_1 ... xi_n ~ zeta+         --+         -- The full reduction is obtained as a composite:+         --+         --   full_co :: F ty_1 ... ty_n ~ zeta+         --   full_co = F co_1 ... co_n ;; fam_co+       ; let+           role    = eqRelRole eq_rel+           args_co = mkTyConAppCo role tc cos+       ;  let homogenise :: Reduction -> Reduction+              homogenise redn+                = homogeniseHetRedn role+                $ mkHetReduction+                    (args_co `mkTransRedn` redn)+                    kind_co -             homogenise :: TcType -> TcCoercion -> (TcType, TcCoercion)-               -- in (xi', co') = homogenise xi co-               --   assume co :: xi ~r F xis, co is homogeneous-               --   then xi' :: tcTypeKind(F tys)-               --   and co' :: xi' ~r F tys, which is homogeneous-             homogenise xi co = homogenise_result xi (co `mkTcTransCo` args_co) role kind_co+              give_up :: Reduction+              give_up = homogenise $ mkReflRedn role reduced+                where reduced = mkTyConApp tc xis -         -- STEP 4: try the inerts-       ; result2 <- liftTcS $ lookupFamAppInert tc xis+         -- STEP 3: try the inerts        ; flavour <- getFlavour+       ; result2 <- liftTcS $ lookupFamAppInert (`eqCanRewriteFR` (flavour, eq_rel)) tc xis        ; case result2 of-         { Just (co, xi, fr@(_, inert_eq_rel))-             -- co :: F xis ~ir xi--             | fr `eqCanRewriteFR` (flavour, eq_rel) ->-                 do { traceRewriteM "rewrite family application with inert"-                                (ppr tc <+> ppr xis $$ ppr xi)-                    ; finish True (homogenise xi downgraded_co) }+         { Just (redn, (inert_flavour, inert_eq_rel))+             -> do { traceRewriteM "rewrite family application with inert"+                                (ppr tc <+> ppr xis $$ ppr redn)+                   ; finish (inert_flavour == Given) (homogenise downgraded_redn) }                -- this will sometimes duplicate an inert in the cache,                -- but avoiding doing so had no impact on performance, and                -- it seems easier not to weed out that special case              where-               inert_role    = eqRelRole inert_eq_rel-               role          = eqRelRole eq_rel-               downgraded_co = tcDowngradeRole role inert_role (mkTcSymCo co)-                 -- downgraded_co :: xi ~r F xis+               inert_role      = eqRelRole inert_eq_rel+               role            = eqRelRole eq_rel+               downgraded_redn = downgradeRedn role inert_role redn           ; _ -> -         -- inert didn't work. Try to reduce again, in STEP 5/6.-    do { result3 <- try_to_reduce tc xis+         -- inerts didn't work. Try to reduce again, in STEP 4.+    do { result3 <- try_to_reduce tc xis tc_rewriters        ; case result3 of-           Just (co, xi) -> finish True (homogenise xi co)-           Nothing       -> -- we have made no progress at all: STEP 7.-                            return (homogenise reduced (mkTcReflCo role reduced))-             where-               reduced = mkTyConApp tc xis }}}}}+           Just redn -> finish True (homogenise redn)+           -- we have made no progress at all: STEP 5 (GIVEUP).+           _         -> return give_up }}}}}   where       -- call this if the above attempts made progress.       -- This recursively rewrites the result and then adds to the cache     finish :: Bool  -- add to the cache?-           -> (Xi, Coercion) -> RewriteM (Xi, Coercion)-    finish use_cache (xi, co)+                    -- Precondition: True ==> input coercion has+                    --                        no coercion holes+           -> Reduction -> RewriteM Reduction+    finish use_cache redn       = do { -- rewrite the result: FINISH 1-             (fully, fully_co) <- bumpDepth $ rewrite_one xi-           ; let final_co = fully_co `mkTcTransCo` co+             final_redn <- rewrite_reduction redn            ; eq_rel <- getEqRel-           ; flavour <- getFlavour               -- extend the cache: FINISH 2-           ; when (use_cache && eq_rel == NomEq && flavour /= Derived) $+           ; when (use_cache && eq_rel == NomEq) $              -- the cache only wants Nominal eqs-             -- and Wanteds can rewrite Deriveds; the cache-             -- has only Givens-             liftTcS $ extendFamAppCache tc tys (final_co, fully)-           ; return (fully, final_co) }+             liftTcS $ extendFamAppCache tc tys final_redn+           ; return final_redn }     {-# INLINE finish #-} --- Returned coercion is output ~r input, where r is the role in the RewriteM monad+-- Returned coercion is input ~r output, where r is the role in the RewriteM monad -- See Note [How to normalise a family application]-try_to_reduce :: TyCon -> [TcType] -> RewriteM (Maybe (TcCoercion, TcType))-try_to_reduce tc tys-  = do { result <- liftTcS $ firstJustsM [ lookupFamAppCache tc tys  -- STEP 5-                                         , matchFam tc tys ]         -- STEP 6-       ; downgrade result }+try_to_reduce :: TyCon -> [TcType] -> [TcPluginRewriter]+              -> RewriteM (Maybe Reduction)+try_to_reduce tc tys tc_rewriters+  = do { rewrite_env <- getRewriteEnv+       ; result <-+            liftTcS $ firstJustsM+              [ runTcPluginRewriters rewrite_env tc_rewriters tys -- STEP 1a & STEP 4a+              , lookupFamAppCache tc tys                          -- STEP 1b & STEP 4b+              , matchFam tc tys ]                                 -- STEP 1c & STEP 4c+       ; traverse downgrade result }   where     -- The result above is always Nominal. We might want a Representational     -- coercion; this downgrades (and prints, out of convenience).-    downgrade :: Maybe (TcCoercionN, TcType) -> RewriteM (Maybe (TcCoercion, TcType))-    downgrade Nothing = return Nothing-    downgrade result@(Just (co, xi))+    downgrade :: Reduction -> RewriteM Reduction+    downgrade redn       = do { traceRewriteM "Eager T.F. reduction success" $-             vcat [ ppr tc, ppr tys, ppr xi-                  , ppr co <+> dcolon <+> ppr (coercionKind co)+             vcat [ ppr tc+                  , ppr tys+                  , ppr redn                   ]            ; eq_rel <- getEqRel               -- manually doing it this way avoids allocation in the vastly               -- common NomEq case            ; case eq_rel of-               NomEq  -> return result-               ReprEq -> return (Just (mkSubCo co, xi)) }+               NomEq  -> return redn+               ReprEq -> return $ mkSubRedn redn } +-- Retrieve all type-checking plugins that can rewrite a (saturated) type-family application+-- headed by the given 'TyCon`.+getTcPluginRewritersForTyCon :: TyCon -> RewriteM [TcPluginRewriter]+getTcPluginRewritersForTyCon tc+  = liftTcS $ do { rewriters <- tcg_tc_plugin_rewriters <$> getGblEnv+                 ; return (lookupWithDefaultUFM rewriters [] tc) }++-- Run a collection of rewriting functions obtained from type-checking plugins,+-- querying in sequence if any plugin wants to rewrite the type family+-- applied to the given arguments.+--+-- Note that the 'TcPluginRewriter's provided all pertain to the same type family+-- (the 'TyCon' of which has been obtained ahead of calling this function).+runTcPluginRewriters :: RewriteEnv+                     -> [TcPluginRewriter]+                     -> [TcType]+                     -> TcS (Maybe Reduction)+runTcPluginRewriters rewriteEnv rewriterFunctions tys+  | null rewriterFunctions+  = return Nothing -- short-circuit for common case+  | otherwise+  = do { givens <- getInertGivens+       ; runRewriters givens rewriterFunctions }+  where+  runRewriters :: [Ct] -> [TcPluginRewriter] -> TcS (Maybe Reduction)+  runRewriters _ []+    = return Nothing+  runRewriters givens (rewriter:rewriters)+    = do+        rewriteResult <- wrapTcS . runTcPluginM $ rewriter rewriteEnv givens tys+        case rewriteResult of+           TcPluginRewriteTo+             { tcPluginReduction    = redn+             , tcRewriterNewWanteds = wanteds+             } -> do { emitWork wanteds; return $ Just redn }+           TcPluginNoRewrite {} -> runRewriters givens rewriters+ {- ************************************************************************ *                                                                      *@@ -938,31 +940,27 @@   = RTRNotFollowed       -- ^ The inert set doesn't make the tyvar equal to anything else -  | RTRFollowed TcType Coercion+  | RTRFollowed !Reduction       -- ^ The tyvar rewrites to a not-necessarily rewritten other type.-      -- co :: new type ~r old type, where the role is determined by-      -- the RewriteEnv+      -- The role is determined by the RewriteEnv.       --       -- With Quick Look, the returned TcType can be a polytype;       -- that is, in the constraint solver, a unification variable       -- can contain a polytype.  See GHC.Tc.Gen.App       -- Note [Instantiation variables are short lived] -rewriteTyVar :: TyVar -> RewriteM (Xi, Coercion)+rewriteTyVar :: TyVar -> RewriteM Reduction rewriteTyVar tv   = do { mb_yes <- rewrite_tyvar1 tv        ; case mb_yes of-           RTRFollowed ty1 co1  -- Recur-             -> do { (ty2, co2) <- rewrite_one ty1-                   -- ; traceRewriteM "rewriteTyVar2" (ppr tv $$ ppr ty2)-                   ; return (ty2, co2 `mkTransCo` co1) }+           RTRFollowed redn -> rewrite_reduction redn             RTRNotFollowed   -- Done, but make sure the kind is zonked                             -- Note [Rewriting] invariant (F0) and (F1)              -> do { tv' <- liftTcS $ updateTyVarKindM zonkTcType tv                    ; role <- getRole                    ; let ty' = mkTyVarTy tv'-                   ; return (ty', mkTcReflCo role ty') } }+                   ; return $ mkReflRedn role ty' } }  rewrite_tyvar1 :: TcTyVar -> RewriteM RewriteTvResult -- "Rewriting" a type variable means to apply the substitution to it@@ -977,7 +975,8 @@            Just ty -> do { traceRewriteM "Following filled tyvar"                              (ppr tv <+> equals <+> ppr ty)                          ; role <- getRole-                         ; return (RTRFollowed ty (mkReflCo role ty)) } ;+                         ; return $ RTRFollowed $+                             mkReflRedn role ty }            Nothing -> do { traceRewriteM "Unfilled tyvar" (pprTyVar tv)                          ; fr <- getFlavourRole                          ; rewrite_tyvar2 tv fr } }@@ -991,31 +990,34 @@ rewrite_tyvar2 tv fr@(_, eq_rel)   = do { ieqs <- liftTcS $ getInertEqs        ; case lookupDVarEnv ieqs tv of-           Just (EqualCtList (ct :| _))   -- If the first doesn't work,-                                          -- the subsequent ones won't either-             | CEqCan { cc_ev = ctev, cc_lhs = TyVarLHS tv+           Just equal_ct_list+             | Just ct <- find can_rewrite equal_ct_list+             , CEqCan { cc_ev = ctev, cc_lhs = TyVarLHS tv                       , cc_rhs = rhs_ty, cc_eq_rel = ct_eq_rel } <- ct-             , let ct_fr = (ctEvFlavour ctev, ct_eq_rel)-             , ct_fr `eqCanRewriteFR` fr  -- This is THE key call of eqCanRewriteFR-             -> do { traceRewriteM "Following inert tyvar"-                        (ppr tv <+>-                         equals <+>-                         ppr rhs_ty $$ ppr ctev)-                    ; let rewrite_co1 = mkSymCo (ctEvCoercion ctev)-                          rewrite_co  = case (ct_eq_rel, eq_rel) of-                            (ReprEq, _rel)  -> ASSERT( _rel == ReprEq )-                                    -- if this ASSERT fails, then+             -> do { let wrw = isWantedCt ct+                   ; traceRewriteM "Following inert tyvar" $+                        vcat [ ppr tv <+> equals <+> ppr rhs_ty+                             , ppr ctev+                             , text "wanted_rewrite_wanted:" <+> ppr wrw ]+                   ; when wrw $ recordRewriter ctev++                   ; let rewriting_co1 = ctEvCoercion ctev+                         rewriting_co  = case (ct_eq_rel, eq_rel) of+                            (ReprEq, _rel)  -> assert (_rel == ReprEq)+                                    -- if this assert fails, then                                     -- eqCanRewriteFR answered incorrectly-                                               rewrite_co1-                            (NomEq, NomEq)  -> rewrite_co1-                            (NomEq, ReprEq) -> mkSubCo rewrite_co1+                                               rewriting_co1+                            (NomEq, NomEq)  -> rewriting_co1+                            (NomEq, ReprEq) -> mkSubCo rewriting_co1 -                    ; return (RTRFollowed rhs_ty rewrite_co) }-                    -- NB: ct is Derived then fmode must be also, hence-                    -- we are not going to touch the returned coercion-                    -- so ctEvCoercion is fine.+                   ; return $ RTRFollowed $ mkReduction rewriting_co rhs_ty }             _other -> return RTRNotFollowed }++  where+    can_rewrite :: Ct -> Bool+    can_rewrite ct = ctFlavourRole ct `eqCanRewriteFR` fr+      -- This is THE key call of eqCanRewriteFR  {- Note [An alternative story for the inert substitution]
compiler/GHC/Tc/TyCl.hs view
@@ -4,7 +4,8 @@  -} -{-# LANGUAGE CPP, TupleSections, ScopedTypeVariables, MultiWayIf #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TupleSections, ScopedTypeVariables, MultiWayIf #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE LambdaCase #-}@@ -22,18 +23,18 @@         tcFamTyPats, tcTyFamInstEqn,         tcAddTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt,         unravelFamInstPats, addConsistencyConstraints,-        wrongKindOfFamily+        wrongKindOfFamily, checkFamTelescope     ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Driver.Env import GHC.Driver.Session+import GHC.Driver.Config.HsToCore  import GHC.Hs +import GHC.Tc.Errors.Types ( TcRnMessage(..), FixedRuntimeRepProvenance(..) ) import GHC.Tc.TyCl.Build import GHC.Tc.Solver( pushLevelAndSolveEqualities, pushLevelAndSolveEqualitiesX                     , reportUnsolvedEqualities )@@ -70,7 +71,9 @@ import GHC.Core.DataCon import GHC.Core.Unify +import GHC.Types.Error import GHC.Types.Id+import GHC.Types.Id.Make import GHC.Types.Var import GHC.Types.Var.Env import GHC.Types.Var.Set@@ -85,18 +88,19 @@  import GHC.Data.FastString import GHC.Data.Maybe-import GHC.Data.List.SetOps+import GHC.Data.List.SetOps( minusList, equivClasses )  import GHC.Unit  import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Misc  import Control.Monad-import Data.Function ( on ) import Data.Functor.Identity-import Data.List (nubBy, partition)+import Data.List ( partition) import Data.List.NonEmpty ( NonEmpty(..) ) import qualified Data.Set as Set import Data.Tuple( swap )@@ -144,31 +148,35 @@                                             -- and their implicit Ids,DataCons                          , [InstInfo GhcRn] -- Source-code instance decls info                          , [DerivInfo]      -- Deriving info+                         , ThBindEnv        -- TH binding levels                          ) -- Fails if there are any errors tcTyAndClassDecls tyclds_s   -- The code recovers internally, but if anything gave rise to   -- an error we'd better stop now, to avoid a cascade   -- Type check each group in dependency order folding the global env-  = checkNoErrs $ fold_env [] [] tyclds_s+  = checkNoErrs $ fold_env [] [] emptyNameEnv tyclds_s   where     fold_env :: [InstInfo GhcRn]              -> [DerivInfo]+             -> ThBindEnv              -> [TyClGroup GhcRn]-             -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])-    fold_env inst_info deriv_info []+             -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ThBindEnv)+    fold_env inst_info deriv_info th_bndrs []       = do { gbl_env <- getGblEnv-           ; return (gbl_env, inst_info, deriv_info) }-    fold_env inst_info deriv_info (tyclds:tyclds_s)-      = do { (tcg_env, inst_info', deriv_info') <- tcTyClGroup tyclds+           ; return (gbl_env, inst_info, deriv_info, th_bndrs) }+    fold_env inst_info deriv_info th_bndrs (tyclds:tyclds_s)+      = do { (tcg_env, inst_info', deriv_info', th_bndrs')+               <- tcTyClGroup tyclds            ; setGblEnv tcg_env $                -- remaining groups are typechecked in the extended global env.              fold_env (inst_info' ++ inst_info)                       (deriv_info' ++ deriv_info)+                      (th_bndrs' `plusNameEnv` th_bndrs)                       tyclds_s }  tcTyClGroup :: TyClGroup GhcRn-            -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])+            -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ThBindEnv) -- Typecheck one strongly-connected component of type, class, and instance decls -- See Note [TyClGroups and dependency analysis] in GHC.Hs.Decls tcTyClGroup (TyClGroup { group_tyclds = tyclds@@ -206,17 +214,18 @@            -- Step 3: Add the implicit things;            -- we want them in the environment because            -- they may be mentioned in interface files-       ; gbl_env <- addTyConsToGblEnv tyclss+       ; (gbl_env, th_bndrs) <- addTyConsToGblEnv tyclss             -- Step 4: check instance declarations-       ; (gbl_env', inst_info, datafam_deriv_info) <-+       ; (gbl_env', inst_info, datafam_deriv_info, th_bndrs') <-          setGblEnv gbl_env $          tcInstDecls1 instds         ; let deriv_info = datafam_deriv_info ++ data_deriv_info        ; let gbl_env'' = gbl_env'                 { tcg_ksigs = tcg_ksigs gbl_env' `unionNameSet` kindless }-       ; return (gbl_env'', inst_info, deriv_info) }+       ; return (gbl_env'', inst_info, deriv_info,+                 th_bndrs' `plusNameEnv` th_bndrs) }  -- Gives the kind for every TyCon that has a standalone kind signature type KindSigEnv = NameEnv Kind@@ -395,32 +404,51 @@     see makeRecoveryTyCon.  2.  When checking a type/class declaration (in module GHC.Tc.TyCl), we come-    upon knowledge of the eventual tycon in bits and pieces.+    upon knowledge of the eventual tycon in bits and pieces, and we use+    a TcTyCon to record what we know before we are ready to build the+    final TyCon. -      S1) First, we use inferInitialKinds to look over the user-provided-          kind signature of a tycon (including, for example, the number-          of parameters written to the tycon) to get an initial shape of-          the tycon's kind.  We record that shape in a TcTyCon.+    We first build a MonoTcTyCon, then generalise to a PolyTcTyCon+    See Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in GHC.Tc.Utils.TcType+    Specifically: -          For CUSK tycons, the TcTyCon has the final, generalised kind.-          For non-CUSK tycons, the TcTyCon has as its tyConBinders only-          the explicit arguments given -- no kind variables, etc.+      S1) In kcTyClGroup, we use checkInitialKinds to get the+          utterly-final Kind of all TyCons in the group that+            (a) have a kind signature or+            (b) have a CUSK.+          This produces a PolyTcTyCon, that is, a TcTyCon in which the binders+          and result kind are full of TyVars (not TcTyVars).  No unification+          variables here; everything is in its final form. -      S2) Then, using these initial kinds, we kind-check the body of the-          tycon (class methods, data constructors, etc.), filling in the+      S2) In kcTyClGroup, we use inferInitialKinds to look over the+          declaration of any TyCon that lacks a kind signature or+          CUSK, to determine its "shape"; for example, the number of+          parameters, and any kind signatures.++          We record that shape record that shape in a MonoTcTyCon; it is+          "mono" because it has not been been generalised, and its binders+          and result kind may have free unification variables.++      S3) Still in kcTyClGroup, we use kcLTyClDecl to kind-check the+          body (class methods, data constructors, etc.) of each of+          these MonoTcTyCons, which has the effect of filling in the           metavariables in the tycon's initial kind. -      S3) We then generalize to get the (non-CUSK) tycon's final, fixed-          kind. Finally, once this has happened for all tycons in a-          mutually recursive group, we can desugar the lot.+      S4) Still in kcTyClGroup, we use generaliseTyClDecl to generalize+          each MonoTcTyCon to get a PolyTcTyCon, with final TyVars in it,+          and a final, fixed kind. -    For convenience, we store partially-known tycons in TcTyCons, which-    might store meta-variables. These TcTyCons are stored in the local-    environment in GHC.Tc.TyCl, until the real full TyCons can be created-    during desugaring. A desugared program should never have a TcTyCon.+      S5) Finally, back in TcTyClDecls, we extend the environment with+          the PolyTcTyCons, and typecheck each declaration (regardless+          of kind signatures etc) to get final TyCon. -3.  In a TcTyCon, everything is zonked after the kind-checking pass (S2).+    These TcTyCons are stored in the local environment in GHC.Tc.TyCl,+    until the real full TyCons can be created during desugaring. A+    desugared program should never have a TcTyCon. +3.  A MonoTcTyCon can contain unification variables, but a PolyTcTyCon+    does not: only skolem TcTyVars.+ 4.  tyConScopedTyVars.  A challenging piece in all of this is that we     end up taking three separate passes over every declaration:       - one in inferInitialKind (this pass look only at the head, not the body)@@ -435,8 +463,10 @@     GHC.Tc.Gen.HsType.splitTelescopeTvs!)      Instead of trying, we just store the list of type variables to-    bring into scope, in the tyConScopedTyVars field of the TcTyCon.-    These tyvars are brought into scope in GHC.Tc.Gen.HsType.bindTyClTyVars.+    bring into scope, in the tyConScopedTyVars field of a MonoTcTyCon.+    These tyvars are brought into scope by the calls to+       tcExtendNameTyVarEnv (tcTyConScopedTyVars tycon)+    in kcTyClDecl.      In a TcTyCon, why is tyConScopedTyVars :: [(Name,TcTyVar)] rather     than just [TcTyVar]?  Consider these mutually-recursive decls@@ -633,7 +663,7 @@  -} -kcTyClGroup :: KindSigEnv -> [LTyClDecl GhcRn] -> TcM ([TcTyCon], NameSet)+kcTyClGroup :: KindSigEnv -> [LTyClDecl GhcRn] -> TcM ([PolyTcTyCon], NameSet)  -- Kind check this group, kind generalize, and return the resulting local env -- This binds the TyCons and Classes of the group, but not the DataCons@@ -677,7 +707,7 @@          ; inferred_tcs             <- tcExtendKindEnvWithTyCons checked_tcs  $-               pushLevelAndSolveEqualities UnkSkol [] $+               pushLevelAndSolveEqualities unkSkolAnon [] $                      -- We are going to kind-generalise, so unification                      -- variables in here must be one level in                do {  -- Step 1: Bind kind variables for all decls@@ -717,7 +747,7 @@   --    specified-tvs ++ required-tvs   -- You can distinguish them because there are tyConArity required-tvs -generaliseTyClDecl :: NameEnv TcTyCon -> LTyClDecl GhcRn -> TcM [TcTyCon]+generaliseTyClDecl :: NameEnv MonoTcTyCon -> LTyClDecl GhcRn -> TcM [PolyTcTyCon] -- See Note [Swizzling the tyvars before generaliseTcTyCon] generaliseTyClDecl inferred_tc_env (L _ decl)   = do { let names_in_this_decl :: [Name]@@ -746,35 +776,38 @@     at_names (ClassDecl { tcdATs = ats }) = map (familyDeclName . unLoc) ats     at_names _ = []  -- Only class decls have associated types -    skolemise_tc_tycon :: Name -> TcM (TcTyCon, ScopedPairs)+    skolemise_tc_tycon :: Name -> TcM (TcTyCon, SkolemInfo, ScopedPairs)     -- Zonk and skolemise the Specified and Required binders     skolemise_tc_tycon tc_name       = do { let tc = lookupNameEnv_NF inferred_tc_env tc_name                       -- This lookup should not fail-           ; scoped_prs <- mapSndM zonkAndSkolemise (tcTyConScopedTyVars tc)-           ; return (tc, scoped_prs) }+           ; skol_info <- mkSkolemInfo (TyConSkol (tyConFlavour tc) tc_name )+           ; scoped_prs <- mapSndM (zonkAndSkolemise skol_info) (tcTyConScopedTyVars tc)+           ; return (tc, skol_info, scoped_prs) } -    zonk_tc_tycon :: (TcTyCon, ScopedPairs) -> TcM (TcTyCon, ScopedPairs, TcKind)-    zonk_tc_tycon (tc, scoped_prs)-      = do { scoped_prs <- mapSndM zonkTcTyVarToTyVar scoped_prs+    zonk_tc_tycon :: (TcTyCon, SkolemInfo, ScopedPairs)+                  -> TcM (TcTyCon, SkolemInfo, ScopedPairs, TcKind)+    zonk_tc_tycon (tc, skol_info, scoped_prs)+      = do { scoped_prs <- mapSndM zonkTcTyVarToTcTyVar scoped_prs                            -- We really have to do this again, even though-                           -- we have just done zonkAndSkolemise+                           -- we have just done zonkAndSkolemise, so that+                           -- occurrences in the /kinds/ get zonked to the skolem            ; res_kind   <- zonkTcType (tyConResKind tc)-           ; return (tc, scoped_prs, res_kind) }+           ; return (tc, skol_info, scoped_prs, res_kind) } -swizzleTcTyConBndrs :: [(TcTyCon, ScopedPairs, TcKind)]-                -> TcM [(TcTyCon, ScopedPairs, TcKind)]+swizzleTcTyConBndrs :: [(TcTyCon, SkolemInfo, ScopedPairs, TcKind)]+                -> TcM [(TcTyCon, SkolemInfo, ScopedPairs, TcKind)] swizzleTcTyConBndrs tc_infos   | all no_swizzle swizzle_prs     -- This fast path happens almost all the time     -- See Note [Cloning for type variable binders] in GHC.Tc.Gen.HsType     -- "Almost all the time" means not the case of mutual recursion with     -- polymorphic kinds.-  = do { traceTc "Skipping swizzleTcTyConBndrs for" (ppr (map fstOf3 tc_infos))+  = do { traceTc "Skipping swizzleTcTyConBndrs for" (ppr_infos tc_infos)        ; return tc_infos }    | otherwise-  = do { check_duplicate_tc_binders+  = do { checkForDuplicateScopedTyVars swizzle_prs         ; traceTc "swizzleTcTyConBndrs" $          vcat [ text "before" <+> ppr_infos tc_infos@@ -784,49 +817,19 @@        ; return swizzled_infos }    where-    swizzled_infos =  [ (tc, mapSnd swizzle_var scoped_prs, swizzle_ty kind)-                      | (tc, scoped_prs, kind) <- tc_infos ]+    swizzled_infos =  [ (tc, skol_info, mapSnd swizzle_var scoped_prs, swizzle_ty kind)+                      | (tc, skol_info, scoped_prs, kind) <- tc_infos ]      swizzle_prs :: [(Name,TyVar)]     -- Pairs the user-specified Name with its representative TyVar     -- See Note [Swizzling the tyvars before generaliseTcTyCon]-    swizzle_prs = [ pr | (_, prs, _) <- tc_infos, pr <- prs ]+    swizzle_prs = [ pr | (_, _, prs, _) <- tc_infos, pr <- prs ]      no_swizzle :: (Name,TyVar) -> Bool     no_swizzle (nm, tv) = nm == tyVarName tv      ppr_infos infos = vcat [ ppr tc <+> pprTyVars (map snd prs)-                           | (tc, prs, _) <- infos ]--    -- Check for duplicates-    -- E.g. data SameKind (a::k) (b::k)-    --      data T (a::k1) (b::k2) = MkT (SameKind a b)-    -- Here k1 and k2 start as TyVarTvs, and get unified with each other-    -- If this happens, things get very confused later, so fail fast-    check_duplicate_tc_binders :: TcM ()-    check_duplicate_tc_binders = unless (null err_prs) $-                                 do { mapM_ report_dup err_prs; failM }--    -------------- Error reporting -------------    err_prs :: [(Name,Name)]-    err_prs = [ (n1,n2)-              | pr :| prs <- findDupsEq ((==) `on` snd) swizzle_prs-              , (n1,_):(n2,_):_ <- [nubBy ((==) `on` fst) (pr:prs)] ]-              -- This nubBy avoids bogus error reports when we have-              --    [("f", f), ..., ("f",f)....] in swizzle_prs-              -- which happens with  class C f where { type T f }--    report_dup :: (Name,Name) -> TcM ()-    report_dup (n1,n2)-      = setSrcSpan (getSrcSpan n2) $ addErrTc $-        hang (text "Different names for the same type variable:") 2 info-      where-        info | nameOccName n1 /= nameOccName n2-             = quotes (ppr n1) <+> text "and" <+> quotes (ppr n2)-             | otherwise -- Same OccNames! See C2 in-                         -- Note [Swizzling the tyvars before generaliseTcTyCon]-             = vcat [ quotes (ppr n1) <+> text "bound at" <+> ppr (getSrcLoc n1)-                    , quotes (ppr n2) <+> text "bound at" <+> ppr (getSrcLoc n2) ]+                           | (tc, _, prs, _) <- infos ]      -------------- The swizzler ------------     -- This does a deep traverse, simply doing a@@ -862,8 +865,10 @@     swizzle_ty ty = runIdentity (map_type ty)  -generaliseTcTyCon :: (TcTyCon, ScopedPairs, TcKind) -> TcM TcTyCon-generaliseTcTyCon (tc, scoped_prs, tc_res_kind)+generaliseTcTyCon :: (MonoTcTyCon, SkolemInfo, ScopedPairs, TcKind) -> TcM PolyTcTyCon+generaliseTcTyCon (tc, skol_info, scoped_prs, tc_res_kind)+  -- The scoped_prs are fully zonked skolem TcTyVars+  -- And tc_res_kind is fully zonked too   -- See Note [Required, Specified, and Inferred for types]   = setSrcSpan (getSrcSpan tc) $     addTyConCtxt tc $@@ -885,7 +890,7 @@         -- Step 2b: quantify, mainly meaning skolemise the free variables        -- Returned 'inferred' are scope-sorted and skolemised-       ; inferred <- quantifyTyVars dvs2+       ; inferred <- quantifyTyVars skol_info DefaultNonStandardTyVars dvs2         ; traceTc "generaliseTcTyCon: pre zonk"            (vcat [ text "tycon =" <+> ppr tc@@ -894,21 +899,18 @@                  , text "dvs1 =" <+> ppr dvs1                  , text "inferred =" <+> pprTyVars inferred ]) -       -- Step 3: Final zonk (following kind generalisation)-       -- See Note [Swizzling the tyvars before generaliseTcTyCon]-       ; ze <- mkEmptyZonkEnv NoFlexi-       ; (ze, inferred)        <- zonkTyBndrsX      ze inferred-       ; (ze, sorted_spec_tvs) <- zonkTyBndrsX      ze sorted_spec_tvs-       ; (ze, req_tvs)         <- zonkTyBndrsX      ze req_tvs-       ; tc_res_kind           <- zonkTcTypeToTypeX ze tc_res_kind+       -- Step 3: Final zonk: quantifyTyVars may have done some defaulting+       ; inferred        <- zonkTcTyVarsToTcTyVars inferred+       ; sorted_spec_tvs <- zonkTcTyVarsToTcTyVars sorted_spec_tvs+       ; req_tvs         <- zonkTcTyVarsToTcTyVars req_tvs+       ; tc_res_kind     <- zonkTcType             tc_res_kind         ; traceTc "generaliseTcTyCon: post zonk" $          vcat [ text "tycon =" <+> ppr tc               , text "inferred =" <+> pprTyVars inferred               , text "spec_req_tvs =" <+> pprTyVars spec_req_tvs               , text "sorted_spec_tvs =" <+> pprTyVars sorted_spec_tvs-              , text "req_tvs =" <+> ppr req_tvs-              , text "zonk-env =" <+> ppr ze ]+              , text "req_tvs =" <+> ppr req_tvs ]         -- Step 4: Make the TyConBinders.        ; let dep_fv_set     = candidateKindVars dvs1@@ -917,15 +919,21 @@              required_tcbs  = map (mkRequiredTyConBinder dep_fv_set) req_tvs         -- Step 5: Assemble the final list.-             final_tcbs = concat [ inferred_tcbs-                                 , specified_tcbs-                                 , required_tcbs ]+             all_tcbs = concat [ inferred_tcbs+                               , specified_tcbs+                               , required_tcbs ]+             flav = tyConFlavour tc +       -- Eta expand+       ; (eta_tcbs, tc_res_kind) <- etaExpandAlgTyCon flav skol_info all_tcbs tc_res_kind+        -- Step 6: Make the result TcTyCon-             tycon = mkTcTyCon (tyConName tc) final_tcbs tc_res_kind-                            (mkTyVarNamePairs (sorted_spec_tvs ++ req_tvs))-                            True {- it's generalised now -}-                            (tyConFlavour tc)+       ; let final_tcbs = all_tcbs `chkAppend` eta_tcbs+             tycon = mkTcTyCon (tyConName tc)+                               final_tcbs tc_res_kind+                               (mkTyVarNamePairs (sorted_spec_tvs ++ req_tvs))+                               True {- it's generalised now -}+                               flav         ; traceTc "generaliseTcTyCon done" $          vcat [ text "tycon =" <+> ppr tc@@ -1150,7 +1158,7 @@   Here we will unify k1 with k2, but this time doing so is an error,   because k1 and k2 are bound in the same declaration. -  We spot this during validity checking (findDupTyVarTvs),+  We spot this during validity checking (checkForDuplicateScopeTyVars),   in generaliseTcTyCon.  * Required arguments.  Even the Required arguments should be made@@ -1283,7 +1291,7 @@     -- Works for family declarations too  ---------------inferInitialKinds :: [LTyClDecl GhcRn] -> TcM [TcTyCon]+inferInitialKinds :: [LTyClDecl GhcRn] -> TcM [MonoTcTyCon] -- Returns a TcTyCon for each TyCon bound by the decls, -- each with its initial kind @@ -1297,7 +1305,7 @@  -- Check type/class declarations against their standalone kind signatures or -- CUSKs, producing a generalized TcTyCon for each.-checkInitialKinds :: [(LTyClDecl GhcRn, SAKS_or_CUSK)] -> TcM [TcTyCon]+checkInitialKinds :: [(LTyClDecl GhcRn, SAKS_or_CUSK)] -> TcM [PolyTcTyCon] checkInitialKinds decls   = do { traceTc "checkInitialKinds {" $ ppr (mapFst (tcdName . unLoc) decls)        ; tcs <- concatMapM check_initial_kind decls@@ -1328,18 +1336,17 @@     (ClassDecl { tcdLName = L _ name                , tcdTyVars = ktvs                , tcdATs = ats })-  = do { cls <- kcDeclHeader strategy name ClassFlavour ktvs $+  = do { cls_tc <- kcDeclHeader strategy name ClassFlavour ktvs $                 return (TheKind constraintKind)-       ; let parent_tv_prs = tcTyConScopedTyVars cls             -- See Note [Don't process associated types in getInitialKind]-       ; inner_tcs <--           tcExtendNameTyVarEnv parent_tv_prs $-           mapM (addLocMA (getAssocFamInitialKind cls)) ats-       ; return (cls : inner_tcs) }++       ; at_tcs <- tcExtendTyVarEnv (tyConTyVars cls_tc) $+                      mapM (addLocMA (getAssocFamInitialKind cls_tc)) ats+       ; return (cls_tc : at_tcs) }   where     getAssocFamInitialKind cls =       case strategy of-        InitialKindInfer -> get_fam_decl_initial_kind (Just cls)+        InitialKindInfer   -> get_fam_decl_initial_kind (Just cls)         InitialKindCheck _ -> check_initial_kind_assoc_fam cls  getInitialKind strategy@@ -1519,7 +1526,7 @@   case info of     DataFamily         -> DataFamilyFlavour mb_parent_tycon     OpenTypeFamily     -> OpenTypeFamilyFlavour mb_parent_tycon-    ClosedTypeFamily _ -> ASSERT( isNothing mb_parent_tycon ) -- See Note [Closed type family mb_parent_tycon]+    ClosedTypeFamily _ -> assert (isNothing mb_parent_tycon) -- See Note [Closed type family mb_parent_tycon]                           ClosedTypeFamilyFlavour  {- Note [Closed type family mb_parent_tycon]@@ -1539,7 +1546,7 @@   -- Called only for declarations without a signature (no CUSKs or SAKs here) kcLTyClDecl (L loc decl)   = setSrcSpanA loc $-    do { tycon <- tcLookupTcTyCon tc_name+    do { tycon <- tcLookupTcTyCon tc_name   -- Always a MonoTcTyCon        ; traceTc "kcTyClDecl {" (ppr tc_name)        ; addVDQNote tycon $   -- See Note [Inferring visible dependent quantification]          addErrCtxt (tcMkDeclCtxt decl) $@@ -1548,15 +1555,21 @@   where     tc_name = tcdName decl -kcTyClDecl :: TyClDecl GhcRn -> TcTyCon -> TcM ()+kcTyClDecl :: TyClDecl GhcRn -> MonoTcTyCon -> TcM () -- This function is used solely for its side effect on kind variables -- NB kind signatures on the type variables and --    result kind signature have already been dealt with --    by inferInitialKind, so we can ignore them here. -kcTyClDecl (DataDecl { tcdLName    = (L _ name), tcdDataDefn = defn }) tycon+-- NB these equations just extend the type environment with carefully constructed+-- TcTyVars rather than create skolemised variables for the bound variables.+-- - inferInitialKinds makes the TcTyCon where the  tyvars are TcTyVars+-- - In this function, those TcTyVars are unified with other kind variables during+--   kind inference (see [How TcTyCons work])++kcTyClDecl (DataDecl { tcdLName    = (L _ _name), tcdDataDefn = defn }) tycon   | HsDataDefn { dd_ctxt = ctxt, dd_cons = cons, dd_ND = new_or_data } <- defn-  = bindTyClTyVars name $ \ _ _ _ ->+  = tcExtendNameTyVarEnv (tcTyConScopedTyVars tycon) $        -- NB: binding these tyvars isn't necessary for GADTs, but it does no        -- harm.  For GADTs, each data con brings its own tyvars into scope,        -- and the ones from this bindTyClTyVars are either not mentioned or@@ -1566,15 +1579,16 @@        ; kcConDecls new_or_data (tyConResKind tycon) cons        } -kcTyClDecl (SynDecl { tcdLName = L _ name, tcdRhs = rhs }) _tycon-  = bindTyClTyVars name $ \ _ _ res_kind ->-    discardResult $ tcCheckLHsType rhs (TheKind res_kind)+kcTyClDecl (SynDecl { tcdLName = L _ _name, tcdRhs = rhs }) tycon+  = tcExtendNameTyVarEnv (tcTyConScopedTyVars tycon) $+    let res_kind = tyConResKind tycon+    in discardResult $ tcCheckLHsType rhs (TheKind res_kind)         -- NB: check against the result kind that we allocated         -- in inferInitialKinds. -kcTyClDecl (ClassDecl { tcdLName = L _ name-                      , tcdCtxt = ctxt, tcdSigs = sigs }) _tycon-  = bindTyClTyVars name $ \ _ _ _ ->+kcTyClDecl (ClassDecl { tcdLName = L _ _name+                      , tcdCtxt = ctxt, tcdSigs = sigs }) tycon+  = tcExtendNameTyVarEnv (tcTyConScopedTyVars tycon) $     do  { _ <- tcHsContext ctxt         ; mapM_ (wrapLocMA_ kc_sig) sigs }   where@@ -1594,7 +1608,7 @@ -- This includes doing kind unification if the type is a newtype. -- See Note [Implementation of UnliftedNewtypes] for why we need -- the first two arguments.-kcConArgTys :: NewOrData -> Kind -> [HsScaled GhcRn (LHsType GhcRn)] -> TcM ()+kcConArgTys :: NewOrData -> TcKind -> [HsScaled GhcRn (LHsType GhcRn)] -> TcM () kcConArgTys new_or_data res_kind arg_tys = do   { let exp_kind = getArgExpKind new_or_data res_kind   ; forM_ arg_tys (\(HsScaled mult ty) -> do _ <- tcCheckLHsType (getBangType ty) exp_kind@@ -1603,7 +1617,7 @@   }  -- Kind-check the types of arguments to a Haskell98 data constructor.-kcConH98Args :: NewOrData -> Kind -> HsConDeclH98Details GhcRn -> TcM ()+kcConH98Args :: NewOrData -> TcKind -> HsConDeclH98Details GhcRn -> TcM () kcConH98Args new_or_data res_kind con_args = case con_args of   PrefixCon _ tys   -> kcConArgTys new_or_data res_kind tys   InfixCon ty1 ty2  -> kcConArgTys new_or_data res_kind [ty1, ty2]@@ -1611,14 +1625,14 @@                        map (hsLinear . cd_fld_type . unLoc) flds  -- Kind-check the types of arguments to a GADT data constructor.-kcConGADTArgs :: NewOrData -> Kind -> HsConDeclGADTDetails GhcRn -> TcM ()+kcConGADTArgs :: NewOrData -> TcKind -> HsConDeclGADTDetails GhcRn -> TcM () kcConGADTArgs new_or_data res_kind con_args = case con_args of-  PrefixConGADT tys     -> kcConArgTys new_or_data res_kind tys-  RecConGADT (L _ flds) -> kcConArgTys new_or_data res_kind $-                           map (hsLinear . cd_fld_type . unLoc) flds+  PrefixConGADT tys     ->   kcConArgTys new_or_data res_kind tys+  RecConGADT (L _ flds) _ -> kcConArgTys new_or_data res_kind $+                             map (hsLinear . cd_fld_type . unLoc) flds  kcConDecls :: NewOrData-           -> Kind             -- The result kind signature+           -> TcKind             -- The result kind signature                                --   Used only in H98 case            -> [LConDecl GhcRn] -- The data constructors            -> TcM ()@@ -1632,7 +1646,7 @@ -- this type. See Note [Implementation of UnliftedNewtypes] for why -- we need the first two arguments. kcConDecl :: NewOrData-          -> Kind  -- Result kind of the type constructor+          -> TcKind  -- Result kind of the type constructor                    -- Usually Type but can be TYPE UnliftedRep                    -- or even TYPE r, in the case of unlifted newtype                    -- Used only in H98 case@@ -1658,6 +1672,7 @@   = -- See Note [kcConDecls: kind-checking data type decls]     addErrCtxt (dataConCtxt names) $     discardResult                      $+    -- Not sure this is right, should just extend rather than skolemise but no test     bindOuterSigTKBndrs_Tv outer_bndrs $         -- Why "_Tv"?  See Note [Using TyVarTvs for kind-checking GADTs]     do { _ <- tcHsContext cxt@@ -2159,7 +2174,7 @@  Note that, in the GADT case, we might have a kind signature with arrows (newtype XYZ a b :: Type -> Type where ...). We want only the final-component of the kind for checking in kcConDecl, so we call etaExpandAlgTyCon+component of the kind for checking in kcConDecl, so we call etaExpanAlgTyCon in kcTyClDecl.  STEP 3: Type-checking (desugaring), as done by tcTyClDecl. The key function@@ -2362,7 +2377,7 @@ tcTyClDecl1 _parent roles_info             (SynDecl { tcdLName = L _ tc_name                      , tcdRhs   = rhs })-  = ASSERT( isNothing _parent )+  = assert (isNothing _parent )     fmap noDerivInfos $     tcTySynRhs roles_info tc_name rhs @@ -2370,7 +2385,7 @@ tcTyClDecl1 _parent roles_info             decl@(DataDecl { tcdLName = L _ tc_name                            , tcdDataDefn = defn })-  = ASSERT( isNothing _parent )+  = assert (isNothing _parent) $     tcDataDefn (tcMkDeclCtxt decl) roles_info tc_name defn  tcTyClDecl1 _parent roles_info@@ -2381,7 +2396,7 @@                        , tcdSigs = sigs                        , tcdATs = ats                        , tcdATDefs = at_defs })-  = ASSERT( isNothing _parent )+  = assert (isNothing _parent) $     do { clas <- tcClassDecl1 roles_info class_name hs_ctxt                               meths fundeps sigs ats at_defs        ; return (noDerivInfos (classTyCon clas)) }@@ -2398,16 +2413,15 @@              -> [LFamilyDecl GhcRn] -> [LTyFamDefltDecl GhcRn]              -> TcM Class tcClassDecl1 roles_info class_name hs_ctxt meths fundeps sigs ats at_defs-  = fixM $ \ clas ->-    -- We need the knot because 'clas' is passed into tcClassATs-    bindTyClTyVars class_name $ \ _ binders res_kind ->+  = fixM $ \ clas -> -- We need the knot because 'clas' is passed into tcClassATs+    bindTyClTyVars class_name $ \ binders res_kind ->     do { checkClassKindSig res_kind        ; traceTc "tcClassDecl 1" (ppr class_name $$ ppr binders)        ; let tycon_name = class_name        -- We use the same name              roles = roles_info tycon_name  -- for TyCon and Class         ; (ctxt, fds, sig_stuff, at_stuff)-            <- pushLevelAndSolveEqualities skol_info (binderVars binders) $+            <- pushLevelAndSolveEqualities skol_info binders $                -- The (binderVars binders) is needed bring into scope the                -- skolems bound by the class decl header (#17841)                do { ctxt <- tcHsContext hs_ctxt@@ -2444,7 +2458,15 @@         ; mindef <- tcClassMinimalDef class_name sigs sig_stuff        ; is_boot <- tcIsHsBootOrSig-       ; let body | is_boot, null ctxt, null at_stuff, null sig_stuff+       ; let body | is_boot, isNothing hs_ctxt, null at_stuff, null sig_stuff+                  -- We use @isNothing hs_ctxt@ rather than @null ctxt@,+                  -- so that a declaration in an hs-boot file such as:+                  --+                  -- class () => C a b | a -> b+                  --+                  -- is not considered abstract; it's sometimes useful+                  -- to be able to declare such empty classes in hs-boot files.+                  -- See #20661.                   = Nothing                   | otherwise                   = Just (ctxt, at_stuff, sig_stuff, mindef)@@ -2455,6 +2477,7 @@        ; return clas }   where     skol_info = TyConSkol ClassFlavour class_name+     tc_fundep :: GHC.Hs.FunDep GhcRn -> TcM ([Var],[Var])     tc_fundep (FunDep _ tvs1 tvs2)                            = do { tvs1' <- mapM (tcLookupTyVar . unLoc) tvs1 ;@@ -2483,7 +2506,7 @@            -> TcM [ClassATItem] tcClassATs class_name cls ats at_defs   = do {  -- Complain about associated type defaults for non associated-types-         sequence_ [ failWithTc (badATErr class_name n)+         sequence_ [ failWithTc (TcRnBadAssociatedType class_name n)                    | n <- map at_def_tycon at_defs                    , not (n `elemNameSet` at_names) ]        ; mapM tc_at ats }@@ -2517,7 +2540,8 @@   = return Nothing  -- No default declaration  tcDefaultAssocDecl _ (d1:_:_)-  = failWithTc (text "More than one default declaration for"+  = failWithTc (TcRnUnknownMessage $ mkPlainError noHints $+                text "More than one default declaration for"                 <+> ppr (tyFamInstDeclName (unLoc d1)))  tcDefaultAssocDecl fam_tc@@ -2535,7 +2559,7 @@              vis_pats  = numVisibleArgs hs_pats         -- Kind of family check-       ; ASSERT( fam_tc_name == tc_name )+       ; assert (fam_tc_name == tc_name) $          checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc)         -- Arity check@@ -2677,8 +2701,8 @@                               , fdResultSig = L _ sig                               , fdInjectivityAnn = inj })   | DataFamily <- fam_info-  = bindTyClTyVars tc_name $ \ _ binders res_kind -> do-  { traceTc "data family:" (ppr tc_name)+  = bindTyClTyVarsAndZonk tc_name $ \ binders res_kind -> do+  { traceTc "tcFamDecl1 data family:" (ppr tc_name)   ; checkFamFlag tc_name    -- Check that the result kind is OK@@ -2703,8 +2727,8 @@   ; return tycon }    | OpenTypeFamily <- fam_info-  = bindTyClTyVars tc_name $ \ _ binders res_kind -> do-  { traceTc "open type family:" (ppr tc_name)+  = bindTyClTyVarsAndZonk tc_name $ \ binders res_kind -> do+  { traceTc "tcFamDecl1 open type family:" (ppr tc_name)   ; checkFamFlag tc_name   ; inj' <- tcInjectivity binders inj   ; checkResultSigFlag tc_name sig  -- check after injectivity for better errors@@ -2716,11 +2740,11 @@   | ClosedTypeFamily mb_eqns <- fam_info   = -- Closed type families are a little tricky, because they contain the definition     -- of both the type family and the equations for a CoAxiom.-    do { traceTc "Closed type family:" (ppr tc_name)+    do { traceTc "tcFamDecl1 Closed type family:" (ppr tc_name)          -- the variables in the header scope only over the injectivity          -- declaration but this is not involved here        ; (inj', binders, res_kind)-            <- bindTyClTyVars tc_name $ \ _ binders res_kind ->+            <- bindTyClTyVarsAndZonk tc_name $ \ binders res_kind ->                do { inj' <- tcInjectivity binders inj                   ; return (inj', binders, res_kind) } @@ -2799,14 +2823,15 @@   -- But this does not seem to be useful in any way so we don't do it.  (Another   -- reason is that the implementation would not be straightforward.) tcInjectivity tcbs (Just (L loc (InjectivityAnn _ _ lInjNames)))-  = setSrcSpan loc $+  = setSrcSpanA loc $     do { let tvs = binderVars tcbs        ; dflags <- getDynFlags        ; checkTc (xopt LangExt.TypeFamilyDependencies dflags)-                 (text "Illegal injectivity annotation" $$+                 (TcRnUnknownMessage $ mkPlainError noHints $+                  text "Illegal injectivity annotation" $$                   text "Use TypeFamilyDependencies to allow this")        ; inj_tvs <- mapM (tcLookupTyVar . unLoc) lInjNames-       ; inj_tvs <- mapM zonkTcTyVarToTyVar inj_tvs -- zonk the kinds+       ; inj_tvs <- zonkTcTyVarsToTcTyVars inj_tvs -- zonk the kinds        ; let inj_ktvs = filterVarSet isTyVar $  -- no injective coercion vars                         closeOverKinds (mkVarSet inj_tvs)        ; let inj_bools = map (`elemVarSet` inj_ktvs) tvs@@ -2817,10 +2842,10 @@ tcTySynRhs :: RolesInfo -> Name            -> LHsType GhcRn -> TcM TyCon tcTySynRhs roles_info tc_name hs_ty-  = bindTyClTyVars tc_name $ \ _ binders res_kind ->+  = bindTyClTyVars tc_name $ \ binders res_kind ->     do { env <- getLclEnv        ; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env))-       ; rhs_ty <- pushLevelAndSolveEqualities skol_info (binderVars binders) $+       ; rhs_ty <- pushLevelAndSolveEqualities skol_info binders $                    tcCheckLHsType hs_ty (TheKind res_kind)           -- See Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType@@ -2834,8 +2859,9 @@                                                  , ppr rhs_ty ] ) }        ; doNotQuantifyTyVars dvs mk_doc -       ; ze <- mkEmptyZonkEnv NoFlexi-       ; rhs_ty <- zonkTcTypeToTypeX ze rhs_ty+       ; ze            <- mkEmptyZonkEnv NoFlexi+       ; (ze, binders) <- zonkTyVarBindersX ze binders+       ; rhs_ty        <- zonkTcTypeToTypeX ze rhs_ty        ; let roles = roles_info tc_name        ; return (buildSynTyCon tc_name binders res_kind roles rhs_ty) }   where@@ -2851,26 +2877,20 @@                                                -- via inferInitialKinds                        , dd_cons = cons                        , dd_derivs = derivs })-  = bindTyClTyVars tc_name $ \ tctc tycon_binders res_kind ->-       -- 'tctc' is a 'TcTyCon' and has the 'tcTyConScopedTyVars' that we need-       -- unlike the finalized 'tycon' defined above which is an 'AlgTyCon'-       --+  = bindTyClTyVars tc_name $ \ tc_bndrs res_kind ->        -- The TyCon tyvars must scope over        --    - the stupid theta (dd_ctxt)        --    - for H98 constructors only, the ConDecl        -- But it does no harm to bring them into scope        -- over GADT ConDecls as well; and it's awkward not to     do { gadt_syntax <- dataDeclChecks tc_name new_or_data ctxt cons-         -- see Note [Datatype return kinds]-       ; (extra_bndrs, final_res_kind) <- etaExpandAlgTyCon tycon_binders res_kind         ; tcg_env <- getGblEnv        ; let hsc_src = tcg_src tcg_env        ; unless (mk_permissive_kind hsc_src cons) $-         checkDataKindSig (DataDeclSort new_or_data) final_res_kind+         checkDataKindSig (DataDeclSort new_or_data) res_kind -       ; let skol_tvs = binderVars tycon_binders-       ; stupid_tc_theta <- pushLevelAndSolveEqualities skol_info skol_tvs $+       ; stupid_tc_theta <- pushLevelAndSolveEqualities skol_info tc_bndrs $                             tcHsContext ctxt         -- See Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType@@ -2885,36 +2905,39 @@                                    , pprTheta theta ] ) }        ; doNotQuantifyTyVars dvs mk_doc -       ; ze              <- mkEmptyZonkEnv NoFlexi-       ; stupid_theta    <- zonkTcTypesToTypesX ze stupid_tc_theta-              -- Check that we don't use kind signatures without the extension        ; kind_signatures <- xoptM LangExt.KindSignatures        ; when (isJust mb_ksig) $          checkTc (kind_signatures) (badSigTyDecl tc_name) +       ; ze             <- mkEmptyZonkEnv NoFlexi+       ; (ze, bndrs)    <- zonkTyVarBindersX   ze tc_bndrs+       ; stupid_theta   <- zonkTcTypesToTypesX ze stupid_tc_theta+       ; res_kind       <- zonkTcTypeToTypeX   ze res_kind+        ; tycon <- fixM $ \ rec_tycon -> do-             { let final_bndrs = tycon_binders `chkAppend` extra_bndrs-                   roles       = roles_info tc_name-             ; data_cons <- tcConDecls-                              new_or_data DDataType-                              rec_tycon final_bndrs final_res_kind-                              cons+             { data_cons <- tcConDecls new_or_data DDataType rec_tycon+                                       tc_bndrs res_kind cons              ; tc_rhs    <- mk_tc_rhs hsc_src rec_tycon data_cons              ; tc_rep_nm <- newTyConRepName tc_name+              ; return (mkAlgTyCon tc_name-                                  final_bndrs-                                  final_res_kind-                                  roles+                                  bndrs+                                  res_kind+                                  (roles_info tc_name)                                   (fmap unLoc cType)                                   stupid_theta tc_rhs                                   (VanillaAlgTyCon tc_rep_nm)-                                  gadt_syntax) }-       ; let deriv_info = DerivInfo { di_rep_tc = tycon-                                    , di_scoped_tvs = tcTyConScopedTyVars tctc+                                  gadt_syntax)+         }++       ; let scoped_tvs = mkTyVarNamePairs (binderVars tc_bndrs)+                          -- scoped_tvs: still the skolem TcTyVars+             deriv_info = DerivInfo { di_rep_tc = tycon+                                    , di_scoped_tvs = scoped_tvs                                     , di_clauses = derivs                                     , di_ctxt = err_ctxt }-       ; traceTc "tcDataDefn" (ppr tc_name $$ ppr tycon_binders $$ ppr extra_bndrs)+       ; traceTc "tcDataDefn" (ppr tc_name $$ ppr tc_bndrs)        ; return (tycon, [deriv_info]) }   where     skol_info = TyConSkol flav tc_name@@ -2931,21 +2954,21 @@     mk_permissive_kind HsigFile [] = True     mk_permissive_kind _ _ = False -    -- In hs-boot, a 'data' declaration with no constructors+    -- In an hs-boot or a signature file,+    -- a 'data' declaration with no constructors     -- indicates a nominally distinct abstract data type.-    mk_tc_rhs HsBootFile _ []-      = return AbstractTyCon--    mk_tc_rhs HsigFile _ [] -- ditto+    mk_tc_rhs (isHsBootOrSig -> True) _ []       = return AbstractTyCon      mk_tc_rhs _ tycon data_cons       = case new_or_data of-          DataType -> return (mkDataTyConRhs data_cons)-          NewType  -> ASSERT( not (null data_cons) )+          DataType -> return $+                        mkLevPolyDataTyConRhs+                          (isFixedRuntimeRepKind (tyConResKind tycon))+                          data_cons+          NewType  -> assert (not (null data_cons)) $                       mkNewTyConRhs tc_name tycon (head data_cons) - ------------------------- kcTyFamInstEqn :: TcTyCon -> LTyFamInstEqn GhcRn -> TcM () -- Used for the equations of a closed type family only@@ -3060,7 +3083,7 @@  So, we use bindOuterFamEqnTKBndrs (which does not create an implication for the telescope), and generalise over /all/ the variables in the LHS,-without treating the explicitly-quanfitifed ones specially. Wrinkles:+without treating the explicitly-quantifed ones specially. Wrinkles:   - When generalising, include the explicit user-specified forall'd    variables, so that we get an error from Validity.checkFamPatBinders@@ -3091,16 +3114,17 @@                    -> TcM ([TyVar], [TcType], TcType)   -- (tyvars, pats, rhs) -- Used only for type families, not data families tcTyFamInstEqnGuts fam_tc mb_clsinfo outer_hs_bndrs hs_pats hs_rhs_ty-  = do { traceTc "tcTyFamInstEqnGuts {" (ppr fam_tc)+  = do { traceTc "tcTyFamInstEqnGuts {" (ppr fam_tc $$ ppr outer_hs_bndrs $$ ppr hs_pats)         -- By now, for type families (but not data families) we should        -- have checked that the number of patterns matches tyConArity+       ; skol_info <- mkSkolemInfo FamInstSkol         -- This code is closely related to the code        -- in GHC.Tc.Gen.HsType.kcCheckDeclHeader_cusk-       ; (tclvl, wanted, (outer_tvs, (lhs_ty, rhs_ty)))+       ; (tclvl, wanted, (outer_bndrs, (lhs_ty, rhs_ty)))                <- pushLevelAndSolveEqualitiesX "tcTyFamInstEqnGuts" $-                  bindOuterFamEqnTKBndrs outer_hs_bndrs             $+                  bindOuterFamEqnTKBndrs skol_info outer_hs_bndrs   $                   do { (lhs_ty, rhs_kind) <- tcFamTyPats fam_tc hs_pats                        -- Ensure that the instance is consistent with its                        -- parent class (#16008)@@ -3108,6 +3132,12 @@                      ; rhs_ty <- tcCheckLHsType hs_rhs_ty (TheKind rhs_kind)                      ; return (lhs_ty, rhs_ty) } +       ; outer_bndrs <- scopedSortOuter outer_bndrs+       ; let outer_tvs = outerTyVars outer_bndrs+       ; checkFamTelescope tclvl outer_hs_bndrs outer_tvs++       ; traceTc "tcTyFamInstEqnGuts 1" (pprTyVars outer_tvs $$ ppr skol_info)+        -- This code (and the stuff immediately above) is very similar        -- to that in tcDataFamInstHeader.  Maybe we should abstract the        -- common code; but for the moment I concluded that it's@@ -3115,15 +3145,17 @@        -- check there too!         -- See Note [Generalising in tcTyFamInstEqnGuts]-       ; dvs  <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys outer_tvs)-       ; qtvs <- quantifyTyVars dvs-       ; reportUnsolvedEqualities FamInstSkol qtvs tclvl wanted-       ; checkFamTelescope tclvl outer_hs_bndrs outer_tvs+       ; dvs  <- candidateQTyVarsWithBinders outer_tvs lhs_ty+       ; qtvs <- quantifyTyVars skol_info TryNotToDefaultNonStandardTyVars dvs+       ; let final_tvs = scopedSort (qtvs ++ outer_tvs)+             -- This scopedSort is important: the qtvs may be /interleaved/ with+             -- the outer_tvs.  See Note [Generalising in tcTyFamInstEqnGuts]+       ; reportUnsolvedEqualities skol_info final_tvs tclvl wanted         ; traceTc "tcTyFamInstEqnGuts 2" $          vcat [ ppr fam_tc-              , text "lhs_ty"     <+> ppr lhs_ty-              , text "qtvs"       <+> pprTyVars qtvs ]+              , text "lhs_ty:"    <+> ppr lhs_ty+              , text "final_tvs:" <+> pprTyVars final_tvs ]         -- See Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType        -- Example: typecheck/should_fail/T17301@@ -3135,20 +3167,24 @@                                    , ppr rhs_ty ] ) }        ; doNotQuantifyTyVars dvs_rhs mk_doc -       ; ze         <- mkEmptyZonkEnv NoFlexi-       ; (ze, qtvs) <- zonkTyBndrsX      ze qtvs-       ; lhs_ty     <- zonkTcTypeToTypeX ze lhs_ty-       ; rhs_ty     <- zonkTcTypeToTypeX ze rhs_ty+       ; ze              <- mkEmptyZonkEnv NoFlexi+       ; (ze, final_tvs) <- zonkTyBndrsX      ze final_tvs+       ; lhs_ty          <- zonkTcTypeToTypeX ze lhs_ty+       ; rhs_ty          <- zonkTcTypeToTypeX ze rhs_ty         ; let pats = unravelFamInstPats lhs_ty              -- Note that we do this after solveEqualities              -- so that any strange coercions inside lhs_ty              -- have been solved before we attempt to unravel it-       ; traceTc "tcTyFamInstEqnGuts }" (ppr fam_tc <+> pprTyVars qtvs)-       ; return (qtvs, pats, rhs_ty) } +       ; traceTc "tcTyFamInstEqnGuts }" (vcat [ ppr fam_tc, pprTyVars final_tvs ])+                 -- Don't try to print 'pats' here, because lhs_ty involves+                 -- a knot-tied type constructor, so we get a black hole -checkFamTelescope :: TcLevel -> HsOuterFamEqnTyVarBndrs GhcRn+       ; return (final_tvs, pats, rhs_ty) }++checkFamTelescope :: TcLevel+                  -> HsOuterFamEqnTyVarBndrs GhcRn                   -> [TcTyVar] -> TcM () -- Emit a constraint (forall a b c. <empty>), so that -- we will do telescope-checking on a,b,c@@ -3157,9 +3193,9 @@   | HsOuterExplicit { hso_bndrs = bndrs } <- hs_outer_bndrs   , (b_first : _) <- bndrs   , let b_last    = last bndrs-        skol_info = ForAllSkol (fsep (map ppr bndrs))-  = setSrcSpan (combineSrcSpans (getLocA b_first) (getLocA b_last)) $-    emitResidualTvConstraint skol_info outer_tvs tclvl emptyWC+  = do { skol_info <- mkSkolemInfo (ForAllSkol $ HsTyVarBndrsRn (map unLoc bndrs))+       ; setSrcSpan (combineSrcSpans (getLocA b_first) (getLocA b_last)) $ do+         emitResidualTvConstraint skol_info outer_tvs tclvl emptyWC }   | otherwise   = return () @@ -3168,11 +3204,11 @@ -- Decompose fam_app to get the argument patterns -- -- We expect fam_app to look like (F t1 .. tn)--- tcFamTyPats is capable of returning ((F ty1 |> co) ty2),--- but that can't happen here because we already checked the--- arity of F matches the number of pattern+--   tcFamTyPats is capable of returning ((F ty1 |> co) ty2),+--   but that can't happen here because we already checked the+--   arity of F matches the number of pattern unravelFamInstPats fam_app-  = case splitTyConApp_maybe fam_app of+  = case tcSplitTyConApp_maybe fam_app of       Just (_, pats) -> pats       Nothing -> panic "unravelFamInstPats: Ill-typed LHS of family instance"         -- The Nothing case cannot happen for type families, because@@ -3188,11 +3224,6 @@ --             F c x y a :: Type -- Here the first  arg of F should be the same as the third of C --  and the fourth arg of F should be the same as the first of C------ We emit /Derived/ constraints (a bit like fundeps) to encourage--- unification to happen, but without actually reporting errors.--- If, despite the efforts, corresponding positions do not match,--- checkConsistentFamInst will complain addConsistencyConstraints mb_clsinfo fam_app   | InClsInst { ai_inst_env = inst_env } <- mb_clsinfo   , Just (fam_tc, pats) <- tcSplitTyConApp_maybe fam_app@@ -3200,8 +3231,9 @@                    | (fam_tc_tv, pat) <- tyConTyVars fam_tc `zip` pats                    , Just cls_ty <- [lookupVarEnv inst_env fam_tc_tv] ]        ; traceTc "addConsistencyConstraints" (ppr eqs)-       ; emitDerivedEqs AssocFamPatOrigin eqs }-    -- Improve inference+       ; emitWantedEqs AssocFamPatOrigin eqs }+    -- Improve inference; these equalities will not produce errors.+    -- See Note [Constraints to ignore] in GHC.Tc.Errors     -- Any mis-match is reports by checkConsistentFamInst   | otherwise   = return ()@@ -3288,7 +3320,8 @@        ; let gadt_syntax = consUseGadtSyntax cons        ; checkTc (gadtSyntax_ok || not gadt_syntax) (badGadtDecl tc_name) -           -- Check that the stupid theta is empty for a GADT-style declaration+           -- Check that the stupid theta is empty for a GADT-style declaration.+           -- See Note [The stupid context] in GHC.Core.DataCon.        ; checkTc (null stupid_theta || not gadt_syntax) (badStupidTheta tc_name)           -- Check that a newtype has exactly one constructor@@ -3328,7 +3361,7 @@ tcConDecls :: NewOrData            -> DataDeclInfo            -> KnotTied TyCon            -- Representation TyCon-           -> [TyConBinder]             -- Binders of representation TyCon+           -> [TcTyConBinder]           -- Binders of representation TyCon            -> TcKind                    -- Result kind            -> [LConDecl GhcRn] -> TcM [DataCon] tcConDecls new_or_data dd_info rep_tycon tmpl_bndrs res_kind@@ -3341,7 +3374,7 @@ tcConDecl :: NewOrData           -> DataDeclInfo           -> KnotTied TyCon   -- Representation tycon. Knot-tied!-          -> [TyConBinder]    -- Binders of representation TyCon+          -> [TcTyConBinder]  -- Binders of representation TyCon           -> TcKind           -- Result kind           -> NameEnv ConTag           -> ConDecl GhcRn@@ -3361,11 +3394,14 @@          --      hs_qvars = HsQTvs { hsq_implicit = {k}          --                        , hsq_explicit = {f,b} } -       ; traceTc "tcConDecl 1" (vcat [ ppr name, ppr explicit_tkv_nms ])+       ; traceTc "tcConDecl 1" (vcat [ ppr name+                                     , text "explicit_tkv_nms" <+> ppr explicit_tkv_nms+                                     , text "tc_bndrs" <+> ppr tc_bndrs ])+       ; skol_info <- mkSkolemInfo (ForAllSkol (HsTyVarBndrsRn (unLoc <$> explicit_tkv_nms)))         ; (tclvl, wanted, (exp_tvbndrs, (ctxt, arg_tys, field_lbls, stricts)))            <- pushLevelAndSolveEqualitiesX "tcConDecl:H98"  $-              tcExplicitTKBndrs explicit_tkv_nms            $+              tcExplicitTKBndrs skol_info explicit_tkv_nms  $               do { ctxt <- tcHsContext hs_ctxt                  ; let exp_kind = getArgExpKind new_or_data res_kind                  ; btys <- tcConH98Args exp_kind hs_args@@ -3392,10 +3428,10 @@          -- the kvs below are those kind variables entirely unmentioned by the user          --   and discovered only by generalization -       ; kvs <- kindGeneralizeAll fake_ty+       ; kvs <- kindGeneralizeAll skol_info fake_ty -       ; let skol_tvs = tc_tvs ++ kvs ++ binderVars exp_tvbndrs-       ; reportUnsolvedEqualities skol_info skol_tvs tclvl wanted+       ; let all_skol_tvs = tc_tvs ++ kvs+       ; reportUnsolvedEqualities skol_info all_skol_tvs tclvl wanted              -- The skol_info claims that all the variables are bound              -- by the data constructor decl, whereas actually the              -- univ_tvs are bound by the data type decl itself.  It@@ -3404,16 +3440,17 @@              -- See test dependent/should_fail/T13780a         -- Zonk to Types-       ; ze                  <- mkEmptyZonkEnv NoFlexi-       ; (ze, qkvs)          <- zonkTyBndrsX              ze kvs-       ; (ze, user_qtvbndrs) <- zonkTyVarBindersX         ze exp_tvbndrs-       ; arg_tys             <- zonkScaledTcTypesToTypesX ze arg_tys-       ; ctxt                <- zonkTcTypesToTypesX       ze ctxt+       ; ze                <- mkEmptyZonkEnv NoFlexi+       ; (ze, tc_bndrs)    <- zonkTyVarBindersX         ze tc_bndrs+       ; (ze, kvs)         <- zonkTyBndrsX              ze kvs+       ; (ze, exp_tvbndrs) <- zonkTyVarBindersX         ze exp_tvbndrs+       ; arg_tys           <- zonkScaledTcTypesToTypesX ze arg_tys+       ; ctxt              <- zonkTcTypesToTypesX       ze ctxt         -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here        ; traceTc "tcConDecl 2" (ppr name $$ ppr field_lbls)        ; let univ_tvbs = tyConInvisTVBinders tc_bndrs-             ex_tvbs   = mkTyVarBinders InferredSpec qkvs ++ user_qtvbndrs+             ex_tvbs   = mkTyVarBinders InferredSpec kvs ++ exp_tvbndrs              ex_tvs    = binderVars ex_tvbs                 -- For H98 datatypes, the user-written tyvar binders are precisely                 -- the universals followed by the existentials.@@ -3425,8 +3462,10 @@        ; is_infix <- tcConIsInfixH98 name hs_args        ; rep_nm   <- newTyConRepName name        ; fam_envs <- tcGetFamInstEnvs-       ; dc <- buildDataCon fam_envs name is_infix rep_nm-                            stricts Nothing field_lbls+       ; dflags   <- getDynFlags+       ; let bang_opts = SrcBangOpts (initBangOpts dflags)+       ; dc <- buildDataCon fam_envs bang_opts name is_infix rep_nm+                            stricts field_lbls                             tc_tvs ex_tvs user_tvbs                             [{- no eq_preds -}] ctxt arg_tys                             user_res_ty rep_tycon tag_map@@ -3435,8 +3474,6 @@                   --      that way checkValidDataCon can complain if it's wrong.         ; return [dc] }-  where-    skol_info = DataConSkol name  tcConDecl new_or_data dd_info rep_tycon tc_bndrs _res_kind tag_map   -- NB: don't use res_kind here, as it's ill-scoped. Instead,@@ -3448,7 +3485,7 @@   = addErrCtxt (dataConCtxt names) $     do { traceTc "tcConDecl 1 gadt" (ppr names)        ; let (L _ name : _) = names-+       ; skol_info <- mkSkolemInfo (DataConSkol name)        ; (tclvl, wanted, (outer_bndrs, (ctxt, arg_tys, res_ty, field_lbls, stricts)))            <- pushLevelAndSolveEqualitiesX "tcConDecl:GADT" $               tcOuterTKBndrs skol_info outer_hs_bndrs       $@@ -3478,12 +3515,14 @@                  ; return (ctxt, arg_tys, res_ty, field_lbls, stricts)                  } -       ; outer_tv_bndrs <- scopedSortOuter outer_bndrs+       ; outer_bndrs <- scopedSortOuter outer_bndrs+       ; let outer_tv_bndrs = outerTyVarBndrs outer_bndrs -       ; tkvs <- kindGeneralizeAll (mkInvisForAllTys outer_tv_bndrs $-                                    mkPhiTy ctxt $-                                    mkVisFunTys arg_tys $-                                    res_ty)+       ; tkvs <- kindGeneralizeAll skol_info+                    (mkInvisForAllTys outer_tv_bndrs $+                     mkPhiTy ctxt                    $+                     mkVisFunTys arg_tys             $+                     res_ty)        ; traceTc "tcConDecl:GADT" (ppr names $$ ppr res_ty $$ ppr tkvs)        ; reportUnsolvedEqualities skol_info tkvs tclvl wanted @@ -3508,14 +3547,15 @@        -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here        ; traceTc "tcConDecl 2" (ppr names $$ ppr field_lbls)        ; fam_envs <- tcGetFamInstEnvs+       ; dflags <- getDynFlags        ; let            buildOneDataCon (L _ name) = do              { is_infix <- tcConIsInfixGADT name hs_args              ; rep_nm   <- newTyConRepName name -             ; buildDataCon fam_envs name is_infix-                            rep_nm-                            stricts Nothing field_lbls+             ; let bang_opts = SrcBangOpts (initBangOpts dflags)+             ; buildDataCon fam_envs bang_opts name is_infix+                            rep_nm stricts field_lbls                             univ_tvs ex_tvs tvbndrs' eq_preds                             ctxt' arg_tys' res_ty' rep_tycon tag_map                   -- NB:  we put data_tc, the type constructor gotten from the@@ -3523,8 +3563,6 @@                   --      that way checkValidDataCon can complain if it's wrong.              }        ; mapM buildOneDataCon names }-  where-    skol_info = DataConSkol (unLoc (head names))  {- Note [GADT return types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -3611,7 +3649,7 @@ -- it is OpenKind for datatypes and liftedTypeKind. -- Why do we not check for -XUnliftedNewtypes? See point <Error Messages> -- in Note [Implementation of UnliftedNewtypes]-getArgExpKind :: NewOrData -> Kind -> ContextKind+getArgExpKind :: NewOrData -> TcKind -> ContextKind getArgExpKind NewType res_ki = TheKind res_ki getArgExpKind DataType _     = OpenKind @@ -3658,7 +3696,7 @@               -> TcM [(Scaled TcType, HsSrcBang)] tcConGADTArgs exp_kind (PrefixConGADT btys)   = mapM (tcConArg exp_kind) btys-tcConGADTArgs exp_kind (RecConGADT fields)+tcConGADTArgs exp_kind (RecConGADT fields _)   = tcRecConDeclFields exp_kind fields  tcConArg :: ContextKind  -- expected kind for args; always OpenKind for datatypes,@@ -4150,7 +4188,7 @@   to add to the context. The problem is that this also grabs data con   wrapper Ids. These could be filtered out. But, painfully, getting   the wrapper Ids checks the DataConRep, and forcing the DataConRep-  can panic if there is a levity-polymorphic argument. This is #18534.+  can panic if there is a representation-polymorphic argument. This is #18534.   We don't need the wrapper Ids here anyway. So the code just takes what   it needs, via child_tycons. -}@@ -4198,7 +4236,7 @@                ; ClosedSynFamilyTyCon Nothing   -> return ()                ; AbstractClosedSynFamilyTyCon ->                  do { hsBoot <- tcIsHsBootOrSig-                    ; checkTc hsBoot $+                    ; checkTc hsBoot $ TcRnUnknownMessage $ mkPlainError noHints $                       text "You may define an abstract closed type family" $$                       text "only in a .hs-boot file" }                ; DataFamilyTyCon {}           -> return ()@@ -4228,6 +4266,11 @@     data_cons = tyConDataCons tc      groups = equivClasses cmp_fld (concatMap get_fields data_cons)+    -- This spot seems OK with non-determinism. cmp_fld is used only in equivClasses+    -- which produces equivalence classes.+    -- The order of these equivalence classes might conceivably (non-deterministically)+    -- depend on the result of this comparison, but that just affects the order in which+    -- fields are checked for compatibility. It will not affect the compiled binary.     cmp_fld (f1,_) (f2,_) = flLabel f1 `uniqCompareFS` flLabel f2     get_fields con = dataConFieldLabels con `zip` repeat con         -- dataConFieldLabels may return the empty list, which is fine@@ -4270,10 +4313,10 @@ -- See Note [Checking partial record field] checkPartialRecordField all_cons fld   = setSrcSpan loc $-      warnIfFlag Opt_WarnPartialFields-        (not is_exhaustive && not (startsWithUnderscore occ_name))-        (sep [text "Use of partial record field selector" <> colon,-              nest 2 $ quotes (ppr occ_name)])+      warnIf (not is_exhaustive && not (startsWithUnderscore occ_name))+        (TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnPartialFields) noHints $+          sep [text "Use of partial record field selector" <> colon,+                nest 2 $ quotes (ppr occ_name)])   where     loc = getSrcSpan (flSelector fld)     occ_name = occName fld@@ -4282,7 +4325,7 @@     has_field con = fld `elem` (dataConFieldLabels con)     is_exhaustive = all (dataConCannotMatch inst_tys) cons_without_field -    con1 = ASSERT( not (null cons_with_field) ) head cons_with_field+    con1 = assert (not (null cons_with_field)) $ head cons_with_field     (univ_tvs, _, eq_spec, _, _, _) = dataConFullSig con1     eq_subst = mkTvSubstPrs (map eqSpecPair eq_spec)     inst_tys = substTyVars eq_subst univ_tvs@@ -4303,7 +4346,9 @@     addErrCtxt (dataConCtxt [L (noAnnSrcSpan con_loc) con_name]) $     do  { let tc_tvs      = tyConTyVars tc               res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs)-              orig_res_ty = dataConOrigResTy con+              arg_tys     = dataConOrigArgTys con+              orig_res_ty = dataConOrigResTy  con+         ; traceTc "checkValidDataCon" (vcat               [ ppr con, ppr tc, ppr tc_tvs               , ppr res_ty_tmpl <+> dcolon <+> ppr (tcTypeKind res_ty_tmpl)@@ -4340,16 +4385,22 @@           -- Reason: it's really the argument of an equality constraint         ; checkValidMonoType orig_res_ty -          -- If we are dealing with a newtype, we allow levity polymorphism-          -- regardless of whether or not UnliftedNewtypes is enabled. A-          -- later check in checkNewDataCon handles this, producing a-          -- better error message than checkForLevPoly would.+        -- Check for an escaping result kind+        -- See Note [Check for escaping result kind]+        ; checkEscapingKind con++        -- For /data/ types check that each argument has a fixed runtime rep+        -- If we are dealing with a /newtype/, we allow representation+        -- polymorphism regardless of whether or not UnliftedNewtypes+        -- is enabled. A later check in checkNewDataCon handles this,+        -- producing a better error message than checkTypeHasFixedRuntimeRep would.+        ; let check_rr = checkTypeHasFixedRuntimeRep FixedRuntimeRepDataConField         ; unless (isNewTyCon tc) $-            checkNoErrs $-            mapM_ (checkForLevPoly empty) (map scaledThing $ dataConOrigArgTys con)-            -- the checkNoErrs is to prevent a panic in isVanillaDataCon+          checkNoErrs            $+          mapM_ (check_rr . scaledThing) arg_tys+            -- The checkNoErrs is to prevent a panic in isVanillaDataCon             -- (called a a few lines down), which can fall over if there is a-            -- bang on a levity-polymorphic argument. This is #18534,+            -- bang on a representation-polymorphic argument. This is #18534,             -- typecheck/should_fail/T18534            -- Extra checks for newtype data constructors. Importantly, these@@ -4370,23 +4421,32 @@           -- E.g.  reject   data T = MkT {-# UNPACK #-} Int     -- No "!"           --                data T = MkT {-# UNPACK #-} !a      -- Can't unpack         ; hsc_env <- getTopEnv-        ; let check_bang :: HsSrcBang -> HsImplBang -> Int -> TcM ()-              check_bang bang rep_bang n+        ; let check_bang :: Type -> HsSrcBang -> HsImplBang -> Int -> TcM ()+              check_bang orig_arg_ty bang rep_bang n                | HsSrcBang _ _ SrcLazy <- bang-               , not (xopt LangExt.StrictData dflags)-               = addErrTc (bad_bang n (text "Lazy annotation (~) without StrictData"))+               , not (bang_opt_strict_data bang_opts)+               = addErrTc $ TcRnUnknownMessage $ mkPlainError noHints $+                 (bad_bang n (text "Lazy annotation (~) without StrictData"))                 | HsSrcBang _ want_unpack strict_mark <- bang                , isSrcUnpacked want_unpack, not (is_strict strict_mark)-               = addWarnTc NoReason (bad_bang n (text "UNPACK pragma lacks '!'"))+               , not (isUnliftedType orig_arg_ty)+               = addDiagnosticTc $ TcRnUnknownMessage $+                   mkPlainDiagnostic WarningWithoutFlag noHints (bad_bang n (text "UNPACK pragma lacks '!'")) +               -- Warn about a redundant ! on an unlifted type+               -- e.g.   data T = MkT !Int#+               | HsSrcBang _ _ SrcStrict <- bang+               , isUnliftedType orig_arg_ty+               = addDiagnosticTc $ TcRnBangOnUnliftedType orig_arg_ty+                | HsSrcBang _ want_unpack _ <- bang                , isSrcUnpacked want_unpack                , case rep_bang of { HsUnpack {} -> False; _ -> True }                -- If not optimising, we don't unpack (rep_bang is never                -- HsUnpack), so don't complain!  This happens, e.g., in Haddock.                -- See dataConSrcToImplBang.-               , not (gopt Opt_OmitInterfacePragmas dflags)+               , not (bang_opt_unbox_disable bang_opts)                -- When typechecking an indefinite package in Backpack, we                -- may attempt to UNPACK an abstract type.  The test here will                -- conclude that this is unusable, but it might become usable@@ -4394,12 +4454,14 @@                -- warn in this case (it gives users the wrong idea about whether                -- or not UNPACK on abstract types is supported; it is!)                , isHomeUnitDefinite (hsc_home_unit hsc_env)-               = addWarnTc NoReason (bad_bang n (text "Ignoring unusable UNPACK pragma"))+               = addDiagnosticTc $ TcRnUnknownMessage $+                   mkPlainDiagnostic WarningWithoutFlag noHints (bad_bang n (text "Ignoring unusable UNPACK pragma"))                 | otherwise                = return () -        ; zipWith3M_ check_bang (dataConSrcBangs con) (dataConImplBangs con) [1..]+        ; void $ zipWith4M check_bang (map scaledThing $ dataConOrigArgTys con)+          (dataConSrcBangs con) (dataConImplBangs con) [1..]            -- Check the dcUserTyVarBinders invariant           -- See Note [DataCon user type variable binders] in GHC.Core.DataCon@@ -4411,12 +4473,12 @@                    user_tvbs_invariant                      =    Set.fromList (filterEqSpec eq_spec univs ++ exs)                        == Set.fromList user_tvs-             ; MASSERT2( user_tvbs_invariant-                       , vcat ([ ppr con+             ; massertPpr user_tvbs_invariant+                          $ vcat ([ ppr con                                , ppr univs                                , ppr exs                                , ppr eq_spec-                               , ppr user_tvs ])) }+                               , ppr user_tvs ]) }          ; traceTc "Done validity of data con" $           vcat [ ppr con@@ -4429,11 +4491,12 @@                    Just (f, _) -> ppr (tyConBinders f) ]     }   where-    con_name = dataConName con-    con_loc  = nameSrcSpan con_name-    ctxt = ConArgCtxt con_name+    bang_opts = initBangOpts dflags+    con_name  = dataConName con+    con_loc   = nameSrcSpan con_name+    ctxt      = ConArgCtxt con_name     is_strict = \case-      NoSrcStrict -> xopt LangExt.StrictData dflags+      NoSrcStrict -> bang_opt_strict_data bang_opts       bang        -> isSrcStrict bang      bad_bang n herald@@ -4452,18 +4515,19 @@          ; unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes         ; let allowedArgType =-                unlifted_newtypes || isLiftedType_maybe (scaledThing arg_ty1) == Just True-        ; checkTc allowedArgType $ vcat+                unlifted_newtypes || typeLevity_maybe (scaledThing arg_ty1) == Just Lifted+        ; checkTc allowedArgType $ TcRnUnknownMessage $ mkPlainError noHints $ vcat           [ text "A newtype cannot have an unlifted argument type"           , text "Perhaps you intended to use UnliftedNewtypes"           ]         ; show_linear_types <- xopt LangExt.LinearTypes <$> getDynFlags          ; let check_con what msg =-               checkTc what (msg $$ ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con))+               checkTc what $ TcRnUnknownMessage $ mkPlainError noHints $+                 (msg $$ ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con))          ; checkTc (ok_mult (scaledMult arg_ty1)) $-          text "A newtype constructor must be linear"+          TcRnUnknownMessage $ mkPlainError noHints $ text "A newtype constructor must be linear"          ; check_con (null eq_spec) $           text "A newtype constructor must have a return type of form T a1 ... an"@@ -4493,6 +4557,47 @@     ok_mult One = True     ok_mult _   = False ++-- | Reject nullary data constructors where a type variables+-- would escape through the result kind+-- See Note [Check for escaping result kind]+checkEscapingKind :: DataCon -> TcM ()+checkEscapingKind data_con+  | null eq_spec, null theta, null arg_tys+  , let tau_kind = tcTypeKind res_ty+  , Nothing <- occCheckExpand (univ_tvs ++ ex_tvs) tau_kind+    -- Ensure that none of the tvs occur in the kind of the forall+    -- /after/ expanding type synonyms.+    -- See Note [Phantom type variables in kinds] in GHC.Core.Type+  = failWithTc $ TcRnForAllEscapeError (dataConWrapperType data_con) tau_kind+  | otherwise+  = return ()+  where+    (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty)+      = dataConFullSig data_con++{- Note [Check for escaping result kind]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider:+  type T :: TYPE (BoxedRep l)+  data T = MkT+This is not OK: we get+  MkT :: forall l. T @l :: TYPE (BoxedRep l)+which is ill-kinded.++For ordinary type signatures f :: blah, we make this check as part of kind-checking+the type signature; see Note [Escaping kind in type signatures] in GHC.Tc.Gen.HsType.+But for data constructors we check the type piecemeal, and there is no very+convenient place to do it.  For example, note that it only applies for /nullary/+constructors.  If we had+  data T = MkT Int+then the type of MkT would be MkT :: forall l. Int -> T @l, which is fine.++So we make the check in checkValidDataCon.++Historical note: we used to do the check in checkValidType (#20929 discusses).+-}+ ------------------------------- checkValidClass :: Class -> TcM () checkValidClass cls@@ -4518,7 +4623,7 @@         ; unless undecidable_super_classes $           case checkClassCycles cls of              Just err -> setSrcSpan (getSrcSpan cls) $-                         addErrTc err+                         addErrTc (TcRnUnknownMessage $ mkPlainError noHints err)              Nothing  -> return ()          -- Check the class operations.@@ -4546,12 +4651,11 @@                 --      newBoard :: MonadState b m => m ()                 -- Here, MonadState has a fundep m->b, so newBoard is fine -           -- a method cannot be levity polymorphic, as we have to store the-           -- method in a dictionary-           -- example of what this prevents:-           --   class BoundedX (a :: TYPE r) where minBound :: a-           -- See Note [Levity polymorphism checking] in GHC.HsToCore.Monad-        ; checkForLevPoly empty tau1+        -- NB: we don't check that the class method is not representation-polymorphic here,+        -- as GHC.TcGen.TyCl.tcClassSigType already includes a subtype check that guarantees+        -- typeclass methods always have kind 'Type'.+        --+        -- Test case: rep-poly/RepPolyClassMethod.          ; unless constrained_class_methods $           mapM_ check_constraint (tail (cls_pred:op_theta))@@ -4559,7 +4663,7 @@         ; check_dm ctxt sel_id cls_pred tau2 dm         }         where-          ctxt    = FunSigCtxt op_name True -- Report redundant class constraints+          ctxt    = FunSigCtxt op_name (WantRRC (getSrcSpan cls)) -- Report redundant class constraints           op_name = idName sel_id           op_ty   = idType sel_id           (_,cls_pred,tau1) = tcSplitMethodTy op_ty@@ -4575,7 +4679,8 @@               pred_tvs = tyCoVarsOfType pred      check_at (ATI fam_tc m_dflt_rhs)-      = do { checkTc (cls_arity == 0 || any (`elemVarSet` cls_tv_set) fam_tvs)+      = do { traceTc "ati" (ppr fam_tc $$ ppr tyvars $$ ppr fam_tvs)+           ; checkTc (cls_arity == 0 || any (`elemVarSet` cls_tv_set) fam_tvs)                      (noClassTyVarErr cls fam_tc)                         -- Check that the associated type mentions at least                         -- one of the class type variables@@ -4661,6 +4766,7 @@           --    default foo2 :: a -> b           unless (isJust $ tcMatchTys [dm_phi_ty, vanilla_phi_ty]                                       [vanilla_phi_ty, dm_phi_ty]) $ addErrTc $+               TcRnUnknownMessage $ mkPlainError noHints $                hang (text "The default type signature for"                      <+> ppr sel_id <> colon)                  2 (ppr dm_ty)@@ -4679,13 +4785,15 @@   = do { idx_tys <- xoptM LangExt.TypeFamilies        ; checkTc idx_tys err_msg }   where-    err_msg = hang (text "Illegal family declaration for" <+> quotes (ppr tc_name))-                 2 (text "Enable TypeFamilies to allow indexed type families")+    err_msg :: TcRnMessage+    err_msg = TcRnUnknownMessage $ mkPlainError noHints $+      hang (text "Illegal family declaration for" <+> quotes (ppr tc_name))+         2 (text "Enable TypeFamilies to allow indexed type families")  checkResultSigFlag :: Name -> FamilyResultSig GhcRn -> TcM () checkResultSigFlag tc_name (TyVarSig _ tvb)   = do { ty_fam_deps <- xoptM LangExt.TypeFamilyDependencies-       ; checkTc ty_fam_deps $+       ; checkTc ty_fam_deps $ TcRnUnknownMessage $ mkPlainError noHints $          hang (text "Illegal result type variable" <+> ppr tvb <+> text "for" <+> quotes (ppr tc_name))             2 (text "Enable TypeFamilyDependencies to allow result variable names") } checkResultSigFlag _ _ = return ()  -- other cases OK@@ -4920,7 +5028,7 @@     check_no_roles       = whenIsJust role_annot_decl_maybe illegalRoleAnnotDecl -checkRoleAnnot :: TyVar -> Located (Maybe Role) -> Role -> TcM ()+checkRoleAnnot :: TyVar -> LocatedAn NoEpAnns (Maybe Role) -> Role -> TcM () checkRoleAnnot _  (L _ Nothing)   _  = return () checkRoleAnnot tv (L _ (Just r1)) r2   = when (r1 /= r2) $@@ -5003,9 +5111,10 @@         check_ty_roles env role ty      report_error doc-      = addErrTc $ vcat [text "Internal error in role inference:",-                         doc,-                         text "Please report this as a GHC bug:  https://www.haskell.org/ghc/reportabug"]+      = addErrTc $ TcRnUnknownMessage $ mkPlainError noHints $+         vcat [text "Internal error in role inference:",+               doc,+               text "Please report this as a GHC bug:  https://www.haskell.org/ghc/reportabug"]  {- ************************************************************************@@ -5023,8 +5132,8 @@ -- See Note [Inferring visible dependent quantification] -- Only types without a signature (CUSK or SAK) here addVDQNote tycon thing_inside-  | ASSERT2( isTcTyCon tycon, ppr tycon )-    ASSERT2( not (tcTyConIsPoly tycon), ppr tycon $$ ppr tc_kind )+  | assertPpr (isTcTyCon tycon) (ppr tycon) $+    assertPpr (not (tcTyConIsPoly tycon)) (ppr tycon $$ ppr tc_kind)     has_vdq   = addLandmarkErrCtxt vdq_warning thing_inside   | otherwise@@ -5084,15 +5193,17 @@     ctxt = text "In the equations for closed type family" <+>            quotes (ppr tc) -resultTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc+resultTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> TcRnMessage resultTypeMisMatch field_name con1 con2-  = vcat [sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2,+  = TcRnUnknownMessage $ mkPlainError noHints $+    vcat [sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2,                 text "have a common field" <+> quotes (ppr field_name) <> comma],           nest 2 $ text "but have different result types"] -fieldTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc+fieldTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> TcRnMessage fieldTypeMisMatch field_name con1 con2-  = sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2,+  = TcRnUnknownMessage $ mkPlainError noHints $+    sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2,          text "give different types for field", quotes (ppr field_name)]  dataConCtxt :: [LocatedN Name] -> SDoc@@ -5111,88 +5222,101 @@ classOpCtxt sel_id tau = sep [text "When checking the class method:",                               nest 2 (pprPrefixOcc sel_id <+> dcolon <+> ppr tau)] -classArityErr :: Int -> Class -> SDoc+classArityErr :: Int -> Class -> TcRnMessage classArityErr n cls     | n == 0 = mkErr "No" "no-parameter"     | otherwise = mkErr "Too many" "multi-parameter"   where-    mkErr howMany allowWhat =+    mkErr howMany allowWhat = TcRnUnknownMessage $ mkPlainError noHints $         vcat [text (howMany ++ " parameters for class") <+> quotes (ppr cls),               parens (text ("Enable MultiParamTypeClasses to allow "                                     ++ allowWhat ++ " classes"))] -classFunDepsErr :: Class -> SDoc+classFunDepsErr :: Class -> TcRnMessage classFunDepsErr cls-  = vcat [text "Fundeps in class" <+> quotes (ppr cls),+  = TcRnUnknownMessage $ mkPlainError noHints $+    vcat [text "Fundeps in class" <+> quotes (ppr cls),           parens (text "Enable FunctionalDependencies to allow fundeps")] -badMethPred :: Id -> TcPredType -> SDoc+badMethPred :: Id -> TcPredType -> TcRnMessage badMethPred sel_id pred-  = vcat [ hang (text "Constraint" <+> quotes (ppr pred)+  = TcRnUnknownMessage $ mkPlainError noHints $+    vcat [ hang (text "Constraint" <+> quotes (ppr pred)                  <+> text "in the type of" <+> quotes (ppr sel_id))               2 (text "constrains only the class type variables")          , text "Enable ConstrainedClassMethods to allow it" ] -noClassTyVarErr :: Class -> TyCon -> SDoc+noClassTyVarErr :: Class -> TyCon -> TcRnMessage noClassTyVarErr clas fam_tc-  = sep [ text "The associated type" <+> quotes (ppr fam_tc <+> hsep (map ppr (tyConTyVars fam_tc)))+  = TcRnUnknownMessage $ mkPlainError noHints $+    sep [ text "The associated type" <+> quotes (ppr fam_tc <+> hsep (map ppr (tyConTyVars fam_tc)))         , text "mentions none of the type or kind variables of the class" <+>                 quotes (ppr clas <+> hsep (map ppr (classTyVars clas)))] -badDataConTyCon :: DataCon -> Type -> SDoc+badDataConTyCon :: DataCon -> Type -> TcRnMessage badDataConTyCon data_con res_ty_tmpl-  = hang (text "Data constructor" <+> quotes (ppr data_con) <+>+  = TcRnUnknownMessage $ mkPlainError noHints $+    hang (text "Data constructor" <+> quotes (ppr data_con) <+>                 text "returns type" <+> quotes (ppr actual_res_ty))        2 (text "instead of an instance of its parent type" <+> quotes (ppr res_ty_tmpl))   where     actual_res_ty = dataConOrigResTy data_con -badGadtDecl :: Name -> SDoc+badGadtDecl :: Name -> TcRnMessage badGadtDecl tc_name-  = vcat [ text "Illegal generalised algebraic data declaration for" <+> quotes (ppr tc_name)+  = TcRnUnknownMessage $ mkPlainError noHints $+    vcat [ text "Illegal generalised algebraic data declaration for" <+> quotes (ppr tc_name)          , nest 2 (parens $ text "Enable the GADTs extension to allow this") ] -badExistential :: DataCon -> SDoc+badExistential :: DataCon -> TcRnMessage badExistential con-  = sdocOption sdocLinearTypes (\show_linear_types ->+  = TcRnUnknownMessage $ mkPlainError noHints $+    sdocOption sdocLinearTypes (\show_linear_types ->       hang (text "Data constructor" <+> quotes (ppr con) <+>                   text "has existential type variables, a context, or a specialised result type")          2 (vcat [ ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con)                  , parens $ text "Enable ExistentialQuantification or GADTs to allow this" ])) -badStupidTheta :: Name -> SDoc+badStupidTheta :: Name -> TcRnMessage badStupidTheta tc_name-  = text "A data type declared in GADT style cannot have a context:" <+> quotes (ppr tc_name)+  = TcRnUnknownMessage $ mkPlainError noHints $+  text "A data type declared in GADT style cannot have a context:" <+> quotes (ppr tc_name) -newtypeConError :: Name -> Int -> SDoc+newtypeConError :: Name -> Int -> TcRnMessage newtypeConError tycon n-  = sep [text "A newtype must have exactly one constructor,",+  = TcRnUnknownMessage $ mkPlainError noHints $+    sep [text "A newtype must have exactly one constructor,",          nest 2 $ text "but" <+> quotes (ppr tycon) <+> text "has" <+> speakN n ] -newtypeStrictError :: DataCon -> SDoc+newtypeStrictError :: DataCon -> TcRnMessage newtypeStrictError con-  = sep [text "A newtype constructor cannot have a strictness annotation,",+  = TcRnUnknownMessage $ mkPlainError noHints $+  sep [text "A newtype constructor cannot have a strictness annotation,",          nest 2 $ text "but" <+> quotes (ppr con) <+> text "does"] -newtypeFieldErr :: DataCon -> Int -> SDoc+newtypeFieldErr :: DataCon -> Int -> TcRnMessage newtypeFieldErr con_name n_flds-  = sep [text "The constructor of a newtype must have exactly one field",+  = TcRnUnknownMessage $ mkPlainError noHints $+    sep [text "The constructor of a newtype must have exactly one field",          nest 2 $ text "but" <+> quotes (ppr con_name) <+> text "has" <+> speakN n_flds] -badSigTyDecl :: Name -> SDoc+badSigTyDecl :: Name -> TcRnMessage badSigTyDecl tc_name-  = vcat [ text "Illegal kind signature" <+>+  = TcRnUnknownMessage $ mkPlainError noHints $+    vcat [ text "Illegal kind signature" <+>            quotes (ppr tc_name)          , nest 2 (parens $ text "Use KindSignatures to allow kind signatures") ] -emptyConDeclsErr :: Name -> SDoc+emptyConDeclsErr :: Name -> TcRnMessage emptyConDeclsErr tycon-  = sep [quotes (ppr tycon) <+> text "has no constructors",+  = TcRnUnknownMessage $ mkPlainError noHints $+    sep [quotes (ppr tycon) <+> text "has no constructors",          nest 2 $ text "(EmptyDataDecls permits this)"] -wrongKindOfFamily :: TyCon -> SDoc+wrongKindOfFamily :: TyCon -> TcRnMessage wrongKindOfFamily family-  = text "Wrong category of family instance; declaration was for a"+  = TcRnUnknownMessage $ mkPlainError noHints $+    text "Wrong category of family instance; declaration was for a"     <+> kindOfFamily   where     kindOfFamily | isTypeFamilyTyCon family = text "type family"@@ -5202,21 +5326,24 @@ -- | Produce an error for oversaturated type family equations with too many -- required arguments. -- See Note [Oversaturated type family equations] in "GHC.Tc.Validity".-wrongNumberOfParmsErr :: Arity -> SDoc+wrongNumberOfParmsErr :: Arity -> TcRnMessage wrongNumberOfParmsErr max_args-  = text "Number of parameters must match family declaration; expected"+  = TcRnUnknownMessage $ mkPlainError noHints $+    text "Number of parameters must match family declaration; expected"     <+> ppr max_args -badRoleAnnot :: Name -> Role -> Role -> SDoc+badRoleAnnot :: Name -> Role -> Role -> TcRnMessage badRoleAnnot var annot inferred-  = hang (text "Role mismatch on variable" <+> ppr var <> colon)+  = TcRnUnknownMessage $ mkPlainError noHints $+    hang (text "Role mismatch on variable" <+> ppr var <> colon)        2 (sep [ text "Annotation says", ppr annot               , text "but role", ppr inferred               , text "is required" ]) -wrongNumberOfRoles :: [a] -> LRoleAnnotDecl GhcRn -> SDoc+wrongNumberOfRoles :: [a] -> LRoleAnnotDecl GhcRn -> TcRnMessage wrongNumberOfRoles tyvars d@(L _ (RoleAnnotDecl _ _ annots))-  = hang (text "Wrong number of roles listed in role annotation;" $$+  = TcRnUnknownMessage $ mkPlainError noHints $+    hang (text "Wrong number of roles listed in role annotation;" $$           text "Expected" <+> (ppr $ length tyvars) <> comma <+>           text "got" <+> (ppr $ length annots) <> colon)        2 (ppr d)@@ -5226,22 +5353,26 @@ illegalRoleAnnotDecl (L loc (RoleAnnotDecl _ tycon _))   = setErrCtxt [] $     setSrcSpanA loc $-    addErrTc (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$-              text "they are allowed only for datatypes and classes.")+    addErrTc $ TcRnUnknownMessage $ mkPlainError noHints $+      (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$+       text "they are allowed only for datatypes and classes.") -needXRoleAnnotations :: TyCon -> SDoc+needXRoleAnnotations :: TyCon -> TcRnMessage needXRoleAnnotations tc-  = text "Illegal role annotation for" <+> ppr tc <> char ';' $$+  = TcRnUnknownMessage $ mkPlainError noHints $+    text "Illegal role annotation for" <+> ppr tc <> char ';' $$     text "did you intend to use RoleAnnotations?" -incoherentRoles :: SDoc-incoherentRoles = (text "Roles other than" <+> quotes (text "nominal") <+>-                   text "for class parameters can lead to incoherence.") $$-                  (text "Use IncoherentInstances to allow this; bad role found")+incoherentRoles :: TcRnMessage+incoherentRoles = TcRnUnknownMessage $ mkPlainError noHints $+  (text "Roles other than" <+> quotes (text "nominal") <+>+   text "for class parameters can lead to incoherence.") $$+  (text "Use IncoherentInstances to allow this; bad role found") -wrongTyFamName :: Name -> Name -> SDoc+wrongTyFamName :: Name -> Name -> TcRnMessage wrongTyFamName fam_tc_name eqn_tc_name-  = hang (text "Mismatched type name in type family instance.")+  = TcRnUnknownMessage $ mkPlainError noHints $+    hang (text "Mismatched type name in type family instance.")        2 (vcat [ text "Expected:" <+> ppr fam_tc_name                , text "  Actual:" <+> ppr eqn_tc_name ])
compiler/GHC/Tc/TyCl/Build.hs view
@@ -3,8 +3,8 @@ (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} -{-# LANGUAGE CPP #-} + {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  module GHC.Tc.TyCl.Build (@@ -15,8 +15,6 @@         newImplicitBinder, newTyConRepName     ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Iface.Env@@ -38,7 +36,6 @@ import GHC.Core.Multiplicity  import GHC.Types.SrcLoc( SrcSpan, noSrcSpan )-import GHC.Driver.Session import GHC.Tc.Utils.Monad import GHC.Types.Unique.Supply import GHC.Utils.Misc@@ -54,11 +51,11 @@   = do  { co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc         ; let nt_ax = mkNewTypeCoAxiom co_tycon_name tycon etad_tvs etad_roles etad_rhs         ; traceIf (text "mkNewTyConRhs" <+> ppr nt_ax)-        ; return (NewTyCon { data_con    = con,-                             nt_rhs      = rhs_ty,-                             nt_etad_rhs = (etad_tvs, etad_rhs),-                             nt_co       = nt_ax,-                             nt_lev_poly = isKindLevPoly res_kind } ) }+        ; return (NewTyCon { data_con     = con,+                             nt_rhs       = rhs_ty,+                             nt_etad_rhs  = (etad_tvs, etad_rhs),+                             nt_co        = nt_ax,+                             nt_fixed_rep = isFixedRuntimeRepKind res_kind } ) }                              -- Coreview looks through newtypes with a Nothing                              -- for nt_co, or uses explicit coercions otherwise   where@@ -79,6 +76,8 @@         -- has a single argument (Foo a) that is a *type class*, so         -- dataConInstOrigArgTys returns []. +    -- Eta-reduce the newtype+    -- See Note [Newtype eta] in GHC.Core.TyCon     etad_tvs   :: [TyVar]  -- Matched lazily, so that mkNewTypeCo can     etad_roles :: [Role]   -- return a TyCon without pulling on rhs_ty     etad_rhs   :: Type     -- See Note [Tricky iface loop] in GHC.Iface.Load@@ -89,21 +88,59 @@                -> Type          -- Rhs type                -> ([TyVar], [Role], Type)  -- Eta-reduced version                                            -- (tyvars in normal order)-    eta_reduce (a:as) (_:rs) ty | Just (fun, arg) <- splitAppTy_maybe ty,-                                  Just tv <- getTyVar_maybe arg,-                                  tv == a,-                                  not (a `elemVarSet` tyCoVarsOfType fun)-                                = eta_reduce as rs fun-    eta_reduce tvs rs ty = (reverse tvs, reverse rs, ty)+    eta_reduce (a:as) (_:rs) ty+      | Just (fun, arg) <- splitAppTy_maybe ty+      , Just tv <- getTyVar_maybe arg+      , tv == a+      , not (a `elemVarSet` tyCoVarsOfType fun)+      , typeKind fun `eqType` typeKind (mkTyConApp tycon (mkTyVarTys $ reverse as))+        -- Why this kind-check?  See Note [Newtype eta and homogeneous axioms]+      = eta_reduce as rs fun+    eta_reduce as rs ty = (reverse as, reverse rs, ty) +{- Note [Newtype eta and homogeneous axioms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When eta-reducing a newtype, we must be careful to make sure the axiom+is homogeneous.  (That is, the two types related by the axiom must+have the same kind.)  All known proofs of type safety for Core rely on+the homogeneity of axioms, so let's not monkey with that.++It is easy to mistakenly make an inhomogeneous axiom (#19739):+  type T :: forall (a :: Type) -> Type+  newtype T a = MkT (Proxy a)++Can we eta-reduce, thus?+  axT :: T ~ Proxy++No!  Because+   T     :: forall a -> Type+   Proxy :: Type     -> Type++This is inhomogeneous. Hence, we have an extra kind-check in eta_reduce,+to make sure the reducts have the same kind. This is simple, although+perhaps quadratic in complexity, if we eta-reduce many arguments (which+seems vanishingly unlikely in practice).  But NB that the free-variable+check, which immediately precedes the kind check, is also potentially+quadratic.++There are other ways we could do the check (discussion on #19739):++* We could look at the sequence of binders on the newtype and on the+  head of the representation type, and make sure the visibilities on+  the binders match up. This is quite a bit more code, and the reasoning+  is subtler.++* We could, say, do the kind-check at the end and then backtrack until the+  kinds match up. Hard to know whether that's more performant or not.+-}+ ------------------------------------------------------ buildDataCon :: FamInstEnvs+            -> DataConBangOpts             -> Name             -> Bool                     -- Declared infix             -> TyConRepName             -> [HsSrcBang]-            -> Maybe [HsImplBang]-                -- See Note [Bangs on imported data constructors] in GHC.Types.Id.Make            -> [FieldLabel]             -- Field labels            -> [TyVar]                  -- Universals            -> [TyCoVar]                -- Existentials@@ -121,7 +158,7 @@ --   a) makes the worker Id --   b) makes the wrapper Id if necessary, including --      allocating its unique (hence monadic)-buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs+buildDataCon fam_envs dc_bang_opts src_name declared_infix prom_info src_bangs              field_lbls univ_tvs ex_tvs user_tvbs eq_spec ctxt arg_tys res_ty              rep_tycon tag_map   = do  { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc@@ -132,7 +169,6 @@          ; traceIf (text "buildDataCon 1" <+> ppr src_name)         ; us <- newUniqueSupply-        ; dflags <- getDynFlags         ; let stupid_ctxt = mkDataConStupidTheta rep_tycon (map scaledThing arg_tys) univ_tvs               tag = lookupNameEnv_NF tag_map src_name               -- See Note [Constructor tag allocation], fixes #14657@@ -142,8 +178,7 @@                                    arg_tys res_ty NoRRI rep_tycon tag                                    stupid_ctxt dc_wrk dc_rep               dc_wrk = mkDataConWorkId work_name data_con-              dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name-                                                impl_bangs data_con)+              dc_rep = initUs_ us (mkDataConRep dc_bang_opts fam_envs wrap_name data_con)          ; traceIf (text "buildDataCon 2" <+> ppr src_name)         ; return data_con }@@ -153,6 +188,8 @@ -- the type variables mentioned in the arg_tys -- ToDo: Or functionally dependent on? --       This whole stupid theta thing is, well, stupid.+--+-- See Note [The stupid context] in GHC.Core.DataCon. mkDataConStupidTheta :: TyCon -> [Type] -> [TyVar] -> [PredType] mkDataConStupidTheta tycon arg_tys univ_tvs   | null stupid_theta = []      -- The common case@@ -173,7 +210,7 @@             -> PatSynMatcher -> PatSynBuilder             -> ([InvisTVBinder], ThetaType) -- ^ Univ and req             -> ([InvisTVBinder], ThetaType) -- ^ Ex and prov-            -> [Type]                       -- ^ Argument types+            -> [FRRType]                    -- ^ Argument types             -> Type                         -- ^ Result type             -> [FieldLabel]                 -- ^ Field labels for                                             --   a record pattern synonym@@ -183,19 +220,19 @@             pat_ty field_labels   = -- The assertion checks that the matcher is     -- compatible with the pattern synonym-    ASSERT2((and [ univ_tvs `equalLength` univ_tvs1-                 , ex_tvs `equalLength` ex_tvs1-                 , pat_ty `eqType` substTy subst (scaledThing pat_ty1)-                 , prov_theta `eqTypes` substTys subst prov_theta1-                 , req_theta `eqTypes` substTys subst req_theta1-                 , compareArgTys arg_tys (substTys subst (map scaledThing arg_tys1))-                 ])-            , (vcat [ ppr univ_tvs <+> twiddle <+> ppr univ_tvs1+    assertPpr (and [ univ_tvs `equalLength` univ_tvs1+                   , ex_tvs `equalLength` ex_tvs1+                   , pat_ty `eqType` substTy subst (scaledThing pat_ty1)+                   , prov_theta `eqTypes` substTys subst prov_theta1+                   , req_theta `eqTypes` substTys subst req_theta1+                   , compareArgTys arg_tys (substTys subst (map scaledThing arg_tys1))+                   ])+              (vcat [ ppr univ_tvs <+> twiddle <+> ppr univ_tvs1                     , ppr ex_tvs <+> twiddle <+> ppr ex_tvs1                     , ppr pat_ty <+> twiddle <+> ppr pat_ty1                     , ppr prov_theta <+> twiddle <+> ppr prov_theta1                     , ppr req_theta <+> twiddle <+> ppr req_theta1-                    , ppr arg_tys <+> twiddle <+> ppr arg_tys1]))+                    , ppr arg_tys <+> twiddle <+> ppr arg_tys1]) $     mkPatSyn src_name declared_infix              (univ_tvs, req_theta) (ex_tvs, prov_theta)              arg_tys pat_ty@@ -253,7 +290,8 @@         ; tc_rep_name  <- newTyConRepName tycon_name         ; let univ_tvs = binderVars binders               tycon = mkClassTyCon tycon_name binders roles-                                   AbstractTyCon rec_clas tc_rep_name+                                   AbstractTyCon+                                   rec_clas tc_rep_name               result = mkAbstractClass tycon_name univ_tvs fds tycon         ; traceIf (text "buildClass" <+> ppr tycon)         ; return result }@@ -288,7 +326,7 @@                 --       i.e. exactly one operation or superclass taken together                 --   (b) that value is of lifted type (which they always are, because                 --       we box equality superclasses)-                -- See note [Class newtypes and equality predicates]+                -- See Note [Class newtypes and equality predicates]                  -- We treat the dictionary superclasses as ordinary arguments.                 -- That means that in the case of@@ -301,14 +339,15 @@               rec_tycon  = classTyCon rec_clas               univ_bndrs = tyConInvisTVBinders binders               univ_tvs   = binderVars univ_bndrs+              bang_opts  = FixedBangOpts (map (const HsLazy) args)          ; rep_nm   <- newTyConRepName datacon_name         ; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs")+                                   bang_opts                                    datacon_name                                    False        -- Not declared infix                                    rep_nm                                    (map (const no_bang) args)-                                   (Just (map (const HsLazy) args))                                    [{- No fields -}]                                    univ_tvs                                    [{- no existentials -}]
compiler/GHC/Tc/TyCl/Class.hs view
@@ -4,7 +4,7 @@  -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE TypeFamilies #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}@@ -26,11 +26,10 @@    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Hs+import GHC.Tc.Errors.Types import GHC.Tc.Gen.Sig import GHC.Tc.Types.Evidence ( idHsWrapper ) import GHC.Tc.Gen.Bind@@ -51,6 +50,7 @@ import GHC.Driver.Session import GHC.Tc.Instance.Family import GHC.Core.FamInstEnv+import GHC.Types.Error import GHC.Types.Id import GHC.Types.Name import GHC.Types.Name.Env@@ -60,14 +60,13 @@ import GHC.Types.SourceFile (HscSource(..)) import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Types.SrcLoc import GHC.Core.TyCon import GHC.Data.Maybe import GHC.Types.Basic import GHC.Data.Bag-import GHC.Data.FastString import GHC.Data.BooleanFormula-import GHC.Utils.Misc  import Control.Monad import Data.List ( mapAccumL, partition )@@ -113,8 +112,8 @@ ************************************************************************ -} -illegalHsigDefaultMethod :: Name -> SDoc-illegalHsigDefaultMethod n =+illegalHsigDefaultMethod :: Name -> TcRnMessage+illegalHsigDefaultMethod n = TcRnUnknownMessage $ mkPlainError noHints $     text "Illegal default method(s) in class definition of" <+> ppr n <+> text "in hsig file"  tcClassSigs :: Name                -- Name of the class@@ -205,11 +204,16 @@         --      dm1 = \d -> case ds d of (a,b,c) -> a         -- And since ds is big, it doesn't get inlined, so we don't get good         -- default methods.  Better to make separate AbsBinds for each++        ; skol_info <- mkSkolemInfo (TyConSkol ClassFlavour (getName class_name))+        ; tc_lvl    <- getTcLevel         ; let (tyvars, _, _, op_items) = classBigSig clas-              prag_fn     = mkPragEnv sigs default_binds-              sig_fn      = mkHsSigFun sigs-              clas_tyvars = snd (tcSuperSkolTyVars tyvars)-              pred        = mkClassPred clas (mkTyVarTys clas_tyvars)+              prag_fn = mkPragEnv sigs default_binds+              sig_fn  = mkHsSigFun sigs+              (_skol_subst, clas_tyvars) = tcSuperSkolTyVars tc_lvl skol_info tyvars+                    -- This make skolemTcTyVars, but does not clone,+                    -- so we can put them in scope with tcExtendTyVarEnv+              pred = mkClassPred clas (mkTyVarTys clas_tyvars)         ; this_dict <- newEvVar pred          ; let tc_item = tcDefMeth clas clas_tyvars this_dict@@ -258,10 +262,10 @@         ; spec_prags <- discardConstraints $                        tcSpecPrags global_dm_id prags-       ; warnTc NoReason-                (not (null spec_prags))-                (text "Ignoring SPECIALISE pragmas on default method"-                 <+> quotes (ppr sel_name))+       ; let dia = TcRnUnknownMessage $+               mkPlainDiagnostic WarningWithoutFlag noHints $+                (text "Ignoring SPECIALISE pragmas on default method" <+> quotes (ppr sel_name))+       ; diagnosticTc (not (null spec_prags)) dia         ; let hs_ty = hs_sig_fn sel_name                      `orElse` pprPanic "tc_dm" (ppr sel_name)@@ -282,8 +286,8 @@                              -- NB: the binding is always a FunBind               warn_redundant = case dm_spec of-                                GenericDM {} -> True-                                VanillaDM    -> False+                                GenericDM {} -> lhsSigTypeContextSpan hs_ty+                                VanillaDM    -> NoRRC                 -- For GenericDM, warn if the user specifies a signature                 -- with redundant constraints; but not for VanillaDM, where                 -- the default method may well be 'error' or something@@ -300,13 +304,12 @@                   tcPolyCheck no_prag_fn local_dm_sig                               (L bind_loc lm_bind) -       ; let export = ABE { abe_ext   = noExtField-                          , abe_poly  = global_dm_id+       ; let export = ABE { abe_poly  = global_dm_id                           , abe_mono  = local_dm_id                           , abe_wrap  = idHsWrapper                           , abe_prags = IsDefaultMethod }-             full_bind = AbsBinds { abs_ext      = noExtField-                                  , abs_tvs      = tyvars+             full_bind = XHsBindsLR $+                         AbsBinds { abs_tvs      = tyvars                                   , abs_ev_vars  = [this_dict]                                   , abs_exports  = [export]                                   , abs_ev_binds = [ev_binds]@@ -337,7 +340,7 @@         -- since you can't write a default implementation.         when (tcg_src tcg_env /= HsigFile) $             whenIsJust (isUnsatisfied (mindef `impliesAtom`) defMindef) $-                       (\bf -> addWarnTc NoReason (warningMinimalDefIncomplete bf))+                       (\bf -> addDiagnosticTc (warningMinimalDefIncomplete bf))         return mindef   where     -- By default require all methods without a default implementation@@ -352,7 +355,7 @@ -- Return the "local method type": --      forall c. Ix x => (ty2,c) -> ty1 instantiateMethod clas sel_id inst_tys-  = ASSERT( ok_first_pred ) local_meth_ty+  = assert ok_first_pred local_meth_ty   where     rho_ty = piResultTys (idType sel_id) inst_tys     (first_pred, local_meth_ty) = tcSplitPredFunTy_maybe rho_ty@@ -438,14 +441,16 @@ ************************************************************************ -} -badMethodErr :: Outputable a => a -> Name -> SDoc+badMethodErr :: Outputable a => a -> Name -> TcRnMessage badMethodErr clas op-  = hsep [text "Class", quotes (ppr clas),+  = TcRnUnknownMessage $ mkPlainError noHints $+    hsep [text "Class", quotes (ppr clas),           text "does not have a method", quotes (ppr op)] -badGenericMethod :: Outputable a => a -> Name -> SDoc+badGenericMethod :: Outputable a => a -> Name -> TcRnMessage badGenericMethod clas op-  = hsep [text "Class", quotes (ppr clas),+  = TcRnUnknownMessage $ mkPlainError noHints $+    hsep [text "Class", quotes (ppr clas),           text "has a generic-default signature without a binding", quotes (ppr op)]  {-@@ -469,13 +474,15 @@ -} badDmPrag :: TcId -> Sig GhcRn -> TcM () badDmPrag sel_id prag-  = addErrTc (text "The" <+> hsSigDoc prag <+> ptext (sLit "for default method")+  = addErrTc (TcRnUnknownMessage $ mkPlainError noHints $+    text "The" <+> hsSigDoc prag <+> text "for default method"               <+> quotes (ppr sel_id)               <+> text "lacks an accompanying binding") -warningMinimalDefIncomplete :: ClassMinimalDef -> SDoc+warningMinimalDefIncomplete :: ClassMinimalDef -> TcRnMessage warningMinimalDefIncomplete mindef-  = vcat [ text "The MINIMAL pragma does not require:"+  = TcRnUnknownMessage $ mkPlainDiagnostic WarningWithoutFlag noHints $+  vcat [ text "The MINIMAL pragma does not require:"          , nest 2 (pprBooleanFormulaNice mindef)          , text "but there is no default implementation." ] @@ -556,7 +563,10 @@        -- hs-boot and signatures never need to provide complete "definitions"        -- of any sort, as they aren't really defining anything, but just        -- constraining items which are defined elsewhere.-       ; warnTc (Reason Opt_WarnMissingMethods) (warn && hsc_src == HsSrcFile)-                (text "No explicit" <+> text "associated type"-                    <+> text "or default declaration for"-                    <+> quotes (ppr name)) }+       ; let dia = TcRnUnknownMessage $+               mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingMethods) noHints $+                 (text "No explicit" <+> text "associated type"+                                     <+> text "or default declaration for"+                                     <+> quotes (ppr name))+       ; diagnosticTc  (warn && hsc_src == HsSrcFile) dia+                       }
compiler/GHC/Tc/TyCl/Instance.hs view
@@ -4,7 +4,7 @@  -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} @@ -19,11 +19,10 @@    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Hs+import GHC.Tc.Errors.Types import GHC.Tc.Gen.Bind import GHC.Tc.TyCl import GHC.Tc.TyCl.Utils ( addTyConsToGblEnv )@@ -62,6 +61,7 @@ import GHC.Core.DataCon import GHC.Core.ConLike import GHC.Core.Class+import GHC.Types.Error import GHC.Types.Var as Var import GHC.Types.Var.Env import GHC.Types.Var.Set@@ -70,7 +70,6 @@ import GHC.Types.Fixity import GHC.Driver.Session import GHC.Driver.Ppr-import GHC.Utils.Error import GHC.Utils.Logger import GHC.Data.FastString import GHC.Types.Id@@ -80,6 +79,7 @@ import GHC.Types.Name.Set import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Types.SrcLoc import GHC.Utils.Misc import GHC.Data.BooleanFormula ( isUnsatisfied, pprBooleanFormulaNice )@@ -388,7 +388,8 @@    -> TcM (TcGblEnv,            -- The full inst env            [InstInfo GhcRn],    -- Source-code instance decls to process;                                 -- contains all dfuns for this module-           [DerivInfo])         -- From data family instances+           [DerivInfo],         -- From data family instances+           ThBindEnv)           -- TH binding levels  tcInstDecls1 inst_decls   = do {    -- Do class and family instance declarations@@ -398,13 +399,14 @@              fam_insts   = concat fam_insts_s              local_infos = concat local_infos_s -       ; gbl_env <- addClsInsts local_infos $-                    addFamInsts fam_insts   $-                    getGblEnv+       ; (gbl_env, th_bndrs) <-+           addClsInsts local_infos $+           addFamInsts fam_insts         ; return ( gbl_env                 , local_infos-                , concat datafam_deriv_infos ) }+                , concat datafam_deriv_infos+                , th_bndrs ) }  -- | Use DerivInfo for data family instances (produced by tcInstDecls1), --   datatype declarations (TyClDecl), and standalone deriving declarations@@ -425,17 +427,18 @@ addClsInsts infos thing_inside   = tcExtendLocalInstEnv (map iSpec infos) thing_inside -addFamInsts :: [FamInst] -> TcM a -> TcM a+addFamInsts :: [FamInst] -> TcM (TcGblEnv, ThBindEnv) -- Extend (a) the family instance envt --        (b) the type envt with stuff from data type decls-addFamInsts fam_insts thing_inside+addFamInsts fam_insts   = tcExtendLocalFamInstEnv fam_insts $     tcExtendGlobalEnv axioms          $     do { traceTc "addFamInsts" (pprFamInsts fam_insts)-       ; gbl_env <- addTyConsToGblEnv data_rep_tycons+       ; (gbl_env, th_bndrs) <- addTyConsToGblEnv data_rep_tycons                     -- Does not add its axiom; that comes                     -- from adding the 'axioms' above-       ; setGblEnv gbl_env thing_inside }+       ; return (gbl_env, th_bndrs)+       }   where     axioms = map (ACoAxiom . toBranchedAxiom . famInstAxiom) fam_insts     data_rep_tycons = famInstsRepTyCons fam_insts@@ -489,8 +492,8 @@     do  { dfun_ty <- tcHsClsInstType (InstDeclCtxt False) hs_ty         ; let (tyvars, theta, clas, inst_tys) = tcSplitDFunTy dfun_ty              -- NB: tcHsClsInstType does checkValidInstance--        ; (subst, skol_tvs) <- tcInstSkolTyVars tyvars+        ; skol_info <- mkSkolemInfo InstSkol+        ; (subst, skol_tvs) <- tcInstSkolTyVars skol_info tyvars         ; let tv_skol_prs = [ (tyVarName tv, skol_tv)                             | (tv, skol_tv) <- tyvars `zip` skol_tvs ]               -- Map from the skolemized Names to the original Names.@@ -553,7 +556,7 @@          -- In hs-boot files there should be no bindings         ; let no_binds = isEmptyLHsBinds binds && null uprags         ; is_boot <- tcIsHsBootOrSig-        ; failIfTc (is_boot && not no_binds) badBootDeclErr+        ; failIfTc (is_boot && not no_binds) TcRnIllegalHsBootFileDecl          ; return ( [inst_info], all_insts, deriv_infos ) }   where@@ -688,8 +691,9 @@        ; gadt_syntax <- dataDeclChecks fam_name new_or_data hs_ctxt hs_cons           -- Do /not/ check that the number of patterns = tyConArity fam_tc           -- See [Arity of data families] in GHC.Core.FamInstEnv-       ; (qtvs, pats, res_kind, stupid_theta)-             <- tcDataFamInstHeader mb_clsinfo fam_tc outer_bndrs fixity+       ; skol_info <- mkSkolemInfo FamInstSkol+       ; (qtvs, pats, tc_res_kind, stupid_theta)+             <- tcDataFamInstHeader mb_clsinfo skol_info fam_tc outer_bndrs fixity                                     hs_ctxt hs_pats m_ksig new_or_data         -- Eta-reduce the axiom if possible@@ -699,7 +703,7 @@              post_eta_qtvs = filterOut (`elem` eta_tvs) qtvs               full_tcbs = mkTyConBindersPreferAnon post_eta_qtvs-                            (tyCoVarsOfType (mkSpecForAllTys eta_tvs res_kind))+                            (tyCoVarsOfType (mkSpecForAllTys eta_tvs tc_res_kind))                          ++ eta_tcbs                  -- Put the eta-removed tyvars at the end                  -- Remember, qtvs is in arbitrary order, except kind vars are@@ -715,15 +719,40 @@        --     we did it before the "extra" tvs from etaExpandAlgTyCon        --     would always be eta-reduced        ---       ; (extra_tcbs, final_res_kind) <- etaExpandAlgTyCon full_tcbs res_kind+       ; let flav = newOrDataToFlavour new_or_data+       ; (extra_tcbs, tc_res_kind) <- etaExpandAlgTyCon flav skol_info full_tcbs tc_res_kind         -- Check the result kind; it may come from a user-written signature.        -- See Note [Datatype return kinds] in GHC.Tc.TyCl point 4(a)-       ; let extra_pats  = map (mkTyVarTy . binderVar) extra_tcbs-             all_pats    = pats `chkAppend` extra_pats-             orig_res_ty = mkTyConApp fam_tc all_pats-             ty_binders  = full_tcbs `chkAppend` extra_tcbs+       ; let extra_pats    = map (mkTyVarTy . binderVar) extra_tcbs+             all_pats      = pats `chkAppend` extra_pats+             orig_res_ty   = mkTyConApp fam_tc all_pats+             tc_ty_binders = full_tcbs `chkAppend` extra_tcbs +       ; traceTc "tcDataFamInstDecl 1" $+         vcat [ text "Fam tycon:" <+> ppr fam_tc+              , text "Pats:" <+> ppr pats+              , text "visibilities:" <+> ppr (tcbVisibilities fam_tc pats)+              , text "all_pats:" <+> ppr all_pats+              , text "tc_ty_binders" <+> ppr tc_ty_binders+              , text "fam_tc_binders:" <+> ppr (tyConBinders fam_tc)+              , text "tc_res_kind:" <+> ppr tc_res_kind+              , text "eta_pats" <+> ppr eta_pats+              , text "eta_tcbs" <+> ppr eta_tcbs ]++       -- Zonk the patterns etc into the Type world+       ; ze                <- mkEmptyZonkEnv NoFlexi+       ; (ze, ty_binders)  <- zonkTyVarBindersX   ze tc_ty_binders+       ; res_kind          <- zonkTcTypeToTypeX   ze tc_res_kind+       ; all_pats          <- zonkTcTypesToTypesX ze all_pats+       ; eta_pats          <- zonkTcTypesToTypesX ze eta_pats+       ; stupid_theta      <- zonkTcTypesToTypesX ze stupid_theta+       ; let zonked_post_eta_qtvs = map (lookupTyVarX ze) post_eta_qtvs+             zonked_eta_tvs       = map (lookupTyVarX ze) eta_tvs+             -- All these qtvs are in ty_binders, and hence will be in+             -- the ZonkEnv, ze.  We need the zonked (TyVar) versions to+             -- put in the CoAxiom that we are about to build.+        ; traceTc "tcDataFamInstDecl" $          vcat [ text "Fam tycon:" <+> ppr fam_tc               , text "Pats:" <+> ppr pats@@ -732,34 +761,36 @@               , text "ty_binders" <+> ppr ty_binders               , text "fam_tc_binders:" <+> ppr (tyConBinders fam_tc)               , text "res_kind:" <+> ppr res_kind-              , text "final_res_kind:" <+> ppr final_res_kind               , text "eta_pats" <+> ppr eta_pats               , text "eta_tcbs" <+> ppr eta_tcbs ]-        ; (rep_tc, axiom) <- fixM $ \ ~(rec_rep_tc, _) ->-           do { data_cons <- tcExtendTyVarEnv qtvs $+           do { data_cons <- tcExtendTyVarEnv (binderVars tc_ty_binders) $                   -- For H98 decls, the tyvars scope                   -- over the data constructors                   tcConDecls new_or_data (DDataInstance orig_res_ty)-                             rec_rep_tc ty_binders final_res_kind+                             rec_rep_tc tc_ty_binders tc_res_kind                              hs_cons                ; rep_tc_name <- newFamInstTyConName lfam_name pats               ; axiom_name  <- newFamInstAxiomName lfam_name [pats]               ; tc_rhs <- case new_or_data of-                     DataType -> return (mkDataTyConRhs data_cons)-                     NewType  -> ASSERT( not (null data_cons) )+                     DataType -> return $+                        mkLevPolyDataTyConRhs+                          (isFixedRuntimeRepKind res_kind)+                          data_cons+                     NewType  -> assert (not (null data_cons)) $                                  mkNewTyConRhs rep_tc_name rec_rep_tc (head data_cons) -              ; let ax_rhs = mkTyConApp rep_tc (mkTyVarTys post_eta_qtvs)+              ; let ax_rhs = mkTyConApp rep_tc (mkTyVarTys zonked_post_eta_qtvs)                     axiom  = mkSingleCoAxiom Representational axiom_name-                                 post_eta_qtvs eta_tvs [] fam_tc eta_pats ax_rhs+                                 zonked_post_eta_qtvs zonked_eta_tvs+                                 [] fam_tc eta_pats ax_rhs                     parent = DataFamInstTyCon axiom fam_tc all_pats                        -- NB: Use the full ty_binders from the pats. See bullet toward                       -- the end of Note [Data type families] in GHC.Core.TyCon                     rep_tc   = mkAlgTyCon rep_tc_name-                                          ty_binders final_res_kind+                                          ty_binders res_kind                                           (map (const Nominal) ty_binders)                                           (fmap unLoc cType) stupid_theta                                           tc_rhs parent@@ -856,21 +887,23 @@  ----------------------- tcDataFamInstHeader-    :: AssocInstInfo -> TyCon -> HsOuterFamEqnTyVarBndrs GhcRn+    :: AssocInstInfo -> SkolemInfo -> TyCon -> HsOuterFamEqnTyVarBndrs GhcRn     -> LexicalFixity -> Maybe (LHsContext GhcRn)     -> HsTyPats GhcRn -> Maybe (LHsKind GhcRn)     -> NewOrData-    -> TcM ([TyVar], [Type], Kind, ThetaType)+    -> TcM ([TcTyVar], [TcType], TcKind, TcThetaType)+         -- All skolem TcTyVars, all zonked so it's clear what the free vars are+ -- The "header" of a data family instance is the part other than -- the data constructors themselves --    e.g.  data instance D [a] :: * -> * where ... -- Here the "header" is the bit before the "where"-tcDataFamInstHeader mb_clsinfo fam_tc outer_bndrs fixity+tcDataFamInstHeader mb_clsinfo skol_info fam_tc hs_outer_bndrs fixity                     hs_ctxt hs_pats m_ksig new_or_data   = do { traceTc "tcDataFamInstHeader {" (ppr fam_tc <+> ppr hs_pats)-       ; (tclvl, wanted, (scoped_tvs, (stupid_theta, lhs_ty, master_res_kind, instance_res_kind)))+       ; (tclvl, wanted, (outer_bndrs, (stupid_theta, lhs_ty, master_res_kind, instance_res_kind)))             <- pushLevelAndSolveEqualitiesX "tcDataFamInstHeader" $-               bindOuterFamEqnTKBndrs outer_bndrs                 $+               bindOuterFamEqnTKBndrs skol_info hs_outer_bndrs    $  -- Binds skolem TcTyVars                do { stupid_theta <- tcHsContext hs_ctxt                   ; (lhs_ty, lhs_kind) <- tcFamTyPats fam_tc hs_pats                   ; (lhs_applied_ty, lhs_applied_kind)@@ -891,16 +924,20 @@                   -- Check that the result kind of the TyCon applied to its args                   -- is compatible with the explicit signature (or Type, if there                   -- is none)-                  ; let hs_lhs = nlHsTyConApp fixity (getName fam_tc) hs_pats-                  ; _ <- unifyKind (Just (ppr hs_lhs)) lhs_applied_kind res_kind+                  ; let hs_lhs = nlHsTyConApp NotPromoted fixity (getName fam_tc) hs_pats+                  ; _ <- unifyKind (Just . HsTypeRnThing $ unLoc hs_lhs) lhs_applied_kind res_kind                    ; traceTc "tcDataFamInstHeader" $-                    vcat [ ppr fam_tc, ppr m_ksig, ppr lhs_applied_kind, ppr res_kind ]+                    vcat [ ppr fam_tc, ppr m_ksig, ppr lhs_applied_kind, ppr res_kind, ppr m_ksig]                   ; return ( stupid_theta                            , lhs_applied_ty                            , lhs_applied_kind                            , res_kind ) } +       ; outer_bndrs <- scopedSortOuter outer_bndrs+       ; let outer_tvs = outerTyVars outer_bndrs+       ; checkFamTelescope tclvl hs_outer_bndrs outer_tvs+        -- This code (and the stuff immediately above) is very similar        -- to that in tcTyFamInstEqnGuts.  Maybe we should abstract the        -- common code; but for the moment I concluded that it's@@ -908,34 +945,30 @@        -- check there too!         -- See GHC.Tc.TyCl Note [Generalising in tcFamTyPatsGuts]-       ; dvs  <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys scoped_tvs)-       ; qtvs <- quantifyTyVars dvs-       ; reportUnsolvedEqualities FamInstSkol qtvs tclvl wanted--       -- Zonk the patterns etc into the Type world-       ; ze           <- mkEmptyZonkEnv NoFlexi-       ; (ze, qtvs)   <- zonkTyBndrsX           ze qtvs-       ; lhs_ty       <- zonkTcTypeToTypeX      ze lhs_ty-       ; stupid_theta <- zonkTcTypesToTypesX    ze stupid_theta-       ; master_res_kind   <- zonkTcTypeToTypeX ze master_res_kind-       ; instance_res_kind <- zonkTcTypeToTypeX ze instance_res_kind+       ; dvs  <- candidateQTyVarsWithBinders outer_tvs lhs_ty+       ; qtvs <- quantifyTyVars skol_info TryNotToDefaultNonStandardTyVars dvs+       ; let final_tvs = scopedSort (qtvs ++ outer_tvs)+             -- This scopedSort is important: the qtvs may be /interleaved/ with+             -- the outer_tvs.  See Note [Generalising in tcTyFamInstEqnGuts]+       ; reportUnsolvedEqualities skol_info final_tvs tclvl wanted -       -- We check that res_kind is OK with checkDataKindSig in-       -- tcDataFamInstDecl, after eta-expansion.  We need to check that-       -- it's ok because res_kind can come from a user-written kind signature.-       -- See Note [Datatype return kinds], point (4a)+       ; final_tvs         <- zonkTcTyVarsToTcTyVars final_tvs+       ; lhs_ty            <- zonkTcType  lhs_ty+       ; master_res_kind   <- zonkTcType  master_res_kind+       ; instance_res_kind <- zonkTcType  instance_res_kind+       ; stupid_theta      <- zonkTcTypes stupid_theta +       -- Check that res_kind is OK with checkDataKindSig.  We need to+       -- check that it's ok because res_kind can come from a user-written+       -- kind signature.  See Note [Datatype return kinds], point (4a)        ; checkDataKindSig (DataInstanceSort new_or_data) master_res_kind        ; checkDataKindSig (DataInstanceSort new_or_data) instance_res_kind -       -- Check that type patterns match the class instance head-       -- The call to splitTyConApp_maybe here is just an inlining of-       -- the body of unravelFamInstPats.-       ; pats <- case splitTyConApp_maybe lhs_ty of-           Just (_, pats) -> pure pats-           Nothing -> pprPanic "tcDataFamInstHeader" (ppr lhs_ty)+       -- Split up the LHS type to get the type patterns+       -- For the scopedSort see Note [Generalising in tcTyFamInstEqnGuts]+       ; let pats      = unravelFamInstPats lhs_ty -       ; return (qtvs, pats, master_res_kind, stupid_theta) }+       ; return (final_tvs, pats, master_res_kind, stupid_theta) }   where     fam_name  = tyConName fam_tc     data_ctxt = DataKindCtxt fam_name@@ -954,11 +987,9 @@     -- See Note [Result kind signature for a data family instance]     tc_kind_sig (Just hs_kind)       = do { sig_kind <- tcLHsKindSig data_ctxt hs_kind-           ; lvl <- getTcLevel-           ; let (tvs, inner_kind) = tcSplitForAllInvisTyVars sig_kind-           ; (subst, _tvs') <- tcInstSkolTyVarsAt lvl False emptyTCvSubst tvs-             -- Perhaps surprisingly, we don't need the skolemised tvs themselves-           ; return (substTy subst inner_kind) }+           ; (_tvs', inner_kind') <- tcSkolemiseInvisibleBndrs (SigTypeSkol data_ctxt) sig_kind+                   -- Perhaps surprisingly, we don't need the skolemised tvs themselves+           ; return inner_kind' }  {- Note [Result kind signature for a data family instance] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1054,6 +1085,23 @@   themselves.  Heavy sigh.  But not truly hard; that's what tcbVisibilities   does. +* Happily, we don't need to worry about the possibility of+  building an inhomogeneous axiom, described in GHC.Tc.TyCl.Build+  Note [Newtype eta and homogeneous axioms].   For example+     type F :: Type -> forall (b :: Type) -> Type+     data family F a b+     newtype instance F Int b = MkF (Proxy b)+  we get a newtype, and a eta-reduced axiom connecting the data family+  with the newtype:+     type R:FIntb :: forall (b :: Type) -> Type+     newtype R:FIntb b = MkF (Proxy b)+     axiom Foo.D:R:FIntb0 :: F Int = Foo.R:FIntb+  Now the subtleties of Note [Newtype eta and homogeneous axioms] are+  dealt with by the newtype (via mkNewTyConRhs called in tcDataFamInstDecl)+  while the axiom connecting F Int ~ R:FIntb is eta-reduced, but the+  quantifer 'b' is derived from the original data family F, and so the+  kinds will always match.+ Note [Kind inference for data family instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this GADT-style data type declaration, where I have used@@ -1188,7 +1236,8 @@     setSrcSpan loc                              $     addErrCtxt (instDeclCtxt2 (idType dfun_id)) $     do {  -- Instantiate the instance decl with skolem constants-       ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType dfun_id+       ; skol_info <- mkSkolemInfo InstSkol+       ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType skol_info dfun_id        ; dfun_ev_vars <- newEvVars dfun_theta                      -- We instantiate the dfun_id with superSkolems.                      -- See Note [Subtle interaction of recursion and overlap]@@ -1250,8 +1299,8 @@                      --    con_app_tys  = MkD ty1 ty2                      --    con_app_scs  = MkD ty1 ty2 sc1 sc2                      --    con_app_args = MkD ty1 ty2 sc1 sc2 op1 op2-             con_app_tys  = mkHsWrap (mkWpTyApps inst_tys)-                                  (HsConLikeOut noExtField (RealDataCon dict_constr))+             con_app_tys  = mkHsWrap (mkWpTyApps inst_tys) $+                            mkConLikeTc (RealDataCon dict_constr)                        -- NB: We *can* have covars in inst_tys, in the case of                        -- promoted GADT constructors. @@ -1272,14 +1321,13 @@                     -- Newtype dfuns just inline unconditionally,                     -- so don't attempt to specialise them -             export = ABE { abe_ext  = noExtField-                          , abe_wrap = idHsWrapper+             export = ABE { abe_wrap = idHsWrapper                           , abe_poly = dfun_id_w_prags                           , abe_mono = self_dict                           , abe_prags = dfun_spec_prags }                           -- NB: see Note [SPECIALISE instance pragmas]-             main_bind = AbsBinds { abs_ext = noExtField-                                  , abs_tvs = inst_tyvars+             main_bind = XHsBindsLR $+                         AbsBinds { abs_tvs = inst_tyvars                                   , abs_ev_vars = dfun_ev_vars                                   , abs_exports = [export]                                   , abs_ev_binds = []@@ -1313,8 +1361,9 @@  where    con_app    = mkLams dfun_bndrs $                 mkApps (Var (dataConWrapId dict_con)) dict_args-                 -- mkApps is OK because of the checkForLevPoly call in checkValidClass-                 -- See Note [Levity polymorphism checking] in GHC.HsToCore.Monad+                -- This application will satisfy the Core invariants+                -- from Note [Representation polymorphism invariants] in GHC.Core,+                -- because typeclass method types are never unlifted.    dict_args  = map Type inst_tys ++                 [mkVarApps (Var id) dfun_bndrs | id <- sc_meth_ids] @@ -1425,14 +1474,13 @@            ; let sc_top_ty = mkInfForAllTys tyvars $                              mkPhiTy (map idType dfun_evs) sc_pred                  sc_top_id = mkLocalId sc_top_name Many sc_top_ty-                 export = ABE { abe_ext  = noExtField-                              , abe_wrap = idHsWrapper+                 export = ABE { abe_wrap = idHsWrapper                               , abe_poly = sc_top_id                               , abe_mono = sc_ev_id                               , abe_prags = noSpecPrags }                  local_ev_binds = TcEvBinds ev_binds_var-                 bind = AbsBinds { abs_ext      = noExtField-                                 , abs_tvs      = tyvars+                 bind = XHsBindsLR $+                        AbsBinds { abs_tvs      = tyvars                                  , abs_ev_vars  = dfun_evs                                  , abs_exports  = [export]                                  , abs_ev_binds = [dfun_ev_binds, local_ev_binds]@@ -1710,7 +1758,7 @@                -> TcM (TcId, LHsBind GhcTc, Maybe Implication)      tc_default sel_id (Just (dm_name, _))-      = do { (meth_bind, inline_prags) <- mkDefMethBind dfun_id clas sel_id dm_name+      = do { (meth_bind, inline_prags) <- mkDefMethBind inst_loc dfun_id clas sel_id dm_name            ; tcMethodBody clas tyvars dfun_ev_vars inst_tys                           dfun_ev_binds is_derived hs_sig_fn                           spec_inst_prags inline_prags@@ -1860,15 +1908,14 @@        ; spec_prags     <- tcSpecPrags global_meth_id prags          ; let specs  = mk_meth_spec_prags global_meth_id spec_inst_prags spec_prags-              export = ABE { abe_ext   = noExtField-                           , abe_poly  = global_meth_id+              export = ABE { abe_poly  = global_meth_id                            , abe_mono  = local_meth_id                            , abe_wrap  = idHsWrapper                            , abe_prags = specs }                local_ev_binds = TcEvBinds ev_binds_var-              full_bind = AbsBinds { abs_ext      = noExtField-                                   , abs_tvs      = tyvars+              full_bind = XHsBindsLR $+                          AbsBinds { abs_tvs      = tyvars                                    , abs_ev_vars  = dfun_ev_vars                                    , abs_exports  = [export]                                    , abs_ev_binds = [dfun_ev_binds, local_ev_binds]@@ -1894,9 +1941,9 @@              <- setSrcSpan (getLocA hs_sig_ty) $                 do { inst_sigs <- xoptM LangExt.InstanceSigs                    ; checkTc inst_sigs (misplacedInstSig sel_name hs_sig_ty)-                   ; sig_ty  <- tcHsSigType (FunSigCtxt sel_name False) hs_sig_ty+                   ; let ctxt = FunSigCtxt sel_name NoRRC+                   ; sig_ty  <- tcHsSigType ctxt hs_sig_ty                    ; let local_meth_ty = idType local_meth_id-                         ctxt = FunSigCtxt sel_name False                                 -- False <=> do not report redundant constraints when                                 --           checking instance-sig <= class-meth-sig                                 -- The instance-sig is the focus here; the class-meth-sig@@ -1907,8 +1954,8 @@                    ; return (sig_ty, hs_wrap) }         ; inner_meth_name <- newName (nameOccName sel_name)-       ; let ctxt = FunSigCtxt sel_name True-                    -- True <=> check for redundant constraints in the+       ; let ctxt = FunSigCtxt sel_name (lhsSigTypeContextSpan hs_sig_ty)+                    -- WantRCC <=> check for redundant constraints in the                     --          user-specified instance signature              inner_meth_id  = mkLocalId inner_meth_name Many sig_ty              inner_meth_sig = CompleteSig { sig_bndr = inner_meth_id@@ -1918,21 +1965,20 @@         ; (tc_bind, [inner_id]) <- tcPolyCheck no_prag_fn inner_meth_sig meth_bind -       ; let export = ABE { abe_ext   = noExtField-                          , abe_poly  = local_meth_id+       ; let export = ABE { abe_poly  = local_meth_id                           , abe_mono  = inner_id                           , abe_wrap  = hs_wrap                           , abe_prags = noSpecPrags } -       ; return (unitBag $ L (getLoc meth_bind) $-                 AbsBinds { abs_ext = noExtField, abs_tvs = [], abs_ev_vars = []+       ; return (unitBag $ L (getLoc meth_bind) $ XHsBindsLR $+                 AbsBinds { abs_tvs = [], abs_ev_vars = []                           , abs_exports = [export]                           , abs_binds = tc_bind, abs_ev_binds = []                           , abs_sig = True }) }    | otherwise  -- No instance signature-  = do { let ctxt = FunSigCtxt sel_name False-                    -- False <=> don't report redundant constraints+  = do { let ctxt = FunSigCtxt sel_name NoRRC+                    -- NoRRC <=> don't report redundant constraints                     -- The signature is not under the users control!              tc_sig = completeSigFromId ctxt local_meth_id               -- Absent a type sig, there are no new scoped type variables here@@ -1950,7 +1996,6 @@     no_prag_fn = emptyPragEnv   -- No pragmas for local_meth_id;                                 -- they are all for meth_id - ------------------------ mkMethIds :: Class -> [TcTyVar] -> [EvVar]           -> [TcType] -> Id -> TcM (TcId, TcId)@@ -1967,7 +2012,8 @@         ; return (poly_meth_id, local_meth_id) }   where     sel_name      = idName sel_id-    sel_occ       = nameOccName sel_name+    -- Force so that a thunk doesn't end up in a Name (#19619)+    !sel_occ      = nameOccName sel_name     local_meth_ty = instantiateMethod clas sel_id inst_tys     poly_meth_ty  = mkSpecSigmaTy tyvars theta local_meth_ty     theta         = map idType dfun_ev_vars@@ -1982,9 +2028,10 @@                               , text "   Class sig:" <+> ppr meth_ty ])        ; return (env2, msg) } -misplacedInstSig :: Name -> LHsSigType GhcRn -> SDoc+misplacedInstSig :: Name -> LHsSigType GhcRn -> TcRnMessage misplacedInstSig name hs_ty-  = vcat [ hang (text "Illegal type signature in instance declaration:")+  = TcRnUnknownMessage $ mkPlainError noHints $+    vcat [ hang (text "Illegal type signature in instance declaration:")               2 (hang (pprPrefixName name)                     2 (dcolon <+> ppr hs_ty))          , text "(Use InstanceSigs to allow this)" ]@@ -2058,7 +2105,7 @@          | L inst_loc (SpecPrag _       wrap inl) <- spec_inst_prags]  -mkDefMethBind :: DFunId -> Class -> Id -> Name+mkDefMethBind :: SrcSpan -> DFunId -> Class -> Id -> Name               -> TcM (LHsBind GhcRn, [LSig GhcRn]) -- The is a default method (vanailla or generic) defined in the class -- So make a binding   op = $dmop @t1 @t2@@ -2066,9 +2113,8 @@ -- and t1,t2 are the instance types. -- See Note [Default methods in instances] for why we use -- visible type application here-mkDefMethBind dfun_id clas sel_id dm_name-  = do  { dflags <- getDynFlags-        ; logger <- getLogger+mkDefMethBind loc dfun_id clas sel_id dm_name+  = do  { logger <- getLogger         ; dm_id <- tcLookupId dm_name         ; let inline_prag = idInlinePragma dm_id               inline_prags | isAnyInlinePragma inline_prag@@ -2082,10 +2128,11 @@               visible_inst_tys = [ ty | (tcb, ty) <- tyConBinders (classTyCon clas) `zip` inst_tys                                       , tyConBinderArgFlag tcb /= Inferred ]               rhs  = foldl' mk_vta (nlHsVar dm_name) visible_inst_tys-              bind = noLocA $ mkTopFunBind Generated fn $-                             [mkSimpleMatch (mkPrefixFunRhs fn) [] rhs]+              bind = L (noAnnSrcSpan loc)+                    $ mkTopFunBind Generated fn+                        [mkSimpleMatch (mkPrefixFunRhs fn) [] rhs] -        ; liftIO (dumpIfSet_dyn logger dflags Opt_D_dump_deriv "Filling in method body"+        ; liftIO (putDumpFileMaybe logger Opt_D_dump_deriv "Filling in method body"                    FormatHaskell                    (vcat [ppr clas <+> ppr inst_tys,                           nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))@@ -2111,7 +2158,9 @@ warnUnsatisfiedMinimalDefinition :: ClassMinimalDef -> TcM () warnUnsatisfiedMinimalDefinition mindef   = do { warn <- woptM Opt_WarnMissingMethods-       ; warnTc (Reason Opt_WarnMissingMethods) warn message+       ; let msg = TcRnUnknownMessage $+               mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingMethods) noHints message+       ; diagnosticTc warn msg        }   where     message = vcat [text "No explicit implementation for"@@ -2330,26 +2379,30 @@ inst_decl_ctxt doc = hang (text "In the instance declaration for")                         2 (quotes doc) -badBootFamInstDeclErr :: SDoc+badBootFamInstDeclErr :: TcRnMessage badBootFamInstDeclErr-  = text "Illegal family instance in hs-boot file"+  = TcRnUnknownMessage $ mkPlainError noHints $ text "Illegal family instance in hs-boot file" -notFamily :: TyCon -> SDoc+notFamily :: TyCon -> TcRnMessage notFamily tycon-  = vcat [ text "Illegal family instance for" <+> quotes (ppr tycon)+  = TcRnUnknownMessage $ mkPlainError noHints $+    vcat [ text "Illegal family instance for" <+> quotes (ppr tycon)          , nest 2 $ parens (ppr tycon <+> text "is not an indexed type family")] -assocInClassErr :: TyCon -> SDoc+assocInClassErr :: TyCon -> TcRnMessage assocInClassErr name- = text "Associated type" <+> quotes (ppr name) <+>+ = TcRnUnknownMessage $ mkPlainError noHints $+   text "Associated type" <+> quotes (ppr name) <+>    text "must be inside a class instance" -badFamInstDecl :: TyCon -> SDoc+badFamInstDecl :: TyCon -> TcRnMessage badFamInstDecl tc_name-  = vcat [ text "Illegal family instance for" <+>+  = TcRnUnknownMessage $ mkPlainError noHints $+    vcat [ text "Illegal family instance for" <+>            quotes (ppr tc_name)          , nest 2 (parens $ text "Use TypeFamilies to allow indexed type families") ] -notOpenFamily :: TyCon -> SDoc+notOpenFamily :: TyCon -> TcRnMessage notOpenFamily tc-  = text "Illegal instance for closed family" <+> quotes (ppr tc)+  = TcRnUnknownMessage $ mkPlainError noHints $+  text "Illegal instance for closed family" <+> quotes (ppr tc)
compiler/GHC/Tc/TyCl/Instance.hs-boot view
@@ -13,4 +13,4 @@ -- We need this because of the mutual recursion -- between GHC.Tc.TyCl and GHC.Tc.TyCl.Instance tcInstDecls1 :: [LInstDecl GhcRn]-             -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])+             -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ThBindEnv)
compiler/GHC/Tc/TyCl/PatSyn.hs view
@@ -23,8 +23,9 @@ import GHC.Hs import GHC.Tc.Gen.Pat import GHC.Core.Multiplicity-import GHC.Core.Type ( tidyTyCoVarBinders, tidyTypes, tidyType )+import GHC.Core.Type ( tidyTyCoVarBinders, tidyTypes, tidyType, isManyDataConTy ) import GHC.Core.TyCo.Subst( extendTvSubstWithClone )+import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Gen.Sig ( TcPragEnv, emptyPragEnv, completeSigFromId, lookupPragEnv                       , addInlinePrags, addInlinePragArity )@@ -32,6 +33,7 @@ import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.Zonk import GHC.Builtin.Types.Prim+import GHC.Types.Error import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.SrcLoc@@ -59,6 +61,7 @@ import GHC.Core.ConLike import GHC.Types.FieldLabel import GHC.Rename.Env+import GHC.Rename.Utils (wrapGenSpan) import GHC.Data.Bag import GHC.Utils.Misc import GHC.Driver.Session ( getDynFlags, xopt_FieldSelectors )@@ -66,8 +69,6 @@ import Control.Monad ( zipWithM ) import Data.List( partition, mapAccumL ) -#include "GhclibHsVersions.h"- {- ************************************************************************ *                                                                      *@@ -152,8 +153,8 @@         ; let (arg_names, is_infix) = collectPatSynArgInfo details        ; (tclvl, wanted, ((lpat', args), pat_ty))-            <- pushLevelAndCaptureConstraints  $-               tcInferPat PatSyn lpat          $+            <- pushLevelAndCaptureConstraints      $+               tcInferPat FRRPatSynArg PatSyn lpat $                mapM tcLookupId arg_names         ; let (ex_tvs, prov_dicts) = tcCollectEx lpat'@@ -241,6 +242,7 @@ -- See Note [Coercions that escape] dependentArgErr (arg, bad_cos)   = failWithTc $  -- fail here: otherwise we get downstream errors+    TcRnUnknownMessage $ mkPlainError noHints $     vcat [ text "Iceland Jack!  Iceland Jack! Stop torturing me!"          , hang (text "Pattern-bound variable")               2 (ppr arg <+> dcolon <+> ppr (idType arg))@@ -327,7 +329,7 @@ So in mkProvEvidence we lift (a ~# b) to (a ~ b).  Tiresome, and marginally less efficient, if the builder/martcher are not inlined. -See also Note [Lift equality constraints when quantifying] in GHC.Tc.Utils.TcType+See also Note [Lift equality constraints when quantifying] in GHC.Tc.Solver  Note [Coercions that escape] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -405,7 +407,7 @@        -- The existential 'x' should not appear in the result type        -- Can't check this until we know P's arity (decl_arity above)        ; let bad_tvs = filter (`elemVarSet` tyCoVarsOfType pat_ty) $ binderVars explicit_ex_bndrs-       ; checkTc (null bad_tvs) $+       ; checkTc (null bad_tvs) $ TcRnUnknownMessage $ mkPlainError noHints $          hang (sep [ text "The result type of the signature for" <+> quotes (ppr name) <> comma                    , text "namely" <+> quotes (ppr pat_ty) ])             2 (text "mentions existential type variable" <> plural bad_tvs@@ -420,13 +422,22 @@              univ_tvs   = binderVars univ_bndrs              ex_tvs     = binderVars ex_bndrs +         -- Pattern synonyms currently cannot be linear (#18806)+       ; checkTc (all (isManyDataConTy . scaledMult) arg_tys) $+           TcRnLinearPatSyn sig_body_ty++       ; skol_info <- mkSkolemInfo (SigSkol (PatSynCtxt name) pat_ty [])+                         -- The type here is a bit bogus, but we do not print+                         -- the type for PatSynCtxt, so it doesn't matter+                         -- See Note [Skolem info for pattern synonyms] in "GHC.Tc.Types.Origin"+          -- Skolemise the quantified type variables. This is necessary          -- in order to check the actual pattern type against the          -- expected type. Even though the tyvars in the type are          -- already skolems, this step changes their TcLevels,          -- avoiding level-check errors when unifying.-       ; (skol_subst0, skol_univ_bndrs) <- skolemiseTvBndrsX emptyTCvSubst univ_bndrs-       ; (skol_subst, skol_ex_bndrs)    <- skolemiseTvBndrsX skol_subst0   ex_bndrs+       ; (skol_subst0, skol_univ_bndrs) <- skolemiseTvBndrsX skol_info emptyTCvSubst univ_bndrs+       ; (skol_subst, skol_ex_bndrs)    <- skolemiseTvBndrsX skol_info skol_subst0   ex_bndrs        ; let skol_univ_tvs   = binderVars skol_univ_bndrs              skol_ex_tvs     = binderVars skol_ex_bndrs              skol_req_theta  = substTheta skol_subst0 req_theta@@ -441,7 +452,7 @@        -- See Note [Checking against a pattern signature]        ; req_dicts <- newEvVars skol_req_theta        ; (tclvl, wanted, (lpat', (ex_tvs', prov_dicts, args'))) <--           ASSERT2( equalLength arg_names arg_tys, ppr name $$ ppr arg_names $$ ppr arg_tys )+           assertPpr (equalLength arg_names arg_tys) (ppr name $$ ppr arg_names $$ ppr arg_tys) $            pushLevelAndCaptureConstraints   $            tcExtendNameTyVarEnv univ_tv_prs $            tcCheckPat PatSyn lpat (unrestricted skol_pat_ty)   $@@ -463,11 +474,7 @@                                        skol_arg_tys               ; return (ex_tvs', prov_dicts, args') } -       ; let skol_info = SigSkol (PatSynCtxt name) pat_ty []-                         -- The type here is a bit bogus, but we do not print-                         -- the type for PatSynCtxt, so it doesn't matter-                         -- See Note [Skolem info for pattern synonyms] in "GHC.Tc.Types.Origin"-       ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info skol_univ_tvs+       ; (implics, ev_binds) <- buildImplicationFor tclvl (getSkolemInfo skol_info) skol_univ_tvs                                                     req_dicts wanted         -- Solve the constraints now, because we are about to make a PatSyn,@@ -508,15 +515,15 @@                 -- See Note [Pattern synonyms and higher rank types]            ; return (mkLHsWrap wrap $ nlHsVar arg_id) } -skolemiseTvBndrsX :: TCvSubst -> [VarBndr TyVar flag]+skolemiseTvBndrsX :: SkolemInfo -> TCvSubst -> [VarBndr TyVar flag]                   -> TcM (TCvSubst, [VarBndr TcTyVar flag]) -- Make new TcTyVars, all skolems with levels, but do not clone -- The level is one level deeper than the current level -- See Note [Skolemising when checking a pattern synonym]-skolemiseTvBndrsX orig_subst tvs+skolemiseTvBndrsX skol_info orig_subst tvs   = do { tc_lvl <- getTcLevel        ; let pushed_lvl = pushTcLevel tc_lvl-             details    = SkolemTv pushed_lvl False+             details    = SkolemTv skol_info pushed_lvl False               mk_skol_tv_x :: TCvSubst -> VarBndr TyVar flag                           -> (TCvSubst, VarBndr TcTyVar flag)@@ -545,8 +552,8 @@ GHC.Tc.Utils.Instantiate.tcInstSkolTyVarsX except that the latter does cloning. -[Pattern synonyms and higher rank types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [Pattern synonyms and higher rank types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider   data T = MkT (forall a. a->a) @@ -674,8 +681,8 @@  wrongNumberOfParmsErr :: Name -> Arity -> Arity -> TcM a wrongNumberOfParmsErr name decl_arity missing-  = failWithTc $-    hang (text "Pattern synonym" <+> quotes (ppr name) <+> ptext (sLit "has")+  = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $+    hang (text "Pattern synonym" <+> quotes (ppr name) <+> text "has"           <+> speakNOf decl_arity (text "argument"))        2 (text "but its type signature has" <+> int missing <+> text "fewer arrows") @@ -688,7 +695,10 @@                  -> TcPragEnv                  -> ([TcInvisTVBinder], [PredType], TcEvBinds, [EvVar])                  -> ([TcInvisTVBinder], [TcType], [PredType], [EvTerm])-                 -> ([LHsExpr GhcTc], [TcType])  -- ^ Pattern arguments and types+                 -> ([LHsExpr GhcTc], [TcTypeFRR])+                   -- ^ Pattern arguments and types.+                   -- These must have a syntactically fixed RuntimeRep as per+                   -- Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.                  -> TcType            -- ^ Pattern type                  -> [FieldLabel]      -- ^ Selector names                  -- ^ Whether fields, empty if not record PatSyn@@ -782,7 +792,7 @@        ; tv_name <- newNameAt (mkTyVarOcc "r")   loc'        ; let rr_tv  = mkTyVar rr_name runtimeRepTy              rr     = mkTyVarTy rr_tv-             res_tv = mkTyVar tv_name (tYPE rr)+             res_tv = mkTyVar tv_name (mkTYPEapp rr)              res_ty = mkTyVarTy res_tv              is_unlifted = null args && null prov_dicts              (cont_args, cont_arg_tys)@@ -802,6 +812,7 @@        ; let matcher_tau   = mkVisFunTysMany [pat_ty, cont_ty, fail_ty] res_ty              matcher_sigma = mkInfSigmaTy (rr_tv:res_tv:univ_tvs) req_theta matcher_tau              matcher_id    = mkExportedVanillaId matcher_name matcher_sigma+             patsyn_id     = mkExportedVanillaId ps_name matcher_sigma                              -- See Note [Exported LocalIds] in GHC.Types.Id               inst_wrap = mkWpEvApps prov_dicts <.> mkWpTyApps ex_tys@@ -829,7 +840,7 @@                        , mg_ext = MatchGroupTc (map unrestricted [pat_ty, cont_ty, fail_ty]) res_ty                        , mg_origin = Generated                        }-             match = mkMatch (mkPrefixFunRhs (L loc ps_name)) []+             match = mkMatch (mkPrefixFunRhs (L loc patsyn_id)) []                              (mkHsLams (rr_tv:res_tv:univ_tvs)                                        req_dicts body')                              (EmptyLocalBinds noExtField)@@ -892,6 +903,8 @@   = do { builder_name <- newImplicitBinder name mkBuilderOcc        ; let theta          = req_theta ++ prov_theta              need_dummy_arg = isUnliftedType pat_ty && null arg_tys && null theta+                              -- NB: pattern arguments cannot be representation-polymorphic,+                              -- as checked in 'tcPatSynSig'. So 'isUnliftedType' is OK here.              builder_sigma  = add_void need_dummy_arg $                               mkInvisForAllTys univ_bndrs $                               mkInvisForAllTys ex_bndrs $@@ -913,7 +926,7 @@   = return emptyBag    | Left why <- mb_match_group       -- Can't invert the pattern-  = setSrcSpan (getLocA lpat) $ failWithTc $+  = setSrcSpan (getLocA lpat) $ failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $     vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym"                  <+> quotes (ppr ps_name) <> colon)               2 why@@ -997,7 +1010,7 @@ patSynBuilderOcc :: PatSyn -> Maybe (HsExpr GhcTc, TcSigmaType) patSynBuilderOcc ps   | Just (_, builder_ty, add_void_arg) <- patSynBuilder ps-  , let builder_expr = HsConLikeOut noExtField (PatSynCon ps)+  , let builder_expr = mkConLikeTc (PatSynCon ps)   = Just $     if add_void_arg     then ( builder_expr   -- still just return builder_expr; the void# arg@@ -1063,11 +1076,10 @@         = return $ HsVar noExtField (L l var)         | otherwise         = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym")-    go1 (ParPat _ pat)          = fmap (HsPar noAnn) $ go pat-    go1 p@(ListPat reb pats)-      | Nothing <- reb = do { exprs <- mapM go pats-                            ; return $ ExplicitList noExtField exprs }-      | otherwise                   = notInvertibleListPat p+    go1 (ParPat _ lpar pat rpar) = fmap (\e -> HsPar noAnn lpar e rpar) $ go pat+    go1 (ListPat _ pats)+      = do { exprs <- mapM go pats+           ; return $ ExplicitList noExtField exprs }     go1 (TuplePat _ pats box)       = do { exprs <- mapM go pats                                          ; return $ ExplicitTuple noExtField                                            (map (Present noAnn) exprs) box }@@ -1084,13 +1096,21 @@     go1 (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat)))                                     = go1 pat     go1 (SplicePat _ (HsSpliced{})) = panic "Invalid splice variety"+    go1 (XPat (HsPatExpanded _ pat))= go1 pat +    -- See Note [Invertible view patterns]+    go1 p@(ViewPat mbInverse _ pat) = case mbInverse of+      Nothing      -> notInvertible p+      Just inverse ->+        fmap+          (\ expr -> HsApp noAnn (wrapGenSpan inverse) (wrapGenSpan expr))+          (go1 (unLoc pat))+     -- The following patterns are not invertible.     go1 p@(BangPat {})                       = notInvertible p -- #14112     go1 p@(LazyPat {})                       = notInvertible p     go1 p@(WildPat {})                       = notInvertible p     go1 p@(AsPat {})                         = notInvertible p-    go1 p@(ViewPat {})                       = notInvertible p     go1 p@(NPlusKPat {})                     = notInvertible p     go1 p@(SplicePat _ (HsTypedSplice {}))   = notInvertible p     go1 p@(SplicePat _ (HsUntypedSplice {})) = notInvertible p@@ -1109,27 +1129,23 @@         pp_name = ppr name         pp_args = hsep (map ppr args) -    -- We should really be able to invert list patterns, even when-    -- rebindable syntax is on, but doing so involves a bit of-    -- refactoring; see #14380.  Until then we reject with a-    -- helpful error message.-    notInvertibleListPat p-      = Left (vcat [ not_invertible_msg p-                   , text "Reason: rebindable syntax is on."-                   , text "This is fixable: add use-case to #14380" ])  {- Note [Builder for a bidirectional pattern synonym] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For a bidirectional pattern synonym we need to produce an /expression/-that matches the supplied /pattern/, given values for the arguments-of the pattern synonym.  For example+For a bidirectional pattern synonym, the function 'tcPatToExpr'+needs to produce an /expression/ that matches the supplied /pattern/,+given values for the arguments of the pattern synonym. For example:   pattern F x y = (Just x, [y]) The 'builder' for F looks like   $builderF x y = (Just x, [y])  We can't always do this:- * Some patterns aren't invertible; e.g. view patterns-      pattern F x = (reverse -> x:_)+ * Some patterns aren't invertible; e.g. general view patterns+      pattern F x = (f -> x)+   as we don't have the ability to write down an expression that matches+   the view pattern specified by an arbitrary view function `f`.+   It is however sometimes possible to write down an inverse;+     see Note [Invertible view patterns].   * The RHS pattern might bind more variables than the pattern    synonym, so again we can't invert it@@ -1138,7 +1154,22 @@  * Ditto wildcards       pattern F x = (x,_) +Note [Invertible view patterns]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For some view patterns, such as those that arise from expansion of overloaded+patterns (as detailed in Note [Handling overloaded and rebindable patterns]),+we are able to explicitly write out an inverse (in the sense of the previous+Note [Builder for a bidirectional pattern synonym]).+For instance, the inverse to the pattern +  (toList -> [True, False])++is the expression++  (fromListN 2 [True,False])++Keeping track of the inverse for such view patterns fixed #14380.+ Note [Redundant constraints for builder] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The builder can have redundant constraints, which are awkward to eliminate.@@ -1250,7 +1281,7 @@     go1 :: Pat GhcTc -> ([TyVar], [EvVar])     go1 (LazyPat _ p)      = go p     go1 (AsPat _ _ p)      = go p-    go1 (ParPat _ p)       = go p+    go1 (ParPat _ _ p _)   = go p     go1 (BangPat _ p)      = go p     go1 (ListPat _ ps)     = mergeMany . map go $ ps     go1 (TuplePat _ ps _)  = mergeMany . map go $ ps@@ -1260,7 +1291,9 @@                            = merge (cpt_tvs con', cpt_dicts con') $                               goConDetails $ pat_args con     go1 (SigPat _ p _)     = go p-    go1 (XPat (CoPat _ p _)) = go1 p+    go1 (XPat ext) = case ext of+      CoPat _ p _      -> go1 p+      ExpansionPat _ p -> go1 p     go1 (NPlusKPat _ n k _ geq subtract)       = pprPanic "TODO: NPlusKPat" $ ppr n $$ ppr k $$ ppr geq $$ ppr subtract     go1 _                   = empty@@ -1272,7 +1305,7 @@       = mergeMany . map goRecFd $ flds      goRecFd :: LHsRecField GhcTc (LPat GhcTc) -> ([TyVar], [EvVar])-    goRecFd (L _ HsRecField{ hsRecFieldArg = p }) = go p+    goRecFd (L _ HsFieldBind{ hfbRHS = p }) = go p      merge (vs1, evs1) (vs2, evs2) = (vs1 ++ vs2, evs1 ++ evs2)     mergeMany = foldr merge empty
compiler/GHC/Tc/TyCl/Utils.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TypeFamilies #-} @@ -27,10 +27,9 @@         tcRecSelBinds, mkRecSelBinds, mkOneRecordSelector     ) where -#include "GhclibHsVersions.h"- import GHC.Prelude +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Env import GHC.Tc.Gen.Bind( tcValBinds )@@ -55,6 +54,7 @@  import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Misc import GHC.Utils.FV as FV @@ -65,6 +65,7 @@ import GHC.Unit.Module  import GHC.Types.Basic+import GHC.Types.Error import GHC.Types.FieldLabel import GHC.Types.SrcLoc import GHC.Types.SourceFile@@ -91,11 +92,11 @@ -}  synonymTyConsOfType :: Type -> [TyCon]--- Does not look through type synonyms at all--- Return a list of synonym tycons+-- Does not look through type synonyms at all.+-- Returns a list of synonym tycons in nondeterministic order. -- Keep this synchronized with 'expandTypeSynonyms' synonymTyConsOfType ty-  = nameEnvElts (go ty)+  = nonDetNameEnvElts (go ty)   where      go :: Type -> NameEnv TyCon  -- The NameEnv does duplicate elim      go (TyConApp tc tys) = go_tc tc `plusNameEnv` go_s tys@@ -205,7 +206,7 @@ checkSynCycles :: Unit -> [TyCon] -> [LTyClDecl GhcRn] -> TcM () checkSynCycles this_uid tcs tyclds =     case runSynCycleM (mapM_ (go emptyTyConSet []) tcs) emptyTyConSet of-        Left (loc, err) -> setSrcSpan loc $ failWithTc err+        Left (loc, err) -> setSrcSpan loc $ failWithTc (TcRnUnknownMessage $ mkPlainError noHints err)         Right _  -> return ()   where     -- Try our best to print the LTyClDecl for locally defined things@@ -650,6 +651,8 @@      -- recurring into coercions. Recall: coercions are totally ignored during      -- role inference. See [Coercions in role inference]     get_ty_vars :: Type -> FV+    get_ty_vars t                 | Just t' <- coreView t -- #20999+                                  = get_ty_vars t'     get_ty_vars (TyVarTy tv)      = unitFV tv     get_ty_vars (AppTy t1 t2)     = get_ty_vars t1 `unionFV` get_ty_vars t2     get_ty_vars (FunTy _ w t1 t2) = get_ty_vars w `unionFV` get_ty_vars t1 `unionFV` get_ty_vars t2@@ -715,21 +718,21 @@  setRoleInferenceTc :: Name -> RoleM a -> RoleM a setRoleInferenceTc name thing = RM $ \m_name vps nvps state ->-                                ASSERT( isNothing m_name )-                                ASSERT( isEmptyVarEnv vps )-                                ASSERT( nvps == 0 )+                                assert (isNothing m_name) $+                                assert (isEmptyVarEnv vps) $+                                assert (nvps == 0) $                                 unRM thing (Just name) vps nvps state  addRoleInferenceVar :: TyVar -> RoleM a -> RoleM a addRoleInferenceVar tv thing   = RM $ \m_name vps nvps state ->-    ASSERT( isJust m_name )+    assert (isJust m_name) $     unRM thing m_name (extendVarEnv vps tv nvps) (nvps+1) state  setRoleInferenceVars :: [TyVar] -> RoleM a -> RoleM a setRoleInferenceVars tvs thing   = RM $ \m_name _vps _nvps state ->-    ASSERT( isJust m_name )+    assert (isJust m_name) $     unRM thing m_name (mkVarEnv (zip tvs [0..])) (panic "setRoleInferenceVars")          state @@ -764,12 +767,14 @@ *                                                                      * ********************************************************************* -} -addTyConsToGblEnv :: [TyCon] -> TcM TcGblEnv+addTyConsToGblEnv :: [TyCon] -> TcM (TcGblEnv, ThBindEnv) -- Given a [TyCon], add to the TcGblEnv --   * extend the TypeEnv with the tycons --   * extend the TypeEnv with their implicitTyThings --   * extend the TypeEnv with any default method Ids --   * add bindings for record selectors+-- Return separately the TH levels of these bindings,+-- to be added to a LclEnv later. addTyConsToGblEnv tyclss   = tcExtendTyConEnv tyclss                    $     tcExtendGlobalEnvImplicit implicit_things  $@@ -777,7 +782,10 @@     do { traceTc "tcAddTyCons" $ vcat             [ text "tycons" <+> ppr tyclss             , text "implicits" <+> ppr implicit_things ]-       ; tcRecSelBinds (mkRecSelBinds tyclss) }+       ; gbl_env <- tcRecSelBinds (mkRecSelBinds tyclss)+       ; th_bndrs <- tcTyThBinders implicit_things+       ; return (gbl_env, th_bndrs)+       }  where    implicit_things = concatMap implicitTyConThings tyclss    def_meth_ids    = mkDefaultMethodIds tyclss@@ -880,6 +888,7 @@     loc      = getSrcSpan sel_name     loc'     = noAnnSrcSpan loc     locn     = noAnnSrcSpan loc+    locc     = noAnnSrcSpan loc     lbl      = flLabel fl     sel_name = flSelector fl @@ -888,7 +897,7 @@      -- Find a representative constructor, con1     cons_w_field = conLikesWithFields all_cons [lbl]-    con1 = ASSERT( not (null cons_w_field) ) head cons_w_field+    con1 = assert (not (null cons_w_field)) $ head cons_w_field      -- Selector type; Note [Polymorphic selectors]     field_ty   = conLikeFieldType con1 lbl@@ -899,7 +908,8 @@                     || has_sel == NoFieldSelectors     sel_ty | is_naughty = unitTy  -- See Note [Naughty record selectors]            | otherwise  = mkForAllTys (tyVarSpecToBinders data_tvbs) $-                          mkPhiTy (conLikeStupidTheta con1) $   -- Urgh!+                          -- Urgh! See Note [The stupid context] in GHC.Core.DataCon+                          mkPhiTy (conLikeStupidTheta con1) $                           -- req_theta is empty for normal DataCon                           mkPhiTy req_theta                 $                           mkVisFunTyMany data_ty            $@@ -921,14 +931,14 @@                                  (L loc' (HsVar noExtField (L locn field_var)))     mk_sel_pat con = ConPat NoExtField (L locn (getName con)) (RecCon rec_fields)     rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing }-    rec_field  = noLocA (HsRecField-                        { hsRecFieldAnn = noAnn-                        , hsRecFieldLbl-                           = L loc (FieldOcc sel_name-                                     (L locn $ mkVarUnqual lbl))-                        , hsRecFieldArg+    rec_field  = noLocA (HsFieldBind+                        { hfbAnn = noAnn+                        , hfbLHS+                           = L locc (FieldOcc sel_name+                                      (L locn $ mkVarUnqual lbl))+                        , hfbRHS                            = L loc' (VarPat noExtField (L locn field_var))-                        , hsRecPun = False })+                        , hfbPun = False })     sel_lname = L locn sel_name     field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc @@ -961,14 +971,14 @@     eq_subst = mkTvSubstPrs (map eqSpecPair eq_spec)     -- inst_tys corresponds to one of the following:     ---    -- * The arguments to the user-written return type (for GADT constructors).-    --   In this scenario, eq_subst provides a mapping from the universally-    --   quantified type variables to the argument types. Note that eq_subst-    --   does not need to be applied to any other part of the DataCon-    --   (see Note [The dcEqSpec domain invariant] in GHC.Core.DataCon).-    -- * The universally quantified type variables-    --   (for Haskell98-style constructors and pattern synonyms). In these-    --   scenarios, eq_subst is an empty substitution.+    --  * The arguments to the user-written return type (for GADT constructors).+    --    In this scenario, eq_subst provides a mapping from the universally+    --    quantified type variables to the argument types. Note that eq_subst+    --    does not need to be applied to any other part of the DataCon+    --    (see Note [The dcEqSpec domain invariant] in GHC.Core.DataCon).+    --  * The universally quantified type variables+    --    (for Haskell98-style constructors and pattern synonyms). In these+    --    scenarios, eq_subst is an empty substitution.     inst_tys = substTyVars eq_subst univ_tvs      unit_rhs = mkLHsTupleExpr [] noExtField
compiler/GHC/Tc/Types/EvTerm.hs view
@@ -13,34 +13,26 @@ import GHC.Unit  import GHC.Builtin.Names-import GHC.Builtin.Types ( liftedRepTy, unitTy )+import GHC.Builtin.Types ( unitTy )  import GHC.Core.Type import GHC.Core import GHC.Core.Make import GHC.Core.Utils -import GHC.Types.Literal ( Literal(..) ) import GHC.Types.SrcLoc-import GHC.Types.Name import GHC.Types.TyThing -import GHC.Data.FastString- -- Used with Opt_DeferTypeErrors -- See Note [Deferring coercion errors to runtime] -- in GHC.Tc.Solver-evDelayedError :: Type -> FastString -> EvTerm+evDelayedError :: Type -> String -> EvTerm evDelayedError ty msg   = EvExpr $-    let fail_expr = Var errorId `mkTyApps` [liftedRepTy, unitTy] `mkApps` [litMsg]+    let fail_expr = mkRuntimeErrorApp tYPE_ERROR_ID unitTy msg     in mkWildCase fail_expr (unrestricted unitTy) ty []        -- See Note [Incompleteness and linearity] in GHC.HsToCore.Utils-       -- c.f. mkFailExpr in GHC.HsToCore.Utils--  where-    errorId = tYPE_ERROR_ID-    litMsg  = Lit (LitString (bytesFS msg))+       -- c.f. mkErrorAppDs in GHC.HsToCore.Utils  -- Dictionary for CallStack implicit parameters evCallStack :: (MonadThings m, HasModule m, HasDynFlags m) =>@@ -78,5 +70,5 @@         return (pushCS nameExpr locExpr (Cast tm ip_co))    case cs of-    EvCsPushCall name loc tm -> mkPush (occNameFS $ getOccName name) loc tm-    EvCsEmpty -> return emptyCS+    EvCsPushCall fs loc tm -> mkPush fs loc tm+    EvCsEmpty              -> return emptyCS
compiler/GHC/Tc/Utils/Backpack.hs view
@@ -1,12 +1,10 @@-{-# LANGUAGE CPP                      #-}+ {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE ScopedTypeVariables      #-} {-# LANGUAGE TypeFamilies             #-}  module GHC.Tc.Utils.Backpack (-    findExtraSigImports',     findExtraSigImports,-    implicitRequirements',     implicitRequirements,     implicitRequirementsShallow,     checkUnit,@@ -19,8 +17,10 @@  import GHC.Prelude + import GHC.Driver.Env import GHC.Driver.Ppr+import GHC.Driver.Session  import GHC.Types.Basic (TypeOrKind(..)) import GHC.Types.Fixity (defaultFixity)@@ -37,9 +37,9 @@ import GHC.Types.Var import GHC.Types.Unique.DSet import GHC.Types.Name.Shape+import GHC.Types.PkgQual  import GHC.Unit-import GHC.Unit.State import GHC.Unit.Finder import GHC.Unit.Module.Warnings import GHC.Unit.Module.ModIface@@ -47,6 +47,7 @@ import GHC.Unit.Module.Imported import GHC.Unit.Module.Deps +import GHC.Tc.Errors.Types import GHC.Tc.Gen.Export import GHC.Tc.Solver import GHC.Tc.TyCl.Utils@@ -76,10 +77,10 @@ import GHC.Tc.Errors import GHC.Tc.Utils.Unify -import GHC.Utils.Misc import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain  import GHC.Data.FastString import GHC.Data.Maybe@@ -89,10 +90,9 @@  import {-# SOURCE #-} GHC.Tc.Module -#include "GhclibHsVersions.h"--fixityMisMatch :: TyThing -> Fixity -> Fixity -> SDoc+fixityMisMatch :: TyThing -> Fixity -> Fixity -> TcRnMessage fixityMisMatch real_thing real_fixity sig_fixity =+  TcRnUnknownMessage $ mkPlainError noHints $     vcat [ppr real_thing <+> text "has conflicting fixities in the module",           text "and its hsig file",           text "Main module:" <+> ppr_fix real_fixity,@@ -134,6 +134,7 @@     traceTc "checkHsigIface" $ vcat         [ ppr sig_type_env, ppr sig_insts, ppr sig_exports ]     mapM_ check_export (map availName sig_exports)+    failIfErrsM -- See Note [Fail before checking instances in checkHsigIface]     unless (null sig_fam_insts) $         panic ("GHC.Tc.Module.checkHsigIface: Cannot handle family " ++                "instances in hsig files yet...")@@ -145,7 +146,7 @@                         tcg_fam_inst_env = emptyFamInstEnv,                         tcg_insts = [],                         tcg_fam_insts = [] } $ do-    mapM_ check_inst sig_insts+    mapM_ check_inst (instEnvElts sig_insts)     failIfErrsM   where     -- NB: the Names in sig_type_env are bogus.  Let's say we have H.hsig@@ -154,8 +155,8 @@     -- have to look up the right name.     sig_type_occ_env = mkOccEnv                      . map (\t -> (nameOccName (getName t), t))-                     $ nameEnvElts sig_type_env-    dfun_names = map getName sig_insts+                     $ nonDetNameEnvElts sig_type_env+    dfun_names = map getName (instEnvElts sig_insts)     check_export name       -- Skip instances, we'll check them later       -- TODO: Actually this should never happen, because DFuns are@@ -168,7 +169,7 @@         -- tcg_env (TODO: but maybe this isn't relevant anymore).         r <- tcLookupImported_maybe name         case r of-          Failed err -> addErr err+          Failed err -> addErr (TcRnUnknownMessage $ mkPlainError noHints err)           Succeeded real_thing -> checkHsigDeclM sig_iface sig_thing real_thing        -- The hsig did NOT define this function; that means it must@@ -194,6 +195,14 @@         addErrAt (nameSrcSpan name)             (missingBootThing False name "exported by") +-- Note [Fail before checking instances in checkHsigIface]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- We need to be careful about failing before checking instances if there happens+-- to be an error in the exports.+-- Otherwise, we might proceed with typechecking (and subsequently panic-ing) on+-- ill-kinded types that are constructed while checking instances.+-- This lead to #19244+ -- Note [Error reporting bad reexport] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- NB: You want to be a bit careful about what location you report on reexports.@@ -220,14 +229,14 @@     mapM_ tcLookupImported_maybe (nameSetElemsStable (orphNamesOfClsInst sig_inst))     -- Based off of 'simplifyDeriv'     let ty = idType (instanceDFunId sig_inst)-        skol_info = InstSkol         -- Based off of tcSplitDFunTy         (tvs, theta, pred) =            case tcSplitForAllInvisTyVars ty of { (tvs, rho)    ->            case splitFunTys rho             of { (theta, pred) ->            (tvs, theta, pred) }}         origin = InstProvidedOrigin (tcg_semantic_mod tcg_env) sig_inst-    (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize+    skol_info <- mkSkolemInfo InstSkol+    (skol_subst, tvs_skols) <- tcInstSkolTyVars skol_info tvs -- Skolemize     (tclvl,cts) <- pushTcLevelM $ do        wanted <- newWanted origin                            (Just TypeLevel)@@ -244,7 +253,7 @@        return $ wanted : givens     unsolved <- simplifyWantedsTcM cts -    (implic, _) <- buildImplicationFor tclvl skol_info tvs_skols [] unsolved+    (implic, _) <- buildImplicationFor tclvl (getSkolemInfo skol_info) tvs_skols [] unsolved     reportAllUnsolved (mkImplicWC implic)  -- | For a module @modname@ of type 'HscSource', determine the list@@ -267,56 +276,42 @@ -- process A first, because the merging process will cause B to indirectly -- import A.  This function finds the TRANSITIVE closure of all such imports -- we need to make.-findExtraSigImports' :: HscEnv-                     -> HscSource-                     -> ModuleName-                     -> IO (UniqDSet ModuleName)-findExtraSigImports' hsc_env HsigFile modname =-    fmap unionManyUniqDSets (forM reqs $ \(Module iuid mod_name) ->-        (initIfaceLoad hsc_env-            . withException+findExtraSigImports :: HscEnv+                    -> HscSource+                    -> ModuleName+                    -> IO [ModuleName]+findExtraSigImports hsc_env HsigFile modname = do+    let+      dflags     = hsc_dflags hsc_env+      ctx        = initSDocContext dflags defaultUserStyle+      unit_state = hsc_units hsc_env+      reqs       = requirementMerges unit_state modname+    holes <- forM reqs $ \(Module iuid mod_name) -> do+        initIfaceLoad hsc_env+            . withException ctx             $ moduleFreeHolesPrecise (text "findExtraSigImports")-                (mkModule (VirtUnit iuid) mod_name)))-  where-    unit_state = hsc_units hsc_env-    reqs = requirementMerges unit_state modname--findExtraSigImports' _ _ _ = return emptyUniqDSet---- | 'findExtraSigImports', but in a convenient form for "GHC.Driver.Make" and--- "GHC.Tc.Module".-findExtraSigImports :: HscEnv -> HscSource -> ModuleName-                    -> IO [(Maybe FastString, Located ModuleName)]-findExtraSigImports hsc_env hsc_src modname = do-    extra_requirements <- findExtraSigImports' hsc_env hsc_src modname-    return [ (Nothing, noLoc mod_name)-           | mod_name <- uniqDSetToList extra_requirements ]+                (mkModule (VirtUnit iuid) mod_name)+    return (uniqDSetToList (unionManyUniqDSets holes)) --- A version of 'implicitRequirements'' which is more friendly--- for "GHC.Tc.Module".-implicitRequirements :: HscEnv-                     -> [(Maybe FastString, Located ModuleName)]-                     -> IO [(Maybe FastString, Located ModuleName)]-implicitRequirements hsc_env normal_imports-  = do mns <- implicitRequirements' hsc_env normal_imports-       return [ (Nothing, noLoc mn) | mn <- mns ]+findExtraSigImports _ _ _ = return []  -- Given a list of 'import M' statements in a module, figure out -- any extra implicit requirement imports they may have.  For -- example, if they 'import M' and M resolves to p[A=<B>,C=D], then -- they actually also import the local requirement B.-implicitRequirements' :: HscEnv-                     -> [(Maybe FastString, Located ModuleName)]+implicitRequirements :: HscEnv+                     -> [(PkgQual, Located ModuleName)]                      -> IO [ModuleName]-implicitRequirements' hsc_env normal_imports+implicitRequirements hsc_env normal_imports   = fmap concat $     forM normal_imports $ \(mb_pkg, L _ imp) -> do         found <- findImportedModule hsc_env imp mb_pkg         case found of-            Found _ mod | not (isHomeModule home_unit mod) ->+            Found _ mod | notHomeModuleMaybe mhome_unit mod ->                 return (uniqDSetToList (moduleFreeHoles mod))             _ -> return []-  where home_unit = hsc_home_unit hsc_env+  where+    mhome_unit = hsc_home_unit_maybe hsc_env  -- | Like @implicitRequirements'@, but returns either the module name, if it is -- a free hole, or the instantiated unit the imported module is from, so that@@ -324,15 +319,17 @@ -- than a transitive closure done here) all the free holes are still reachable. implicitRequirementsShallow   :: HscEnv-  -> [(Maybe FastString, Located ModuleName)]+  -> [(PkgQual, Located ModuleName)]   -> IO ([ModuleName], [InstantiatedUnit]) implicitRequirementsShallow hsc_env normal_imports = go ([], []) normal_imports  where+  mhome_unit = hsc_home_unit_maybe hsc_env+   go acc [] = pure acc   go (accL, accR) ((mb_pkg, L _ imp):imports) = do     found <- findImportedModule hsc_env imp mb_pkg     let acc' = case found of-          Found _ mod | not (isHomeModule (hsc_home_unit hsc_env) mod) ->+          Found _ mod | notHomeModuleMaybe mhome_unit mod ->               case moduleUnit mod of                   HoleUnit -> (moduleName mod : accL, accR)                   RealUnit _ -> (accL, accR)@@ -361,15 +358,15 @@ -- an @hsig@ file.) tcRnCheckUnit ::     HscEnv -> Unit ->-    IO (Messages DecoratedSDoc, Maybe ())+    IO (Messages TcRnMessage, Maybe ()) tcRnCheckUnit hsc_env uid =-   withTiming logger dflags+   withTiming logger               (text "Check unit id" <+> ppr uid)               (const ()) $    initTc hsc_env           HsigFile -- bogus           False-          (mainModIs hsc_env)+          (mainModIs (hsc_HUE hsc_env))           (realSrcLocSpan (mkRealSrcLoc (fsLit loc_str) 0 0)) -- bogus     $ checkUnit uid   where@@ -382,15 +379,14 @@ -- | Top-level driver for signature merging (run after typechecking -- an @hsig@ file). tcRnMergeSignatures :: HscEnv -> HsParsedModule -> TcGblEnv {- from local sig -} -> ModIface-                    -> IO (Messages DecoratedSDoc, Maybe TcGblEnv)+                    -> IO (Messages TcRnMessage, Maybe TcGblEnv) tcRnMergeSignatures hsc_env hpm orig_tcg_env iface =-  withTiming logger dflags+  withTiming logger              (text "Signature merging" <+> brackets (ppr this_mod))              (const ()) $   initTc hsc_env HsigFile False this_mod real_loc $     mergeSignatures hpm orig_tcg_env iface  where-  dflags   = hsc_dflags hsc_env   logger   = hsc_logger hsc_env   this_mod = mi_module iface   real_loc = tcg_top_loc orig_tcg_env@@ -560,10 +556,10 @@     tcg_env <- getGblEnv      let outer_mod  = tcg_mod tcg_env-        inner_mod  = tcg_semantic_mod tcg_env-        mod_name   = moduleName (tcg_mod tcg_env)-        unit_state = hsc_units hsc_env-        home_unit  = hsc_home_unit hsc_env+    let inner_mod  = tcg_semantic_mod tcg_env+    let mod_name   = moduleName (tcg_mod tcg_env)+    let unit_state = hsc_units hsc_env+    let dflags     = hsc_dflags hsc_env      -- STEP 1: Figure out all of the external signature interfaces     -- we are going to merge in.@@ -572,12 +568,14 @@     addErrCtxt (pprWithUnitState unit_state $ merge_msg mod_name reqs) $ do      -- STEP 2: Read in the RAW forms of all of these interfaces-    ireq_ifaces0 <- forM reqs $ \(Module iuid mod_name) ->+    ireq_ifaces0 <- liftIO $ forM reqs $ \(Module iuid mod_name) -> do         let m = mkModule (VirtUnit iuid) mod_name             im = fst (getModuleInstantiation m)-        in fmap fst-         . withException-         $ findAndReadIface (text "mergeSignatures") im m NotBoot+            ctx = initSDocContext dflags defaultUserStyle+        fmap fst+         . withException ctx+         $ findAndReadIface hsc_env+                            (text "mergeSignatures") im m NotBoot      -- STEP 3: Get the unrenamed exports of all these interfaces,     -- thin it according to the export list, and do shaping on them.@@ -596,7 +594,7 @@             let insts = instUnitInsts iuid                 isFromSignaturePackage =                     let inst_uid = instUnitInstanceOf iuid-                        pkg = unsafeLookupUnitId unit_state (indefUnit inst_uid)+                        pkg = unsafeLookupUnitId unit_state inst_uid                     in null (unitExposedModules pkg)             -- 3(a). Rename the exports according to how the dependency             -- was instantiated.  The resulting export list will be accurate@@ -689,7 +687,7 @@             -- 3(d). Extend the name substitution (performing shaping)             mb_r <- extend_ns nsubst as2             case mb_r of-                Left err -> failWithTc err+                Left err -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints err)                 Right nsubst' -> return (nsubst',oks',(imod, thinned_iface):ifaces)         nsubst0 = mkNameShape (moduleName inner_mod) (mi_exports lcl_iface0)         ok_to_use0 = mkOccSet (exportOccs (mi_exports lcl_iface0))@@ -756,6 +754,8 @@     setGblEnv tcg_env { tcg_rn_exports = mb_lies } $ do     tcg_env <- getGblEnv +    let home_unit = hsc_home_unit hsc_env+     -- STEP 4: Rename the interfaces     ext_ifaces <- forM thinned_ifaces $ \((Module iuid _), ireq_iface) ->         tcRnModIface (instUnitInsts iuid) (Just nsubst) ireq_iface@@ -865,14 +865,15 @@                 = (inst:insts, extendInstEnv inst_env inst)             (insts, inst_env) = foldl' merge_inst                                     (tcg_insts tcg_env, tcg_inst_env tcg_env)-                                    (md_insts details)+                                    (instEnvElts $ md_insts details)             -- This is a HACK to prevent calculateAvails from including imp_mod             -- in the listing.  We don't want it because a module is NOT             -- supposed to include itself in its dep_orphs/dep_finsts.  See #13214             iface' = iface { mi_final_exts = (mi_final_exts iface){ mi_orphan = False, mi_finsts = False } }             home_unit = hsc_home_unit hsc_env+            other_home_units = hsc_all_home_unit_ids hsc_env             avails = plusImportAvails (tcg_imports tcg_env) $-                        calculateAvails home_unit iface' False NotBoot ImportedBySystem+                        calculateAvails home_unit other_home_units iface' False NotBoot ImportedBySystem         return tcg_env {             tcg_inst_env = inst_env,             tcg_insts    = insts,@@ -914,14 +915,13 @@ -- an @hsig@ file.) tcRnInstantiateSignature ::     HscEnv -> Module -> RealSrcSpan ->-    IO (Messages DecoratedSDoc, Maybe TcGblEnv)+    IO (Messages TcRnMessage, Maybe TcGblEnv) tcRnInstantiateSignature hsc_env this_mod real_loc =-   withTiming logger dflags+   withTiming logger               (text "Signature instantiation"<+>brackets (ppr this_mod))               (const ()) $    initTc hsc_env HsigFile False this_mod real_loc $ instantiateSignature   where-   dflags = hsc_dflags hsc_env    logger = hsc_logger hsc_env  exportOccs :: [AvailInfo] -> [OccName]@@ -942,6 +942,7 @@   hsc_env <- getTopEnv   let unit_state = hsc_units hsc_env       home_unit  = hsc_home_unit hsc_env+      other_home_units = hsc_all_home_unit_ids hsc_env   addErrCtxt (impl_msg unit_state impl_mod req_mod) $ do     let insts = instUnitInsts uid @@ -962,7 +963,7 @@     loadModuleInterfaces (text "Loading orphan modules (from implementor of hsig)")                          (dep_orphs (mi_deps impl_iface)) -    let avails = calculateAvails home_unit+    let avails = calculateAvails home_unit other_home_units                     impl_iface False{- safe -} NotBoot ImportedBySystem         fix_env = mkNameEnv [ (greMangledName rdr_elt, FixItem occ f)                             | (occ, f) <- mi_fixities impl_iface@@ -987,10 +988,13 @@     -- instantiation is correct.     let sig_mod = mkModule (VirtUnit uid) mod_name         isig_mod = fst (getModuleInstantiation sig_mod)-    mb_isig_iface <- findAndReadIface (text "checkImplements 2") isig_mod sig_mod NotBoot+    hsc_env <- getTopEnv+    mb_isig_iface <- liftIO $ findAndReadIface hsc_env+                                               (text "checkImplements 2")+                                               isig_mod sig_mod NotBoot     isig_iface <- case mb_isig_iface of         Succeeded (iface, _) -> return iface-        Failed err -> failWithTc $+        Failed err -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $             hang (text "Could not find hi interface for signature" <+>                   quotes (ppr isig_mod) <> colon) 4 err @@ -998,7 +1002,8 @@     -- we need.  (Notice we IGNORE the Modules in the AvailInfos.)     forM_ (exportOccs (mi_exports isig_iface)) $ \occ ->         case lookupGlobalRdrEnv impl_gr occ of-            [] -> addErr $ quotes (ppr occ)+            [] -> addErr $ TcRnUnknownMessage $ mkPlainError noHints $+                        quotes (ppr occ)                     <+> text "is exported by the hsig file, but not exported by the implementing module"                     <+> quotes (pprWithUnitState unit_state $ ppr impl_mod)             _ -> return ()@@ -1034,9 +1039,9 @@     -- TODO: setup the local RdrEnv so the error messages look a little better.     -- But this information isn't stored anywhere. Should we RETYPECHECK     -- the local one just to get the information?  Hmm...-    MASSERT( isHomeModule home_unit outer_mod )-    MASSERT( isHomeUnitInstantiating home_unit)-    let uid = Indefinite (homeUnitInstanceOf home_unit)+    massert (isHomeModule home_unit outer_mod )+    massert (isHomeUnitInstantiating home_unit)+    let uid = homeUnitInstanceOf home_unit     inner_mod `checkImplements`         Module             (mkInstantiatedUnit uid (homeUnitInstantiations home_unit))
+ compiler/GHC/Tc/Utils/Concrete.hs view
@@ -0,0 +1,684 @@+{-# LANGUAGE MultiWayIf #-}++-- | Checking for representation-polymorphism using the Concrete mechanism.+--+-- This module contains the logic for enforcing the representation-polymorphism+-- invariants by way of emitting constraints.+module GHC.Tc.Utils.Concrete+  ( -- * Ensuring that a type has a fixed runtime representation+    hasFixedRuntimeRep+  , hasFixedRuntimeRep_syntactic++    -- * Making a type concrete+  , makeTypeConcrete+  )+ where++import GHC.Prelude++import GHC.Builtin.Types       ( liftedTypeKindTyCon, unliftedTypeKindTyCon )++import GHC.Core.Coercion       ( coToMCo, mkCastTyMCo )+import GHC.Core.TyCo.Rep       ( Type(..), MCoercion(..) )+import GHC.Core.TyCon          ( isConcreteTyCon )+import GHC.Core.Type           ( isConcrete, typeKind, tyVarKind, tcView+                               , mkTyVarTy, mkTyConApp, mkFunTy, mkAppTy )++import GHC.Tc.Types            ( TcM, ThStage(..), PendingStuff(..) )+import GHC.Tc.Types.Constraint ( NotConcreteError(..), NotConcreteReason(..) )+import GHC.Tc.Types.Evidence   ( Role(..), TcCoercionN, TcMCoercionN+                               , mkTcGReflRightMCo, mkTcNomReflCo )+import GHC.Tc.Types.Origin     ( CtOrigin(..), FixedRuntimeRepContext, FixedRuntimeRepOrigin(..) )+import GHC.Tc.Utils.Monad      ( emitNotConcreteError, setTcLevel, getCtLocM, getStage, traceTc )+import GHC.Tc.Utils.TcType     ( TcType, TcKind, TcTypeFRR+                               , MetaInfo(..), ConcreteTvOrigin(..)+                               , isMetaTyVar, metaTyVarInfo, tcTyVarLevel )+import GHC.Tc.Utils.TcMType    ( newConcreteTyVar, isFilledMetaTyVar_maybe, writeMetaTyVar+                               , emitWantedEq )++import GHC.Types.Basic         ( TypeOrKind(..) )+import GHC.Utils.Misc          ( HasDebugCallStack )+import GHC.Utils.Outputable++import Control.Monad      ( void )+import Data.Functor       ( ($>) )+import Data.List.NonEmpty ( NonEmpty((:|)) )++import Control.Monad.Trans.Class      ( lift )+import Control.Monad.Trans.Writer.CPS ( WriterT, runWriterT, tell )++{- Note [Concrete overview]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC ensures that certain types have a fixed runtime representation in the+typechecker, by emitting certain constraints.+Emitting constraints to be solved later allows us to accept more programs:+if we directly inspected the type (using e.g. `typePrimRep`), we might not+have enough information available (e.g. if the type has kind `TYPE r` for+a metavariable `r` which has not yet been filled in.)++We give here an overview of the various moving parts, to serve+as a central point of reference for this topic.++  * Representation polymorphism+    Note [Representation polymorphism invariants] in GHC.Core+    Note [Representation polymorphism checking]++    The first note explains why we require that certain types have+    a fixed runtime representation.++    The second note details why we sometimes need a constraint to+    perform such checks in the typechecker: we might not know immediately+    whether a type has a fixed runtime representation. For example, we might+    need further unification to take place before being able to decide.+    So, instead of checking immediately, we emit a constraint.++  * What does it mean for a type to be concrete?+    Note [Concrete types] explains what it means for a type to be concrete.++    To compute which representation to use for a type, `typePrimRep` expects+    its kind to be concrete: something specific like `BoxedRep Lifted` or+    `IntRep`; certainly not a type involving type variables or type families.++  * What constraints do we emit?+    Note [The Concrete mechanism]++    Instead of simply checking that a type `ty` is concrete (i.e. computing+    'isConcrete`), we emit an equality constraint:++       co :: ty ~# concrete_ty++    where 'concrete_ty' is a concrete metavariable: a metavariable whose 'MetaInfo'+    is 'ConcreteTv', signifying that it can only be unified with a concrete type.++    The Note explains that this allows us to accept more programs. The Note+    also explains that the implementation is happening in two phases+    (PHASE 1 and PHASE 2).+    In PHASE 1 (the current implementation) we only allow trivial evidence+    of the form `co = Refl`.++  * Fixed runtime representation vs fixed RuntimeRep+    Note [Fixed RuntimeRep]++    We currently enforce the representation-polymorphism invariants by checking+    that binders and function arguments have a "fixed RuntimeRep".++    This is slightly less general than we might like, as this rules out+    types with kind `TYPE (BoxedRep l)`: we know that this will be represented+    by a pointer, which should be enough to go on in many situations.++  * When do we emit these constraints?+    Note [hasFixedRuntimeRep]++    We introduce constraints to satisfy the representation-polymorphism+    invariants outlined in Note [Representation polymorphism invariants] in GHC.Core,+    which mostly amounts to the following two cases:++      - checking that a binder has a fixed runtime representation,+      - checking that a function argument has a fixed runtime representation.++    The Note explains precisely how and where these constraints are emitted.++  * Reporting unsolved constraints+    Note [Reporting representation-polymorphism errors] in GHC.Tc.Types.Origin++    When we emit a constraint to enforce a fixed representation, we also provide+    a 'FixedRuntimeRepOrigin' which gives context about the check being done.+    This origin gets reported to the user if we end up with such an an unsolved Wanted constraint.++Note [Representation polymorphism checking]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+According to the "Levity Polymorphism" paper (PLDI '17),+there are two places in which we must know that a type has a+fixed runtime representation, as explained in+  Note [Representation polymorphism invariants] in GHC.Core:++  I1. the type of a bound term-level variable,+  I2. the type of an argument to a function.++The paper explains the restrictions more fully, but briefly:+expressions in these contexts need to be stored in registers, and it's+hard (read: impossible) to store something that does not have a+fixed runtime representation.++In practice, we enforce these types to have a /fixed RuntimeRep/, which is slightly+stronger, as explained in Note [Fixed RuntimeRep].++There are two different ways we check whether a given type+has a fixed runtime representation, both in the typechecker:++  1. When typechecking type declarations (e.g. datatypes, typeclass, pattern synonyms),+     under the GHC.Tc.TyCl module hierarchy.+     In these situations, we can immediately reject bad representation polymorphism.++     For instance, the following datatype declaration++       data Foo (r :: RuntimeRep) (a :: TYPE r) = Foo a++     is rejected in GHC.Tc.TyCl.checkValidDataCon upon seeing that the type 'a'+     is representation-polymorphic.++     Such checks are done using `GHC.Tc.Utils.TcMType.checkTypeHasFixedRuntimeRep`,+     with `GHC.Tc.Errors.Types.FixedRuntimeRepProvenance` describing the different+     contexts in which bad representation polymorphism can occur while validity checking.++  2. When typechecking value-level declarations (functions, expressions, patterns, ...),+     under the GHC.Tc.Gen module hierarchy.+     In these situations, the typechecker might need to do some work to figure out+     whether a type has a fixed runtime representation or not. For instance,+     GHC might introduce a metavariable (rr :: RuntimeRep), which is only later+     (through constraint solving) discovered to be equal to FloatRep.++     This is handled by the Concrete mechanism outlined in+     Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete.+     See Note [Concrete overview] in GHC.Tc.Utils.Concrete for an overview+     of the various moving parts.++Note [Concrete types]+~~~~~~~~~~~~~~~~~~~~~+Definition: a type is /concrete/ iff it is:+            - a concrete type constructor (as defined below), or+            - a concrete type variable (see Note [ConcreteTv] below), or+            - an application of a concrete type to another concrete type+GHC.Core.Type.isConcrete checks whether a type meets this definition.++Definition: a /concrete type constructor/ is defined by+            - a promoted data constructor+            - a class, data type or newtype+            - a primitive type like Array# or Int#+            - an abstract type as defined in a Backpack signature file+              (see Note [Synonyms implement abstract data] in GHC.Tc.Module)+            In particular, type and data families are not concrete.+GHC.Core.TyCon.isConcreteTyCon checks whether a TyCon meets this definition.++Examples of concrete types:+   Lifted, BoxedRep Lifted, TYPE (BoxedRep Lifted) are all concrete+Examples of non-concrete types+   F Int, TYPE (F Int), TYPE r, a[sk]+   NB: (F Int) is not concrete because F is a type function++The recursive definition of concreteness entails the following property:++Concrete Congruence Property (CCP)+  All sub-trees of a concrete type tree are concrete.++The following property also holds due to the invariant that the kind of a+concrete metavariable is itself concrete (see Note [ConcreteTv]):++Concrete Kinds Property (CKP)+  The kind of a concrete type is concrete.++Note [ConcreteTv]+~~~~~~~~~~~~~~~~~+A concrete metavariable is a metavariable whose 'MetaInfo' is 'ConcreteTv'.+Similar to 'TyVarTv's which are type variables which can only be unified with+other type variables, a 'ConcreteTv' type variable is a type variable which can+only be unified with a concrete type (in the sense of Note [Concrete types]).++INVARIANT: the kind of a concrete metavariable is concrete.++This invariant is upheld at the time of creation of a new concrete metavariable.++Concrete metavariables are useful for representation-polymorphism checks:+they allow us to refer to a type whose representation is not yet known but will+be figured out by the typechecker (see Note [The Concrete mechanism]).++Note [The Concrete mechanism]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To check (ty :: ki) has a fixed runtime representation, we proceed as follows:++  - Create a new concrete metavariable `concrete_tv`, i.e. a metavariable+    with 'ConcreteTv' 'MetaInfo' (see Note [ConcreteTv]).++  - Emit an equality constraint:++      ki ~# concrete_tv++    The origin for such an equality constraint uses+    `GHC.Tc.Types.Origin.FixedRuntimeRepOrigin`, so that we can report the+    appropriate representation-polymorphism error if any such constraint+    goes unsolved.++To solve `ki ~# concrete_ki`, we must unify `concrete_tv := concrete_ki`,+where `concrete_ki` is some concrete type. We can then compute `kindPrimRep`+on `concrete_ki` to compute the representation: this means `ty` indeed+has a fixed runtime representation.++-------------------------+-- PHASE 1 and PHASE 2 --+-------------------------++The Concrete mechanism is being implemented in two separate phases.++In PHASE 1, we enforce that we only solve the emitted constraints+`co :: ki ~# concrete_tv` with `Refl`. This forbids any program+which requires type family evaluation in order to determine that a 'RuntimeRep'+is fixed.+To achieve this, instead of creating a new concrete metavariable, we directly+ensure that 'ki' is concrete, using 'makeTypeConcrete'. If it fails, then+we report an error (even though rewriting might have allowed us to proceed).++In PHASE 2, we lift this restriction. This means we replace a call to+`hasFixedRuntimeRep_syntactic` with a call to `hasFixedRuntimeRep`, and insert the+obtained coercion in the typechecked result. To illustrate what this entails,+recall that the code generator needs to be able to compute 'PrimRep's, so that it+can put function arguments in the correct registers, etc.+As a result, we must insert additional casts in Core to ensure that no type family+reduction is needed to be able to compute 'PrimRep's. For example, the Core++  f = /\ ( a :: F Int ). \ ( x :: a ). some_expression++is problematic when 'F' is a type family: we don't know what runtime representation to use+for 'x', so we can't compile this function (we can't evaluate type family applications+after we are done with typechecking). Instead, we ensure the 'RuntimeRep' is always+explicitly visible:++  f = /\ ( a :: F Int ). \ ( x :: ( a |> kco ) ). some_expression++where 'kco' is the appropriate coercion; for example if `F Int = TYPE Int#`+this would be:++  kco :: F Int ~# TYPE Int#++As `( a |> kco ) :: TYPE Int#`, the code generator knows to use a machine-sized+integer register for `x`, and all is good again.++Because we can convert calls from hasFixedRuntimeRep_syntactic to+hasFixedRuntimeRep one at a time, we can migrate from PHASE 1 to PHASE 2+incrementally.++Example test cases that require PHASE 2: T13105, T17021, T20363b.++Note [Fixed RuntimeRep]+~~~~~~~~~~~~~~~~~~~~~~~+Definitions:++  FRR.++    The type `ty :: ki` has a /syntactically fixed RuntimeRep/+    (we also say that `ty` is an `FRRType`)+      <=>+    the kind `ki` is concrete (in the sense of Note [Concrete types])+      <=>+    `typePrimRep ty` (= `kindPrimRep ki`) does not crash+    (assuming that typechecking succeeded, so that all metavariables+    in `ty` have been filled)++  Fixed RuntimeRep.++    The type `ty :: ki` has a /fixed RuntimeRep/+      <=>+    there exists an FRR type `ty'` with `ty ~# ty'`+      <=>+    there exists a concrete type `concrete_ki` such that+    `ki ~ concrete_ki`++These definitions are crafted to be useful to satisfy the invariants of+Core; see Note [Representation polymorphism invariants] in GHC.Core.++Notice that "fixed RuntimeRep" means (for now anyway) that+  * we know the runtime representation, and+  * we know the levity.++For example (ty :: TYPE (BoxedRep l)), where `l` is a levity variable+is /not/ "fixed RuntimeRep", even though it is always represented by+a heap pointer, because we don't know the levity.  In due course we+will want to make finer distinctions, as explained in the paper+Kinds are Calling Conventions [ICFP'20], but this suffices for now.++Note [hasFixedRuntimeRep]+~~~~~~~~~~~~~~~~~~~~~~~~~+The 'hasFixedRuntimeRep' function is responsible for taking a type 'ty'+and emitting a constraint to ensure that 'ty' has a fixed `RuntimeRep`,+as outlined in Note [The Concrete mechanism].++To do so, we compute the kind 'ki' of 'ty', create a new concrete metavariable+`concrete_tv` of kind `ki`, and emit a constraint `ki ~# concrete_tv`,+which will only be solved if we can prove that 'ty' indeed has a fixed RuntimeRep.++If we can solve the equality constraint, i.e. produce a coercion+`kco :: ki ~# concrete_tv`, then 'hasFixedRuntimeRep' returns the coercion++  co = GRefl ty kco :: ty ~# ty |> kco++The RHS of the coercion `co` is `ty |> kco`. The kind of this type is+concrete (by construction), which means that `ty |> kco` is an FRRType+in the sense of Note [Fixed RuntimeRep], so that we can directely compute+its runtime representation using `typePrimRep`.++  [Wrinkle: Typed Template Haskell]+    We don't perform any checks when type-checking a typed Template Haskell quote:+    we want to allow representation polymorphic quotes, as long as they are+    monomorphised at splice site.++    Example:++      Module1++        repPolyId :: forall r (a :: TYPE r). CodeQ (a -> a)+        repPolyId = [|| \ x -> x ||]++      Module2++        import Module1++        id1 :: Int -> Int+        id1 = $$repPolyId++        id2 :: Int# -> Int#+        id2 = $$repPolyId++    We implement this skip by inspecting the TH stage in `hasFixedRuntimeRep`.++    A better solution would be to use 'CodeC' constraints, as in the paper+      "Staging With Class", POPL 2022+        by Ningning Xie, Matthew Pickering, Andres Löh, Nicolas Wu, Jeremy Yallop, Meng Wang+    but for the moment, as we will typecheck again when splicing,+    this shouldn't cause any problems in practice.  See ticket #18170.++    Test case: rep-poly/T18170a.+-}++-- | Given a type @ty :: ki@, this function ensures that @ty@+-- has a __fixed__ 'RuntimeRep', by emitting a new equality constraint+-- @ki ~ concrete_tv@ for a concrete metavariable @concrete_tv@.+--+-- Returns a coercion @co :: ty ~# concrete_ty@ as evidence.+-- If @ty@ obviously has a fixed 'RuntimeRep', e.g @ki = IntRep@,+-- then this function immediately returns 'MRefl',+-- without emitting any constraints.+hasFixedRuntimeRep :: HasDebugCallStack+                   => FixedRuntimeRepContext+                        -- ^ Context to be reported to the user+                        -- if the type ends up not having a fixed+                        -- 'RuntimeRep'.+                   -> TcType+                        -- ^ The type to check (we only look at its kind).+                   -> TcM (TcCoercionN, TcTypeFRR)+                        -- ^ @(co, ty')@ where @ty' :: ki'@,+                        -- @ki@ is concrete, and @co :: ty ~# ty'@.+                        -- That is, @ty'@ has a syntactically fixed RuntimeRep+                        -- in the sense of Note [Fixed RuntimeRep].+hasFixedRuntimeRep frr_ctxt ty = checkFRR_with unifyConcrete frr_ctxt ty++-- | Like 'hasFixedRuntimeRep', but we perform an eager syntactic check.+--+-- Throws an error in the 'TcM' monad if the check fails.+--+-- This is useful if we are not actually going to use the coercion returned+-- from 'hasFixedRuntimeRep'; it would generally be unsound to allow a non-reflexive+-- coercion but not actually make use of it in a cast.+--+-- The goal is to eliminate all uses of this function and replace them with+-- 'hasFixedRuntimeRep', making use of the returned coercion. This is what+-- is meant by going from PHASE 1 to PHASE 2, in Note [The Concrete mechanism].+hasFixedRuntimeRep_syntactic :: HasDebugCallStack+                             => FixedRuntimeRepContext+                                  -- ^ Context to be reported to the user+                                  -- if the type does not have a syntactically+                                  -- fixed 'RuntimeRep'.+                             -> TcType+                                  -- ^ The type to check (we only look at its kind).+                             -> TcM ()+hasFixedRuntimeRep_syntactic frr_ctxt ty+  = void $ checkFRR_with ensure_conc frr_ctxt ty+    where+      ensure_conc :: FixedRuntimeRepOrigin -> TcKind -> TcM TcMCoercionN+      ensure_conc frr_orig ki = ensureConcrete frr_orig ki $> MRefl++-- | Internal function to check whether the given type has a fixed 'RuntimeRep'.+--+-- Use 'hasFixedRuntimeRep' to allow rewriting, or 'hasFixedRuntimeRep_syntactic'+-- to perform a syntactic check.+checkFRR_with :: HasDebugCallStack+              => (FixedRuntimeRepOrigin -> TcKind -> TcM TcMCoercionN)+                   -- ^ The check to perform on the kind.+              -> FixedRuntimeRepContext+                   -- ^ The context which required a fixed 'RuntimeRep',+                   -- e.g. an application, a lambda abstraction, ...+              -> TcType+                   -- ^ The type @ty@ to check (the check itself only looks at its kind).+              -> TcM (TcCoercionN, TcTypeFRR)+                  -- ^ Returns @(co, frr_ty)@ with @co :: ty ~# frr_ty@+                  -- and @frr_@ty has a fixed 'RuntimeRep'.+checkFRR_with check_kind frr_ctxt ty+  = do { th_stage <- getStage+       ; if+          -- Shortcut: check for 'Type' and 'UnliftedType' type synonyms.+          | TyConApp tc [] <- ki+          , tc == liftedTypeKindTyCon || tc == unliftedTypeKindTyCon+          -> return refl++          -- See [Wrinkle: Typed Template Haskell] in Note [hasFixedRuntimeRep].+          | Brack _ (TcPending {}) <- th_stage+          -> return refl++          -- Otherwise: ensure that the kind 'ki' of 'ty' is concrete.+          | otherwise+          -> do { kco <- check_kind frr_orig ki+                ; return ( mkTcGReflRightMCo Nominal ty kco+                         , mkCastTyMCo ty kco ) } }++  where+    refl :: (TcCoercionN, TcType)+    refl = (mkTcNomReflCo ty, ty)+    ki :: TcKind+    ki = typeKind ty+    frr_orig :: FixedRuntimeRepOrigin+    frr_orig = FixedRuntimeRepOrigin { frr_type = ty, frr_context = frr_ctxt }++-- | Ensure that the given type @ty@ can unify with a concrete type,+-- in the sense of Note [Concrete types].+--+-- Returns a coercion @co :: ty ~# conc_ty@, where @conc_ty@ is+-- concrete.+--+-- If the type is already syntactically concrete, this+-- immediately returns a reflexive coercion. Otherwise,+-- it creates a new concrete metavariable @concrete_tv@+-- and emits an equality constraint @ty ~# concrete_tv@,+-- to be handled by the constraint solver.+--+-- Invariant: the kind of the supplied type must be concrete.+--+-- We assume the provided type is already at the kind-level+-- (this only matters for error messages).+unifyConcrete :: HasDebugCallStack+              => FixedRuntimeRepOrigin -> TcType -> TcM TcMCoercionN+unifyConcrete frr_orig ty+  = do { (ty, errs) <- makeTypeConcrete (ConcreteFRR frr_orig) ty+       ; case errs of+           -- We were able to make the type fully concrete.+         { [] -> return MRefl+           -- The type could not be made concrete; perhaps it contains+           -- a skolem type variable, a type family application, ...+           --+           -- Create a new ConcreteTv metavariable @concrete_tv@+           -- and unify @ty ~# concrete_tv@.+         ; _  ->+    do { conc_tv <- newConcreteTyVar (ConcreteFRR frr_orig) ki+           -- NB: newConcreteTyVar asserts that 'ki' is concrete.+       ; coToMCo <$> emitWantedEq orig KindLevel Nominal ty (mkTyVarTy conc_tv) } } }+  where+    ki :: TcKind+    ki = typeKind ty+    orig :: CtOrigin+    orig = FRROrigin frr_orig++-- | Ensure that the given type is concrete.+--+-- This is an eager syntactic check, and never defers+-- any work to the constraint solver.+--+-- Invariant: the kind of the supplied type must be concrete.+-- Invariant: the output type is equal to the input type,+--            up to zonking.+--+-- We assume the provided type is already at the kind-level+-- (this only matters for error messages).+ensureConcrete :: HasDebugCallStack+               => FixedRuntimeRepOrigin+               -> TcType+               -> TcM TcType+ensureConcrete frr_orig ty+  = do { (ty', errs) <- makeTypeConcrete conc_orig ty+       ; case errs of+          { err:errs ->+              do { traceTc "ensureConcrete } failure" $+                     vcat [ text "ty:" <+> ppr ty+                          , text "ty':" <+> ppr ty' ]+                 ; loc <- getCtLocM (FRROrigin frr_orig) (Just KindLevel)+                 ; emitNotConcreteError $+                     NCE_FRR+                       { nce_loc = loc+                       , nce_frr_origin = frr_orig+                       , nce_reasons = err :| errs }+                 }+          ; [] ->+              traceTc "ensureConcrete } success" $+                vcat [ text "ty: " <+> ppr ty+                     , text "ty':" <+> ppr ty' ] }+        ; return ty' }+  where+    conc_orig :: ConcreteTvOrigin+    conc_orig = ConcreteFRR frr_orig++{-***********************************************************************+%*                                                                      *+                    Making a type concrete+%*                                                                      *+%************************************************************************++Note [Unifying concrete metavariables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Unifying concrete metavariables (as defined in Note [ConcreteTv]) is not+an all-or-nothing affair as it is for other sorts of metavariables.++Consider the following unification problem in which all metavariables+are unfilled (and ignoring any TcLevel considerations):++  alpha[conc] ~# TYPE (TupleRep '[ beta[conc], IntRep, gamma[tau] ])++We can't immediately unify `alpha` with the RHS, because the RHS is not+a concrete type (in the sense of Note [Concrete types]). Instead, we+proceed as follows:++  - create a fresh concrete metavariable variable `gamma'[conc]`,+  - write gamma[tau] := gamma'[conc],+  - write alpha[conc] := TYPE (TupleRep '[ beta[conc], IntRep, gamma'[conc] ]).++Thus, in general, to unify `alpha[conc] ~# rhs`, we first try to turn+`rhs` into a concrete type (see the 'makeTypeConcrete' function).+If this succeeds, resulting in a concrete type `rhs'`, we simply fill+`alpha[conc] := rhs'`. If it fails, then syntactic unification fails.++Example 1:++    alpha[conc] ~# TYPE (TupleRep '[ beta[conc], IntRep, gamma[tau] ])++  We proceed by filling metavariables:++    gamma[tau] := gamma[conc]+    alpha[conc] := TYPE (TupleRep '[ beta[conc], IntRep, gamma[conc] ])++  This successfully unifies alpha.++Example 2:++  For a type family `F :: Type -> Type`:++    delta[conc] ~# TYPE (SumRep '[ zeta[tau], a[sk], F omega[tau] ])++  We write zeta[tau] := zeta[conc], and then fail, providing the following+  two reasons:++    - `a[sk]` is not a concrete type variable, so the overall type+      cannot be concrete+    - `F` is not a concrete type constructor, in the sense of+       Note [Concrete types]. So we keep it as is; in particular,+       we /should not/ try to make its argument `omega[tau]` into+       a ConcreteTv.++  Note that making zeta concrete allows us to propagate information.+  For example, after more typechecking, we might try to unify+  `zeta ~# rr[sk]`. If we made zeta a ConcreteTv, we will report+  this unsolved equality using the 'ConcreteTvOrigin' stored in zeta[conc].+  This allows us to report ALL the problems in a representation-polymorphism+  check (instead of only a non-empty subset).+-}++-- | Try to turn the provided type into a concrete type, by ensuring+-- unfilled metavariables are appropriately marked as concrete.+--+-- Returns a zonked type which is "as concrete as possible", and+-- a list of problems encountered when trying to make it concrete.+--+-- INVARIANT: the returned type is equal to the input type, up to zonking.+-- INVARIANT: if this function returns an empty list of 'NotConcreteReasons',+-- then the returned type is concrete, in the sense of Note [Concrete types].+makeTypeConcrete :: ConcreteTvOrigin -> TcType -> TcM (TcType, [NotConcreteReason])+-- TODO: it could be worthwhile to return enough information to continue solving.+-- Consider unifying `alpha[conc] ~# TupleRep '[ beta[tau], F Int ]` for+-- a type family 'F'.+-- This function will concretise `beta[tau] := beta[conc]` and return+-- that `TupleRep '[ beta[conc], F Int ]` is not concrete because of the+-- type family application `F Int`. But we could decompose by setting+-- alpha := TupleRep '[ beta, gamma[conc] ] and emitting `[W] gamma[conc] ~ F Int`.+--+-- This would be useful in startSolvingByUnification.+makeTypeConcrete conc_orig ty =+  do { res@(ty', _) <- runWriterT $ go ty+     ; traceTc "makeTypeConcrete" $+        vcat [ text "ty:" <+> ppr ty+             , text "ty':" <+> ppr ty' ]+     ; return res }+  where+    go :: TcType -> WriterT [NotConcreteReason] TcM TcType+    go ty+      | Just ty <- tcView ty+      = go ty+      | isConcrete ty+      = pure ty+    go ty@(TyVarTy tv) -- not a ConcreteTv (already handled above)+      = do { mb_filled <- lift $ isFilledMetaTyVar_maybe tv+           ; case mb_filled of+           { Just ty -> go ty+           ; Nothing+               | isMetaTyVar tv+               , TauTv <- metaTyVarInfo tv+               -> -- Change the MetaInfo to ConcreteTv, but retain the TcLevel+               do { kind <- go (tyVarKind tv)+                  ; lift $+                    do { conc_tv <- setTcLevel (tcTyVarLevel tv) $+                                    newConcreteTyVar conc_orig kind+                       ; let conc_ty = mkTyVarTy conc_tv+                       ; writeMetaTyVar tv conc_ty+                       ; return conc_ty } }+               | otherwise+               -- Don't attempt to make other type variables concrete+               -- (e.g. SkolemTv, TyVarTv, CycleBreakerTv, RuntimeUnkTv).+               -> bale_out ty (NonConcretisableTyVar tv) } }+    go ty@(TyConApp tc tys)+      | isConcreteTyCon tc+      = mkTyConApp tc <$> mapM go tys+      | otherwise+      = bale_out ty (NonConcreteTyCon tc tys)+    go (FunTy af w ty1 ty2)+      = do { w <- go w+           ; ty1 <- go ty1+           ; ty2 <- go ty2+           ; return $ mkFunTy af w ty1 ty2 }+    go (AppTy ty1 ty2)+      = do { ty1 <- go ty1+           ; ty2 <- go ty2+           ; return $ mkAppTy ty1 ty2 }+    go ty@(LitTy {})+      = return ty+    go ty@(CastTy cast_ty kco)+      = bale_out ty (ContainsCast cast_ty kco)+    go ty@(ForAllTy tcv body)+      = bale_out ty (ContainsForall tcv body)+    go ty@(CoercionTy co)+      = bale_out ty (ContainsCoercionTy co)++    bale_out :: TcType -> NotConcreteReason -> WriterT [NotConcreteReason] TcM TcType+    bale_out ty reason = do { tell [reason]; return ty }
compiler/GHC/Tc/Utils/Env.hs view
@@ -1,5 +1,5 @@ -- (c) The University of Glasgow 2006-{-# LANGUAGE CPP, FlexibleInstances #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  -- instance MonadThings is necessarily an                                        -- orphan@@ -18,13 +18,13 @@         -- Global environment         tcExtendGlobalEnv, tcExtendTyConEnv,         tcExtendGlobalEnvImplicit, setGlobalTypeEnv,-        tcExtendGlobalValEnv,+        tcExtendGlobalValEnv, tcTyThBinders,         tcLookupLocatedGlobal, tcLookupGlobal, tcLookupGlobalOnly,         tcLookupTyCon, tcLookupClass,         tcLookupDataCon, tcLookupPatSyn, tcLookupConLike,         tcLookupLocatedGlobalId, tcLookupLocatedTyCon,         tcLookupLocatedClass, tcLookupAxiom,-        lookupGlobal, ioLookupDataCon,+        lookupGlobal, lookupGlobal_maybe, ioLookupDataCon,         addTypecheckedBinds,          -- Local environment@@ -70,8 +70,6 @@         mkWrapperName   ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Driver.Env@@ -87,6 +85,7 @@ import GHC.Iface.Env import GHC.Iface.Load +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType@@ -96,7 +95,7 @@  import GHC.Core.UsageEnv import GHC.Core.InstEnv-import GHC.Core.DataCon ( DataCon )+import GHC.Core.DataCon ( DataCon, flSelector ) import GHC.Core.PatSyn  ( PatSyn ) import GHC.Core.ConLike import GHC.Core.TyCon@@ -130,11 +129,13 @@ import GHC.Types.Var.Env import GHC.Types.Name.Reader import GHC.Types.TyThing+import GHC.Types.Error import qualified GHC.LanguageExtensions as LangExt  import Data.IORef import Data.List (intercalate) import Control.Monad+import GHC.Driver.Env.KnotVars  {- ********************************************************************* *                                                                      *@@ -160,8 +161,8 @@ lookupGlobal_maybe hsc_env name   = do  {    -- Try local envt           let mod = icInteractiveModule (hsc_IC hsc_env)-              home_unit = hsc_home_unit hsc_env-              tcg_semantic_mod = homeModuleInstantiation home_unit mod+              mhome_unit = hsc_home_unit_maybe hsc_env+              tcg_semantic_mod = homeModuleInstantiation mhome_unit mod          ; if nameIsLocalOrFrom tcg_semantic_mod name               then (return@@ -256,7 +257,7 @@     do  { mb_thing <- tcLookupImported_maybe name         ; case mb_thing of             Succeeded thing -> return thing-            Failed msg      -> failWithTc msg+            Failed msg      -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints msg)         }}}  -- Look up only in this module's global env't. Don't look in imports, etc.@@ -326,10 +327,12 @@ tcLookupInstance cls tys   = do { instEnv <- tcGetInstEnvs        ; case lookupUniqueInstEnv instEnv cls tys of-           Left err             -> failWithTc $ text "Couldn't match instance:" <+> err+           Left err             ->+             failWithTc $ TcRnUnknownMessage+                        $ mkPlainError noHints (text "Couldn't match instance:" <+> err)            Right (inst, tys)              | uniqueTyVars tys -> return inst-             | otherwise        -> failWithTc errNotExact+             | otherwise        -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints errNotExact)        }   where     errNotExact = text "Not an exact match (i.e., some variables get instantiated)"@@ -363,7 +366,9 @@ --                  * the tcg_type_env_var field seen by interface files setGlobalTypeEnv tcg_env new_type_env   = do  {     -- Sync the type-envt variable seen by interface files-           writeMutVar (tcg_type_env_var tcg_env) new_type_env+         ; case lookupKnotVars (tcg_type_env_var tcg_env) (tcg_mod tcg_env) of+              Just tcg_env_var -> writeMutVar tcg_env_var new_type_env+              Nothing -> return ()          ; return (tcg_env { tcg_type_env = new_type_env }) }  @@ -397,6 +402,24 @@          tcExtendGlobalEnvImplicit (map ATyCon tycons) thing_inside        } +-- Given a [TyThing] of "non-value" bindings coming from type decls+-- (constructors, field selectors, class methods) return their+-- TH binding levels (to be added to a LclEnv).+-- See GHC ticket #17820 .+tcTyThBinders :: [TyThing] -> TcM ThBindEnv+tcTyThBinders implicit_things = do+  stage <- getStage+  let th_lvl  = thLevel stage+      th_bndrs = mkNameEnv+                  [ ( n , (TopLevel, th_lvl) ) | n <- names ]+  return th_bndrs+  where+    names = concatMap get_names implicit_things+    get_names (AConLike acl) =+      conLikeName acl : map flSelector (conLikeFieldLabels acl)+    get_names (AnId i) = [idName i]+    get_names _ = []+ tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a   -- Same deal as tcExtendGlobalEnv, but for Ids tcExtendGlobalValEnv ids thing_inside@@ -513,6 +536,7 @@ -- Scoped type and kind variables tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r tcExtendTyVarEnv tvs thing_inside+  -- MP: This silently coerces TyVar to TcTyVar.   = tcExtendNameTyVarEnv (mkTyVarNamePairs tvs) thing_inside  tcExtendNameTyVarEnv :: [(Name,TcTyVar)] -> TcM r -> TcM r@@ -615,29 +639,28 @@ -- that are bound together with extra_env and should not be regarded -- as free in the types of extra_env.   = do  { traceTc "tc_extend_local_env" (ppr extra_env)-        ; stage <- getStage-        ; env0@(TcLclEnv { tcl_rdr      = rdr_env-                         , tcl_th_bndrs = th_bndrs-                         , tcl_env      = lcl_type_env }) <- getLclEnv--        ; let thlvl = (top_lvl, thLevel stage)--              env1 = env0 { tcl_rdr = extendLocalRdrEnvList rdr_env-                                      [ n | (n, _) <- extra_env, isInternalName n ]-                                      -- The LocalRdrEnv contains only non-top-level names-                                      -- (GlobalRdrEnv handles the top level)--                         , tcl_th_bndrs = extendNameEnvList th_bndrs-                                          [(n, thlvl) | (n, ATcId {}) <- extra_env]-                                          -- We only track Ids in tcl_th_bndrs+        ; updLclEnv upd_lcl_env thing_inside }+  where+    upd_lcl_env env0@(TcLclEnv { tcl_th_ctxt  = stage+                               , tcl_rdr      = rdr_env+                               , tcl_th_bndrs = th_bndrs+                               , tcl_env      = lcl_type_env })+       = env0 { tcl_rdr = extendLocalRdrEnvList rdr_env+                          [ n | (n, _) <- extra_env, isInternalName n ]+                          -- The LocalRdrEnv contains only non-top-level names+                          -- (GlobalRdrEnv handles the top level) -                         , tcl_env = extendNameEnvList lcl_type_env extra_env }+              , tcl_th_bndrs = extendNameEnvList th_bndrs+                               [(n, thlvl) | (n, ATcId {}) <- extra_env]+                               -- We only track Ids in tcl_th_bndrs +              , tcl_env = extendNameEnvList lcl_type_env extra_env }               -- tcl_rdr and tcl_th_bndrs: extend the local LocalRdrEnv and               -- Template Haskell staging env simultaneously. Reason for extending               -- LocalRdrEnv: after running a TH splice we need to do renaming.+      where+        thlvl = (top_lvl, thLevel stage) -        ; setLclEnv env1 thing_inside }  tcExtendLocalTypeEnv :: TcLclEnv -> [(Name, TcTyThing)] -> TcLclEnv tcExtendLocalTypeEnv lcl_env@(TcLclEnv { tcl_env = lcl_type_env }) tc_ty_things@@ -723,7 +746,7 @@        = do { let (env', occ') = tidyOccName env (nameOccName name)                   name'  = tidyNameOcc name occ'                   tyvar1 = setTyVarName tyvar name'-            ; tyvar2 <- zonkTcTyVarToTyVar tyvar1+            ; tyvar2 <- zonkTcTyVarToTcTyVar tyvar1               -- Be sure to zonk here!  Tidying applies to zonked               -- types, so if we don't zonk we may create an               -- ill-kinded type (#14175)@@ -876,6 +899,7 @@    | otherwise                   -- Badly staged   = failWithTc $                -- E.g.  \x -> $(f x)+    TcRnUnknownMessage $ mkPlainError noHints $     text "Stage error:" <+> pp_thing <+>         hsep   [text "is bound at stage" <+> ppr bind_lvl,                 text "but used at stage" <+> ppr use_lvl]@@ -883,6 +907,7 @@ stageRestrictionError :: SDoc -> TcM a stageRestrictionError pp_thing   = failWithTc $+    TcRnUnknownMessage $ mkPlainError noHints $     sep [ text "GHC stage restriction:"         , nest 2 (vcat [ pp_thing <+> text "is used in a top-level splice, quasi-quote, or annotation,"                        , text "and must be imported, not defined locally"])]@@ -1086,7 +1111,8 @@ mkStableIdFromString str sig_ty loc occ_wrapper = do     uniq <- newUnique     mod <- getModule-    name <- mkWrapperName "stable" str+    nextWrapperNum <- tcg_next_wrapper_num <$> getGblEnv+    name <- mkWrapperName nextWrapperNum "stable" str     let occ = mkVarOccFS name :: OccName         gnm = mkExternalName uniq mod (occ_wrapper occ) loc :: Name         id  = mkExportedVanillaId gnm sig_ty :: Id@@ -1095,14 +1121,14 @@ mkStableIdFromName :: Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId mkStableIdFromName nm = mkStableIdFromString (getOccString nm) -mkWrapperName :: (MonadIO m, HasDynFlags m, HasModule m)-              => String -> String -> m FastString-mkWrapperName what nameBase-    = do dflags <- getDynFlags-         thisMod <- getModule-         let -- Note [Generating fresh names for ccall wrapper]-             wrapperRef = nextWrapperNum dflags-             pkg = unitString  (moduleUnit thisMod)+mkWrapperName :: (MonadIO m, HasModule m)+              => IORef (ModuleEnv Int) -> String -> String -> m FastString+-- ^ @mkWrapperName ref what nameBase@+--+-- See Note [Generating fresh names for ccall wrapper] for @ref@'s purpose.+mkWrapperName wrapperRef what nameBase+    = do thisMod <- getModule+         let pkg = unitString  (moduleUnit thisMod)              mod = moduleNameString (moduleName      thisMod)          wrapperNum <- liftIO $ atomicModifyIORef' wrapperRef $ \mod_env ->              let num = lookupWithDefaultModuleEnv mod_env 0 thisMod@@ -1149,6 +1175,7 @@                                             -- don't report it again (#11941)              | otherwise -> stageRestrictionError (quotes (ppr name))            _ -> failWithTc $+                TcRnUnknownMessage $ mkPlainError noHints $                 vcat[text "GHC internal error:" <+> quotes (ppr name) <+>                      text "is not in scope during type checking, but it passed the renamer",                      text "tcl_env of environment:" <+> ppr (tcl_env lcl_env)]@@ -1164,8 +1191,10 @@ -- turn does not look at the details of the TcTyThing. -- See Note [Placeholder PatSyn kinds] in GHC.Tc.Gen.Bind wrongThingErr expected thing name-  = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+>-                text "used as a" <+> text expected)+  = let msg = TcRnUnknownMessage $ mkPlainError noHints $+          (pprTcTyThingCategory thing <+> quotes (ppr name) <+>+                     text "used as a" <+> text expected)+  in failWithTc msg  {- Note [Out of scope might be a staging error] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Tc/Utils/Instantiate.hs view
@@ -1,5 +1,6 @@-{-# LANGUAGE CPP              #-}+ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DisambiguateRecordFields #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}@@ -18,7 +19,8 @@      newWanted, newWanteds,       tcInstType, tcInstTypeBndrs,-     tcInstSkolTyVars, tcInstSkolTyVarsX, tcInstSkolTyVarsAt,+     tcSkolemiseInvisibleBndrs,+     tcInstSkolTyVars, tcInstSkolTyVarsX,      tcSkolDFunType, tcSuperSkolTyVars, tcInstSuperSkolTyVarsX,       freshenTyVarBndrs, freshenCoVarBndrsX,@@ -38,8 +40,6 @@      tyCoVarsOfCt, tyCoVarsOfCts,   ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Driver.Session@@ -49,6 +49,7 @@ import GHC.Builtin.Names  import GHC.Hs+import GHC.Hs.Syn.Type   ( hsLitType )  import GHC.Core.InstEnv import GHC.Core.Predicate@@ -69,11 +70,14 @@ import GHC.Tc.Utils.Env import GHC.Tc.Types.Evidence import GHC.Tc.Instance.FunDeps+import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType+import GHC.Tc.Errors.Types  import GHC.Types.Id.Make( mkDictFunId )-import GHC.Types.Basic ( TypeOrKind(..) )+import GHC.Types.Basic ( TypeOrKind(..), Arity )+import GHC.Types.Error import GHC.Types.SourceText import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Var.Env@@ -85,13 +89,15 @@  import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Outputable  import GHC.Unit.State import GHC.Unit.External -import Data.List ( sortBy, mapAccumL )-import Control.Monad( unless )+import Data.List ( mapAccumL )+import qualified Data.List.NonEmpty as NE+import Control.Monad( when, unless ) import Data.Function ( on )  {-@@ -124,7 +130,7 @@         ; let ty = piResultTys (idType id) ty_args              (theta, _caller_knows_this) = tcSplitPhiTy ty-       ; wrap <- ASSERT( not (isForAllTy ty) && isSingleton theta )+       ; wrap <- assert (not (isForAllTy ty) && isSingleton theta) $                  instCall origin ty_args theta         ; return (mkHsWrap wrap (HsVar noExtField (noLocA id))) }@@ -163,13 +169,14 @@  -} -topSkolemise :: TcSigmaType+topSkolemise :: SkolemInfo+             -> TcSigmaType              -> TcM ( HsWrapper                     , [(Name,TyVar)]     -- All skolemised variables                     , [EvVar]            -- All "given"s                     , TcRhoType ) -- See Note [Skolemisation]-topSkolemise ty+topSkolemise skolem_info ty   = go init_subst idHsWrapper [] [] ty   where     init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty))@@ -178,7 +185,7 @@     go subst wrap tv_prs ev_vars ty       | (tvs, theta, inner_ty) <- tcSplitSigmaTy ty       , not (null tvs && null theta)-      = do { (subst', tvs1) <- tcInstSkolTyVarsX subst tvs+      = do { (subst', tvs1) <- tcInstSkolTyVarsX skolem_info subst tvs            ; ev_vars1       <- newEvVars (substTheta subst' theta)            ; go subst'                 (wrap <.> mkWpTyLams tvs1 <.> mkWpLams ev_vars1)@@ -397,7 +404,7 @@   | Just (mk, k1, k2) <- get_eq_tys_maybe (substTy subst (scaledThing ty))     -- Equality is the *only* constraint currently handled in types.     -- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep-  = ASSERT( af == InvisArg )+  = assert (af == InvisArg) $     do { co <- unifyKind Nothing k1 k2        ; arg' <- mk co        ; return (subst, arg') }@@ -491,70 +498,99 @@       = do { (subst', tv') <- newMetaTyVarTyVarX subst tv            ; return (subst', Bndr tv' spec) } -tcSkolDFunType :: DFunId -> TcM ([TcTyVar], TcThetaType, TcType)+--------------------------+tcSkolDFunType :: SkolemInfo -> DFunId -> TcM ([TcTyVar], TcThetaType, TcType) -- Instantiate a type signature with skolem constants. -- This freshens the names, but no need to do so-tcSkolDFunType dfun-  = do { (tv_prs, theta, tau) <- tcInstType tcInstSuperSkolTyVars dfun+tcSkolDFunType skol_info dfun+  = do { (tv_prs, theta, tau) <- tcInstType (tcInstSuperSkolTyVars skol_info) dfun        ; return (map snd tv_prs, theta, tau) } -tcSuperSkolTyVars :: [TyVar] -> (TCvSubst, [TcTyVar])+tcSuperSkolTyVars :: TcLevel -> SkolemInfo -> [TyVar] -> (TCvSubst, [TcTyVar]) -- Make skolem constants, but do *not* give them new names, as above--- Moreover, make them "super skolems"; see comments with superSkolemTv--- see Note [Kind substitution when instantiating]+-- As always, allocate them one level in+-- Moreover, make them "super skolems"; see GHC.Core.InstEnv+--    Note [Binding when looking up instances]+-- See Note [Kind substitution when instantiating] -- Precondition: tyvars should be ordered by scoping-tcSuperSkolTyVars = mapAccumL tcSuperSkolTyVar emptyTCvSubst--tcSuperSkolTyVar :: TCvSubst -> TyVar -> (TCvSubst, TcTyVar)-tcSuperSkolTyVar subst tv-  = (extendTvSubstWithClone subst tv new_tv, new_tv)+tcSuperSkolTyVars tc_lvl skol_info = mapAccumL do_one emptyTCvSubst   where-    kind   = substTyUnchecked subst (tyVarKind tv)-    new_tv = mkTcTyVar (tyVarName tv) kind superSkolemTv+    details = SkolemTv skol_info (pushTcLevel tc_lvl)+                       True   -- The "super" bit+    do_one subst tv = (extendTvSubstWithClone subst tv new_tv, new_tv)+      where+        kind   = substTyUnchecked subst (tyVarKind tv)+        new_tv = mkTcTyVar (tyVarName tv) kind details  -- | Given a list of @['TyVar']@, skolemize the type variables, -- returning a substitution mapping the original tyvars to the -- skolems, and the list of newly bound skolems.-tcInstSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])+tcInstSkolTyVars :: SkolemInfo -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) -- See Note [Skolemising type variables]-tcInstSkolTyVars = tcInstSkolTyVarsX emptyTCvSubst+tcInstSkolTyVars skol_info = tcInstSkolTyVarsX skol_info emptyTCvSubst -tcInstSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar])+tcInstSkolTyVarsX :: SkolemInfo -> TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) -- See Note [Skolemising type variables]-tcInstSkolTyVarsX = tcInstSkolTyVarsPushLevel False+tcInstSkolTyVarsX skol_info = tcInstSkolTyVarsPushLevel skol_info False -tcInstSuperSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])+tcInstSuperSkolTyVars :: SkolemInfo -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) -- See Note [Skolemising type variables] -- This version freshens the names and creates "super skolems"; -- see comments around superSkolemTv.-tcInstSuperSkolTyVars = tcInstSuperSkolTyVarsX emptyTCvSubst+tcInstSuperSkolTyVars skol_info = tcInstSuperSkolTyVarsX skol_info emptyTCvSubst -tcInstSuperSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar])+tcInstSuperSkolTyVarsX :: SkolemInfo -> TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) -- See Note [Skolemising type variables] -- This version freshens the names and creates "super skolems"; -- see comments around superSkolemTv.-tcInstSuperSkolTyVarsX subst = tcInstSkolTyVarsPushLevel True subst+tcInstSuperSkolTyVarsX skol_info subst = tcInstSkolTyVarsPushLevel skol_info True subst -tcInstSkolTyVarsPushLevel :: Bool  -- True <=> make "super skolem"+tcInstSkolTyVarsPushLevel :: SkolemInfo -> Bool  -- True <=> make "super skolem"                           -> TCvSubst -> [TyVar]                           -> TcM (TCvSubst, [TcTyVar]) -- Skolemise one level deeper, hence pushTcLevel -- See Note [Skolemising type variables]-tcInstSkolTyVarsPushLevel overlappable subst tvs+tcInstSkolTyVarsPushLevel skol_info overlappable subst tvs   = do { tc_lvl <- getTcLevel        -- Do not retain the whole TcLclEnv        ; let !pushed_lvl = pushTcLevel tc_lvl-       ; tcInstSkolTyVarsAt pushed_lvl overlappable subst tvs }+       ; tcInstSkolTyVarsAt skol_info pushed_lvl overlappable subst tvs } -tcInstSkolTyVarsAt :: TcLevel -> Bool+tcInstSkolTyVarsAt :: SkolemInfo -> TcLevel -> Bool                    -> TCvSubst -> [TyVar]                    -> TcM (TCvSubst, [TcTyVar])-tcInstSkolTyVarsAt lvl overlappable subst tvs+tcInstSkolTyVarsAt skol_info lvl overlappable subst tvs   = freshenTyCoVarsX new_skol_tv subst tvs   where-    details = SkolemTv lvl overlappable-    new_skol_tv name kind = mkTcTyVar name kind details+    sk_details = SkolemTv skol_info lvl overlappable+    new_skol_tv name kind = mkTcTyVar name kind sk_details +tcSkolemiseInvisibleBndrs :: SkolemInfoAnon -> Type -> TcM ([TcTyVar], TcType)+-- Skolemise the outer invisible binders of a type+-- Do /not/ freshen them, because their scope is broader than+-- just this type.  It's a bit dubious, but used in very limited ways.+tcSkolemiseInvisibleBndrs skol_info ty+  = do { let (tvs, body_ty) = tcSplitForAllInvisTyVars ty+       ; lvl           <- getTcLevel+       ; skol_info     <- mkSkolemInfo skol_info+       ; let details = SkolemTv skol_info lvl False+             mk_skol_tv name kind = return (mkTcTyVar name kind details)  -- No freshening+       ; (subst, tvs') <- instantiateTyVarsX mk_skol_tv emptyTCvSubst tvs+       ; return (tvs', substTy subst body_ty) }++instantiateTyVarsX :: (Name -> Kind -> TcM TcTyVar)+                   -> TCvSubst -> [TyVar]+                   -> TcM (TCvSubst, [TcTyVar])+-- Instantiate each type variable in turn with the specified function+instantiateTyVarsX mk_tv subst tvs+  = case tvs of+      []       -> return (subst, [])+      (tv:tvs) -> do { let kind1 = substTyUnchecked subst (tyVarKind tv)+                     ; tv' <- mk_tv (tyVarName tv) kind1+                     ; let subst1 = extendTCvSubstWithClone subst tv tv'+                     ; (subst', tvs') <- instantiateTyVarsX mk_tv subst1 tvs+                     ; return (subst', tv':tvs') }+ ------------------ freshenTyVarBndrs :: [TyVar] -> TcM (TCvSubst, [TyVar]) -- ^ Give fresh uniques to a bunch of TyVars, but they stay@@ -575,22 +611,21 @@ freshenTyCoVarsX :: (Name -> Kind -> TyCoVar)                  -> TCvSubst -> [TyCoVar]                  -> TcM (TCvSubst, [TyCoVar])-freshenTyCoVarsX mk_tcv = mapAccumLM (freshenTyCoVarX mk_tcv)--freshenTyCoVarX :: (Name -> Kind -> TyCoVar)-                -> TCvSubst -> TyCoVar -> TcM (TCvSubst, TyCoVar) -- This a complete freshening operation: -- the skolems have a fresh unique, and a location from the monad -- See Note [Skolemising type variables]-freshenTyCoVarX mk_tcv subst tycovar-  = do { loc  <- getSrcSpanM-       ; uniq <- newUnique-       ; let old_name = tyVarName tycovar-             new_name = mkInternalName uniq (getOccName old_name) loc-             new_kind = substTyUnchecked subst (tyVarKind tycovar)-             new_tcv  = mk_tcv new_name new_kind-             subst1   = extendTCvSubstWithClone subst tycovar new_tcv-       ; return (subst1, new_tcv) }+freshenTyCoVarsX mk_tcv+  = instantiateTyVarsX freshen_tcv+  where+    freshen_tcv :: Name -> Kind -> TcM TcTyVar+    freshen_tcv name kind+      = do { loc  <- getSrcSpanM+           ; uniq <- newUnique+           ; let !occ_name = getOccName name+                    -- Force so we don't retain reference to the old+                    -- name and id.   See (#19619) for more discussion+                 new_name = mkInternalName uniq occ_name loc+           ; return (mk_tcv new_name kind) }  {- Note [Skolemising type variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -672,8 +707,8 @@                            -> ExpRhoType                            -> TcM (HsOverLit GhcTc) newNonTrivialOverloadedLit-  lit@(OverLit { ol_val = val, ol_witness = HsVar _ (L _ meth_name)-               , ol_ext = rebindable }) res_ty+  lit@(OverLit { ol_val = val, ol_ext = OverLitRn rebindable (L _ meth_name) })+  res_ty   = do  { hs_lit <- mkOverLit val         ; let lit_ty = hsLitType hs_lit         ; (_, fi') <- tcSyntaxOp orig (mkRnSyntaxExpr meth_name)@@ -681,14 +716,12 @@                       \_ _ -> return ()         ; let L _ witness = nlHsSyntaxApps fi' [nlHsLit hs_lit]         ; res_ty <- readExpType res_ty-        ; return (lit { ol_witness = witness-                      , ol_ext = OverLitTc rebindable res_ty }) }+        ; return (lit { ol_ext = OverLitTc { ol_rebindable = rebindable+                                           , ol_witness = witness+                                           , ol_type = res_ty } }) }   where     orig = LiteralOrigin lit -newNonTrivialOverloadedLit lit _-  = pprPanic "newNonTrivialOverloadedLit" (ppr lit)- ------------ mkOverLit ::OverLitVal -> TcM (HsLit GhcTc) mkOverLit (HsIntegral i)@@ -735,10 +768,10 @@ -}  tcSyntaxName :: CtOrigin-             -> TcType                 -- ^ Type to instantiate it at-             -> (Name, HsExpr GhcRn)   -- ^ (Standard name, user name)+             -> TcType                  -- ^ Type to instantiate it at+             -> (Name, HsExpr GhcRn)    -- ^ (Standard name, user name)              -> TcM (Name, HsExpr GhcTc)-                                       -- ^ (Standard name, suitable expression)+                                        -- ^ (Standard name, suitable expression) -- USED ONLY FOR CmdTop (sigh) *** -- See Note [CmdSyntaxTable] in "GHC.Hs.Expr" @@ -750,35 +783,69 @@ tcSyntaxName orig ty (std_nm, user_nm_expr) = do     std_id <- tcLookupId std_nm     let-        -- C.f. newMethodAtLoc         ([tv], _, tau) = tcSplitSigmaTy (idType std_id)         sigma1         = substTyWith [tv] [ty] tau         -- Actually, the "tau-type" might be a sigma-type in the         -- case of locally-polymorphic methods. -    addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do+    span <- getSrcSpanM+    addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1 span) $ do          -- Check that the user-supplied thing has the         -- same type as the standard one.         -- Tiresome jiggling because tcCheckSigma takes a located expression-     span <- getSrcSpanM      expr <- tcCheckPolyExpr (L (noAnnSrcSpan span) user_nm_expr) sigma1+     hasFixedRuntimeRepRes std_nm user_nm_expr sigma1      return (std_nm, unLoc expr) -syntaxNameCtxt :: HsExpr GhcRn -> CtOrigin -> Type -> TidyEnv+syntaxNameCtxt :: HsExpr GhcRn -> CtOrigin -> Type -> SrcSpan -> TidyEnv                -> TcRn (TidyEnv, SDoc)-syntaxNameCtxt name orig ty tidy_env-  = do { inst_loc <- getCtLocM orig (Just TypeLevel)-       ; let msg = vcat [ text "When checking that" <+> quotes (ppr name)+syntaxNameCtxt name orig ty loc tidy_env = return (tidy_env, msg)+  where+    msg = vcat [ text "When checking that" <+> quotes (ppr name)                           <+> text "(needed by a syntactic construct)"-                        , nest 2 (text "has the required type:"-                                  <+> ppr (tidyType tidy_env ty))-                        , nest 2 (pprCtLoc inst_loc) ]-       ; return (tidy_env, msg) }+               , nest 2 (text "has the required type:"+                         <+> ppr (tidyType tidy_env ty))+               , nest 2 (sep [ppr orig, text "at" <+> ppr loc])]  {- ************************************************************************ *                                                                      *+                FixedRuntimeRep+*                                                                      *+************************************************************************+-}++-- | Check that the result type of an expression has a fixed runtime representation.+--+-- Used only for arrow operations such as 'arr', 'first', etc.+hasFixedRuntimeRepRes :: Name -> HsExpr GhcRn -> TcSigmaType -> TcM ()+hasFixedRuntimeRepRes std_nm user_expr ty = mapM_ do_check mb_arity+  where+   do_check :: Arity -> TcM ()+   do_check arity =+     let res_ty = nTimes arity (snd . splitPiTy) ty+     in hasFixedRuntimeRep_syntactic (FRRArrow $ ArrowFun user_expr) res_ty+   mb_arity :: Maybe Arity+   mb_arity -- arity of the arrow operation, counting type-level arguments+     | std_nm == arrAName     -- result used as an argument in, e.g., do_premap+     = Just 3+     | std_nm == composeAName -- result used as an argument in, e.g., dsCmdStmt/BodyStmt+     = Just 5+     | std_nm == firstAName   -- result used as an argument in, e.g., dsCmdStmt/BodyStmt+     = Just 4+     | std_nm == appAName     -- result used as an argument in, e.g., dsCmd/HsCmdArrApp/HsHigherOrderApp+     = Just 2+     | std_nm == choiceAName  -- result used as an argument in, e.g., HsCmdIf+     = Just 5+     | std_nm == loopAName    -- result used as an argument in, e.g., HsCmdIf+     = Just 4+     | otherwise+     = Nothing++{-+************************************************************************+*                                                                      *                 Instances *                                                                      * ************************************************************************@@ -822,29 +889,24 @@         ; oflag <- getOverlapFlag overlap_mode        ; let inst = mkLocalInstance dfun oflag tvs' clas tys'-       ; warnIfFlag Opt_WarnOrphans-                    (isOrphan (is_orphan inst))-                    (instOrphWarn inst)+       ; when (isOrphan (is_orphan inst)) $+          addDiagnostic (TcRnOrphanInstance inst)        ; return inst } -instOrphWarn :: ClsInst -> SDoc-instOrphWarn inst-  = hang (text "Orphan instance:") 2 (pprInstanceHdr inst)-    $$ text "To avoid this"-    $$ nest 4 (vcat possibilities)-  where-    possibilities =-      text "move the instance declaration to the module of the class or of the type, or" :-      text "wrap the type with a newtype and declare the instance on the new type." :-      []- tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a   -- Add new locally-defined instances tcExtendLocalInstEnv dfuns thing_inside  = do { traceDFuns dfuns       ; env <- getGblEnv+      -- Force the access to the TcgEnv so it isn't retained.+      -- During auditing it is much easier to observe in -hi profiles if+      -- there are a very small number of TcGblEnv. Keeping a TcGblEnv+      -- alive is quite dangerous because it contains reference to many+      -- large data structures.+      ; let !init_inst_env = tcg_inst_env env+            !init_insts = tcg_insts env       ; (inst_env', cls_insts') <- foldlM addLocalInst-                                          (tcg_inst_env env, tcg_insts env)+                                          (init_inst_env, init_insts)                                           dfuns       ; let env' = env { tcg_insts    = cls_insts'                        , tcg_inst_env = inst_env' }@@ -955,21 +1017,21 @@  funDepErr :: ClsInst -> [ClsInst] -> TcRn () funDepErr ispec ispecs-  = addClsInstsErr (text "Functional dependencies conflict between instance declarations:")-                    (ispec : ispecs)+  = addClsInstsErr TcRnFunDepConflict (ispec NE.:| ispecs)  dupInstErr :: ClsInst -> ClsInst -> TcRn () dupInstErr ispec dup_ispec-  = addClsInstsErr (text "Duplicate instance declarations:")-                    [ispec, dup_ispec]+  = addClsInstsErr TcRnDupInstanceDecls (ispec NE.:| [dup_ispec]) -addClsInstsErr :: SDoc -> [ClsInst] -> TcRn ()-addClsInstsErr herald ispecs = do+addClsInstsErr :: (UnitState -> NE.NonEmpty ClsInst -> TcRnMessage)+               -> NE.NonEmpty ClsInst+               -> TcRn ()+addClsInstsErr mkErr ispecs = do    unit_state <- hsc_units <$> getTopEnv-   setSrcSpan (getSrcSpan (head sorted)) $-      addErr $ pprWithUnitState unit_state $ (hang herald 2 (pprInstances sorted))+   setSrcSpan (getSrcSpan (NE.head sorted)) $+      addErr $ mkErr unit_state sorted  where-   sorted = sortBy (SrcLoc.leftmost_smallest `on` getSrcSpan) ispecs+   sorted = NE.sortBy (SrcLoc.leftmost_smallest `on` getSrcSpan) ispecs    -- The sortBy just arranges that instances are displayed in order    -- of source location, which reduced wobbling in error messages,    -- and is better for users
compiler/GHC/Tc/Utils/Monad.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns      #-}-{-# LANGUAGE CPP               #-} {-# LANGUAGE ExplicitForAll    #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RecordWildCards   #-}@@ -21,18 +20,19 @@   -- * Simple accessors   discardResult,   getTopEnv, updTopEnv, getGblEnv, updGblEnv,-  setGblEnv, getLclEnv, updLclEnv, setLclEnv,-  getEnvs, setEnvs,+  setGblEnv, getLclEnv, updLclEnv, setLclEnv, restoreLclEnv,+  updTopFlags,+  getEnvs, setEnvs, updEnvs, restoreEnvs,   xoptM, doptM, goptM, woptM,   setXOptM, unsetXOptM, unsetGOptM, unsetWOptM,   whenDOptM, whenGOptM, whenWOptM,   whenXOptM, unlessXOptM,   getGhcMode,-  withDynamicNow, withoutDynamicNow,+  withoutDynamicNow,   getEpsVar,   getEps,   updateEps, updateEps_,-  getHpt, getEpsAndHpt,+  getHpt, getEpsAndHug,    -- * Arrow scopes   newArrowScope, escapeArrowScope,@@ -49,7 +49,7 @@   dumpTcRn,   getPrintUnqualified,   printForUserTcRn,-  traceIf, traceHiDiffs, traceOptIf,+  traceIf, traceOptIf,   debugTc,    -- * Typechecker global environment@@ -76,8 +76,7 @@   tcCollectingUsage, tcScalingUsage, tcEmitBindingUsage,    -- * Shared error message stuff: renamer and typechecker-  mkLongErrAt, mkDecoratedSDocAt, addLongErrAt, reportErrors, reportError,-  reportWarning, recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM,+  recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM,   attemptM, tryTc,   askNoErrs, discardErrs, tryTcDiscardingErrs,   checkNoErrs, whenNoErrs,@@ -87,15 +86,17 @@   getErrCtxt, setErrCtxt, addErrCtxt, addErrCtxtM, addLandmarkErrCtxt,   addLandmarkErrCtxtM, popErrCtxt, getCtLocM, setCtLocM, -  -- * Error message generation (type checker)+  -- * Diagnostic message generation (type checker)   addErrTc,   addErrTcM,   failWithTc, failWithTcM,   checkTc, checkTcM,   failIfTc, failIfTcM,-  warnIfFlag, warnIf, warnTc, warnTcM,-  addWarnTc, addWarnTcM, addWarn, addWarnAt, add_warn,   mkErrInfo,+  addTcRnDiagnostic, addDetailedDiagnostic,+  mkTcRnMessage, reportDiagnostic, reportDiagnostics,+  warnIf, diagnosticTc, diagnosticTcM,+  addDiagnosticTc, addDiagnosticTcM, addDiagnostic, addDiagnosticAt,    -- * Type constraints   newTcEvBinds, newNoTcEvBinds, cloneEvBindsVar,@@ -105,17 +106,17 @@   getConstraintVar, setConstraintVar,   emitConstraints, emitStaticConstraints, emitSimple, emitSimples,   emitImplication, emitImplications, emitInsoluble,-  emitHole, emitHoles,+  emitDelayedErrors, emitHole, emitHoles, emitNotConcreteError,   discardConstraints, captureConstraints, tryCaptureConstraints,   pushLevelAndCaptureConstraints,-  pushTcLevelM_, pushTcLevelM, pushTcLevelsM,+  pushTcLevelM_, pushTcLevelM,   getTcLevel, setTcLevel, isTouchableTcM,   getLclTypeEnv, setLclTypeEnv,   traceTcConstraints,   emitNamedTypeHole, IsExtraConstraint(..), emitAnonTypeHole,    -- * Template Haskell context-  recordThUse, recordThSpliceUse,+  recordThUse, recordThSpliceUse, recordThNeededRuntimeDeps,   keepAlive, getStage, getStageAndBindLevel, setStage,   addModFinalizersWithLclEnv, @@ -132,9 +133,9 @@   initIfaceLcl,   initIfaceLclWithSubst,   initIfaceLoad,+  initIfaceLoadModule,   getIfModule,   failIfM,-  forkM_maybe,   forkM,   setImplicitEnvM, @@ -148,8 +149,6 @@   module GHC.Data.IOEnv   ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  @@ -164,6 +163,7 @@ import GHC.Hs hiding (LIE)  import GHC.Unit+import GHC.Unit.Env import GHC.Unit.External import GHC.Unit.Module.Warnings import GHC.Unit.Home.ModInfo@@ -174,8 +174,8 @@ import GHC.Core.FamInstEnv  import GHC.Driver.Env-import GHC.Driver.Ppr import GHC.Driver.Session+import GHC.Driver.Config.Diagnostic  import GHC.Runtime.Context @@ -187,8 +187,9 @@ import GHC.Utils.Outputable as Outputable import GHC.Utils.Error import GHC.Utils.Panic-import GHC.Utils.Misc+import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Logger+import qualified GHC.Data.Strict as Strict  import GHC.Types.Error import GHC.Types.Fixity.Env@@ -203,6 +204,7 @@ import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Types.Name.Ppr+import GHC.Types.Unique.FM ( emptyUFM ) import GHC.Types.Unique.Supply import GHC.Types.Annotations import GHC.Types.Basic( TopLevelFlag, TypeOrKind(..) )@@ -214,9 +216,13 @@ import Data.IORef import Control.Monad +import GHC.Tc.Errors.Types import {-# SOURCE #-} GHC.Tc.Utils.Env    ( tcInitTidyEnv )  import qualified Data.Map as Map+import GHC.Driver.Env.KnotVars+import GHC.Linker.Types+import GHC.Types.Unique.DFM  {- ************************************************************************@@ -233,7 +239,7 @@        -> Module        -> RealSrcSpan        -> TcM r-       -> IO (Messages DecoratedSDoc, Maybe r)+       -> IO (Messages TcRnMessage, Maybe r)                 -- Nothing => error thrown by the thing inside                 -- (error messages should have been printed already) @@ -242,11 +248,10 @@         used_gre_var <- newIORef [] ;         th_var       <- newIORef False ;         th_splice_var<- newIORef False ;-        infer_var    <- newIORef (True, emptyBag) ;+        infer_var    <- newIORef True ;+        infer_reasons_var <- newIORef emptyMessages ;         dfun_n_var   <- newIORef emptyOccSet ;-        type_env_var <- case hsc_type_env_var hsc_env of {-                           Just (_mod, te_var) -> return te_var ;-                           Nothing             -> newIORef emptyNameEnv } ;+        let { type_env_var = hsc_type_env_vars hsc_env };          dependent_files_var <- newIORef [] ;         static_wc_var       <- newIORef emptyWC ;@@ -259,14 +264,17 @@         th_state_var         <- newIORef Map.empty ;         th_remote_state_var  <- newIORef Nothing ;         th_docs_var          <- newIORef Map.empty ;+        th_needed_deps_var   <- newIORef ([], emptyUDFM) ;+        next_wrapper_num     <- newIORef emptyModuleEnv ;         let {              -- bangs to avoid leaking the env (#19356)              !dflags = hsc_dflags hsc_env ;-             !home_unit = hsc_home_unit hsc_env ;+             !mhome_unit = hsc_home_unit_maybe hsc_env;+             !logger = hsc_logger hsc_env ;               maybe_rn_syntax :: forall a. a -> Maybe a ;              maybe_rn_syntax empty_val-                | dopt Opt_D_dump_rn_ast dflags = Just empty_val+                | logHasDumpFlag logger Opt_D_dump_rn_ast = Just empty_val                  | gopt Opt_WriteHie dflags       = Just empty_val @@ -289,7 +297,7 @@                 tcg_th_docs          = th_docs_var,                  tcg_mod            = mod,-                tcg_semantic_mod   = homeModuleInstantiation home_unit mod,+                tcg_semantic_mod   = homeModuleInstantiation mhome_unit mod,                 tcg_src            = hsc_src,                 tcg_rdr_env        = emptyGlobalRdrEnv,                 tcg_fix_env        = emptyNameEnv,@@ -305,6 +313,7 @@                 tcg_ann_env        = emptyAnnEnv,                 tcg_th_used        = th_var,                 tcg_th_splice_used = th_splice_var,+                tcg_th_needed_deps = th_needed_deps_var,                 tcg_exports        = [],                 tcg_imports        = emptyImportAvails,                 tcg_used_gres     = used_gre_var,@@ -339,14 +348,18 @@                 tcg_hpc            = False,                 tcg_main           = Nothing,                 tcg_self_boot      = NoSelfBoot,-                tcg_safeInfer      = infer_var,+                tcg_safe_infer     = infer_var,+                tcg_safe_infer_reasons = infer_reasons_var,                 tcg_dependent_files = dependent_files_var,-                tcg_tc_plugins     = [],+                tcg_tc_plugin_solvers   = [],+                tcg_tc_plugin_rewriters = emptyUFM,+                tcg_defaulting_plugins  = [],                 tcg_hf_plugins     = [],                 tcg_top_loc        = loc,                 tcg_static_wc      = static_wc_var,                 tcg_complete_matches = [],-                tcg_cc_st          = cc_st_var+                tcg_cc_st          = cc_st_var,+                tcg_next_wrapper_num = next_wrapper_num              } ;         } ; @@ -359,7 +372,7 @@               -> TcGblEnv               -> RealSrcSpan               -> TcM r-              -> IO (Messages DecoratedSDoc, Maybe r)+              -> IO (Messages TcRnMessage, Maybe r) initTcWithGbl hsc_env gbl_env loc do_this  = do { lie_var      <- newIORef emptyWC       ; errs_var     <- newIORef emptyMessages@@ -405,7 +418,7 @@       ; return (msgs, final_res)       } -initTcInteractive :: HscEnv -> TcM a -> IO (Messages DecoratedSDoc, Maybe a)+initTcInteractive :: HscEnv -> TcM a -> IO (Messages TcRnMessage, Maybe a) -- Initialise the type checker monad for use in GHCi initTcInteractive hsc_env thing_inside   = initTc hsc_env HsSrcFile False@@ -472,7 +485,7 @@ updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) ->                           env { env_gbl = upd gbl }) -setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a+setGblEnv :: gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env })  getLclEnv :: TcRnIf gbl lcl lcl@@ -482,44 +495,93 @@ updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) ->                           env { env_lcl = upd lcl }) + setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env }) +restoreLclEnv :: TcLclEnv -> TcRnIf gbl TcLclEnv a -> TcRnIf gbl TcLclEnv a+-- See Note [restoreLclEnv vs setLclEnv]+restoreLclEnv new_lcl_env = updLclEnv upd+  where+    upd old_lcl_env =  new_lcl_env { tcl_errs  = tcl_errs  old_lcl_env+                                   , tcl_lie   = tcl_lie   old_lcl_env+                                   , tcl_usage = tcl_usage old_lcl_env }+ getEnvs :: TcRnIf gbl lcl (gbl, lcl) getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) }  setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a-setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env })+setEnvs (gbl_env, lcl_env) = setGblEnv gbl_env . setLclEnv lcl_env +updEnvs :: ((gbl,lcl) -> (gbl, lcl)) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a+updEnvs upd_envs = updEnv upd+  where+    upd env@(Env { env_gbl = gbl, env_lcl = lcl })+      = env { env_gbl = gbl', env_lcl = lcl' }+      where+        !(gbl', lcl') = upd_envs (gbl, lcl)++restoreEnvs :: (TcGblEnv, TcLclEnv) -> TcRn a -> TcRn a+-- See Note [restoreLclEnv vs setLclEnv]+restoreEnvs (gbl, lcl) = setGblEnv gbl . restoreLclEnv lcl++{- Note [restoreLclEnv vs setLclEnv]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the typechecker we use this idiom quite a lot+   do { (gbl_env, lcl_env) <- tcRnSrcDecls ...+      ; setGblEnv gbl_env $ setLclEnv lcl_env $+        more_stuff }++The `tcRnSrcDecls` extends the environments in `gbl_env` and `lcl_env`+which we then want to be in scope in `more stuff`.++The problem is that `lcl_env :: TcLclEnv` has an IORef for error+messages `tcl_errs`, and another for constraints (`tcl_lie`), and+another for Linear Haskell usage information (`tcl_usage`).  Now+suppose we change it a tiny bit+   do { (gbl_env, lcl_env) <- checkNoErrs $+                              tcRnSrcDecls ...+      ; setGblEnv gbl_env $ setLclEnv lcl_env $+        more_stuff }++That should be innocuous.  But *alas*, `checkNoErrs` gathers errors in+a fresh IORef *which is then captured in the returned `lcl_env`.  When+we do the `setLclEnv` we'll make that captured IORef into the place+where we gather error messages -- but no one is going to look at that!!!+This led to #19470 and #20981.++Solution: instead of setLclEnv use restoreLclEnv, which preserves from+the /parent/ context these mutable collection IORefs:+      tcl_errs, tcl_lie, tcl_usage+-}+ -- Command-line flags  xoptM :: LangExt.Extension -> TcRnIf gbl lcl Bool-xoptM flag = do { dflags <- getDynFlags; return (xopt flag dflags) }+xoptM flag = xopt flag <$> getDynFlags  doptM :: DumpFlag -> TcRnIf gbl lcl Bool-doptM flag = do { dflags <- getDynFlags; return (dopt flag dflags) }+doptM flag = do+  logger <- getLogger+  return (logHasDumpFlag logger flag)  goptM :: GeneralFlag -> TcRnIf gbl lcl Bool-goptM flag = do { dflags <- getDynFlags; return (gopt flag dflags) }+goptM flag = gopt flag <$> getDynFlags  woptM :: WarningFlag -> TcRnIf gbl lcl Bool-woptM flag = do { dflags <- getDynFlags; return (wopt flag dflags) }+woptM flag = wopt flag <$> getDynFlags  setXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a-setXOptM flag =-  updTopEnv (\top -> top { hsc_dflags = xopt_set (hsc_dflags top) flag})+setXOptM flag = updTopFlags (\dflags -> xopt_set dflags flag)  unsetXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a-unsetXOptM flag =-  updTopEnv (\top -> top { hsc_dflags = xopt_unset (hsc_dflags top) flag})+unsetXOptM flag = updTopFlags (\dflags -> xopt_unset dflags flag)  unsetGOptM :: GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a-unsetGOptM flag =-  updTopEnv (\top -> top { hsc_dflags = gopt_unset (hsc_dflags top) flag})+unsetGOptM flag = updTopFlags (\dflags -> gopt_unset dflags flag)  unsetWOptM :: WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a-unsetWOptM flag =-  updTopEnv (\top -> top { hsc_dflags = wopt_unset (hsc_dflags top) flag})+unsetWOptM flag = updTopFlags (\dflags -> wopt_unset dflags flag)  -- | Do it flag is true whenDOptM :: DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()@@ -549,23 +611,21 @@ {-# INLINE unlessXOptM #-} -- see Note [INLINE conditional tracing utilities]  getGhcMode :: TcRnIf gbl lcl GhcMode-getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) }--withDynamicNow :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a-withDynamicNow =-  updTopEnv (\top@(HscEnv { hsc_dflags = dflags }) ->-              top { hsc_dflags = setDynamicNow dflags })+getGhcMode = ghcMode <$> getDynFlags  withoutDynamicNow :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a-withoutDynamicNow =-  updTopEnv (\top@(HscEnv { hsc_dflags = dflags }) ->-              top { hsc_dflags = dflags { dynamicNow = False} })+withoutDynamicNow = updTopFlags (\dflags -> dflags { dynamicNow = False}) +updTopFlags :: (DynFlags -> DynFlags) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a+updTopFlags f = updTopEnv (hscUpdateFlags f)+ getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState)-getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) }+getEpsVar = do+  env <- getTopEnv+  return (euc_eps (ue_eps (hsc_unit_env env)))  getEps :: TcRnIf gbl lcl ExternalPackageState-getEps = do { env <- getTopEnv; readMutVar (hsc_EPS env) }+getEps = do { env <- getTopEnv; liftIO $ hscEPS env }  -- | Update the external package state.  Returns the second result of the -- modifier function.@@ -590,18 +650,17 @@ getHpt :: TcRnIf gbl lcl HomePackageTable getHpt = do { env <- getTopEnv; return (hsc_HPT env) } -getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable)-getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env)-                  ; return (eps, hsc_HPT env) }+getEpsAndHug :: TcRnIf gbl lcl (ExternalPackageState, HomeUnitGraph)+getEpsAndHug = do { env <- getTopEnv; eps <- liftIO $ hscEPS env+                  ; return (eps, hsc_HUG env) }  -- | A convenient wrapper for taking a @MaybeErr SDoc a@ and throwing -- an exception if it is an error.-withException :: TcRnIf gbl lcl (MaybeErr SDoc a) -> TcRnIf gbl lcl a-withException do_this = do+withException :: MonadIO m => SDocContext -> m (MaybeErr SDoc a) -> m a+withException ctx do_this = do     r <- do_this-    dflags <- getDynFlags     case r of-        Failed err -> liftIO $ throwGhcExceptionIO (ProgramError (showSDoc dflags err))+        Failed err -> liftIO $ throwGhcExceptionIO (ProgramError (renderWithContext ctx err))         Succeeded result -> return result  {-@@ -708,30 +767,42 @@ ************************************************************************ -} --- Note [INLINE conditional tracing utilities]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~--- In general we want to optimise for the case where tracing is not enabled.--- To ensure this happens, we ensure that traceTc and friends are inlined; this--- ensures that the allocation of the document can be pushed into the tracing--- path, keeping the non-traced path free of this extraneous work. For--- instance, instead of------     let thunk = ...---     in if doTracing---          then emitTraceMsg thunk---          else return ()------ where the conditional is buried in a non-inlined utility function (e.g.--- traceTc), we would rather have:------     if doTracing---       then let thunk = ...---            in emitTraceMsg thunk---       else return ()------ See #18168.---+{- Note [INLINE conditional tracing utilities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In general we want to optimise for the case where tracing is not enabled.+To ensure this happens, we ensure that traceTc and friends are inlined; this+ensures that the allocation of the document can be pushed into the tracing+path, keeping the non-traced path free of this extraneous work. For+instance, if we don't inline traceTc, we'll get +    let stuff_to_print = ...+    in traceTc "wombat" stuff_to_print++and the stuff_to_print thunk will be allocated in the "hot path", regardless+of tracing.  But if we INLINE traceTc we get++    let stuff_to_print = ...+    in if doTracing+         then emitTraceMsg "wombat" stuff_to_print+         else return ()++and then we float in:++    if doTracing+      then let stuff_to_print = ...+           in emitTraceMsg "wombat" stuff_to_print+      else return ()++Now stuff_to_print is allocated only in the "cold path".++Moreover, on the "cold" path, after the conditional, we want to inline+as /little/ as possible.  Performance doesn't matter here, and we'd like+to bloat the caller's code as little as possible.  So we put a NOINLINE+on 'emitTraceMsg'++See #18168.+-}+ -- Typechecker trace traceTc :: String -> SDoc -> TcRn () traceTc herald doc =@@ -776,24 +847,23 @@ -- dumpTcRn :: Bool -> DumpFlag -> String -> DumpFormat -> SDoc -> TcRn () dumpTcRn useUserStyle flag title fmt doc = do-  dflags <- getDynFlags   logger <- getLogger   printer <- getPrintUnqualified   real_doc <- wrapDocLoc doc   let sty = if useUserStyle               then mkUserStyle printer AllTheWay               else mkDumpStyle printer-  liftIO $ putDumpMsg logger dflags sty flag title fmt real_doc+  liftIO $ logDumpFile logger sty flag title fmt real_doc  -- | Add current location if -dppr-debug -- (otherwise the full location is usually way too much) wrapDocLoc :: SDoc -> TcRn SDoc wrapDocLoc doc = do-  dflags <- getDynFlags-  if hasPprDebug dflags+  logger <- getLogger+  if logHasDumpFlag logger Opt_D_ppr_debug     then do       loc <- getSrcSpanM-      return (mkLocMessage SevOutput loc doc)+      return (mkLocMessage MCOutput loc doc)     else       return doc @@ -806,30 +876,26 @@ -- | Like logInfoTcRn, but for user consumption printForUserTcRn :: SDoc -> TcRn () printForUserTcRn doc = do-    dflags <- getDynFlags     logger <- getLogger     printer <- getPrintUnqualified-    liftIO (printOutputForUser logger dflags printer doc)+    liftIO (printOutputForUser logger printer doc)  {--traceIf and traceHiDiffs work in the TcRnIf monad, where no RdrEnv is+traceIf works in the TcRnIf monad, where no RdrEnv is available.  Alas, they behave inconsistently with the other stuff; e.g. are unaffected by -dump-to-file. -} -traceIf, traceHiDiffs :: SDoc -> TcRnIf m n ()-traceIf      = traceOptIf Opt_D_dump_if_trace-traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs+traceIf :: SDoc -> TcRnIf m n ()+traceIf = traceOptIf Opt_D_dump_if_trace {-# INLINE traceIf #-}-{-# INLINE traceHiDiffs #-}   -- see Note [INLINE conditional tracing utilities]  traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n () traceOptIf flag doc   = whenDOptM flag $ do   -- No RdrEnv available, so qualify everything-        dflags <- getDynFlags         logger <- getLogger-        liftIO (putMsg logger dflags doc)+        liftIO (putMsg logger doc) {-# INLINE traceOptIf #-}  -- see Note [INLINE conditional tracing utilities]  {-@@ -898,7 +964,7 @@  getSrcSpanM :: TcRn SrcSpan         -- Avoid clash with Name.getSrcLoc-getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env) Nothing) }+getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env) Strict.Nothing) }  -- See Note [Error contexts in generated code] inGeneratedCode :: TcRn Bool@@ -932,8 +998,7 @@                                             ; return (L loc b) }  wrapLocAM :: (a -> TcM b) -> LocatedAn an a -> TcM (Located b)-wrapLocAM fn (L loc a) = setSrcSpanA loc $ do { b <- fn a-                                              ; return (L (locA loc) b) }+wrapLocAM fn a = wrapLocM fn (reLoc a)  wrapLocMA :: (a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcRn (GenLocated (SrcSpanAnn' ann) b) wrapLocMA fn (L loc a) = setSrcSpanA loc $ do { b <- fn a@@ -945,7 +1010,12 @@     (b,c) <- fn a     return (L loc b, c) -wrapLocFstMA :: (a -> TcM (b,c)) -> LocatedA a -> TcM (LocatedA b, c)+-- Possible instantiations:+--    wrapLocFstMA :: (a -> TcM (b,c)) -> LocatedA    a -> TcM (LocatedA    b, c)+--    wrapLocFstMA :: (a -> TcM (b,c)) -> LocatedN    a -> TcM (LocatedN    b, c)+--    wrapLocFstMA :: (a -> TcM (b,c)) -> LocatedAn t a -> TcM (LocatedAn t b, c)+-- and so on.+wrapLocFstMA :: (a -> TcM (b,c)) -> GenLocated (SrcSpanAnn' ann) a -> TcM (GenLocated (SrcSpanAnn' ann) b, c) wrapLocFstMA fn (L loc a) =   setSrcSpanA loc $ do     (b,c) <- fn a@@ -957,7 +1027,12 @@     (b,c) <- fn a     return (b, L loc c) -wrapLocSndMA :: (a -> TcM (b, c)) -> LocatedA a -> TcM (b, LocatedA c)+-- Possible instantiations:+--    wrapLocSndMA :: (a -> TcM (b, c)) -> LocatedA    a -> TcM (b, LocatedA    c)+--    wrapLocSndMA :: (a -> TcM (b, c)) -> LocatedN    a -> TcM (b, LocatedN    c)+--    wrapLocSndMA :: (a -> TcM (b, c)) -> LocatedAn t a -> TcM (b, LocatedAn t c)+-- and so on.+wrapLocSndMA :: (a -> TcM (b, c)) -> GenLocated (SrcSpanAnn' ann) a -> TcM (b, GenLocated (SrcSpanAnn' ann) c) wrapLocSndMA fn (L loc a) =   setSrcSpanA loc $ do     (b,c) <- fn a@@ -971,44 +1046,44 @@  -- Reporting errors -getErrsVar :: TcRn (TcRef (Messages DecoratedSDoc))+getErrsVar :: TcRn (TcRef (Messages TcRnMessage)) getErrsVar = do { env <- getLclEnv; return (tcl_errs env) } -setErrsVar :: TcRef (Messages DecoratedSDoc) -> TcRn a -> TcRn a+setErrsVar :: TcRef (Messages TcRnMessage) -> TcRn a -> TcRn a setErrsVar v = updLclEnv (\ env -> env { tcl_errs =  v }) -addErr :: SDoc -> TcRn ()+addErr :: TcRnMessage -> TcRn () addErr msg = do { loc <- getSrcSpanM; addErrAt loc msg } -failWith :: SDoc -> TcRn a+failWith :: TcRnMessage -> TcRn a failWith msg = addErr msg >> failM -failAt :: SrcSpan -> SDoc -> TcRn a+failAt :: SrcSpan -> TcRnMessage -> TcRn a failAt loc msg = addErrAt loc msg >> failM -addErrAt :: SrcSpan -> SDoc -> TcRn ()+addErrAt :: SrcSpan -> TcRnMessage -> TcRn () -- addErrAt is mainly (exclusively?) used by the renamer, where -- tidying is not an issue, but it's all lazy so the extra -- work doesn't matter addErrAt loc msg = do { ctxt <- getErrCtxt                       ; tidy_env <- tcInitTidyEnv                       ; err_info <- mkErrInfo tidy_env ctxt-                      ; addLongErrAt loc msg err_info }+                      ; add_long_err_at loc (TcRnMessageDetailed (ErrInfo err_info Outputable.empty) msg) } -addErrs :: [(SrcSpan,SDoc)] -> TcRn ()+addErrs :: [(SrcSpan,TcRnMessage)] -> TcRn () addErrs msgs = mapM_ add msgs              where                add (loc,msg) = addErrAt loc msg -checkErr :: Bool -> SDoc -> TcRn ()+checkErr :: Bool -> TcRnMessage -> TcRn () -- Add the error if the bool is False checkErr ok msg = unless ok (addErr msg) -addMessages :: Messages DecoratedSDoc -> TcRn ()+addMessages :: Messages TcRnMessage -> TcRn () addMessages msgs1-  = do { errs_var <- getErrsVar ;-         msgs0 <- readTcRef errs_var ;-         writeTcRef errs_var (unionMessages msgs0 msgs1) }+  = do { errs_var <- getErrsVar+       ; msgs0    <- readTcRef errs_var+       ; writeTcRef errs_var (msgs0 `unionMessages` msgs1) }  discardWarnings :: TcRn a -> TcRn a -- Ignore warnings inside the thing inside;@@ -1033,60 +1108,39 @@ ************************************************************************ -} -mkLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn (MsgEnvelope DecoratedSDoc)-mkLongErrAt loc msg extra-  = do { printer <- getPrintUnqualified ;-         unit_state <- hsc_units <$> getTopEnv ;-         let msg' = pprWithUnitState unit_state msg in-         return $ mkLongMsgEnvelope loc printer msg' extra }+add_long_err_at :: SrcSpan -> TcRnMessageDetailed -> TcRn ()+add_long_err_at loc msg = mk_long_err_at loc msg >>= reportDiagnostic+  where+    mk_long_err_at :: SrcSpan -> TcRnMessageDetailed -> TcRn (MsgEnvelope TcRnMessage)+    mk_long_err_at loc msg+      = do { printer <- getPrintUnqualified ;+             unit_state <- hsc_units <$> getTopEnv ;+             return $ mkErrorMsgEnvelope loc printer+                    $ TcRnMessageWithInfo unit_state msg+                    } -mkDecoratedSDocAt :: SrcSpan-                  -> SDoc-                  -- ^ The important part of the message-                  -> SDoc-                  -- ^ The context of the message-                  -> SDoc-                  -- ^ Any supplementary information.-                  -> TcRn (MsgEnvelope DecoratedSDoc)-mkDecoratedSDocAt loc important context extra+mkTcRnMessage :: SrcSpan+              -> TcRnMessage+              -> TcRn (MsgEnvelope TcRnMessage)+mkTcRnMessage loc msg   = do { printer <- getPrintUnqualified ;-         unit_state <- hsc_units <$> getTopEnv ;-         let f = pprWithUnitState unit_state-             errDoc  = [important, context, extra]-             errDoc' = mkDecorated $ map f errDoc-         in-         return $ mkErr loc printer errDoc' }--addLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn ()-addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError+         diag_opts <- initDiagOpts <$> getDynFlags ;+         return $ mkMsgEnvelope diag_opts loc printer msg } -reportErrors :: [MsgEnvelope DecoratedSDoc] -> TcM ()-reportErrors = mapM_ reportError+reportDiagnostics :: [MsgEnvelope TcRnMessage] -> TcM ()+reportDiagnostics = mapM_ reportDiagnostic -reportError :: MsgEnvelope DecoratedSDoc -> TcRn ()-reportError err-  = do { traceTc "Adding error:" (pprLocMsgEnvelope err) ;+reportDiagnostic :: MsgEnvelope TcRnMessage -> TcRn ()+reportDiagnostic msg+  = do { traceTc "Adding diagnostic:" (pprLocMsgEnvelope msg) ;          errs_var <- getErrsVar ;          msgs     <- readTcRef errs_var ;-         writeTcRef errs_var (err `addMessage` msgs) }--reportWarning :: WarnReason -> MsgEnvelope DecoratedSDoc -> TcRn ()-reportWarning reason err-  = do { let warn = makeIntoWarning reason err-                    -- 'err' was built by mkLongMsgEnvelope or something like that,-                    -- so it's of error severity.  For a warning we downgrade-                    -- its severity to SevWarning--       ; traceTc "Adding warning:" (pprLocMsgEnvelope warn)-       ; errs_var <- getErrsVar-       ; (warns, errs) <- partitionMessages <$> readTcRef errs_var-       ; writeTcRef errs_var (mkMessages $ (warns `snocBag` warn) `unionBags` errs) }-+         writeTcRef errs_var (msg `addMessage` msgs) }  ----------------------- checkNoErrs :: TcM r -> TcM r -- (checkNoErrs m) succeeds iff m succeeds and generates no errors--- If m fails then (checkNoErrsTc m) fails.+-- If m fails then (checkNoErrs m) fails. -- If m succeeds, it checks whether m generated any errors messages --      (it might have recovered internally) --      If so, it fails too.@@ -1206,10 +1260,10 @@ getCtLocM :: CtOrigin -> Maybe TypeOrKind -> TcM CtLoc getCtLocM origin t_or_k   = do { env <- getLclEnv-       ; return (CtLoc { ctl_origin = origin-                       , ctl_env    = env-                       , ctl_t_or_k = t_or_k-                       , ctl_depth  = initialSubGoalDepth }) }+       ; return (CtLoc { ctl_origin   = origin+                       , ctl_env      = env+                       , ctl_t_or_k   = t_or_k+                       , ctl_depth    = initialSubGoalDepth }) }  setCtLocM :: CtLoc -> TcM a -> TcM a -- Set the SrcSpan and error context from the CtLoc@@ -1254,7 +1308,7 @@        ; lie <- readTcRef lie_var        ; return (res, lie) } -capture_messages :: TcM r -> TcM (r, Messages DecoratedSDoc)+capture_messages :: TcM r -> TcM (r, Messages TcRnMessage) -- capture_messages simply captures and returns the --                  errors arnd warnings generated by thing_inside -- Precondition: thing_inside must not throw an exception!@@ -1337,10 +1391,8 @@ -- returned usage information into the larger context appropriately. tcCollectingUsage :: TcM a -> TcM (UsageEnv,a) tcCollectingUsage thing_inside-  = do { env0 <- getLclEnv-       ; local_usage_ref <- newTcRef zeroUE-       ; let env1 = env0 { tcl_usage = local_usage_ref }-       ; result <- setLclEnv env1 thing_inside+  = do { local_usage_ref <- newTcRef zeroUE+       ; result <- updLclEnv (\env -> env { tcl_usage = local_usage_ref }) thing_inside        ; local_usage <- readTcRef local_usage_ref        ; return (local_usage,result) } @@ -1424,7 +1476,7 @@                                 Just acc' -> foldAndRecoverM f acc' xs  }  ------------------------tryTc :: TcRn a -> TcRn (Maybe a, Messages DecoratedSDoc)+tryTc :: TcRn a -> TcRn (Maybe a, Messages TcRnMessage) -- (tryTc m) executes m, and returns --      Just r,  if m succeeds (returning r) --      Nothing, if m fails@@ -1477,11 +1529,11 @@     tidy up the message; we then use it to tidy the context messages -} -addErrTc :: SDoc -> TcM ()+addErrTc :: TcRnMessage -> TcM () addErrTc err_msg = do { env0 <- tcInitTidyEnv                       ; addErrTcM (env0, err_msg) } -addErrTcM :: (TidyEnv, SDoc) -> TcM ()+addErrTcM :: (TidyEnv, TcRnMessage) -> TcM () addErrTcM (tidy_env, err_msg)   = do { ctxt <- getErrCtxt ;          loc  <- getSrcSpanM ;@@ -1489,27 +1541,27 @@  -- The failWith functions add an error message and cause failure -failWithTc :: SDoc -> TcM a               -- Add an error message and fail+failWithTc :: TcRnMessage -> TcM a               -- Add an error message and fail failWithTc err_msg   = addErrTc err_msg >> failM -failWithTcM :: (TidyEnv, SDoc) -> TcM a   -- Add an error message and fail+failWithTcM :: (TidyEnv, TcRnMessage) -> TcM a   -- Add an error message and fail failWithTcM local_and_msg   = addErrTcM local_and_msg >> failM -checkTc :: Bool -> SDoc -> TcM ()         -- Check that the boolean is true+checkTc :: Bool -> TcRnMessage -> TcM ()         -- Check that the boolean is true checkTc True  _   = return () checkTc False err = failWithTc err -checkTcM :: Bool -> (TidyEnv, SDoc) -> TcM ()+checkTcM :: Bool -> (TidyEnv, TcRnMessage) -> TcM () checkTcM True  _   = return () checkTcM False err = failWithTcM err -failIfTc :: Bool -> SDoc -> TcM ()         -- Check that the boolean is false+failIfTc :: Bool -> TcRnMessage -> TcM ()         -- Check that the boolean is false failIfTc False _   = return () failIfTc True  err = failWithTc err -failIfTcM :: Bool -> (TidyEnv, SDoc) -> TcM ()+failIfTcM :: Bool -> (TidyEnv, TcRnMessage) -> TcM ()    -- Check that the boolean is false failIfTcM False _   = return () failIfTcM True  err = failWithTcM err@@ -1517,66 +1569,77 @@  --         Warnings have no 'M' variant, nor failure --- | Display a warning if a condition is met,---   and the warning is enabled-warnIfFlag :: WarningFlag -> Bool -> SDoc -> TcRn ()-warnIfFlag warn_flag is_bad msg-  = do { warn_on <- woptM warn_flag-       ; when (warn_on && is_bad) $-         addWarn (Reason warn_flag) msg }- -- | Display a warning if a condition is met.-warnIf :: Bool -> SDoc -> TcRn ()-warnIf is_bad msg-  = when is_bad (addWarn NoReason msg)+warnIf :: Bool -> TcRnMessage -> TcRn ()+warnIf is_bad msg -- No need to check any flag here, it will be done in 'diagReasonSeverity'.+  = when is_bad (addDiagnostic msg) --- | Display a warning if a condition is met.-warnTc :: WarnReason -> Bool -> SDoc -> TcM ()-warnTc reason warn_if_true warn_msg-  | warn_if_true = addWarnTc reason warn_msg-  | otherwise    = return ()+no_err_info :: ErrInfo+no_err_info = ErrInfo Outputable.empty Outputable.empty  -- | Display a warning if a condition is met.-warnTcM :: WarnReason -> Bool -> (TidyEnv, SDoc) -> TcM ()-warnTcM reason warn_if_true warn_msg-  | warn_if_true = addWarnTcM reason warn_msg-  | otherwise    = return ()+diagnosticTc :: Bool -> TcRnMessage -> TcM ()+diagnosticTc should_report warn_msg+  | should_report = addDiagnosticTc warn_msg+  | otherwise     = return () --- | Display a warning in the current context.-addWarnTc :: WarnReason -> SDoc -> TcM ()-addWarnTc reason msg+-- | Display a diagnostic if a condition is met.+diagnosticTcM :: Bool -> (TidyEnv, TcRnMessage) -> TcM ()+diagnosticTcM should_report warn_msg+  | should_report = addDiagnosticTcM warn_msg+  | otherwise     = return ()++-- | Display a diagnostic in the current context.+addDiagnosticTc :: TcRnMessage -> TcM ()+addDiagnosticTc msg  = do { env0 <- tcInitTidyEnv ;-      addWarnTcM reason (env0, msg) }+      addDiagnosticTcM (env0, msg) } --- | Display a warning in a given context.-addWarnTcM :: WarnReason -> (TidyEnv, SDoc) -> TcM ()-addWarnTcM reason (env0, msg)- = do { ctxt <- getErrCtxt ;-        err_info <- mkErrInfo env0 ctxt ;-        add_warn reason msg err_info }+-- | Display a diagnostic in a given context.+addDiagnosticTcM :: (TidyEnv, TcRnMessage) -> TcM ()+addDiagnosticTcM (env0, msg)+ = do { ctxt <- getErrCtxt+      ; extra <- mkErrInfo env0 ctxt+      ; let err_info = ErrInfo extra Outputable.empty+      ; add_diagnostic (TcRnMessageDetailed err_info msg) } --- | Display a warning for the current source location.-addWarn :: WarnReason -> SDoc -> TcRn ()-addWarn reason msg = add_warn reason msg Outputable.empty+-- | A variation of 'addDiagnostic' that takes a function to produce a 'TcRnDsMessage'+-- given some additional context about the diagnostic.+addDetailedDiagnostic :: (ErrInfo -> TcRnMessage) -> TcM ()+addDetailedDiagnostic mkMsg = do+  loc <- getSrcSpanM+  printer <- getPrintUnqualified+  !diag_opts  <- initDiagOpts <$> getDynFlags+  env0 <- tcInitTidyEnv+  ctxt <- getErrCtxt+  err_info <- mkErrInfo env0 ctxt+  reportDiagnostic (mkMsgEnvelope diag_opts loc printer (mkMsg (ErrInfo err_info empty))) --- | Display a warning for a given source location.-addWarnAt :: WarnReason -> SrcSpan -> SDoc -> TcRn ()-addWarnAt reason loc msg = add_warn_at reason loc msg Outputable.empty+addTcRnDiagnostic :: TcRnMessage -> TcM ()+addTcRnDiagnostic msg = do+  loc <- getSrcSpanM+  mkTcRnMessage loc msg >>= reportDiagnostic --- | Display a warning, with an optional flag, for the current source+-- | Display a diagnostic for the current source location, taken from+-- the 'TcRn' monad.+addDiagnostic :: TcRnMessage -> TcRn ()+addDiagnostic msg = add_diagnostic (TcRnMessageDetailed no_err_info msg)++-- | Display a diagnostic for a given source location.+addDiagnosticAt :: SrcSpan -> TcRnMessage -> TcRn ()+addDiagnosticAt loc msg = do+  unit_state <- hsc_units <$> getTopEnv+  let dia = TcRnMessageDetailed no_err_info msg+  mkTcRnMessage loc (TcRnMessageWithInfo unit_state dia) >>= reportDiagnostic++-- | Display a diagnostic, with an optional flag, for the current source -- location.-add_warn :: WarnReason -> SDoc -> SDoc -> TcRn ()-add_warn reason msg extra_info+add_diagnostic :: TcRnMessageDetailed -> TcRn ()+add_diagnostic msg   = do { loc <- getSrcSpanM-       ; add_warn_at reason loc msg extra_info }---- | Display a warning, with an optional flag, for a given location.-add_warn_at :: WarnReason -> SrcSpan -> SDoc -> SDoc -> TcRn ()-add_warn_at reason loc msg extra_info-  = do { printer <- getPrintUnqualified ;-         let { warn = mkLongWarnMsg loc printer-                                    msg extra_info } ;-         reportWarning reason warn }+       ; unit_state <- hsc_units <$> getTopEnv+       ; mkTcRnMessage loc (TcRnMessageWithInfo unit_state msg) >>= reportDiagnostic+       }   {-@@ -1584,12 +1647,12 @@         Other helper functions -} -add_err_tcm :: TidyEnv -> SDoc -> SrcSpan+add_err_tcm :: TidyEnv -> TcRnMessage -> SrcSpan             -> [ErrCtxt]             -> TcM ()-add_err_tcm tidy_env err_msg loc ctxt+add_err_tcm tidy_env msg loc ctxt  = do { err_info <- mkErrInfo tidy_env ctxt ;-        addLongErrAt loc err_msg err_info }+        add_long_err_at loc (TcRnMessageDetailed (ErrInfo err_info Outputable.empty) msg) }  mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc -- Tidy the error info, trimming excessive contexts@@ -1753,6 +1816,12 @@        ; lie_var <- getConstraintVar        ; updTcRef lie_var (`addInsols` unitBag ct) } +emitDelayedErrors :: Bag DelayedError -> TcM ()+emitDelayedErrors errs+  = do { traceTc "emitDelayedErrors" (ppr errs)+       ; lie_var <- getConstraintVar+       ; updTcRef lie_var (`addDelayedErrors` errs)}+ emitHole :: Hole -> TcM () emitHole hole   = do { traceTc "emitHole" (ppr hole)@@ -1765,6 +1834,12 @@        ; lie_var <- getConstraintVar        ; updTcRef lie_var (`addHoles` holes) } +emitNotConcreteError :: NotConcreteError -> TcM ()+emitNotConcreteError err+  = do { traceTc "emitNotConcreteError" (ppr err)+       ; lie_var <- getConstraintVar+       ; updTcRef lie_var (`addNotConcreteError` err) }+ -- | Throw out any constraints emitted by the thing_inside discardConstraints :: TcM a -> TcM a discardConstraints thing_inside = fst <$> captureConstraints thing_inside@@ -1772,10 +1847,10 @@ -- | The name says it all. The returned TcLevel is the *inner* TcLevel. pushLevelAndCaptureConstraints :: TcM a -> TcM (TcLevel, WantedConstraints, a) pushLevelAndCaptureConstraints thing_inside-  = do { env <- getLclEnv-       ; let tclvl' = pushTcLevel (tcl_tclvl env)+  = do { tclvl <- getTcLevel+       ; let tclvl' = pushTcLevel tclvl        ; traceTc "pushLevelAndCaptureConstraints {" (ppr tclvl')-       ; (res, lie) <- setLclEnv (env { tcl_tclvl = tclvl' }) $+       ; (res, lie) <- updLclEnv (\env -> env { tcl_tclvl = tclvl' }) $                        captureConstraints thing_inside        ; traceTc "pushLevelAndCaptureConstraints }" (ppr tclvl')        ; return (tclvl', lie, res) }@@ -1786,21 +1861,11 @@ pushTcLevelM :: TcM a -> TcM (TcLevel, a) -- See Note [TcLevel assignment] in GHC.Tc.Utils.TcType pushTcLevelM thing_inside-  = do { env <- getLclEnv-       ; let tclvl' = pushTcLevel (tcl_tclvl env)-       ; res <- setLclEnv (env { tcl_tclvl = tclvl' })-                          thing_inside+  = do { tclvl <- getTcLevel+       ; let tclvl' = pushTcLevel tclvl+       ; res <- updLclEnv (\env -> env { tcl_tclvl = tclvl' }) thing_inside        ; return (tclvl', res) } --- Returns pushed TcLevel-pushTcLevelsM :: Int -> TcM a -> TcM (a, TcLevel)-pushTcLevelsM num_levels thing_inside-  = do { env <- getLclEnv-       ; let tclvl' = nTimes num_levels pushTcLevel (tcl_tclvl env)-       ; res <- setLclEnv (env { tcl_tclvl = tclvl' }) $-                thing_inside-       ; return (res, tclvl') }- getTcLevel :: TcM TcLevel getTcLevel = do { env <- getLclEnv                 ; return (tcl_tclvl env) }@@ -1955,6 +2020,15 @@ recordThSpliceUse :: TcM () recordThSpliceUse = do { env <- getGblEnv; writeTcRef (tcg_th_splice_used env) True } +recordThNeededRuntimeDeps :: [Linkable] -> PkgsLoaded -> TcM ()+recordThNeededRuntimeDeps new_links new_pkgs+  = do { env <- getGblEnv+       ; updTcRef (tcg_th_needed_deps env) $ \(needed_links, needed_pkgs) ->+           let links = new_links ++ needed_links+               !pkgs = plusUDFM needed_pkgs new_pkgs+               in (links, pkgs)+       }+ keepAlive :: Name -> TcRn ()     -- Record the name in the keep-alive set keepAlive name   = do { env <- getGblEnv@@ -1994,14 +2068,15 @@ -- | Mark that safe inference has failed -- See Note [Safe Haskell Overlapping Instances Implementation] -- although this is used for more than just that failure case.-recordUnsafeInfer :: WarningMessages -> TcM ()-recordUnsafeInfer warns =-    getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) (False, warns)+recordUnsafeInfer :: Messages TcRnMessage -> TcM ()+recordUnsafeInfer msgs =+    getGblEnv >>= \env -> do writeTcRef (tcg_safe_infer env) False+                             writeTcRef (tcg_safe_infer_reasons env) msgs  -- | Figure out the final correct safe haskell mode finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode finalSafeMode dflags tcg_env = do-    safeInf <- fst <$> readIORef (tcg_safeInfer tcg_env)+    safeInf <- readIORef (tcg_safe_infer tcg_env)     return $ case safeHaskell dflags of         Sf_None | safeInferOn dflags && safeInf -> Sf_SafeInferred                 | otherwise                     -> Sf_None@@ -2055,43 +2130,49 @@   = do  { tcg_env <- getGblEnv         ; hsc_env <- getTopEnv           -- bangs to avoid leaking the envs (#19356)-        ; let !mod = tcg_semantic_mod tcg_env-              !home_unit = hsc_home_unit hsc_env+        ; let !mhome_unit = hsc_home_unit_maybe hsc_env+              !knot_vars = tcg_type_env_var tcg_env               -- When we are instantiating a signature, we DEFINITELY               -- do not want to knot tie.-              is_instantiate = isHomeUnitInstantiating home_unit+              is_instantiate = fromMaybe False (isHomeUnitInstantiating <$> mhome_unit)         ; let { if_env = IfGblEnv {                             if_doc = text "initIfaceTcRn",                             if_rec_types =                                 if is_instantiate-                                    then Nothing-                                    else Just (mod, get_type_env)+                                    then emptyKnotVars+                                    else readTcRef <$> knot_vars+                            }                          }-              ; get_type_env = readTcRef (tcg_type_env_var tcg_env) }         ; setEnvs (if_env, ()) thing_inside } --- Used when sucking in a ModIface into a ModDetails to put in--- the HPT.  Notably, unlike initIfaceCheck, this does NOT use--- hsc_type_env_var (since we're not actually going to typecheck,--- so this variable will never get updated!)+-- | 'initIfaceLoad' can be used when there's no chance that the action will+-- call 'typecheckIface' when inside a module loop and hence 'tcIfaceGlobal'. initIfaceLoad :: HscEnv -> IfG a -> IO a initIfaceLoad hsc_env do_this  = do let gbl_env = IfGblEnv {                         if_doc = text "initIfaceLoad",-                        if_rec_types = Nothing+                        if_rec_types = emptyKnotVars                     }+      initTcRnIf 'i' (hsc_env { hsc_type_env_vars = emptyKnotVars }) gbl_env () do_this++-- | This is used when we are doing to call 'typecheckModule' on an 'ModIface',+-- if it's part of a loop with some other modules then we need to use their+-- IORef TypeEnv vars when typechecking but crucially not our own.+initIfaceLoadModule :: HscEnv -> Module -> IfG a -> IO a+initIfaceLoadModule hsc_env this_mod do_this+ = do let gbl_env = IfGblEnv {+                        if_doc = text "initIfaceLoadModule",+                        if_rec_types = readTcRef <$> knotVarsWithout this_mod (hsc_type_env_vars hsc_env)+                    }       initTcRnIf 'i' hsc_env gbl_env () do_this  initIfaceCheck :: SDoc -> HscEnv -> IfG a -> IO a -- Used when checking the up-to-date-ness of the old Iface -- Initialise the environment with no useful info at all initIfaceCheck doc hsc_env do_this- = do let rec_types = case hsc_type_env_var hsc_env of-                         Just (mod,var) -> Just (mod, readTcRef var)-                         Nothing        -> Nothing-          gbl_env = IfGblEnv {+ = do let gbl_env = IfGblEnv {                         if_doc = text "initIfaceCheck" <+> doc,-                        if_rec_types = rec_types+                        if_rec_types = readTcRef <$> hsc_type_env_vars hsc_env                     }       initTcRnIf 'i' hsc_env gbl_env () do_this @@ -2117,9 +2198,8 @@ failIfM msg = do     env <- getLclEnv     let full_msg = (if_loc env <> colon) $$ nest 2 msg-    dflags <- getDynFlags     logger <- getLogger-    liftIO (putLogMsg logger dflags NoReason SevFatal+    liftIO (logMsg logger MCFatal              noSrcSpan $ withPprStyle defaultErrStyle full_msg)     failM @@ -2128,14 +2208,14 @@ -- | Run thing_inside in an interleaved thread. -- It shares everything with the parent thread, so this is DANGEROUS. ----- It returns Nothing if the computation fails+-- It throws an error if the computation fails -- -- It's used for lazily type-checking interface -- signatures, which is pretty benign. ----- See Note [Masking exceptions in forkM_maybe]-forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a)-forkM_maybe doc thing_inside+-- See Note [Masking exceptions in forkM]+forkM :: SDoc -> IfL a -> IfL a+forkM doc thing_inside  = unsafeInterleaveM $ uninterruptibleMaskM_ $     do { traceIf (text "Starting fork {" <+> doc)        ; mb_res <- tryM $@@ -2143,48 +2223,37 @@                    thing_inside        ; case mb_res of             Right r  -> do  { traceIf (text "} ending fork" <+> doc)-                            ; return (Just r) }+                            ; return r }             Left exn -> do {                 -- Bleat about errors in the forked thread, if -ddump-if-trace is on                 -- Otherwise we silently discard errors. Errors can legitimately-                -- happen when compiling interface signatures (see tcInterfaceSigs)+                -- happen when compiling interface signatures.                   whenDOptM Opt_D_dump_if_trace $ do-                      dflags <- getDynFlags                       logger <- getLogger                       let msg = hang (text "forkM failed:" <+> doc)                                    2 (text (show exn))-                      liftIO $ putLogMsg logger dflags-                                         NoReason-                                         SevFatal+                      liftIO $ logMsg logger+                                         MCFatal                                          noSrcSpan                                          $ withPprStyle defaultErrStyle msg-                 ; traceIf (text "} ending fork (badly)" <+> doc)-                ; return Nothing }+                ; pgmError "Cannot continue after interface file error" }     } -forkM :: SDoc -> IfL a -> IfL a-forkM doc thing_inside- = do   { mb_res <- forkM_maybe doc thing_inside-        ; return (case mb_res of-                        Nothing -> pgmError "Cannot continue after interface file error"-                                   -- pprPanic "forkM" doc-                        Just r  -> r) }- setImplicitEnvM :: TypeEnv -> IfL a -> IfL a setImplicitEnvM tenv m = updLclEnv (\lcl -> lcl                                      { if_implicits_env = Just tenv }) m  {--Note [Masking exceptions in forkM_maybe]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [Masking exceptions in forkM]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  When using GHC-as-API it must be possible to interrupt snippets of code executed using runStmt (#1381). Since commit 02c4ab04 this is almost possible by throwing an asynchronous interrupt to the GHC thread. However, there is a subtle problem: runStmt first typechecks the code before running it, and the exception might interrupt the type checker rather than the code. Moreover, the-typechecker might be inside an unsafeInterleaveIO (through forkM_maybe), and+typechecker might be inside an unsafeInterleaveIO (through forkM), and more importantly might be inside an exception handler inside that unsafeInterleaveIO. If that is the case, the exception handler will rethrow the asynchronous exception as a synchronous exception, and the exception will end
compiler/GHC/Tc/Utils/TcMType.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP             #-}+ {-# LANGUAGE MultiWayIf      #-} {-# LANGUAGE TupleSections   #-} @@ -25,7 +25,7 @@   newOpenFlexiTyVar, newOpenFlexiTyVarTy, newOpenTypeKind,   newOpenBoxedTypeKind,   newMetaKindVar, newMetaKindVars, newMetaTyVarTyAtLevel,-  newAnonMetaTyVar, cloneMetaTyVar,+  newAnonMetaTyVar, newConcreteTyVar, cloneMetaTyVar,   newCycleBreakerTyVar,    newMultiplicityVar,@@ -36,9 +36,9 @@   --------------------------------   -- Creating new evidence variables   newEvVar, newEvVars, newDict,-  newWanted, newWanteds, cloneWanted, cloneWC,+  newWantedWithLoc, newWanted, newWanteds, cloneWanted, cloneWC, cloneWantedCtEv,   emitWanted, emitWantedEq, emitWantedEvVar, emitWantedEvVars,-  emitDerivedEqs,+  emitWantedEqs,   newTcEvBinds, newNoTcEvBinds, addTcEvBind,   emitNewExprHole, @@ -46,6 +46,8 @@   unpackCoercionHole, unpackCoercionHole_maybe,   checkCoercionHole, +  ConcreteHole, newConcreteHole,+   newImplication,    --------------------------------@@ -58,84 +60,98 @@   --------------------------------   -- Expected types   ExpType(..), ExpSigmaType, ExpRhoType,-  mkCheckExpType, newInferExpType, tcInfer,+  mkCheckExpType, newInferExpType, newInferExpTypeFRR,+  tcInfer, tcInferFRR,   readExpType, readExpType_maybe, readScaledExpType,   expTypeToType, scaledExpTypeToType,   checkingExpType_maybe, checkingExpType,-  inferResultToType, fillInferResult, promoteTcType,+  inferResultToType, ensureMonoType, promoteTcType,    --------------------------------   -- Zonking and tidying-  zonkTidyTcType, zonkTidyTcTypes, zonkTidyOrigin,-  tidyEvVar, tidyCt, tidyHole, tidySkolemInfo,+  zonkTidyTcType, zonkTidyTcTypes, zonkTidyOrigin, zonkTidyOrigins,+  zonkTidyFRRInfos,+  tidyEvVar, tidyCt, tidyHole, tidyDelayedError,     zonkTcTyVar, zonkTcTyVars,-  zonkTcTyVarToTyVar, zonkInvisTVBinder,+  zonkTcTyVarToTcTyVar, zonkTcTyVarsToTcTyVars,+  zonkInvisTVBinder,   zonkTyCoVarsAndFV, zonkTcTypeAndFV, zonkDTyCoVarSetAndFV,   zonkTyCoVarsAndFVList,    zonkTcType, zonkTcTypes, zonkCo,-  zonkTyCoVarKind, zonkTyCoVarKindBinder,+  zonkTyCoVarKind,   zonkEvVar, zonkWC, zonkImplication, zonkSimples,   zonkId, zonkCoVar,-  zonkCt, zonkSkolemInfo,+  zonkCt, zonkSkolemInfo, zonkSkolemInfoAnon,    ---------------------------------   -- Promotion, defaulting, skolemisation   defaultTyVar, promoteMetaTyVarTo, promoteTyVarSet,   quantifyTyVars, isQuantifiableTv,-  skolemiseUnboundMetaTyVar, zonkAndSkolemise, skolemiseQuantifiedTyVar,+  zonkAndSkolemise, skolemiseQuantifiedTyVar,   doNotQuantifyTyVars,    candidateQTyVarsOfType,  candidateQTyVarsOfKind,   candidateQTyVarsOfTypes, candidateQTyVarsOfKinds,+  candidateQTyVarsWithBinders,   CandidatesQTvs(..), delCandidates,   candidateKindVars, partitionCandidates,    -------------------------------  -- Levity polymorphism-  ensureNotLevPoly, checkForLevPoly, checkForLevPolyX, formatLevPolyErr-  ) where+  -- Representation polymorphism+  checkTypeHasFixedRuntimeRep, -#include "GhclibHsVersions.h"+  ------------------------------+  -- Other+  anyUnfilledCoercionHoles+  ) where --- friends: import GHC.Prelude -import {-# SOURCE #-}   GHC.Tc.Utils.Unify( unifyType {- , unifyKind -} )+import GHC.Driver.Session+import qualified GHC.LanguageExtensions as LangExt +import GHC.Tc.Types.Origin+import GHC.Tc.Utils.Monad        -- TcType, amongst others+import GHC.Tc.Types.Constraint+import GHC.Tc.Types.Evidence+import GHC.Tc.Utils.TcType+import GHC.Tc.Errors.Types+import GHC.Tc.Errors.Ppr+ import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Ppr-import GHC.Tc.Utils.TcType import GHC.Core.Type import GHC.Core.TyCon import GHC.Core.Coercion import GHC.Core.Class-import GHC.Types.Var import GHC.Core.Predicate-import GHC.Tc.Types.Origin+import GHC.Core.InstEnv (ClsInst(is_tys)) --- others:-import GHC.Tc.Utils.Monad        -- TcType, amongst others-import GHC.Tc.Types.Constraint-import GHC.Tc.Types.Evidence+import GHC.Types.Var import GHC.Types.Id as Id import GHC.Types.Name import GHC.Types.Var.Set+ import GHC.Builtin.Types+import GHC.Types.Error import GHC.Types.Var.Env-import GHC.Types.Name.Env-import GHC.Utils.Misc-import GHC.Utils.Outputable-import GHC.Utils.Panic+import GHC.Types.Unique.Set+import GHC.Types.Basic ( TypeOrKind(..)+                       , NonStandardDefaultingStrategy(..)+                       , DefaultingStrategy(..), defaultNonStandardTyVars )+ import GHC.Data.FastString import GHC.Data.Bag import GHC.Data.Pair-import GHC.Types.Unique.Set-import GHC.Driver.Session-import GHC.Driver.Ppr-import qualified GHC.LanguageExtensions as LangExt-import GHC.Types.Basic ( TypeOrKind(..) ) +import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.Trace+ import Control.Monad import GHC.Data.Maybe import qualified Data.Semigroup as Semi@@ -179,17 +195,27 @@ newEvVar ty = do { name <- newSysName (predTypeOccName ty)                  ; return (mkLocalIdOrCoVar name Many ty) } +-- | Create a new Wanted constraint with the given 'CtLoc'.+newWantedWithLoc :: CtLoc -> PredType -> TcM CtEvidence+newWantedWithLoc loc pty+  = do dst <- case classifyPredType pty of+                EqPred {} -> HoleDest  <$> newCoercionHole pty+                _         -> EvVarDest <$> newEvVar pty+       return $ CtWanted { ctev_dest      = dst+                         , ctev_pred      = pty+                         , ctev_loc       = loc+                         , ctev_rewriters = emptyRewriterSet }++-- | Create a new Wanted constraint with the given 'CtOrigin', and+-- location information taken from the 'TcM' environment. newWanted :: CtOrigin -> Maybe TypeOrKind -> PredType -> TcM CtEvidence -- Deals with both equality and non-equality predicates newWanted orig t_or_k pty   = do loc <- getCtLocM orig t_or_k-       d <- if isEqPrimPred pty then HoleDest  <$> newCoercionHole pty-                                else EvVarDest <$> newEvVar pty-       return $ CtWanted { ctev_dest = d-                         , ctev_pred = pty-                         , ctev_nosh = WDeriv-                         , ctev_loc = loc }+       newWantedWithLoc loc pty +-- | Create new Wanted constraints with the given 'CtOrigin',+-- and location information taken from the 'TcM' environment. newWanteds :: CtOrigin -> ThetaType -> TcM [CtEvidence] newWanteds orig = mapM (newWanted orig Nothing) @@ -197,14 +223,18 @@ -- Cloning constraints ---------------------------------------------- -cloneWanted :: Ct -> TcM Ct-cloneWanted ct-  | ev@(CtWanted { ctev_pred = pty, ctev_dest = HoleDest _ }) <- ctEvidence ct+cloneWantedCtEv :: CtEvidence -> TcM CtEvidence+cloneWantedCtEv ctev@(CtWanted { ctev_pred = pty, ctev_dest = HoleDest _ })+  | isEqPrimPred pty   = do { co_hole <- newCoercionHole pty-       ; return (mkNonCanonical (ev { ctev_dest = HoleDest co_hole })) }+       ; return (ctev { ctev_dest = HoleDest co_hole }) }   | otherwise-  = return ct+  = pprPanic "cloneWantedCtEv" (ppr pty)+cloneWantedCtEv ctev = return ctev +cloneWanted :: Ct -> TcM Ct+cloneWanted ct = mkNonCanonical <$> cloneWantedCtEv (ctEvidence ct)+ cloneWC :: WantedConstraints -> TcM WantedConstraints -- Clone all the evidence bindings in --   a) the ic_bind field of any implications@@ -233,19 +263,13 @@        ; emitSimple $ mkNonCanonical ev        ; return $ ctEvTerm ev } -emitDerivedEqs :: CtOrigin -> [(TcType,TcType)] -> TcM ()--- Emit some new derived nominal equalities-emitDerivedEqs origin pairs+emitWantedEqs :: CtOrigin -> [(TcType,TcType)] -> TcM ()+-- Emit some new wanted nominal equalities+emitWantedEqs origin pairs   | null pairs   = return ()   | otherwise-  = do { loc <- getCtLocM origin Nothing-       ; emitSimples (listToBag (map (mk_one loc) pairs)) }-  where-    mk_one loc (ty1, ty2)-       = mkNonCanonical $-         CtDerived { ctev_pred = mkPrimEqPred ty1 ty2-                   , ctev_loc = loc }+  = mapM_ (uncurry (emitWantedEq origin TypeLevel Nominal)) pairs  -- | Emits a new equality constraint emitWantedEq :: CtOrigin -> TypeOrKind -> Role -> TcType -> TcType -> TcM Coercion@@ -253,8 +277,10 @@   = do { hole <- newCoercionHole pty        ; loc <- getCtLocM origin (Just t_or_k)        ; emitSimple $ mkNonCanonical $-         CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole-                  , ctev_nosh = WDeriv, ctev_loc = loc }+         CtWanted { ctev_pred = pty+                  , ctev_dest = HoleDest hole+                  , ctev_loc = loc+                  , ctev_rewriters = rewriterSetFromTypes [ty1, ty2] }        ; return (HoleCo hole) }   where     pty = mkPrimEqPredRole role ty1 ty2@@ -265,10 +291,10 @@ emitWantedEvVar origin ty   = do { new_cv <- newEvVar ty        ; loc <- getCtLocM origin Nothing-       ; let ctev = CtWanted { ctev_dest = EvVarDest new_cv-                             , ctev_pred = ty-                             , ctev_nosh = WDeriv-                             , ctev_loc  = loc }+       ; let ctev = CtWanted { ctev_dest      = EvVarDest new_cv+                             , ctev_pred      = ty+                             , ctev_loc       = loc+                             , ctev_rewriters = emptyRewriterSet }        ; emitSimple $ mkNonCanonical ctev        ; return new_cv } @@ -331,21 +357,19 @@ newCoercionHole :: TcPredType -> TcM CoercionHole newCoercionHole pred_ty   = do { co_var <- newEvVar pred_ty-       ; traceTc "New coercion hole:" (ppr co_var)+       ; traceTc "New coercion hole:" (ppr co_var <+> dcolon <+> ppr pred_ty)        ; ref <- newMutVar Nothing        ; return $ CoercionHole { ch_co_var = co_var, ch_ref = ref } }  -- | Put a value in a coercion hole fillCoercionHole :: CoercionHole -> Coercion -> TcM ()-fillCoercionHole (CoercionHole { ch_ref = ref, ch_co_var = cv }) co-  = do {-#if defined(DEBUG)-       ; cts <- readTcRef ref-       ; whenIsJust cts $ \old_co ->-         pprPanic "Filling a filled coercion hole" (ppr cv $$ ppr co $$ ppr old_co)-#endif-       ; traceTc "Filling coercion hole" (ppr cv <+> text ":=" <+> ppr co)-       ; writeTcRef ref (Just co) }+fillCoercionHole (CoercionHole { ch_ref = ref, ch_co_var = cv }) co = do+  when debugIsOn $ do+    cts <- readTcRef ref+    whenIsJust cts $ \old_co ->+      pprPanic "Filling a filled coercion hole" (ppr cv $$ ppr co $$ ppr old_co)+  traceTc "Filling coercion hole" (ppr cv <+> text ":=" <+> ppr co)+  writeTcRef ref (Just co)  -- | Is a coercion hole filled in? isFilledCoercionHole :: CoercionHole -> TcM Bool@@ -374,10 +398,10 @@   = do { cv_ty <- zonkTcType (varType cv)                   -- co is already zonked, but cv might not be        ; return $-         ASSERT2( ok cv_ty-                , (text "Bad coercion hole" <+>-                   ppr cv <> colon <+> vcat [ ppr t1, ppr t2, ppr role-                                            , ppr cv_ty ]) )+         assertPpr (ok cv_ty)+                   (text "Bad coercion hole" <+>+                    ppr cv <> colon <+> vcat [ ppr t1, ppr t2, ppr role+                                             , ppr cv_ty ])          co }   | otherwise   = return co@@ -391,6 +415,24 @@              | otherwise              = False +-- | A coercion hole used to store evidence for `Concrete#` constraints.+--+-- See Note [The Concrete mechanism].+type ConcreteHole = CoercionHole++-- | Create a new (initially unfilled) coercion hole,+-- to hold evidence for a @'Concrete#' (ty :: ki)@ constraint.+newConcreteHole :: Kind -- ^ Kind of the thing we want to ensure is concrete (e.g. 'runtimeRepTy')+                -> Type -- ^ Thing we want to ensure is concrete (e.g. some 'RuntimeRep')+                -> TcM (ConcreteHole, TcType)+                  -- ^ where to put the evidence, and a metavariable to store+                  -- the concrete type+newConcreteHole ki ty+  = do { concrete_ty <- newFlexiTyVarTy ki+       ; let co_ty = mkHeteroPrimEqPred ki ki ty concrete_ty+       ; hole <- newCoercionHole co_ty+       ; return (hole, concrete_ty) }+ {- ********************************************************************** *                       ExpType functions@@ -434,18 +476,42 @@ out later by some means -- see fillInferResult, and Note [fillInferResult]  This behaviour triggered in test gadt/gadt-escape1.++Note [FixedRuntimeRep context in ExpType]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Sometimes, we want to be sure that we fill an ExpType with a type+that has a syntactically fixed RuntimeRep (in the sense of+Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete).++Example:++  pattern S a = (a :: (T :: TYPE R))++We have to infer a type for `a` which has a syntactically fixed RuntimeRep.+When it comes time to filling in the inferred type, we do the appropriate+representation-polymorphism check, much like we do a level check+as explained in Note [TcLevel of ExpType].++See test case T21325. -}  -- actual data definition is in GHC.Tc.Utils.TcType  newInferExpType :: TcM ExpType-newInferExpType+newInferExpType = new_inferExpType Nothing++newInferExpTypeFRR :: FixedRuntimeRepContext -> TcM ExpTypeFRR+newInferExpTypeFRR frr_orig = new_inferExpType (Just frr_orig)++new_inferExpType :: Maybe FixedRuntimeRepContext -> TcM ExpType+new_inferExpType mb_frr_orig   = do { u <- newUnique        ; tclvl <- getTcLevel        ; traceTc "newInferExpType" (ppr u <+> ppr tclvl)        ; ref <- newMutVar Nothing        ; return (Infer (IR { ir_uniq = u, ir_lvl = tclvl-                           , ir_ref = ref })) }+                           , ir_ref = ref+                           , ir_frr = mb_frr_orig })) }  -- | Extract a type out of an ExpType, if one exists. But one should always -- exist. Unless you're quite sure you know what you're doing.@@ -498,7 +564,7 @@                             -- See Note [inferResultToType]                           ; return ty }             Nothing -> do { rr  <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy-                          ; tau <- newMetaTyVarTyAtLevel tc_lvl (tYPE rr)+                          ; tau <- newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr)                             -- See Note [TcLevel of ExpType]                           ; writeMutVar ref (Just tau)                           ; return tau }@@ -515,119 +581,30 @@ already.  See also Note [TcLevel of ExpType] above, and-Note [fillInferResult].+Note [fillInferResult] in GHC.Tc.Utils.Unify. -}  -- | Infer a type using a fresh ExpType -- See also Note [ExpType] in "GHC.Tc.Utils.TcMType"+--+-- Use 'tcInferFRR' if you require the type to have a fixed+-- runtime representation. tcInfer :: (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType)-tcInfer tc_check-  = do { res_ty <- newInferExpType+tcInfer = tc_infer Nothing++-- | Like 'tcInfer', except it ensures that the resulting type+-- has a syntactically fixed RuntimeRep as per Note [Fixed RuntimeRep] in+-- GHC.Tc.Utils.Concrete.+tcInferFRR :: FixedRuntimeRepContext -> (ExpSigmaTypeFRR -> TcM a) -> TcM (a, TcSigmaTypeFRR)+tcInferFRR frr_orig = tc_infer (Just frr_orig)++tc_infer :: Maybe FixedRuntimeRepContext -> (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType)+tc_infer mb_frr tc_check+  = do { res_ty <- new_inferExpType mb_frr        ; result <- tc_check res_ty        ; res_ty <- readExpType res_ty        ; return (result, res_ty) } -fillInferResult :: TcType -> InferResult -> TcM TcCoercionN--- If co = fillInferResult t1 t2---    => co :: t1 ~ t2--- See Note [fillInferResult]-fillInferResult act_res_ty (IR { ir_uniq = u, ir_lvl = res_lvl-                               , ir_ref = ref })-  = do { mb_exp_res_ty <- readTcRef ref-       ; case mb_exp_res_ty of-            Just exp_res_ty-               -> do { traceTc "Joining inferred ExpType" $-                       ppr u <> colon <+> ppr act_res_ty <+> char '~' <+> ppr exp_res_ty-                     ; cur_lvl <- getTcLevel-                     ; unless (cur_lvl `sameDepthAs` res_lvl) $-                       ensureMonoType act_res_ty-                     ; unifyType Nothing act_res_ty exp_res_ty }-            Nothing-               -> do { traceTc "Filling inferred ExpType" $-                       ppr u <+> text ":=" <+> ppr act_res_ty-                     ; (prom_co, act_res_ty) <- promoteTcType res_lvl act_res_ty-                     ; writeTcRef ref (Just act_res_ty)-                     ; return prom_co }-     }---{- Note [fillInferResult]-~~~~~~~~~~~~~~~~~~~~~~~~~-When inferring, we use fillInferResult to "fill in" the hole in InferResult-   data InferResult = IR { ir_uniq :: Unique-                         , ir_lvl  :: TcLevel-                         , ir_ref  :: IORef (Maybe TcType) }--There are two things to worry about:--1. What if it is under a GADT or existential pattern match?-   - GADTs: a unification variable (and Infer's hole is similar) is untouchable-   - Existentials: be careful about skolem-escape--2. What if it is filled in more than once?  E.g. multiple branches of a case-     case e of-        T1 -> e1-        T2 -> e2--Our typing rules are:--* The RHS of a existential or GADT alternative must always be a-  monotype, regardless of the number of alternatives.--* Multiple non-existential/GADT branches can have (the same)-  higher rank type (#18412).  E.g. this is OK:-      case e of-        True  -> hr-        False -> hr-  where hr:: (forall a. a->a) -> Int-  c.f. Section 7.1 of "Practical type inference for arbitrary-rank types"-       We use choice (2) in that Section.-       (GHC 8.10 and earlier used choice (1).)--  But note that-      case e of-        True  -> hr-        False -> \x -> hr x-  will fail, because we still /infer/ both branches, so the \x will get-  a (monotype) unification variable, which will fail to unify with-  (forall a. a->a)--For (1) we can detect the GADT/existential situation by seeing that-the current TcLevel is greater than that stored in ir_lvl of the Infer-ExpType.  We bump the level whenever we go past a GADT/existential match.--Then, before filling the hole use promoteTcType to promote the type-to the outer ir_lvl.  promoteTcType does this-  - create a fresh unification variable alpha at level ir_lvl-  - emits an equality alpha[ir_lvl] ~ ty-  - fills the hole with alpha-That forces the type to be a monotype (since unification variables can-only unify with monotypes); and catches skolem-escapes because the-alpha is untouchable until the equality floats out.--For (2), we simply look to see if the hole is filled already.-  - if not, we promote (as above) and fill the hole-  - if it is filled, we simply unify with the type that is-    already there--There is one wrinkle.  Suppose we have-   case e of-      T1 -> e1 :: (forall a. a->a) -> Int-      G2 -> e2-where T1 is not GADT or existential, but G2 is a GADT.  Then supppose the-T1 alternative fills the hole with (forall a. a->a) -> Int, which is fine.-But now the G2 alternative must not *just* unify with that else we'd risk-allowing through (e2 :: (forall a. a->a) -> Int).  If we'd checked G2 first-we'd have filled the hole with a unification variable, which enforces a-monotype.--So if we check G2 second, we still want to emit a constraint that restricts-the RHS to be a monotype. This is done by ensureMonoType, and it works-by simply generating a constraint (alpha ~ ty), where alpha is a fresh-unification variable.  We discard the evidence.---}- {- ********************************************************************* *                                                                      *               Promoting types@@ -675,7 +652,7 @@     promote_it  -- Emit a constraint  (alpha :: TYPE rr) ~ ty                 -- where alpha and rr are fresh and from level dest_lvl       = do { rr      <- newMetaTyVarTyAtLevel dest_lvl runtimeRepTy-           ; prom_ty <- newMetaTyVarTyAtLevel dest_lvl (tYPE rr)+           ; prom_ty <- newMetaTyVarTyAtLevel dest_lvl (mkTYPEapp rr)            ; let eq_orig = TypeEqOrigin { uo_actual   = ty                                         , uo_expected = prom_ty                                         , uo_thing    = Nothing@@ -816,6 +793,7 @@        TyVarTv        -> fsLit "a"        RuntimeUnkTv   -> fsLit "r"        CycleBreakerTv -> fsLit "b"+       ConcreteTv {}  -> fsLit "c"  newAnonMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar newAnonMetaTyVar mi = newNamedAnonMetaTyVar (metaInfoToTyVarName mi) mi@@ -831,10 +809,10 @@         ; return tyvar }  -- makes a new skolem tv-newSkolemTyVar :: Name -> Kind -> TcM TcTyVar-newSkolemTyVar name kind+newSkolemTyVar :: SkolemInfo -> Name -> Kind -> TcM TcTyVar+newSkolemTyVar skol_info name kind   = do { lvl <- getTcLevel-       ; return (mkTcTyVar name kind (SkolemTv lvl False)) }+       ; return (mkTcTyVar name kind (SkolemTv skol_info lvl False)) }  newTyVarTyVar :: Name -> Kind -> TcM TcTyVar -- See Note [TyVarTv]@@ -860,6 +838,17 @@        ; traceTc "cloneTyVarTyVar" (ppr tyvar)        ; return tyvar } +-- | Create a new metavariable, of the given kind, which can only be unified+-- with a concrete type.+--+-- Invariant: the kind must be concrete, as per Note [ConcreteTv].+-- This is checked with an assertion.+newConcreteTyVar :: HasDebugCallStack => ConcreteTvOrigin -> TcKind -> TcM TcTyVar+newConcreteTyVar reason kind =+  assertPpr (isConcrete kind)+    (text "newConcreteTyVar: non-concrete kind" <+> ppr kind)+  $ newAnonMetaTyVar (ConcreteTv reason) kind+ newPatSigTyVar :: Name -> Kind -> TcM TcTyVar newPatSigTyVar name kind   = do { details <- newMetaDetails TauTv@@ -906,7 +895,7 @@  cloneMetaTyVar :: TcTyVar -> TcM TcTyVar cloneMetaTyVar tv-  = ASSERT( isTcTyVar tv )+  = assert (isTcTyVar tv) $     do  { ref  <- newMutVar Flexi         ; name' <- cloneMetaTyVarName (tyVarName tv)         ; let details' = case tcTyVarDetails tv of@@ -918,12 +907,15 @@  -- Works for both type and kind variables readMetaTyVar :: TyVar -> TcM MetaDetails-readMetaTyVar tyvar = ASSERT2( isMetaTyVar tyvar, ppr tyvar )+readMetaTyVar tyvar = assertPpr (isMetaTyVar tyvar) (ppr tyvar) $                       readMutVar (metaTyVarRef tyvar)  isFilledMetaTyVar_maybe :: TcTyVar -> TcM (Maybe Type) isFilledMetaTyVar_maybe tv- | MetaTv { mtv_ref = ref } <- tcTyVarDetails tv+-- TODO: This should be an assertion that tv is definitely a TcTyVar but it fails+-- at the moment (Jan 22)+ | isTcTyVar tv+ , MetaTv { mtv_ref = ref } <- tcTyVarDetails tv  = do { cts <- readTcRef ref       ; case cts of           Indirect ty -> return (Just ty)@@ -955,15 +947,13 @@  -- Everything from here on only happens if DEBUG is on   | not (isTcTyVar tyvar)-  = ASSERT2( False, text "Writing to non-tc tyvar" <+> ppr tyvar )-    return ()+  = massertPpr False (text "Writing to non-tc tyvar" <+> ppr tyvar)    | MetaTv { mtv_ref = ref } <- tcTyVarDetails tyvar   = writeMetaTyVarRef tyvar ref ty    | otherwise-  = ASSERT2( False, text "Writing to non-meta tyvar" <+> ppr tyvar )-    return ()+  = massertPpr False (text "Writing to non-meta tyvar" <+> ppr tyvar)  -------------------- writeMetaTyVarRef :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM ()@@ -987,10 +977,10 @@              zonked_ty_lvl  = tcTypeLevel zonked_ty              level_check_ok  = not (zonked_ty_lvl `strictlyDeeperThan` tv_lvl)              level_check_msg = ppr zonked_ty_lvl $$ ppr tv_lvl $$ ppr tyvar $$ ppr ty-             kind_check_ok = tcIsConstraintKind zonked_tv_kind-                          || tcEqKind zonked_ty_kind zonked_tv_kind-             -- Hack alert! tcIsConstraintKind: see GHC.Tc.Gen.HsType-             -- Note [Extra-constraint holes in partial type signatures]+             kind_check_ok = zonked_ty_kind `eqType` zonked_tv_kind+             -- Hack alert! eqType, not tcEqType. see:+             -- Note [coreView vs tcView] in GHC.Core.Type+             -- Note [Extra-constraint holes in partial type signatures] in GHC.Tc.Gen.HsType               kind_msg = hang (text "Ill-kinded update to meta tyvar")                            2 (    ppr tyvar <+> text "::" <+> (ppr tv_kind $$ ppr zonked_tv_kind)@@ -1000,13 +990,13 @@        ; traceTc "writeMetaTyVar" (ppr tyvar <+> text ":=" <+> ppr ty)         -- Check for double updates-       ; MASSERT2( isFlexi meta_details, double_upd_msg meta_details )+       ; massertPpr (isFlexi meta_details) (double_upd_msg meta_details)         -- Check for level OK-       ; MASSERT2( level_check_ok, level_check_msg )+       ; massertPpr level_check_ok level_check_msg         -- Check Kinds ok-       ; MASSERT2( kind_check_ok, kind_msg )+       ; massertPpr kind_check_ok kind_msg         -- Do the write        ; writeMutVar ref (Indirect ty) }@@ -1062,7 +1052,7 @@ newOpenTypeKind :: TcM TcKind newOpenTypeKind   = do { rr <- newFlexiTyVarTy runtimeRepTy-       ; return (tYPE rr) }+       ; return (mkTYPEapp rr) }  -- | Create a tyvar that can be a lifted or unlifted type. -- Returns alpha :: TYPE kappa, where both alpha and kappa are fresh@@ -1080,7 +1070,7 @@ newOpenBoxedTypeKind   = do { lev <- newFlexiTyVarTy (mkTyConTy levityTyCon)        ; let rr = mkTyConApp boxedRepDataConTyCon [lev]-       ; return (tYPE rr) }+       ; return (mkTYPEapp rr) }  newMetaTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) -- Instantiate with META type variables@@ -1252,6 +1242,9 @@ This change is inspired by and described in Section 7.2 of "Kind Inference for Datatypes", POPL'20. +NB: this is all rather similar to, but sadly not the same as+    Note [Error on unconstrained meta-variables]+ Wrinkle:  We must make absolutely sure that alpha indeed is not@@ -1339,6 +1332,12 @@ candidateKindVars :: CandidatesQTvs -> TyVarSet candidateKindVars dvs = dVarSetToVarSet (dv_kvs dvs) +delCandidates :: CandidatesQTvs -> [Var] -> CandidatesQTvs+delCandidates (DV { dv_kvs = kvs, dv_tvs = tvs, dv_cvs = cvs }) vars+  = DV { dv_kvs = kvs `delDVarSetList` vars+       , dv_tvs = tvs `delDVarSetList` vars+       , dv_cvs = cvs `delVarSetList`  vars }+ partitionCandidates :: CandidatesQTvs -> (TyVar -> Bool) -> (TyVarSet, CandidatesQTvs) -- The selected TyVars are returned as a non-deterministic TyVarSet partitionCandidates dvs@(DV { dv_kvs = kvs, dv_tvs = tvs }) pred@@ -1348,6 +1347,17 @@     (extracted_tvs, rest_tvs) = partitionDVarSet pred tvs     extracted = dVarSetToVarSet extracted_kvs `unionVarSet` dVarSetToVarSet extracted_tvs +candidateQTyVarsWithBinders :: [TyVar] -> Type -> TcM CandidatesQTvs+-- (candidateQTyVarsWithBinders tvs ty) returns the candidateQTyVars+-- of (forall tvs. ty), but do not treat 'tvs' as bound for the purpose+-- of Note [Naughty quantification candidates].  Why?+-- Because we are going to scoped-sort the quantified variables+-- in among the tvs+candidateQTyVarsWithBinders bound_tvs ty+  = do { kvs <- candidateQTyVarsOfKinds (map tyVarKind bound_tvs)+       ; all_tvs <- collect_cand_qtvs ty False emptyVarSet kvs ty+       ; return (all_tvs `delCandidates` bound_tvs) }+ -- | Gathers free variables to use as quantification candidates (in -- 'quantifyTyVars'). This might output the same var -- in both sets, if it's used in both a type and a kind.@@ -1379,12 +1389,6 @@ candidateQTyVarsOfKinds tys = foldM (\acc ty -> collect_cand_qtvs ty True emptyVarSet acc ty)                                     mempty tys -delCandidates :: CandidatesQTvs -> [Var] -> CandidatesQTvs-delCandidates (DV { dv_kvs = kvs, dv_tvs = tvs, dv_cvs = cvs }) vars-  = DV { dv_kvs = kvs `delDVarSetList` vars-       , dv_tvs = tvs `delDVarSetList` vars-       , dv_cvs = cvs `delVarSetList`  vars }- collect_cand_qtvs   :: TcType          -- original type that we started recurring into; for errors   -> Bool            -- True <=> consider every fv in Type to be dependent@@ -1467,6 +1471,11 @@                 -> return dv   -- this variable is from an outer context; skip                                -- See Note [Use level numbers for quantification] +                | case tcTyVarDetails tv of+                     SkolemTv _ lvl _ -> lvl > pushTcLevel cur_lvl+                     _                -> False+                -> return dv  -- Skip inner skolems; ToDo: explain+                 |  intersectsVarSet bound tv_kind_vars                    -- the tyvar must not be from an outer context, but we have                    -- already checked for this.@@ -1683,7 +1692,9 @@ Note [Deterministic UniqFM] in GHC.Types.Unique.DFM. -} -quantifyTyVars :: CandidatesQTvs   -- See Note [Dependent type variables]+quantifyTyVars :: SkolemInfo+               -> NonStandardDefaultingStrategy+               -> CandidatesQTvs   -- See Note [Dependent type variables]                                    -- Already zonked                -> TcM [TcTyVar] -- See Note [quantifyTyVars]@@ -1693,16 +1704,18 @@ -- invariants on CandidateQTvs, we do not have to filter out variables -- free in the environment here. Just quantify unconditionally, subject -- to the restrictions in Note [quantifyTyVars].-quantifyTyVars dvs+quantifyTyVars skol_info ns_strat dvs        -- short-circuit common case   | isEmptyCandidates dvs   = do { traceTc "quantifyTyVars has nothing to quantify" empty        ; return [] }    | otherwise-  = do { traceTc "quantifyTyVars {" (ppr dvs)+  = do { traceTc "quantifyTyVars {"+           ( vcat [ text "ns_strat =" <+> ppr ns_strat+                  , text "dvs =" <+> ppr dvs ]) -       ; undefaulted <- defaultTyVars dvs+       ; undefaulted <- defaultTyVars ns_strat dvs        ; final_qtvs  <- mapMaybeM zonk_quant undefaulted         ; traceTc "quantifyTyVars }"@@ -1711,7 +1724,7 @@         -- We should never quantify over coercion variables; check this        ; let co_vars = filter isCoVar final_qtvs-       ; MASSERT2( null co_vars, ppr co_vars )+       ; massertPpr (null co_vars) (ppr co_vars)         ; return final_qtvs }   where@@ -1723,12 +1736,14 @@       = return Nothing   -- this can happen for a covar that's associated with                          -- a coercion hole. Test case: typecheck/should_compile/T2494 -      | not (isTcTyVar tkv)-      = return (Just tkv)  -- For associated types in a class with a standalone-                           -- kind signature, we have the class variables in-                           -- scope, and they are TyVars not TcTyVars+-- Omit: no TyVars now+--      | not (isTcTyVar tkv)+--      = return (Just tkv)  -- For associated types in a class with a standalone+--                           -- kind signature, we have the class variables in+--                           -- scope, and they are TyVars not TcTyVars+       | otherwise-      = Just <$> skolemiseQuantifiedTyVar tkv+      = Just <$> skolemiseQuantifiedTyVar skol_info tkv  isQuantifiableTv :: TcLevel   -- Level of the context, outside the quantification                  -> TcTyVar@@ -1739,25 +1754,25 @@   | otherwise   = False -zonkAndSkolemise :: TcTyCoVar -> TcM TcTyCoVar+zonkAndSkolemise :: SkolemInfo -> TcTyCoVar -> TcM TcTyCoVar -- A tyvar binder is never a unification variable (TauTv), -- rather it is always a skolem. It *might* be a TyVarTv. -- (Because non-CUSK type declarations use TyVarTvs.) -- Regardless, it may have a kind that has not yet been zonked, -- and may include kind unification variables.-zonkAndSkolemise tyvar+zonkAndSkolemise skol_info tyvar   | isTyVarTyVar tyvar      -- We want to preserve the binding location of the original TyVarTv.      -- This is important for error messages. If we don't do this, then      -- we get bad locations in, e.g., typecheck/should_fail/T2688-  = do { zonked_tyvar <- zonkTcTyVarToTyVar tyvar-       ; skolemiseQuantifiedTyVar zonked_tyvar }+  = do { zonked_tyvar <- zonkTcTyVarToTcTyVar tyvar+       ; skolemiseQuantifiedTyVar skol_info zonked_tyvar }    | otherwise-  = ASSERT2( isImmutableTyVar tyvar || isCoVar tyvar, pprTyVar tyvar )+  = assertPpr (isImmutableTyVar tyvar || isCoVar tyvar) (pprTyVar tyvar) $     zonkTyCoVarKind tyvar -skolemiseQuantifiedTyVar :: TcTyVar -> TcM TcTyVar+skolemiseQuantifiedTyVar :: SkolemInfo -> TcTyVar -> TcM TcTyVar -- The quantified type variables often include meta type variables -- we want to freeze them into ordinary type variables -- The meta tyvar is updated to point to the new skolem TyVar.  Now any@@ -1769,54 +1784,57 @@ -- This function is called on both kind and type variables, -- but kind variables *only* if PolyKinds is on. -skolemiseQuantifiedTyVar tv+skolemiseQuantifiedTyVar skol_info tv   = case tcTyVarDetails tv of       SkolemTv {} -> do { kind <- zonkTcType (tyVarKind tv)                         ; return (setTyVarKind tv kind) }         -- It might be a skolem type variable,         -- for example from a user type signature -      MetaTv {} -> skolemiseUnboundMetaTyVar tv+      MetaTv {} -> skolemiseUnboundMetaTyVar skol_info tv        _other -> pprPanic "skolemiseQuantifiedTyVar" (ppr tv) -- RuntimeUnk -defaultTyVar :: Bool      -- True <=> please default this kind variable to *-             -> TcTyVar   -- If it's a MetaTyVar then it is unbound-             -> TcM Bool  -- True <=> defaulted away altogether--defaultTyVar default_kind tv+-- | Default a type variable using the given defaulting strategy.+--+-- See Note [Type variable defaulting options] in GHC.Types.Basic.+defaultTyVar :: DefaultingStrategy+             -> TcTyVar    -- If it's a MetaTyVar then it is unbound+             -> TcM Bool   -- True <=> defaulted away altogether+defaultTyVar def_strat tv   | not (isMetaTyVar tv)-  = return False--  | isTyVarTyVar tv+  || isTyVarTyVar tv     -- Do not default TyVarTvs. Doing so would violate the invariants     -- on TyVarTvs; see Note [TyVarTv] in GHC.Tc.Utils.TcMType.     -- #13343 is an example; #14555 is another     -- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl   = return False --  | isRuntimeRepVar tv  -- Do not quantify over a RuntimeRep var-                        -- unless it is a TyVarTv, handled earlier+  | isRuntimeRepVar tv+  , default_ns_vars   = do { traceTc "Defaulting a RuntimeRep var to LiftedRep" (ppr tv)        ; writeMetaTyVar tv liftedRepTy        ; return True }   | isLevityVar tv+  , default_ns_vars   = do { traceTc "Defaulting a Levity var to Lifted" (ppr tv)        ; writeMetaTyVar tv liftedDataConTy        ; return True }   | isMultiplicityVar tv-  = do { traceTc "Defaulting a Multiplicty var to Many" (ppr tv)+  , default_ns_vars+  = do { traceTc "Defaulting a Multiplicity var to Many" (ppr tv)        ; writeMetaTyVar tv manyDataConTy        ; return True } -  | default_kind            -- -XNoPolyKinds and this is a kind var-  = default_kind_var tv     -- so default it to * if possible+  | DefaultKindVars <- def_strat -- -XNoPolyKinds and this is a kind var: we must default it+  = default_kind_var tv    | otherwise   = return False    where+    default_ns_vars :: Bool+    default_ns_vars = defaultNonStandardTyVars def_strat     default_kind_var :: TyVar -> TcM Bool        -- defaultKindVar is used exclusively with -XNoPolyKinds        -- See Note [Defaulting with -XNoPolyKinds]@@ -1828,9 +1846,10 @@            ; writeMetaTyVar kv liftedTypeKind            ; return True }       | otherwise-      = do { addErr (vcat [ text "Cannot default kind variable" <+> quotes (ppr kv')-                          , text "of kind:" <+> ppr (tyVarKind kv')-                          , text "Perhaps enable PolyKinds or add a kind signature" ])+      = do { addErr $ TcRnUnknownMessage $ mkPlainError noHints $+               (vcat [ text "Cannot default kind variable" <+> quotes (ppr kv')+                     , text "of kind:" <+> ppr (tyVarKind kv')+                     , text "Perhaps enable PolyKinds or add a kind signature" ])            -- We failed to default it, so return False to say so.            -- Hence, it'll get skolemised.  That might seem odd, but we must either            -- promote, skolemise, or zap-to-Any, to satisfy GHC.Tc.Gen.HsType@@ -1842,17 +1861,37 @@       where         (_, kv') = tidyOpenTyCoVar emptyTidyEnv kv --- | Default some unconstrained type variables:---     RuntimeRep tyvars default to LiftedRep---     Multiplicity tyvars default to Many---     Type tyvars from dv_kvs default to Type, when -XNoPolyKinds---     (under -XNoPolyKinds, non-defaulting vars in dv_kvs is an error)-defaultTyVars :: CandidatesQTvs  -- ^ all candidates for quantification-              -> TcM [TcTyVar]   -- ^ those variables not defaulted-defaultTyVars dvs+-- | Default some unconstrained type variables, as specified+-- by the defaulting options:+--+--  - 'RuntimeRep' tyvars default to 'LiftedRep'+--  - 'Levity' tyvars default to 'Lifted'+--  - 'Multiplicity' tyvars default to 'Many'+--  - 'Type' tyvars from dv_kvs default to 'Type', when -XNoPolyKinds+--    (under -XNoPolyKinds, non-defaulting vars in dv_kvs is an error)+defaultTyVars :: NonStandardDefaultingStrategy+              -> CandidatesQTvs    -- ^ all candidates for quantification+              -> TcM [TcTyVar]     -- ^ those variables not defaulted+defaultTyVars ns_strat dvs   = do { poly_kinds <- xoptM LangExt.PolyKinds-       ; defaulted_kvs <- mapM (defaultTyVar (not poly_kinds)) dep_kvs-       ; defaulted_tvs <- mapM (defaultTyVar False)            nondep_tvs+       ; let+           def_tvs, def_kvs :: DefaultingStrategy+           def_tvs = NonStandardDefaulting ns_strat+           def_kvs+             | poly_kinds = def_tvs+             | otherwise  = DefaultKindVars+             -- As -XNoPolyKinds precludes polymorphic kind variables, we default them.+             -- For example:+             --+             --   type F :: Type -> Type+             --   type family F a where+             --      F (a -> b) = b+             --+             -- Here we get `a :: TYPE r`, so to accept this program when -XNoPolyKinds is enabled+             -- we must default the kind variable `r :: RuntimeRep`.+             -- Test case: T20584.+       ; defaulted_kvs <- mapM (defaultTyVar def_kvs) dep_kvs+       ; defaulted_tvs <- mapM (defaultTyVar def_tvs) nondep_tvs        ; let undefaulted_kvs = [ kv | (kv, False) <- dep_kvs    `zip` defaulted_kvs ]              undefaulted_tvs = [ tv | (tv, False) <- nondep_tvs `zip` defaulted_tvs ]        ; return (undefaulted_kvs ++ undefaulted_tvs) }@@ -1860,38 +1899,48 @@   where     (dep_kvs, nondep_tvs) = candidateVars dvs -skolemiseUnboundMetaTyVar :: TcTyVar -> TcM TyVar+skolemiseUnboundMetaTyVar :: SkolemInfo -> TcTyVar -> TcM TyVar -- We have a Meta tyvar with a ref-cell inside it -- Skolemise it, so that we are totally out of Meta-tyvar-land -- We create a skolem TcTyVar, not a regular TyVar --   See Note [Zonking to Skolem]-skolemiseUnboundMetaTyVar tv-  = ASSERT2( isMetaTyVar tv, ppr tv )-    do  { when debugIsOn (check_empty tv)-        ; here <- getSrcSpanM    -- Get the location from "here"-                                 -- ie where we are generalising-        ; kind <- zonkTcType (tyVarKind tv)-        ; let tv_name     = tyVarName tv+--+-- Its level should be one greater than the ambient level, which will typically+-- be the same as the level on the meta-tyvar. But not invariably; for example+--    f :: (forall a b. SameKind a b) -> Int+-- The skolems 'a' and 'b' are bound by tcTKTelescope, at level 2; and they each+-- have a level-2 kind unification variable, since it might get unified with another+-- of the level-2 skolems e.g. 'k' in this version+--    f :: (forall k (a :: k) b. SameKind a b) -> Int+-- So when we quantify the kind vars at the top level of the signature, the ambient+-- level is 1, but we will quantify over kappa[2].++skolemiseUnboundMetaTyVar skol_info tv+  = assertPpr (isMetaTyVar tv) (ppr tv) $+    do  { check_empty tv+        ; tc_lvl <- getTcLevel   -- Get the location and level from "here"+        ; here   <- getSrcSpanM  -- i.e. where we are generalising+        ; kind   <- zonkTcType (tyVarKind tv)+        ; let tv_name = tyVarName tv               -- See Note [Skolemising and identity]               final_name | isSystemName tv_name                          = mkInternalName (nameUnique tv_name)                                           (nameOccName tv_name) here                          | otherwise                          = tv_name-              final_tv = mkTcTyVar final_name kind details+              details    = SkolemTv skol_info (pushTcLevel tc_lvl) False+              final_tv   = mkTcTyVar final_name kind details          ; traceTc "Skolemising" (ppr tv <+> text ":=" <+> ppr final_tv)         ; writeMetaTyVar tv (mkTyVarTy final_tv)         ; return final_tv }-   where-    details = SkolemTv (metaTyVarTcLevel tv) False     check_empty tv       -- [Sept 04] Check for non-empty.-      = when debugIsOn $  -- See note [Silly Type Synonym]+      = when debugIsOn $  -- See Note [Silly Type Synonyms]         do { cts <- readMetaTyVar tv            ; case cts of                Flexi       -> return ()-               Indirect ty -> WARN( True, ppr tv $$ ppr ty )+               Indirect ty -> warnPprTrace True "skolemiseUnboundMetaTyVar" (ppr tv $$ ppr ty) $                               return () }  {- Note [Error on unconstrained meta-variables]@@ -1926,10 +1975,6 @@ NB: this is all rather similar to, but sadly not the same as     Note [Naughty quantification candidates] -(One last example: type instance F Int = Proxy Any, where the unconstrained-kind variable is the inferred kind of Any. The four examples here illustrate-all cases in which this Note applies.)- To do this, we must take an extra step before doing the final zonk to create e.g. a TyCon. (There is no problem in the final term-level zonk. See the section on alternative (B) below.) This extra step is needed only for@@ -2005,13 +2050,14 @@                     -> (TidyEnv -> TcM (TidyEnv, SDoc))                             -- ^ like "the class context (D a b, E foogle)"                     -> TcM ()+-- See Note [Error on unconstrained meta-variables] doNotQuantifyTyVars dvs where_found   | isEmptyCandidates dvs   = traceTc "doNotQuantifyTyVars has nothing to error on" empty    | otherwise   = do { traceTc "doNotQuantifyTyVars" (ppr dvs)-       ; undefaulted <- defaultTyVars dvs+       ; undefaulted <- defaultTyVars DefaultNonStandardTyVars dvs           -- could have regular TyVars here, in an associated type RHS, or           -- bound by a type declaration head. So filter looking only for           -- metavars. e.g. b and c in `class (forall a. a b ~ a c) => C b c`@@ -2020,12 +2066,15 @@        ; unless (null leftover_metas) $          do { let (tidy_env1, tidied_tvs) = tidyOpenTyCoVars emptyTidyEnv leftover_metas             ; (tidy_env2, where_doc) <- where_found tidy_env1-            ; let doc = vcat [ text "Uninferrable type variable"-                               <> plural tidied_tvs-                               <+> pprWithCommas pprTyVar tidied_tvs-                               <+> text "in"-                             , where_doc ]-            ; failWithTcM (tidy_env2, pprWithExplicitKindsWhen True doc) }+            ; let msg = TcRnUnknownMessage            $+                        mkPlainError noHints          $+                        pprWithExplicitKindsWhen True $+                    vcat [ text "Uninferrable type variable"+                           <> plural tidied_tvs+                           <+> pprWithCommas pprTyVar tidied_tvs+                           <+> text "in"+                         , where_doc ]+            ; failWithTcM (tidy_env2, msg) }        ; traceTc "doNotQuantifyTyVars success" empty }  {- Note [Defaulting with -XNoPolyKinds]@@ -2174,7 +2223,7 @@  * So we get a dict binding for Num (C d a), which is zonked to give         a = ()-  [Note Sept 04: now that we are zonking quantified type variables+  Note (Sept 04): now that we are zonking quantified type variables   on construction, the 'a' will be frozen as a regular tyvar on   quantification, so the floated dict will still have type (C d a).   Which renders this whole note moot; happily!]@@ -2198,7 +2247,7 @@ -- Also returns either the original tyvar (no promotion) or the new one -- See Note [Promoting unification variables] promoteMetaTyVarTo tclvl tv-  | ASSERT2( isMetaTyVar tv, ppr tv )+  | assertPpr (isMetaTyVar tv) (ppr tv) $     tcTyVarLevel tv `strictlyDeeperThan` tclvl   = do { cloned_tv <- cloneMetaTyVar tv        ; let rhs_tv = setMetaTyVarTcLevel cloned_tv tclvl@@ -2239,7 +2288,7 @@ -- Works on TyVars and TcTyVars zonkTyCoVar tv | isTcTyVar tv = zonkTcTyVar tv                | isTyVar   tv = mkTyVarTy <$> zonkTyCoVarKind tv-               | otherwise    = ASSERT2( isCoVar tv, ppr tv )+               | otherwise    = assertPpr (isCoVar tv) (ppr tv) $                                 mkCoercionTy . mkCoVarCo <$> zonkTyCoVarKind tv    -- Hackily, when typechecking type and class decls    -- we have TyVars in scope added (only) in@@ -2271,10 +2320,6 @@ zonkTyCoVarKind tv = do { kind' <- zonkTcType (tyVarKind tv)                         ; return (setTyVarKind tv kind') } -zonkTyCoVarKindBinder :: (VarBndr TyCoVar fl) -> TcM (VarBndr TyCoVar fl)-zonkTyCoVarKindBinder (Bndr tv fl) = do { kind' <- zonkTcType (tyVarKind tv)-                                        ; return $ Bndr (setTyVarKind tv kind') fl }- {- ************************************************************************ *                                                                      *@@ -2291,7 +2336,7 @@   = do { skols'  <- mapM zonkTyCoVarKind skols  -- Need to zonk their kinds!                                                 -- as #7230 showed        ; given'  <- mapM zonkEvVar given-       ; info'   <- zonkSkolemInfo info+       ; info'   <- zonkSkolemInfoAnon info        ; wanted' <- zonkWCRec wanted        ; return (implic { ic_skols  = skols'                         , ic_given  = given'@@ -2306,22 +2351,38 @@ zonkWC wc = zonkWCRec wc  zonkWCRec :: WantedConstraints -> TcM WantedConstraints-zonkWCRec (WC { wc_simple = simple, wc_impl = implic, wc_holes = holes })+zonkWCRec (WC { wc_simple = simple, wc_impl = implic, wc_errors = errs })   = do { simple' <- zonkSimples simple        ; implic' <- mapBagM zonkImplication implic-       ; holes'  <- mapBagM zonkHole holes-       ; return (WC { wc_simple = simple', wc_impl = implic', wc_holes = holes' }) }+       ; errs'   <- mapBagM zonkDelayedError errs+       ; return (WC { wc_simple = simple', wc_impl = implic', wc_errors = errs' }) }  zonkSimples :: Cts -> TcM Cts zonkSimples cts = do { cts' <- mapBagM zonkCt cts                      ; traceTc "zonkSimples done:" (ppr cts')                      ; return cts' } +zonkDelayedError :: DelayedError -> TcM DelayedError+zonkDelayedError (DE_Hole hole)+  = DE_Hole <$> zonkHole hole+zonkDelayedError (DE_NotConcrete err)+  = DE_NotConcrete <$> zonkNotConcreteError err+ zonkHole :: Hole -> TcM Hole zonkHole hole@(Hole { hole_ty = ty })   = do { ty' <- zonkTcType ty        ; return (hole { hole_ty = ty' }) } +zonkNotConcreteError :: NotConcreteError -> TcM NotConcreteError+zonkNotConcreteError err@(NCE_FRR { nce_frr_origin = frr_orig })+  = do { frr_orig  <- zonkFRROrigin frr_orig+       ; return $ err { nce_frr_origin = frr_orig  } }++zonkFRROrigin :: FixedRuntimeRepOrigin -> TcM FixedRuntimeRepOrigin+zonkFRROrigin (FixedRuntimeRepOrigin ty orig)+  = do { ty' <- zonkTcType ty+       ; return $ FixedRuntimeRepOrigin ty' orig }+ {- Note [zonkCt behaviour] ~~~~~~~~~~~~~~~~~~~~~~~~~~ zonkCt tries to maintain the canonical form of a Ct.  For example,@@ -2368,38 +2429,29 @@        ; return (mkNonCanonical fl') }  zonkCtEvidence :: CtEvidence -> TcM CtEvidence-zonkCtEvidence ctev@(CtGiven { ctev_pred = pred })-  = do { pred' <- zonkTcType pred-       ; return (ctev { ctev_pred = pred'}) }-zonkCtEvidence ctev@(CtWanted { ctev_pred = pred, ctev_dest = dest })-  = do { pred' <- zonkTcType pred-       ; let dest' = case dest of-                       EvVarDest ev -> EvVarDest $ setVarType ev pred'-                         -- necessary in simplifyInfer-                       HoleDest h   -> HoleDest h-       ; return (ctev { ctev_pred = pred', ctev_dest = dest' }) }-zonkCtEvidence ctev@(CtDerived { ctev_pred = pred })-  = do { pred' <- zonkTcType pred-       ; return (ctev { ctev_pred = pred' }) }+zonkCtEvidence ctev+  = do { pred' <- zonkTcType (ctev_pred ctev)+       ; return (setCtEvPredType ctev pred')+       }  zonkSkolemInfo :: SkolemInfo -> TcM SkolemInfo-zonkSkolemInfo (SigSkol cx ty tv_prs)  = do { ty' <- zonkTcType ty+zonkSkolemInfo (SkolemInfo u sk) = SkolemInfo u <$> zonkSkolemInfoAnon sk++zonkSkolemInfoAnon :: SkolemInfoAnon -> TcM SkolemInfoAnon+zonkSkolemInfoAnon (SigSkol cx ty tv_prs)  = do { ty' <- zonkTcType ty                                             ; return (SigSkol cx ty' tv_prs) }-zonkSkolemInfo (InferSkol ntys) = do { ntys' <- mapM do_one ntys+zonkSkolemInfoAnon (InferSkol ntys) = do { ntys' <- mapM do_one ntys                                      ; return (InferSkol ntys') }   where     do_one (n, ty) = do { ty' <- zonkTcType ty; return (n, ty') }-zonkSkolemInfo skol_info = return skol_info+zonkSkolemInfoAnon skol_info = return skol_info  {--%************************************************************************-%*                                                                      *-\subsection{Zonking -- the main work-horses: zonkTcType, zonkTcTyVar}+************************************************************************ *                                                                      *-*              For internal use only!                                  *+     Zonking -- the main work-horses: zonkTcType, zonkTcTyVar *                                                                      * ************************************************************************- -}  -- For unbound, mutable tyvars, zonkType uses the function given to it@@ -2464,17 +2516,20 @@  -- Variant that assumes that any result of zonking is still a TyVar. -- Should be used only on skolems and TyVarTvs-zonkTcTyVarToTyVar :: HasDebugCallStack => TcTyVar -> TcM TcTyVar-zonkTcTyVarToTyVar tv+zonkTcTyVarsToTcTyVars :: HasDebugCallStack => [TcTyVar] -> TcM [TcTyVar]+zonkTcTyVarsToTcTyVars = mapM zonkTcTyVarToTcTyVar++zonkTcTyVarToTcTyVar :: HasDebugCallStack => TcTyVar -> TcM TcTyVar+zonkTcTyVarToTcTyVar tv   = do { ty <- zonkTcTyVar tv        ; let tv' = case tcGetTyVar_maybe ty of                      Just tv' -> tv'-                     Nothing  -> pprPanic "zonkTcTyVarToTyVar"+                     Nothing  -> pprPanic "zonkTcTyVarToTcTyVar"                                           (ppr tv $$ ppr ty)        ; return tv' } -zonkInvisTVBinder :: VarBndr TcTyVar spec -> TcM (VarBndr TyVar spec)-zonkInvisTVBinder (Bndr tv spec) = do { tv' <- zonkTcTyVarToTyVar tv+zonkInvisTVBinder :: VarBndr TcTyVar spec -> TcM (VarBndr TcTyVar spec)+zonkInvisTVBinder (Bndr tv spec) = do { tv' <- zonkTcTyVarToTcTyVar tv                                       ; return (Bndr tv' spec) }  -- zonkId is used *during* typechecking just to zonk the Id's type@@ -2524,12 +2579,12 @@  zonkTidyOrigin :: TidyEnv -> CtOrigin -> TcM (TidyEnv, CtOrigin) zonkTidyOrigin env (GivenOrigin skol_info)-  = do { skol_info1 <- zonkSkolemInfo skol_info-       ; let skol_info2 = tidySkolemInfo env skol_info1+  = do { skol_info1 <- zonkSkolemInfoAnon skol_info+       ; let skol_info2 = tidySkolemInfoAnon env skol_info1        ; return (env, GivenOrigin skol_info2) } zonkTidyOrigin env (OtherSCOrigin sc_depth skol_info)-  = do { skol_info1 <- zonkSkolemInfo skol_info-       ; let skol_info2 = tidySkolemInfo env skol_info1+  = do { skol_info1 <- zonkSkolemInfoAnon skol_info+       ; let skol_info2 = tidySkolemInfoAnon env skol_info1        ; return (env, OtherSCOrigin sc_depth skol_info2) } zonkTidyOrigin env orig@(TypeEqOrigin { uo_actual   = act                                       , uo_expected = exp })@@ -2544,122 +2599,113 @@        ; return (env3, KindEqOrigin ty1' ty2' orig' t_or_k) } zonkTidyOrigin env (FunDepOrigin1 p1 o1 l1 p2 o2 l2)   = do { (env1, p1') <- zonkTidyTcType env  p1-       ; (env2, p2') <- zonkTidyTcType env1 p2-       ; return (env2, FunDepOrigin1 p1' o1 l1 p2' o2 l2) }+       ; (env2, o1') <- zonkTidyOrigin env1 o1+       ; (env3, p2') <- zonkTidyTcType env2 p2+       ; (env4, o2') <- zonkTidyOrigin env3 o2+       ; return (env4, FunDepOrigin1 p1' o1' l1 p2' o2' l2) } zonkTidyOrigin env (FunDepOrigin2 p1 o1 p2 l2)   = do { (env1, p1') <- zonkTidyTcType env  p1        ; (env2, p2') <- zonkTidyTcType env1 p2        ; (env3, o1') <- zonkTidyOrigin env2 o1        ; return (env3, FunDepOrigin2 p1' o1' p2' l2) }+zonkTidyOrigin env (InjTFOrigin1 pred1 orig1 loc1 pred2 orig2 loc2)+  = do { (env1, pred1') <- zonkTidyTcType env  pred1+       ; (env2, orig1') <- zonkTidyOrigin env1 orig1+       ; (env3, pred2') <- zonkTidyTcType env2 pred2+       ; (env4, orig2') <- zonkTidyOrigin env3 orig2+       ; return (env4, InjTFOrigin1 pred1' orig1' loc1 pred2' orig2' loc2) }+zonkTidyOrigin env (CycleBreakerOrigin orig)+  = do { (env1, orig') <- zonkTidyOrigin env orig+       ; return (env1, CycleBreakerOrigin orig') }+zonkTidyOrigin env (InstProvidedOrigin mod cls_inst)+  = do { (env1, is_tys') <- mapAccumLM zonkTidyTcType env (is_tys cls_inst)+       ; return (env1, InstProvidedOrigin mod (cls_inst {is_tys = is_tys'})) }+zonkTidyOrigin env (WantedSuperclassOrigin pty orig)+  = do { (env1, pty')  <- zonkTidyTcType env pty+       ; (env2, orig') <- zonkTidyOrigin env1 orig+       ; return (env2, WantedSuperclassOrigin pty' orig') } zonkTidyOrigin env orig = return (env, orig) +zonkTidyOrigins :: TidyEnv -> [CtOrigin] -> TcM (TidyEnv, [CtOrigin])+zonkTidyOrigins = mapAccumLM zonkTidyOrigin++zonkTidyFRRInfos :: TidyEnv+                 -> [FixedRuntimeRepErrorInfo]+                 -> TcM (TidyEnv, [FixedRuntimeRepErrorInfo])+zonkTidyFRRInfos = go []+  where+    go zs env [] = return (env, reverse zs)+    go zs env (FRR_Info { frr_info_origin = FixedRuntimeRepOrigin ty orig+                        , frr_info_not_concrete = mb_not_conc } : tys)+      = do { (env, ty) <- zonkTidyTcType env ty+           ; (env, mb_not_conc) <- go_mb_not_conc env mb_not_conc+           ; let info = FRR_Info { frr_info_origin = FixedRuntimeRepOrigin ty orig+                                 , frr_info_not_concrete = mb_not_conc }+           ; go (info:zs) env tys }++    go_mb_not_conc env Nothing = return (env, Nothing)+    go_mb_not_conc env (Just (tv, ty))+      = do { (env, tv) <- return $ tidyOpenTyCoVar env tv+           ; (env, ty) <- zonkTidyTcType env ty+           ; return (env, Just (tv, ty)) }+ ---------------- tidyCt :: TidyEnv -> Ct -> Ct -- Used only in error reporting-tidyCt env ct-  = ct { cc_ev = tidy_ev (ctEvidence ct) }-  where-    tidy_ev :: CtEvidence -> CtEvidence+tidyCt env ct = ct { cc_ev = tidyCtEvidence env (ctEvidence ct) }++tidyCtEvidence :: TidyEnv -> CtEvidence -> CtEvidence      -- NB: we do not tidy the ctev_evar field because we don't      --     show it in error messages-    tidy_ev ctev = ctev { ctev_pred = tidyType env (ctev_pred ctev) }+tidyCtEvidence env ctev = ctev { ctev_pred = tidyType env ty }+  where+    ty  = ctev_pred ctev  tidyHole :: TidyEnv -> Hole -> Hole tidyHole env h@(Hole { hole_ty = ty }) = h { hole_ty = tidyType env ty } +tidyDelayedError :: TidyEnv -> DelayedError -> DelayedError+tidyDelayedError env (DE_Hole hole)+  = DE_Hole $ tidyHole env hole+tidyDelayedError env (DE_NotConcrete err)+  = DE_NotConcrete $ tidyConcreteError env err++tidyConcreteError :: TidyEnv -> NotConcreteError -> NotConcreteError+tidyConcreteError env err@(NCE_FRR { nce_frr_origin = frr_orig })+  = err { nce_frr_origin = tidyFRROrigin env frr_orig }++tidyFRROrigin :: TidyEnv -> FixedRuntimeRepOrigin -> FixedRuntimeRepOrigin+tidyFRROrigin env (FixedRuntimeRepOrigin ty orig)+  = FixedRuntimeRepOrigin (tidyType env ty) orig+ ---------------- tidyEvVar :: TidyEnv -> EvVar -> EvVar tidyEvVar env var = updateIdTypeAndMult (tidyType env) var ------------------tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo-tidySkolemInfo env (DerivSkol ty)         = DerivSkol (tidyType env ty)-tidySkolemInfo env (SigSkol cx ty tv_prs) = tidySigSkol env cx ty tv_prs-tidySkolemInfo env (InferSkol ids)        = InferSkol (mapSnd (tidyType env) ids)-tidySkolemInfo env (UnifyForAllSkol ty)   = UnifyForAllSkol (tidyType env ty)-tidySkolemInfo _   info                   = info -tidySigSkol :: TidyEnv -> UserTypeCtxt-            -> TcType -> [(Name,TcTyVar)] -> SkolemInfo--- We need to take special care when tidying SigSkol--- See Note [SigSkol SkolemInfo] in "GHC.Tc.Types.Origin"-tidySigSkol env cx ty tv_prs-  = SigSkol cx (tidy_ty env ty) tv_prs'-  where-    tv_prs' = mapSnd (tidyTyCoVarOcc env) tv_prs-    inst_env = mkNameEnv tv_prs'--    tidy_ty env (ForAllTy (Bndr tv vis) ty)-      = ForAllTy (Bndr tv' vis) (tidy_ty env' ty)-      where-        (env', tv') = tidy_tv_bndr env tv--    tidy_ty env ty@(FunTy InvisArg w arg res) -- Look under  c => t-      = ty { ft_mult = tidy_ty env w,-             ft_arg = tidyType env arg,-             ft_res = tidy_ty env res }--    tidy_ty env ty = tidyType env ty--    tidy_tv_bndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar)-    tidy_tv_bndr env@(occ_env, subst) tv-      | Just tv' <- lookupNameEnv inst_env (tyVarName tv)-      = ((occ_env, extendVarEnv subst tv tv'), tv')--      | otherwise-      = tidyVarBndr env tv- ------------------------------------------------------------------------- {- %************************************************************************ %*                                                                      *-             Levity polymorphism checks+             Representation polymorphism checks *                                                                       *-*************************************************************************--See Note [Levity polymorphism checking] in GHC.HsToCore.Monad---}---- | According to the rules around representation polymorphism--- (see https://gitlab.haskell.org/ghc/ghc/wikis/no-sub-kinds), no binder--- can have a representation-polymorphic type. This check ensures--- that we respect this rule. It is a bit regrettable that this error--- occurs in zonking, after which we should have reported all errors.--- But it's hard to see where else to do it, because this can be discovered--- only after all solving is done. And, perhaps most importantly, this--- isn't really a compositional property of a type system, so it's--- not a terrible surprise that the check has to go in an awkward spot.-ensureNotLevPoly :: Type  -- its zonked type-                 -> SDoc  -- where this happened-                 -> TcM ()-ensureNotLevPoly ty doc-  = whenNoErrs $   -- sometimes we end up zonking bogus definitions of type-                   -- forall a. a. See, for example, test ghci/scripts/T9140-    checkForLevPoly doc ty--  -- See Note [Levity polymorphism checking] in GHC.HsToCore.Monad-checkForLevPoly :: SDoc -> Type -> TcM ()-checkForLevPoly = checkForLevPolyX addErr--checkForLevPolyX :: Monad m-                 => (SDoc -> m ())  -- how to report an error-                 -> SDoc -> Type -> m ()-checkForLevPolyX add_err extra ty-  | isTypeLevPoly ty-  = add_err (formatLevPolyErr ty $$ extra)-  | otherwise-  = return ()+***********************************************************************-} -formatLevPolyErr :: Type  -- levity-polymorphic type-                 -> SDoc-formatLevPolyErr ty-  = hang (text "A levity-polymorphic type is not allowed here:")-       2 (vcat [ text "Type:" <+> pprWithTYPE tidy_ty-               , text "Kind:" <+> pprWithTYPE tidy_ki ])-  where-    (tidy_env, tidy_ty) = tidyOpenType emptyTidyEnv ty-    tidy_ki             = tidyType tidy_env (tcTypeKind ty)+-- | Check that the specified type has a fixed runtime representation.+--+-- If it isn't, throw a representation-polymorphism error appropriate+-- for the context (as specified by the 'FixedRuntimeRepProvenance').+--+-- Unlike the other representation polymorphism checks, which can emit+-- new Wanted constraints to be solved by the constraint solver, this function+-- does not emit any constraints: it has enough information to immediately+-- make a decision.+--+-- See (1) in Note [Representation polymorphism checking] in GHC.Tc.Utils.Concrete+checkTypeHasFixedRuntimeRep :: FixedRuntimeRepProvenance -> Type -> TcM ()+checkTypeHasFixedRuntimeRep prov ty =+  unless (typeHasFixedRuntimeRep ty)+    (addDetailedDiagnostic $ TcRnTypeDoesNotHaveFixedRuntimeRep ty prov)  {- %************************************************************************@@ -2678,7 +2724,7 @@ naughtyQuantification orig_ty tv escapees   = do { orig_ty1 <- zonkTcType orig_ty  -- in case it's not zonked -       ; escapees' <- mapM zonkTcTyVarToTyVar $+       ; escapees' <- zonkTcTyVarsToTcTyVars $                       nonDetEltsUniqSet escapees                      -- we'll just be printing, so no harmful non-determinism @@ -2690,7 +2736,8 @@               orig_ty'   = tidyType env orig_ty1              ppr_tidied = pprTyVars . map (tidyTyCoVarOcc env)-             doc = pprWithExplicitKindsWhen True $+             msg = TcRnUnknownMessage $ mkPlainError noHints $+                   pprWithExplicitKindsWhen True $                    vcat [ sep [ text "Cannot generalise type; skolem" <> plural escapees'                               , quotes $ ppr_tidied escapees'                               , text "would escape" <+> itsOrTheir escapees' <+> text "scope"@@ -2704,4 +2751,50 @@                         , text " due to its ill-scoped nature.)"                         ] -       ; failWithTcM (env, doc) }+       ; failWithTcM (env, msg) }++{-+************************************************************************+*                                                                      *+             Checking for coercion holes+*                                                                      *+************************************************************************+-}++-- | Check whether any coercion hole in a RewriterSet is still unsolved.+-- Does this by recursively looking through filled coercion holes until+-- one is found that is not yet filled in, at which point this aborts.+anyUnfilledCoercionHoles :: RewriterSet -> TcM Bool+anyUnfilledCoercionHoles (RewriterSet set)+  = nonDetStrictFoldUniqSet go (return False) set+     -- this does not introduce non-determinism, because the only+     -- monadic action is to read, and the combining function is+     -- commutative+  where+    go :: CoercionHole -> TcM Bool -> TcM Bool+    go hole m_acc = m_acc <||> check_hole hole++    check_hole :: CoercionHole -> TcM Bool+    check_hole hole = do { m_co <- unpackCoercionHole_maybe hole+                         ; case m_co of+                             Nothing -> return True  -- unfilled hole+                             Just co -> unUCHM (check_co co) }++    check_ty :: Type -> UnfilledCoercionHoleMonoid+    check_co :: Coercion -> UnfilledCoercionHoleMonoid+    (check_ty, _, check_co, _) = foldTyCo folder ()++    folder :: TyCoFolder () UnfilledCoercionHoleMonoid+    folder = TyCoFolder { tcf_view  = noView+                        , tcf_tyvar = \ _ tv -> check_ty (tyVarKind tv)+                        , tcf_covar = \ _ cv -> check_ty (varType cv)+                        , tcf_hole  = \ _ -> UCHM . check_hole+                        , tcf_tycobinder = \ _ _ _ -> () }++newtype UnfilledCoercionHoleMonoid = UCHM { unUCHM :: TcM Bool }++instance Semigroup UnfilledCoercionHoleMonoid where+  UCHM l <> UCHM r = UCHM (l <||> r)++instance Monoid UnfilledCoercionHoleMonoid where+  mempty = UCHM (return False)
compiler/GHC/Tc/Utils/Unify.hs view
@@ -1,7 +1,5 @@-{-# LANGUAGE CPP                 #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections       #-}-{-# LANGUAGE BlockArguments      #-} {-# LANGUAGE RecursiveDo         #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}@@ -17,7 +15,7 @@   -- Full-blown subsumption   tcWrapResult, tcWrapResultO, tcWrapResultMono,   tcTopSkolemise, tcSkolemiseScoped, tcSkolemiseExpType,-  tcSubType, tcSubTypeSigma, tcSubTypePat, tcSubTypeDS,+  tcSubType, tcSubTypeNC, tcSubTypeSigma, tcSubTypePat,   tcSubTypeAmbiguity, tcSubMult,   checkConstraints, checkTvConstraints,   buildImplicationFor, buildTvImplication, emitResidualTvConstraint,@@ -25,7 +23,7 @@   -- Various unifications   unifyType, unifyKind, unifyExpectedType,   uType, promoteTcType,-  swapOverTyVars, canSolveByUnification,+  swapOverTyVars, startSolvingByUnification,    --------------------------------   -- Holes@@ -41,27 +39,28 @@    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Hs import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Ppr( debugPprType )-import GHC.Tc.Utils.TcMType+import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep, makeTypeConcrete, hasFixedRuntimeRep_syntactic )+import GHC.Tc.Utils.Env+import GHC.Tc.Utils.Instantiate import GHC.Tc.Utils.Monad+import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType-import GHC.Tc.Utils.Env+ import GHC.Core.Type import GHC.Core.Coercion import GHC.Core.Multiplicity+ import qualified GHC.LanguageExtensions as LangExt  import GHC.Tc.Types.Evidence import GHC.Tc.Types.Constraint import GHC.Tc.Types.Origin -import GHC.Tc.Utils.Instantiate import GHC.Core.TyCon import GHC.Builtin.Types import GHC.Types.Name( Name, isSystemName )@@ -76,6 +75,7 @@ import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain  import GHC.Exts      ( inline ) import Control.Monad@@ -87,19 +87,31 @@ *                                                                      * ********************************************************************* -} --- | matchActualFunTySigma does looks for just one function arrow---   returning an uninstantiated sigma-type+-- | 'matchActualFunTySigma' looks for just one function arrow,+-- returning an uninstantiated sigma-type.+--+-- Invariant: the returned argument type has a syntactically fixed+-- RuntimeRep in the sense of Note [Fixed RuntimeRep]+-- in GHC.Tc.Utils.Concrete.+--+-- See Note [Return arguments with a fixed RuntimeRep]. matchActualFunTySigma-  :: SDoc -- See Note [Herald for matchExpectedFunTys]-  -> Maybe SDoc                    -- The thing with type TcSigmaType-  -> (Arity, [Scaled TcSigmaType]) -- Total number of value args in the call, and-                                   -- types of values args to which function has-                                   --   been applied already (reversed)-                                   -- Both are used only for error messages)-  -> TcRhoType                     -- Type to analyse: a TcRhoType-  -> TcM (HsWrapper, Scaled TcSigmaType, TcSigmaType)--- The /argument/ is a RhoType--- The /result/   is an (uninstantiated) SigmaType+  :: ExpectedFunTyOrigin+      -- ^ See Note [Herald for matchExpectedFunTys]+  -> Maybe TypedThing+      -- ^ The thing with type TcSigmaType+  -> (Arity, [Scaled TcSigmaType])+      -- ^ Total number of value args in the call, and+      -- types of values args to which function has+      --   been applied already (reversed)+      -- (Both are used only for error messages)+  -> TcRhoType+      -- ^ Type to analyse: a TcRhoType+  -> TcM (HsWrapper, Scaled TcSigmaTypeFRR, TcSigmaType)+-- This function takes in a type to analyse (a RhoType) and returns+-- an argument type and a result type (splitting apart a function arrow).+-- The returned argument type is a SigmaType with a fixed RuntimeRep;+-- as explained in Note [Return arguments with a fixed RuntimeRep]. -- -- See Note [matchActualFunTy error handling] for the first three arguments @@ -108,7 +120,7 @@ -- and NB: res_ty is an (uninstantiated) SigmaType  matchActualFunTySigma herald mb_thing err_info fun_ty-  = ASSERT2( isRhoTy fun_ty, ppr fun_ty )+  = assertPpr (isRhoTy fun_ty) (ppr fun_ty) $     go fun_ty   where     -- Does not allocate unnecessary meta variables: if the input already is@@ -118,13 +130,14 @@     -- If allocated (fresh-meta-var1 -> fresh-meta-var2) and unified, we'd     -- hide the forall inside a meta-variable     go :: TcRhoType   -- The type we're processing, perhaps after-                      -- expanding any type synonym-       -> TcM (HsWrapper, Scaled TcSigmaType, TcSigmaType)+                      -- expanding type synonyms+       -> TcM (HsWrapper, Scaled TcSigmaTypeFRR, TcSigmaType)     go ty | Just ty' <- tcView ty = go ty'      go (FunTy { ft_af = af, ft_mult = w, ft_arg = arg_ty, ft_res = res_ty })-      = ASSERT( af == VisArg )-        return (idHsWrapper, Scaled w arg_ty, res_ty)+      = assert (af == VisArg) $+      do { hasFixedRuntimeRep_syntactic (FRRExpectedFunTy herald 1) arg_ty+         ; return (idHsWrapper, Scaled w arg_ty, res_ty) }      go ty@(TyVarTy tv)       | isMetaTyVar tv@@ -157,6 +170,7 @@            ; mult <- newFlexiTyVarTy multiplicityTy            ; let unif_fun_ty = mkVisFunTy mult arg_ty res_ty            ; co <- unifyType mb_thing fun_ty unif_fun_ty+           ; hasFixedRuntimeRep_syntactic (FRRExpectedFunTy herald 1) arg_ty            ; return (mkWpCastN co, Scaled mult arg_ty, res_ty) }      ------------@@ -188,14 +202,18 @@ Ugh! -} --- Like 'matchExpectedFunTys', but used when you have an "actual" type,--- for example in function application-matchActualFunTysRho :: SDoc   -- See Note [Herald for matchExpectedFunTys]+-- | Like 'matchExpectedFunTys', but used when you have an "actual" type,+-- for example in function application.+--+-- INVARIANT: the returned arguemnt types all have a syntactically fixed RuntimeRep+-- in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.+-- See Note [Return arguments with a fixed RuntimeRep].+matchActualFunTysRho :: ExpectedFunTyOrigin -- ^ See Note [Herald for matchExpectedFunTys]                      -> CtOrigin-                     -> Maybe SDoc  -- the thing with type TcSigmaType+                     -> Maybe TypedThing -- ^ the thing with type TcSigmaType                      -> Arity                      -> TcSigmaType-                     -> TcM (HsWrapper, [Scaled TcSigmaType], TcRhoType)+                     -> TcM (HsWrapper, [Scaled TcSigmaTypeFRR], TcRhoType) -- If    matchActualFunTysRho n ty = (wrap, [t1,..,tn], res_ty) -- then  wrap : ty ~> (t1 -> ... -> tn -> res_ty) --       and res_ty is a RhoType@@ -217,13 +235,11 @@                                                  (n_val_args_wanted, so_far)                                                  fun_ty            ; (wrap_res, arg_tys, res_ty)   <- go (n-1) (arg_ty1:so_far) res_ty1-           ; let wrap_fun2 = mkWpFun idHsWrapper wrap_res arg_ty1 res_ty doc+           ; let wrap_fun2 = mkWpFun idHsWrapper wrap_res arg_ty1 res_ty+           -- NB: arg_ty1 comes from matchActualFunTySigma, so it has+           -- a syntactically fixed RuntimeRep as needed to call mkWpFun.            ; return (wrap_fun2 <.> wrap_fun1, arg_ty1:arg_tys, res_ty) }-      where-        doc = text "When inferring the argument type of a function with type" <+>-              quotes (ppr fun_ty) - {- ************************************************************************ *                                                                      *@@ -286,18 +302,75 @@ ExpTypes produced for arguments before it can fill in the ExpType passed in. +Note [Return arguments with a fixed RuntimeRep]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The functions++  - matchExpectedFunTys,+  - matchActualFunTySigma,+  - matchActualFunTysRho,++peel off argument types, as explained in Note [matchExpectedFunTys].+It's important that these functions return argument types that have+a fixed runtime representation, otherwise we would be in violation+of the representation-polymorphism invariants of+Note [Representation polymorphism invariants] in GHC.Core.++This is why all these functions have an additional invariant,+that the argument types they return all have a syntactically fixed RuntimeRep,+in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.++Example:++  Suppose we have++    type F :: Type -> RuntimeRep+    type family F a where { F Int = LiftedRep }++    type Dual :: Type -> Type+    type family Dual a where+      Dual a = a -> ()++    f :: forall (a :: TYPE (F Int)). Dual a+    f = \ x -> ()++  The body of `f` is a lambda abstraction, so we must be able to split off+  one argument type from its type. This is handled by `matchExpectedFunTys`+  (see 'GHC.Tc.Gen.Match.tcMatchLambda'). We end up with desugared Core that+  looks like this:++    f :: forall (a :: TYPE (F Int)). Dual (a |> (TYPE F[0]))+    f = \ @(a :: TYPE (F Int)) ->+          (\ (x :: (a |> (TYPE F[0]))) -> ())+          `cast`+          (Sub (Sym (Dual[0] <(a |> (TYPE F[0]))>)))++  Two important transformations took place:++    1. We inserted casts around the argument type to ensure that it has+       a fixed runtime representation, as required by invariant (I1) from+       Note [Representation polymorphism invariants] in GHC.Core.+    2. We inserted a cast around the whole lambda to make everything line up+       with the type signature. -} --- Use this one when you have an "expected" type.+-- | Use this function to split off arguments types when you have an+-- \"expected\" type.+-- -- This function skolemises at each polytype.+--+-- Invariant: this function only applies the provided function+-- to a list of argument types which all have a syntactically fixed RuntimeRep+-- in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.+-- See Note [Return arguments with a fixed RuntimeRep]. matchExpectedFunTys :: forall a.-                       SDoc   -- See Note [Herald for matchExpectedFunTys]+                       ExpectedFunTyOrigin -- See Note [Herald for matchExpectedFunTys]                     -> UserTypeCtxt                     -> Arity                     -> ExpRhoType      -- Skolemised-                    -> ([Scaled ExpSigmaType] -> ExpRhoType -> TcM a)+                    -> ([Scaled ExpSigmaTypeFRR] -> ExpRhoType -> TcM a)                     -> TcM (HsWrapper, a)--- If    matchExpectedFunTys n ty = (_, wrap)+-- If    matchExpectedFunTys n ty = (wrap, _) -- then  wrap : (t1 -> ... -> tn -> ty_r) ~> ty, --   where [t1, ..., tn], ty_r are passed to the thing_inside matchExpectedFunTys herald ctx arity orig_ty thing_inside@@ -324,14 +397,14 @@       | Just ty' <- tcView ty = go acc_arg_tys n ty'      go acc_arg_tys n (FunTy { ft_mult = mult, ft_af = af, ft_arg = arg_ty, ft_res = res_ty })-      = ASSERT( af == VisArg )-        do { (wrap_res, result) <- go ((Scaled mult $ mkCheckExpType arg_ty) : acc_arg_tys)+      = assert (af == VisArg) $+        do { let arg_pos = 1 + length acc_arg_tys -- for error messages only+           ; (arg_co, arg_ty) <- hasFixedRuntimeRep (FRRExpectedFunTy herald arg_pos) arg_ty+           ; (wrap_res, result) <- go ((Scaled mult $ mkCheckExpType arg_ty) : acc_arg_tys)                                       (n-1) res_ty-           ; let fun_wrap = mkWpFun idHsWrapper wrap_res (Scaled mult arg_ty) res_ty doc-           ; return ( fun_wrap, result ) }-      where-        doc = text "When inferring the argument type of a function with type" <+>-              quotes (ppr orig_ty)+           ; let wrap_arg = mkWpCastN arg_co+                 fun_wrap = mkWpFun wrap_arg wrap_res (Scaled mult arg_ty) res_ty+           ; return (fun_wrap, result) }      go acc_arg_tys n ty@(TyVarTy tv)       | isMetaTyVar tv@@ -359,9 +432,10 @@                           defer acc_arg_tys n (mkCheckExpType ty)      -------------    defer :: [Scaled ExpSigmaType] -> Arity -> ExpRhoType -> TcM (HsWrapper, a)+    defer :: [Scaled ExpSigmaTypeFRR] -> Arity -> ExpRhoType -> TcM (HsWrapper, a)     defer acc_arg_tys n fun_ty-      = do { more_arg_tys <- replicateM n (mkScaled <$> newFlexiTyVarTy multiplicityTy <*> newInferExpType)+      = do { let last_acc_arg_pos = length acc_arg_tys+           ; more_arg_tys <- mapM new_exp_arg_ty [last_acc_arg_pos + 1 .. last_acc_arg_pos + n]            ; res_ty       <- newInferExpType            ; result       <- thing_inside (reverse acc_arg_tys ++ more_arg_tys) res_ty            ; more_arg_tys <- mapM (\(Scaled m t) -> Scaled m <$> readExpType t) more_arg_tys@@ -371,8 +445,13 @@                          -- Not a good origin at all :-(            ; return (wrap, result) } +    new_exp_arg_ty :: Int -> TcM (Scaled ExpSigmaTypeFRR)+    new_exp_arg_ty arg_pos -- position for error messages only+      = mkScaled <$> newFlexiTyVarTy multiplicityTy+                 <*> newInferExpTypeFRR (FRRExpectedFunTy herald arg_pos)+     -------------    mk_ctxt :: [Scaled ExpSigmaType] -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc)+    mk_ctxt :: [Scaled ExpSigmaTypeFRR] -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc)     mk_ctxt arg_tys res_ty env       = mkFunTysMsg env herald arg_tys' res_ty arity       where@@ -380,7 +459,9 @@                    reverse arg_tys             -- this is safe b/c we're called from "go" -mkFunTysMsg :: TidyEnv -> SDoc -> [Scaled TcType] -> TcType -> Arity+mkFunTysMsg :: TidyEnv+            -> ExpectedFunTyOrigin+            -> [Scaled TcType] -> TcType -> Arity             -> TcM (TidyEnv, SDoc) mkFunTysMsg env herald arg_tys res_ty n_val_args_in_call   = do { (env', fun_rho) <- zonkTidyTcType env $@@ -399,7 +480,8 @@         ; return (env', msg) }  where-  full_herald = herald <+> speakNOf n_val_args_in_call (text "value argument")+  full_herald = pprExpectedFunTyHerald herald+            <+> speakNOf n_val_args_in_call (text "value argument")  ---------------------- matchExpectedListTy :: TcRhoType -> TcM (TcCoercionN, TcRhoType)@@ -420,7 +502,7 @@ -- Postcondition: (T k1 k2 k3 a b c) is well-kinded  matchExpectedTyConApp tc orig_ty-  = ASSERT(not $ isFunTyCon tc) go orig_ty+  = assert (not $ isFunTyCon tc) $ go orig_ty   where     go ty        | Just ty' <- tcView ty@@ -494,6 +576,167 @@     kind2 = liftedTypeKind    -- m :: * -> k                               -- arg type :: * +{- **********************************************************************+*+                      fillInferResult+*+********************************************************************** -}++{- Note [inferResultToType]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+expTypeToType and inferResultType convert an InferResult to a monotype.+It must be a monotype because if the InferResult isn't already filled in,+we fill it in with a unification variable (hence monotype).  So to preserve+order-independence we check for mono-type-ness even if it *is* filled in+already.++See also Note [TcLevel of ExpType] in GHC.Tc.Utils.TcType, and+Note [fillInferResult].+-}++-- | Fill an 'InferResult' with the given type.+--+-- If @co = fillInferResult t1 infer_res@, then @co :: t1 ~# t2@,+-- where @t2@ is the type stored in the 'ir_ref' field of @infer_res@.+--+-- This function enforces the following invariants:+--+--  - Level invariant.+--    The stored type @t2@ is at the same level as given by the+--    'ir_lvl' field.+--  - FRR invariant.+--    Whenever the 'ir_frr' field is not @Nothing@, @t2@ is guaranteed+--    to have a syntactically fixed RuntimeRep, in the sense of+--    Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.+fillInferResult :: TcType -> InferResult -> TcM TcCoercionN+fillInferResult act_res_ty (IR { ir_uniq = u+                               , ir_lvl  = res_lvl+                               , ir_frr  = mb_frr+                               , ir_ref  = ref })+  = do { mb_exp_res_ty <- readTcRef ref+       ; case mb_exp_res_ty of+            Just exp_res_ty+               -- We progressively refine the type stored in 'ref',+               -- for example when inferring types across multiple equations.+               --+               -- Example:+               --+               --  \ x -> case y of { True -> x ; False -> 3 :: Int }+               --+               -- When inferring the return type of this function, we will create+               -- an 'Infer' 'ExpType', which will first be filled by the type of 'x'+               -- after typechecking the first equation, and then filled again with+               -- the type 'Int', at which point we want to ensure that we unify+               -- the type of 'x' with 'Int'. This is what is happening below when+               -- we are "joining" several inferred 'ExpType's.+               -> do { traceTc "Joining inferred ExpType" $+                       ppr u <> colon <+> ppr act_res_ty <+> char '~' <+> ppr exp_res_ty+                     ; cur_lvl <- getTcLevel+                     ; unless (cur_lvl `sameDepthAs` res_lvl) $+                       ensureMonoType act_res_ty+                     ; unifyType Nothing act_res_ty exp_res_ty }+            Nothing+               -> do { traceTc "Filling inferred ExpType" $+                       ppr u <+> text ":=" <+> ppr act_res_ty++                     -- Enforce the level invariant: ensure the TcLevel of+                     -- the type we are writing to 'ref' matches 'ir_lvl'.+                     ; (prom_co, act_res_ty) <- promoteTcType res_lvl act_res_ty++                     -- Enforce the FRR invariant: ensure the type has a syntactically+                     -- fixed RuntimeRep (if necessary, i.e. 'mb_frr' is not 'Nothing').+                     ; (frr_co, act_res_ty) <-+                         case mb_frr of+                           Nothing       -> return (mkNomReflCo act_res_ty, act_res_ty)+                           Just frr_orig -> hasFixedRuntimeRep frr_orig act_res_ty++                     -- Compose the two coercions.+                     ; let final_co = prom_co `mkTcTransCo` frr_co++                     ; writeTcRef ref (Just act_res_ty)++                     ; return final_co }+     }++{- Note [fillInferResult]+~~~~~~~~~~~~~~~~~~~~~~~~~+When inferring, we use fillInferResult to "fill in" the hole in InferResult+   data InferResult = IR { ir_uniq :: Unique+                         , ir_lvl  :: TcLevel+                         , ir_ref  :: IORef (Maybe TcType) }++There are two things to worry about:++1. What if it is under a GADT or existential pattern match?+   - GADTs: a unification variable (and Infer's hole is similar) is untouchable+   - Existentials: be careful about skolem-escape++2. What if it is filled in more than once?  E.g. multiple branches of a case+     case e of+        T1 -> e1+        T2 -> e2++Our typing rules are:++* The RHS of a existential or GADT alternative must always be a+  monotype, regardless of the number of alternatives.++* Multiple non-existential/GADT branches can have (the same)+  higher rank type (#18412).  E.g. this is OK:+      case e of+        True  -> hr+        False -> hr+  where hr:: (forall a. a->a) -> Int+  c.f. Section 7.1 of "Practical type inference for arbitrary-rank types"+       We use choice (2) in that Section.+       (GHC 8.10 and earlier used choice (1).)++  But note that+      case e of+        True  -> hr+        False -> \x -> hr x+  will fail, because we still /infer/ both branches, so the \x will get+  a (monotype) unification variable, which will fail to unify with+  (forall a. a->a)++For (1) we can detect the GADT/existential situation by seeing that+the current TcLevel is greater than that stored in ir_lvl of the Infer+ExpType.  We bump the level whenever we go past a GADT/existential match.++Then, before filling the hole use promoteTcType to promote the type+to the outer ir_lvl.  promoteTcType does this+  - create a fresh unification variable alpha at level ir_lvl+  - emits an equality alpha[ir_lvl] ~ ty+  - fills the hole with alpha+That forces the type to be a monotype (since unification variables can+only unify with monotypes); and catches skolem-escapes because the+alpha is untouchable until the equality floats out.++For (2), we simply look to see if the hole is filled already.+  - if not, we promote (as above) and fill the hole+  - if it is filled, we simply unify with the type that is+    already there++There is one wrinkle.  Suppose we have+   case e of+      T1 -> e1 :: (forall a. a->a) -> Int+      G2 -> e2+where T1 is not GADT or existential, but G2 is a GADT.  Then supppose the+T1 alternative fills the hole with (forall a. a->a) -> Int, which is fine.+But now the G2 alternative must not *just* unify with that else we'd risk+allowing through (e2 :: (forall a. a->a) -> Int).  If we'd checked G2 first+we'd have filled the hole with a unification variable, which enforces a+monotype.++So if we check G2 second, we still want to emit a constraint that restricts+the RHS to be a monotype. This is done by ensureMonoType, and it works+by simply generating a constraint (alpha ~ ty), where alpha is a fresh+unification variable.  We discard the evidence.++-}+++ {- ************************************************************************ *                                                                      *@@ -559,7 +802,7 @@ tcWrapResultO orig rn_expr expr actual_ty res_ty   = do { traceTc "tcWrapResult" (vcat [ text "Actual:  " <+> ppr actual_ty                                       , text "Expected:" <+> ppr res_ty ])-       ; wrap <- tcSubTypeNC orig GenSigCtxt (Just (ppr rn_expr)) actual_ty res_ty+       ; wrap <- tcSubTypeNC orig GenSigCtxt (Just $ HsExprRnThing rn_expr) actual_ty res_ty        ; return (mkHsWrap wrap expr) }  tcWrapResultMono :: HsExpr GhcRn -> HsExpr GhcTc@@ -570,7 +813,7 @@ -- rho-type, so nothing to instantiate; just go straight to unify. -- It means we don't need to pass in a CtOrigin tcWrapResultMono rn_expr expr act_ty res_ty-  = ASSERT2( isRhoTy act_ty, ppr act_ty $$ ppr rn_expr )+  = assertPpr (isRhoTy act_ty) (ppr act_ty $$ ppr rn_expr) $     do { co <- unifyExpectedType rn_expr act_ty res_ty        ; return (mkHsWrapCo co expr) } @@ -581,7 +824,7 @@ unifyExpectedType rn_expr act_ty exp_ty   = case exp_ty of       Infer inf_res -> fillInferResult act_ty inf_res-      Check exp_ty  -> unifyType (Just (ppr rn_expr)) act_ty exp_ty+      Check exp_ty  -> unifyType (Just $ HsExprRnThing rn_expr) act_ty exp_ty  ------------------------ tcSubTypePat :: CtOrigin -> UserTypeCtxt@@ -591,8 +834,7 @@ -- If wrap = tc_sub_type_et t1 t2 --    => wrap :: t1 ~> t2 tcSubTypePat inst_orig ctxt (Check ty_actual) ty_expected-  = do { dflags <- getDynFlags-       ; tc_sub_type dflags unifyTypeET inst_orig ctxt ty_actual ty_expected }+  = tc_sub_type unifyTypeET inst_orig ctxt ty_actual ty_expected  tcSubTypePat _ _ (Infer inf_res) ty_expected   = do { co <- fillInferResult ty_expected inf_res@@ -602,8 +844,8 @@  --------------- tcSubType :: CtOrigin -> UserTypeCtxt-          -> TcSigmaType  -- Actual-          -> ExpRhoType   -- Expected+          -> TcSigmaType  -- ^ Actual+          -> ExpRhoType   -- ^ Expected           -> TcM HsWrapper -- Checks that 'actual' is more polymorphic than 'expected' tcSubType orig ctxt ty_actual ty_expected@@ -612,37 +854,16 @@        ; tcSubTypeNC orig ctxt Nothing ty_actual ty_expected }  ----------------tcSubTypeDS :: HsExpr GhcRn-            -> TcRhoType   -- Actual -- a rho-type not a sigma-type-            -> ExpRhoType  -- Expected-            -> TcM HsWrapper--- Similar signature to unifyExpectedType; does deep subsumption--- Only one call site, in GHC.Tc.Gen.App.tcApp-tcSubTypeDS rn_expr act_rho res_ty-  = case res_ty of-      Check exp_rho -> do { dflags <- getDynFlags-                          ; tc_sub_type_deep dflags (unifyType m_thing) orig-                                        GenSigCtxt act_rho exp_rho-                          }--      Infer inf_res -> do { co <- fillInferResult act_rho inf_res-                          ; return (mkWpCastN co) }-  where-    orig    = exprCtOrigin rn_expr-    m_thing = Just (ppr rn_expr)----------------- tcSubTypeNC :: CtOrigin          -- ^ Used when instantiating             -> UserTypeCtxt      -- ^ Used when skolemising-            -> Maybe SDoc        -- ^ The expression that has type 'actual' (if known)+            -> Maybe TypedThing -- ^ The expression that has type 'actual' (if known)             -> TcSigmaType       -- ^ Actual type             -> ExpRhoType        -- ^ Expected type             -> TcM HsWrapper tcSubTypeNC inst_orig ctxt m_thing ty_actual res_ty   = case res_ty of-      Check ty_expected -> do { dflags <- getDynFlags-                              ; tc_sub_type dflags (unifyType m_thing) inst_orig ctxt-                                            ty_actual ty_expected }+      Check ty_expected -> tc_sub_type (unifyType m_thing) inst_orig ctxt+                                       ty_actual ty_expected        Infer inf_res -> do { (wrap, rho) <- topInstantiate inst_orig ty_actual                                    -- See Note [Instantiation of InferResult]@@ -658,20 +879,16 @@ -- Checks that actual <= expected -- Returns HsWrapper :: actual ~ expected tcSubTypeSigma orig ctxt ty_actual ty_expected-  = do { dflags <- getDynFlags-       ; tc_sub_type dflags (unifyType Nothing) orig ctxt ty_actual ty_expected-       }+  = tc_sub_type (unifyType Nothing) orig ctxt ty_actual ty_expected  --------------- tcSubTypeAmbiguity :: UserTypeCtxt   -- Where did this type arise                    -> TcSigmaType -> TcSigmaType -> TcM HsWrapper -- See Note [Ambiguity check and deep subsumption] tcSubTypeAmbiguity ctxt ty_actual ty_expected-  = do { dflags <- getDynFlags-       ; tc_sub_type_shallow dflags (unifyType Nothing)+  = tc_sub_type_shallow (unifyType Nothing)                         (AmbiguityCheckOrigin ctxt)                         ctxt ty_actual ty_expected-       }  --------------- addSubTypeCtxt :: TcType -> ExpType -> TcM a -> TcM a@@ -733,8 +950,7 @@  --------------- tc_sub_type, tc_sub_type_deep, tc_sub_type_shallow-    :: DynFlags-    -> (TcType -> TcType -> TcM TcCoercionN)  -- How to unify+    :: (TcType -> TcType -> TcM TcCoercionN)  -- How to unify     -> CtOrigin       -- Used when instantiating     -> UserTypeCtxt   -- Used when skolemising     -> TcSigmaType    -- Actual; a sigma-type@@ -749,16 +965,16 @@ -- the argument types and context.  -----------------------tc_sub_type dflags unify inst_orig ctxt ty_actual ty_expected+tc_sub_type unify inst_orig ctxt ty_actual ty_expected   = do { deep_subsumption <- xoptM LangExt.DeepSubsumption        ; if deep_subsumption-         then tc_sub_type_deep    dflags unify inst_orig ctxt ty_actual ty_expected-         else tc_sub_type_shallow dflags unify inst_orig ctxt ty_actual ty_expected+         then tc_sub_type_deep    unify inst_orig ctxt ty_actual ty_expected+         else tc_sub_type_shallow unify inst_orig ctxt ty_actual ty_expected   }  -----------------------tc_sub_type_shallow dflags unify inst_orig ctxt ty_actual ty_expected-  | definitely_poly dflags ty_expected   -- See Note [Don't skolemise unnecessarily]+tc_sub_type_shallow unify inst_orig ctxt ty_actual ty_expected+  | definitely_poly ty_expected   -- See Note [Don't skolemise unnecessarily]   , definitely_mono_shallow ty_actual   = do { traceTc "tc_sub_type (drop to equality)" $          vcat [ text "ty_actual   =" <+> ppr ty_actual@@ -780,8 +996,8 @@        ; return (sk_wrap <.> inner_wrap) }  -----------------------tc_sub_type_deep dflags unify inst_orig ctxt ty_actual ty_expected-  | definitely_poly dflags ty_expected      -- See Note [Don't skolemise unnecessarily]+tc_sub_type_deep unify inst_orig ctxt ty_actual ty_expected+  | definitely_poly ty_expected      -- See Note [Don't skolemise unnecessarily]   , definitely_mono_deep ty_actual   = do { traceTc "tc_sub_type_deep (drop to equality)" $          vcat [ text "ty_actual   =" <+> ppr ty_actual@@ -813,14 +1029,14 @@     -- Top level (->)   | otherwise                              = True -definitely_poly :: DynFlags -> TcType -> Bool+definitely_poly :: TcType -> Bool -- A very conservative test: -- see Note [Don't skolemise unnecessarily]-definitely_poly dflags ty+definitely_poly ty   | (tvs, theta, tau) <- tcSplitSigmaTy ty   , (tv:_) <- tvs   -- At least one tyvar   , null theta      -- No constraints; see (DP1)-  , checkTyVarEq dflags tv tau `cterHasProblem` cteInsolubleOccurs+  , checkTyVarEq tv tau `cterHasProblem` cteInsolubleOccurs        -- The tyvar actually occurs (DP2),        --     and occurs in an injective position (DP3).        -- Fortunately checkTyVarEq, used for the occur check,@@ -866,7 +1082,7 @@ returned by tcSubMult (and derived functions such as tcCheckUsage and checkManyPattern) is quite unlike any other wrapper: it checks whether the coercion produced by the constraint solver is trivial, producing a type error-is it is not. This is implemented via the WpMultCoercion wrapper, as desugared+if it is not. This is implemented via the WpMultCoercion wrapper, as desugared by GHC.HsToCore.Binds.dsHsWrapper, which does the reflexivity check.  This wrapper needs to be placed in the term; otherwise, checking of the@@ -875,11 +1091,14 @@  Why do we check this in the desugarer? It's a convenient place, since it's right after all the constraints are solved. We need the constraints to be-solved to check whether they are trivial or not. Plus there is precedent for-type errors during desuraging (such as the levity polymorphism-restriction). An alternative would be to have a kind of constraint which can-only produce trivial evidence, then this check would happen in the constraint-solver.+solved to check whether they are trivial or not.++An alternative would be to have a kind of constraint which can+only produce trivial evidence. This would allow such checks to happen+in the constraint solver (#18756).+This would be similar to the existing setup for Concrete, see+  Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete+    (PHASE 1 in particular). -}  tcSubMult :: CtOrigin -> Mult -> Mult -> TcM HsWrapper@@ -935,7 +1154,7 @@    signatures (e.g. f :: ty; f = e), we must deeply skolemise the type;    see the call to tcDeeplySkolemise in tcSkolemiseScoped. -4. In GHC.Tc.Gen.App.tcApp we call tcSubTypeDS to match the result+4. In GHC.Tc.Gen.App.tcApp we call tcSubTypeNC to match the result    type. Without deep subsumption, unifyExpectedType would be sufficent.  In all these cases note that the deep skolemisation must be done /first/.@@ -1062,16 +1281,13 @@       | otherwise       = -- This is where we do the co/contra thing, and generate a WpFun, which in turn         -- causes eta-expansion, which we don't like; hence encouraging NoDeepSubsumption-        do { dflags <- getDynFlags-           ; arg_wrap  <- tc_sub_type_deep dflags unify given_orig GenSigCtxt exp_arg act_arg+        do { arg_wrap  <- tc_sub_type_deep unify given_orig GenSigCtxt exp_arg act_arg                           -- GenSigCtxt: See Note [Setting the argument context]            ; res_wrap  <- tc_sub_type_ds   unify inst_orig  ctxt       act_res exp_res            ; mult_wrap <- tcEqMult inst_orig act_mult exp_mult                           -- See Note [Multiplicity in deep subsumption]-           ; let doc = text "When checking that" <+> quotes (ppr ty_actual)-                   <+> text "is more polymorphic than" <+> quotes (ppr ty_expected)            ; return (mult_wrap <.>-                     mkWpFun arg_wrap res_wrap (Scaled exp_mult exp_arg) exp_res doc)}+                     mkWpFun arg_wrap res_wrap (Scaled exp_mult exp_arg) exp_res) }                      -- arg_wrap :: exp_arg ~> act_arg                      -- res_wrap :: act-res ~> exp_res       where@@ -1111,26 +1327,29 @@   = do { res <- thing_inside expected_ty        ; return (idHsWrapper, res) }   | otherwise-  = do  { (wrap, tv_prs, given, rho_ty) <- deeplySkolemise expected_ty-        ; let skol_info = SigSkol ctxt expected_ty tv_prs+  = do  { -- This (unpleasant) rec block allows us to pass skol_info to deeplySkolemise;+          -- but skol_info can't be built until we have tv_prs+          rec { (wrap, tv_prs, given, rho_ty) <- deeplySkolemise skol_info expected_ty+              ; skol_info <- mkSkolemInfo (SigSkol ctxt expected_ty tv_prs) }+         ; traceTc "tcDeeplySkolemise" (ppr expected_ty $$ ppr rho_ty $$ ppr tv_prs)          ; let skol_tvs  = map snd tv_prs         ; (ev_binds, result)-              <- checkConstraints skol_info skol_tvs given $+              <- checkConstraints (getSkolemInfo skol_info) skol_tvs given $                  thing_inside rho_ty          ; return (wrap <.> mkWpLet ev_binds, result) }           -- The ev_binds returned by checkConstraints is very           -- often empty, in which case mkWpLet is a no-op -deeplySkolemise :: TcSigmaType+deeplySkolemise :: SkolemInfo -> TcSigmaType                 -> TcM ( HsWrapper                        , [(Name,TyVar)]     -- All skolemised variables                        , [EvVar]            -- All "given"s                        , TcRhoType ) -- See Note [Deep skolemisation]-deeplySkolemise ty+deeplySkolemise skol_info ty   = go init_subst ty   where     init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty))@@ -1139,7 +1358,7 @@       | Just (arg_tys, tvs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty       = do { let arg_tys' = substScaledTys subst arg_tys            ; ids1           <- newSysLocalIds (fsLit "dk") arg_tys'-           ; (subst', tvs1) <- tcInstSkolTyVarsX subst tvs+           ; (subst', tvs1) <- tcInstSkolTyVarsX skol_info subst tvs            ; ev_vars1       <- newEvVars (substTheta subst' theta)            ; (wrap, tvs_prs2, ev_vars2, rho) <- go subst' ty'            ; let tv_prs1 = map tyVarName tvs `zip` tvs1@@ -1246,12 +1465,14 @@   = do { deep_subsumption <- xoptM LangExt.DeepSubsumption        ; let skolemise | deep_subsumption = deeplySkolemise                        | otherwise        = topSkolemise-       ; (wrap, tv_prs, given, rho_ty) <- skolemise expected_ty+       ; -- This (unpleasant) rec block allows us to pass skol_info to deeplySkolemise;+         -- but skol_info can't be built until we have tv_prs+         rec { (wrap, tv_prs, given, rho_ty) <- skolemise skol_info expected_ty+             ; skol_info <- mkSkolemInfo (SigSkol ctxt expected_ty tv_prs) }         ; let skol_tvs = map snd tv_prs-             skol_info = SigSkol ctxt expected_ty tv_prs        ; (ev_binds, res)-             <- checkConstraints skol_info skol_tvs given $+             <- checkConstraints (getSkolemInfo skol_info) skol_tvs given $                 tcExtendNameTyVarEnv tv_prs               $                 thing_inside rho_ty @@ -1262,13 +1483,12 @@   = do { res <- thing_inside expected_ty        ; return (idHsWrapper, res) }   | otherwise-  = do { rec { let skol_info = SigSkol ctxt expected_ty tv_prs-             ; (wrap, tv_prs, given, rho_ty) <- topSkolemise expected_ty-             }+  = do { rec { (wrap, tv_prs, given, rho_ty) <- topSkolemise skol_info expected_ty+             ; skol_info <- mkSkolemInfo (SigSkol ctxt expected_ty tv_prs) }         ; let skol_tvs = map snd tv_prs        ; (ev_binds, result)-             <- checkConstraints skol_info skol_tvs given $+             <- checkConstraints (getSkolemInfo skol_info) skol_tvs given $                 thing_inside rho_ty         ; return (wrap <.> mkWpLet ev_binds, result) }@@ -1288,7 +1508,7 @@        ; skolemise ctxt ty $ \rho_ty ->          thing_inside (mkCheckExpType rho_ty) } -checkConstraints :: SkolemInfo+checkConstraints :: SkolemInfoAnon                  -> [TcTyVar]           -- Skolems                  -> [EvVar]             -- Given                  -> TcM result@@ -1324,33 +1544,39 @@                          -> TcLevel -> WantedConstraints -> TcM () emitResidualTvConstraint skol_info skol_tvs tclvl wanted   | not (isEmptyWC wanted) ||-    checkTelescopeSkol skol_info+    checkTelescopeSkol skol_info_anon   = -- checkTelescopeSkol: in this case, /always/ emit this implication     -- even if 'wanted' is empty. We need the implication so that we check     -- for a bad telescope. See Note [Skolem escape and forall-types] in     -- GHC.Tc.Gen.HsType-    do { implic <- buildTvImplication skol_info skol_tvs tclvl wanted+    do { implic <- buildTvImplication skol_info_anon skol_tvs tclvl wanted        ; emitImplication implic }    | otherwise  -- Empty 'wanted', emit nothing   = return ()+  where+     skol_info_anon = getSkolemInfo skol_info -buildTvImplication :: SkolemInfo -> [TcTyVar]+buildTvImplication :: SkolemInfoAnon -> [TcTyVar]                    -> TcLevel -> WantedConstraints -> TcM Implication buildTvImplication skol_info skol_tvs tclvl wanted-  = do { ev_binds <- newNoTcEvBinds  -- Used for equalities only, so all the constraints+  = assertPpr (all (isSkolemTyVar <||> isTyVarTyVar) skol_tvs) (ppr skol_tvs) $+    do { ev_binds <- newNoTcEvBinds  -- Used for equalities only, so all the constraints                                      -- are solved by filling in coercion holes, not                                      -- by creating a value-level evidence binding        ; implic   <- newImplication -       ; return (implic { ic_tclvl     = tclvl-                        , ic_skols     = skol_tvs-                        , ic_given_eqs = NoGivenEqs-                        , ic_wanted    = wanted-                        , ic_binds     = ev_binds-                        , ic_info      = skol_info }) }+       ; let implic' = implic { ic_tclvl     = tclvl+                              , ic_skols     = skol_tvs+                              , ic_given_eqs = NoGivenEqs+                              , ic_wanted    = wanted+                              , ic_binds     = ev_binds+                              , ic_info      = skol_info } -implicationNeeded :: SkolemInfo -> [TcTyVar] -> [EvVar] -> TcM Bool+       ; checkImplicationInvariants implic'+       ; return implic' }++implicationNeeded :: SkolemInfoAnon -> [TcTyVar] -> [EvVar] -> TcM Bool -- See Note [When to build an implication] implicationNeeded skol_info skol_tvs given   | null skol_tvs@@ -1370,7 +1596,7 @@   | otherwise     -- Non-empty skolems or givens   = return True   -- Definitely need an implication -alwaysBuildImplication :: SkolemInfo -> Bool+alwaysBuildImplication :: SkolemInfoAnon -> Bool -- See Note [When to build an implication] alwaysBuildImplication _ = False @@ -1387,7 +1613,7 @@ alwaysBuildImplication _                  = False -} -buildImplicationFor :: TcLevel -> SkolemInfo -> [TcTyVar]+buildImplicationFor :: TcLevel -> SkolemInfoAnon -> [TcTyVar]                    -> [EvVar] -> WantedConstraints                    -> TcM (Bag Implication, TcEvBinds) buildImplicationFor tclvl skol_info skol_tvs given wanted@@ -1399,7 +1625,7 @@   = return (emptyBag, emptyTcEvBinds)    | otherwise-  = ASSERT2( all (isSkolemTyVar <||> isTyVarTyVar) skol_tvs, ppr skol_tvs )+  = assertPpr (all (isSkolemTyVar <||> isTyVarTyVar) skol_tvs) (ppr skol_tvs) $       -- Why allow TyVarTvs? Because implicitly declared kind variables in       -- non-CUSK type declarations are TyVarTvs, and we need to bring them       -- into scope as a skolem in an implication. This is OK, though,@@ -1412,6 +1638,7 @@                               , ic_wanted = wanted                               , ic_binds  = ev_binds_var                               , ic_info   = skol_info }+       ; checkImplicationInvariants implic'         ; return (unitBag implic', TcEvBinds ev_binds_var) } @@ -1441,7 +1668,7 @@   can yield /very/ confusing error messages, because we can get       [W] C Int b1    -- from f_blah       [W] C Int b2    -- from g_blan-  and fundpes can yield [D] b1 ~ b2, even though the two functions have+  and fundpes can yield [W] b1 ~ b2, even though the two functions have   literally nothing to do with each other.  #14185 is an example.   Building an implication keeps them separate. -}@@ -1457,7 +1684,7 @@ non-exported generic functions. -} -unifyType :: Maybe SDoc  -- ^ If present, the thing that has type ty1+unifyType :: Maybe TypedThing  -- ^ If present, the thing that has type ty1           -> TcTauType -> TcTauType    -- ty1, ty2           -> TcM TcCoercionN           -- :: ty1 ~# ty2 -- Actual and expected types@@ -1467,7 +1694,7 @@   where     origin = TypeEqOrigin { uo_actual   = ty1                           , uo_expected = ty2-                          , uo_thing    = ppr <$> thing+                          , uo_thing    = thing                           , uo_visible  = True }  unifyTypeET :: TcTauType -> TcTauType -> TcM CoercionN@@ -1482,7 +1709,7 @@                           , uo_visible  = True }  -unifyKind :: Maybe SDoc -> TcKind -> TcKind -> TcM CoercionN+unifyKind :: Maybe TypedThing -> TcKind -> TcKind -> TcM CoercionN unifyKind mb_thing ty1 ty2   = uType KindLevel origin ty1 ty2   where@@ -1610,7 +1837,7 @@     go (TyConApp tc1 tys1) (TyConApp tc2 tys2)       -- See Note [Mismatched type lists and application decomposition]       | tc1 == tc2, equalLength tys1 tys2-      = ASSERT2( isGenerativeTyCon tc1 Nominal, ppr tc1 )+      = assertPpr (isGenerativeTyCon tc1 Nominal) (ppr tc1) $         do { cos <- zipWith3M (uType t_or_k) origins' tys1 tys2            ; return $ mkTyConAppCo Nominal tc1 cos }       where@@ -1629,12 +1856,12 @@      go (AppTy s1 t1) (TyConApp tc2 ts2)       | Just (ts2', t2') <- snocView ts2-      = ASSERT( not (mustBeSaturated tc2) )+      = assert (not (mustBeSaturated tc2)) $         go_app (isNextTyConArgVisible tc2 ts2') s1 t1 (TyConApp tc2 ts2') t2'      go (TyConApp tc1 ts1) (AppTy s2 t2)       | Just (ts1', t1') <- snocView ts1-      = ASSERT( not (mustBeSaturated tc1) )+      = assert (not (mustBeSaturated tc1)) $         go_app (isNextTyConArgVisible tc1 ts1') (TyConApp tc1 ts1') t1' s2 t2      go (CoercionTy co1) (CoercionTy co2)@@ -1745,7 +1972,6 @@ synonyms have already been expanded via tcCoreView).  This is, as usual, to improve error messages. - ************************************************************************ *                                                                      *                  uUnfilledVar and friends@@ -1821,17 +2047,19 @@               -> TcTauType      -- Type 2, zonked               -> TcM Coercion uUnfilledVar2 origin t_or_k swapped tv1 ty2-  = do { dflags  <- getDynFlags-       ; cur_lvl <- getTcLevel-       ; go dflags cur_lvl }+  = do { cur_lvl <- getTcLevel+       ; go cur_lvl }   where-    go dflags cur_lvl+    go cur_lvl       | isTouchableMetaTyVar cur_lvl tv1            -- See Note [Unification preconditions], (UNTOUCHABLE) wrinkles-      , canSolveByUnification (metaTyVarInfo tv1) ty2-      , cterHasNoProblem (checkTyVarEq dflags tv1 ty2)+      , cterHasNoProblem (checkTyVarEq tv1 ty2)            -- See Note [Prevent unification with type families]-      = do { co_k <- uType KindLevel kind_origin (tcTypeKind ty2) (tyVarKind tv1)+      = do { can_continue_solving <- startSolvingByUnification (metaTyVarInfo tv1) ty2+           ; if not can_continue_solving+             then not_ok_so_defer+             else+        do { co_k <- uType KindLevel kind_origin (tcTypeKind ty2) (tyVarKind tv1)            ; traceTc "uUnfilledVar2 ok" $              vcat [ ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1)                   , ppr ty2 <+> dcolon <+> ppr (tcTypeKind  ty2)@@ -1844,36 +2072,61 @@              then do { writeMetaTyVar tv1 ty2                      ; return (mkTcNomReflCo ty2) } -             else defer } -- This cannot be solved now.  See GHC.Tc.Solver.Canonical-                          -- Note [Equalities with incompatible kinds]+             else defer }} -- This cannot be solved now.  See GHC.Tc.Solver.Canonical+                           -- Note [Equalities with incompatible kinds] for how+                           -- this will be dealt with in the solver        | otherwise-      = do { traceTc "uUnfilledVar2 not ok" (ppr tv1 $$ ppr ty2)-               -- Occurs check or an untouchable: just defer-               -- NB: occurs check isn't necessarily fatal:-               --     eg tv1 occurred in type family parameter-            ; defer }+      = not_ok_so_defer      ty1 = mkTyVarTy tv1     kind_origin = KindEqOrigin ty1 ty2 origin (Just t_or_k)      defer = unSwap swapped (uType_defer t_or_k origin) ty1 ty2 -canSolveByUnification :: MetaInfo -> TcType -> Bool--- See Note [Unification preconditions, (TYVAR-TV)]-canSolveByUnification info xi+    not_ok_so_defer =+      do { traceTc "uUnfilledVar2 not ok" (ppr tv1 $$ ppr ty2)+               -- Occurs check or an untouchable: just defer+               -- NB: occurs check isn't necessarily fatal:+               --     eg tv1 occurred in type family parameter+          ; defer }++-- | Checks (TYVAR-TV), (COERCION-HOLE) and (CONCRETE) of+-- Note [Unification preconditions]; returns True if these conditions+-- are satisfied. But see the Note for other preconditions, too.+startSolvingByUnification :: MetaInfo -> TcType  -- zonked+                          -> TcM Bool+startSolvingByUnification _ xi+  | hasCoercionHoleTy xi  -- (COERCION-HOLE) check+  = return False+startSolvingByUnification info xi   = case info of-      CycleBreakerTv -> False-      TyVarTv -> case tcGetTyVar_maybe xi of-                   Nothing -> False-                   Just tv -> case tcTyVarDetails tv of-                                 MetaTv { mtv_info = info }-                                            -> case info of-                                                 TyVarTv -> True-                                                 _       -> False-                                 SkolemTv {} -> True-                                 RuntimeUnk  -> True-      _ -> True+      CycleBreakerTv -> return False+      ConcreteTv conc_orig ->+        do { (_, not_conc_reasons) <- makeTypeConcrete conc_orig xi+                 -- NB: makeTypeConcrete has the side-effect of turning+                 -- some TauTvs into ConcreteTvs, e.g.+                 -- alpha[conc] ~# TYPE (TupleRep '[ beta[tau], IntRep ])+                 -- will write `beta[tau] := beta[conc]`.+                 --+                 -- We don't need to track these unifications for the purposes+                 -- of constraint solving (e.g. updating tcs_unified or tcs_unif_lvl),+                 -- as they don't unlock any further progress.+           ; case not_conc_reasons of+               [] -> return True+               _  -> return False }+      TyVarTv ->+        case tcGetTyVar_maybe xi of+           Nothing -> return False+           Just tv ->+             case tcTyVarDetails tv of -- (TYVAR-TV) wrinkle+                SkolemTv {} -> return True+                RuntimeUnk  -> return True+                MetaTv { mtv_info = info } ->+                  case info of+                    TyVarTv -> return True+                    _       -> return False+      _ -> return True  swapOverTyVars :: Bool -> TcTyVar -> TcTyVar -> Bool swapOverTyVars is_given tv1 tv2@@ -1908,15 +2161,16 @@ --        => more likely to be eliminated -- See Note [TyVar/TyVar orientation] lhsPriority tv-  = ASSERT2( isTyVar tv, ppr tv)+  = assertPpr (isTyVar tv) (ppr tv) $     case tcTyVarDetails tv of       RuntimeUnk  -> 0       SkolemTv {} -> 0       MetaTv { mtv_info = info } -> case info of                                      CycleBreakerTv -> 0                                      TyVarTv        -> 1-                                     TauTv          -> 2-                                     RuntimeUnkTv   -> 3+                                     ConcreteTv {}  -> 2+                                     TauTv          -> 3+                                     RuntimeUnkTv   -> 4  {- Note [Unification preconditions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1926,7 +2180,7 @@ This note only applied to /homogeneous/ equalities, in which both sides have the same kind. -There are three reasons not to unify:+There are five reasons not to unify:  1. (SKOL-ESC) Skolem-escape    Consider the constraint@@ -1952,7 +2206,7 @@    between levels 'n' and 'l'.     Exactly what is a "given equality" for the purpose of (UNTOUCHABLE)?-   Answer: see Note [Tracking Given equalities] in GHC.Tc.Solver.Monad+   Answer: see Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet  3. (TYVAR-TV) Unifying TyVarTvs and CycleBreakerTvs    This precondition looks at the MetaInfo of the unification variable:@@ -1964,9 +2218,41 @@     * CycleBreakerTv: never unified, except by restoreTyVarCycles. +4. (CONCRETE) A ConcreteTv can only unify with a concrete type,+    by definition. -Needless to say, all three have wrinkles:+    That is, if we have `rr[conc] ~ F Int`, we can't unify+    `rr` with `F Int`, so we hold off on unifying.+    Note however that the equality might get rewritten; for instance+    if we can rewrite `F Int` to a concrete type, say `FloatRep`,+    then we will have `rr[conc] ~ FloatRep` and we can unify `rr ~ FloatRep`. +    Note that we can still make progress on unification even if+    we can't fully solve an equality, e.g.++      alpha[conc] ~# TupleRep '[ beta[tau], F gamma[tau] ]++    we can fill beta[tau] := beta[conc]. This is why we call+    'makeTypeConcrete' in startSolvingByUnification.++5. (COERCION-HOLE) Confusing coercion holes+   Suppose our equality is+     (alpha :: k) ~ (Int |> {co})+   where co :: Type ~ k is an unsolved wanted. Note that this+   equality is homogeneous; both sides have kind k. Unifying here+   is sensible, but it can lead to very confusing error messages.+   It's very much like a Wanted rewriting a Wanted. Even worse,+   unifying a variable essentially turns an equality into a Given,+   and so we could not use the tracking mechansim in+   Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint.+   We thus simply do not unify in this case.++   This is expanded as Wrinkle (2) in Note [Equalities with incompatible kinds]+   in GHC.Tc.Solver.Canonical.+++Needless to say, all there are wrinkles:+ * (SKOL-ESC) Promotion.  Given alpha[n] ~ ty, what if beta[k] is free   in 'ty', where beta is a unification variable, and k>n?  'beta'   stands for a monotype, and since it is part of a level-n type@@ -1993,7 +2279,7 @@     isTouchableMetaTyVar.    * In the constraint solver, we track where Given equalities occur-    and use that to guard unification in GHC.Tc.Solver.Canonical.unifyTest+    and use that to guard unification in GHC.Tc.Solver.Canonical.touchabilityTest     More details in Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet      Historical note: in the olden days (pre 2021) the constraint solver@@ -2027,7 +2313,7 @@   Generally speaking we always try to put a MetaTv on the left   in preference to SkolemTv or RuntimeUnkTv:      a) Because the MetaTv may be touchable and can be unified-     b) Even if it's not touchable, GHC.Tc.Solver.floatEqualities+     b) Even if it's not touchable, GHC.Tc.Solver.floatConstraints         looks for meta tyvars on the left    Tie-breaking rules for MetaTvs:@@ -2038,12 +2324,16 @@        a TyVarTv with a TauTv, because then the TyVarTv could (transitively)        get a non-tyvar type. So give these a low priority: 1. +  - ConcreteTv: These are like TauTv, except they can only unify with+    a concrete type. So we want to be able to write to them, but not quite+    as much as TauTvs: 2.+   - TauTv: This is the common case; we want these on the left so that they-       can be written to: 2.+       can be written to: 3.    - RuntimeUnkTv: These aren't really meta-variables used in type inference,        but just a convenience in the implementation of the GHCi debugger.-       Eagerly write to these: 3. See Note [RuntimeUnkTv] in+       Eagerly write to these: 4. See Note [RuntimeUnkTv] in        GHC.Runtime.Heap.Inspect.  * Names. If the level and priority comparisons are all@@ -2090,7 +2380,7 @@   Otherwise it can't.  By putting the deepest variable on the left   we maximise our changes of eliminating skolem capture. -  See also GHC.Tc.Solver.Monad Note [Let-bound skolems] for another reason+  See also GHC.Tc.Solver.InertSet Note [Let-bound skolems] for another reason   to orient with the deepest skolem on the left.    IMPORTANT NOTE: this test does a level-number comparison on@@ -2151,38 +2441,6 @@ Revisited in Nov '20, along with removing flattening variables. Problem is still present, and the solution is still the same. -Note [Refactoring hazard: metaTyVarUpdateOK]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-I (Richard E.) have a sad story about refactoring this code, retained here-to prevent others (or a future me!) from falling into the same traps.--It all started with #11407, which was caused by the fact that the TyVarTy-case of defer_me didn't look in the kind. But it seemed reasonable to-simply remove the defer_me check instead.--It referred to two Notes (since removed) that were out of date, and the-fast_check code in occurCheckExpand seemed to do just about the same thing as-defer_me. The one piece that defer_me did that wasn't repeated by-occurCheckExpand was the type-family check. (See Note [Prevent unification-with type families].) So I checked the result of occurCheckExpand for any-type family occurrences and deferred if there were any. This was done-in commit e9bf7bb5cc9fb3f87dd05111aa23da76b86a8967 .--This approach turned out not to be performant, because the expanded-type was bigger than the original type, and tyConsOfType (needed to-see if there are any type family occurrences) looks through type-synonyms. So it then struck me that we could dispense with the-defer_me check entirely. This simplified the code nicely, and it cut-the allocations in T5030 by half. But, as documented in Note [Prevent-unification with type families], this destroyed performance in-T3064. Regardless, I missed this regression and the change was-committed as 3f5d1a13f112f34d992f6b74656d64d95a3f506d .--Bottom lines:- * defer_me is back, but now fixed w.r.t. #11407.- * Tread carefully before you start to refactor here. There can be-   lots of hard-to-predict consequences.- Note [Type synonyms and the occur check] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Generally speaking we try to update a variable with type synonyms not@@ -2238,8 +2496,7 @@  -- | Breaks apart a function kind into its pieces. matchExpectedFunKind-  :: Outputable fun-  => fun             -- ^ type, only for errors+  :: TypedThing     -- ^ type, only for errors   -> Arity           -- ^ n: number of desired arrows   -> TcKind          -- ^ fun_ kind   -> TcM Coercion    -- ^ co :: fun_kind ~ (arg1 -> ... -> argn -> res)@@ -2270,7 +2527,7 @@            ; let new_fun = mkVisFunTysMany arg_kinds res_kind                  origin  = TypeEqOrigin { uo_actual   = k                                         , uo_expected = new_fun-                                        , uo_thing    = Just (ppr hs_ty)+                                        , uo_thing    = Just hs_ty                                         , uo_visible  = True                                         }            ; uType KindLevel origin k new_fun }@@ -2316,23 +2573,22 @@  ---------------- {-# NOINLINE checkTyVarEq #-}  -- checkTyVarEq becomes big after the `inline` fires-checkTyVarEq :: DynFlags -> TcTyVar -> TcType -> CheckTyEqResult-checkTyVarEq dflags tv ty-  = inline checkTypeEq dflags (TyVarLHS tv) ty+checkTyVarEq :: TcTyVar -> TcType -> CheckTyEqResult+checkTyVarEq tv ty+  = inline checkTypeEq (TyVarLHS tv) ty     -- inline checkTypeEq so that the `case`s over the CanEqLHS get blasted away  {-# NOINLINE checkTyFamEq #-}  -- checkTyFamEq becomes big after the `inline` fires-checkTyFamEq :: DynFlags-             -> TyCon     -- type function+checkTyFamEq :: TyCon     -- type function              -> [TcType]  -- args, exactly saturated              -> TcType    -- RHS              -> CheckTyEqResult   -- always drops cteTypeFamily-checkTyFamEq dflags fun_tc fun_args ty-  = inline checkTypeEq dflags (TyFamLHS fun_tc fun_args) ty+checkTyFamEq fun_tc fun_args ty+  = inline checkTypeEq (TyFamLHS fun_tc fun_args) ty     `cterRemoveProblem` cteTypeFamily     -- inline checkTypeEq so that the `case`s over the CanEqLHS get blasted away -checkTypeEq :: DynFlags -> CanEqLHS -> TcType -> CheckTyEqResult+checkTypeEq :: CanEqLHS -> TcType -> CheckTyEqResult -- If cteHasNoProblem (checkTypeEq dflags lhs rhs), then lhs ~ rhs -- is a canonical CEqCan. --@@ -2340,8 +2596,7 @@ --   (a) a forall type (forall a. blah) --   (b) a predicate type (c => ty) --   (c) a type family; see Note [Prevent unification with type families]---   (d) a blocking coercion hole---   (e) an occurrence of the LHS (occurs check)+--   (d) an occurrence of the LHS (occurs check) -- -- Note that an occurs-check does not mean "definite error".  For example --   type family F a@@ -2352,22 +2607,20 @@ -- certainly can't unify b0 := F b0 -- -- For (a), (b), and (c) we check only the top level of the type, NOT--- inside the kinds of variables it mentions.  For (d) we look deeply--- in coercions when the LHS is a tyvar (but skip coercions for type family--- LHSs), and for (e) see Note [CEqCan occurs check] in GHC.Tc.Types.Constraint.+-- inside the kinds of variables it mentions, and for (d) see+-- Note [CEqCan occurs check] in GHC.Tc.Types.Constraint. -- -- checkTypeEq is called from --    * checkTyFamEq, checkTyVarEq (which inline it to specialise away the --      case-analysis on 'lhs') --    * checkEqCanLHSFinish, which does not know the form of 'lhs'-checkTypeEq dflags lhs ty+checkTypeEq lhs ty   = go ty   where-    impredicative    = cteProblem cteImpredicative-    type_family      = cteProblem cteTypeFamily-    hole_blocker     = cteProblem cteHoleBlocker-    insoluble_occurs = cteProblem cteInsolubleOccurs-    soluble_occurs   = cteProblem cteSolubleOccurs+    impredicative      = cteProblem cteImpredicative+    type_family        = cteProblem cteTypeFamily+    insoluble_occurs   = cteProblem cteInsolubleOccurs+    soluble_occurs     = cteProblem cteSolubleOccurs      -- The GHCi runtime debugger does its type-matching with     -- unification variables that can unify with a polytype@@ -2436,21 +2689,11 @@      -- inferred     go_co co | TyVarLHS tv <- lhs              , tv `elemVarSet` tyCoVarsOfCo co-             = soluble_occurs S.<> maybe_hole_blocker+             = soluble_occurs          -- Don't check coercions for type families; see commentary at top of function              | otherwise-             = maybe_hole_blocker-      where-        -- See GHC.Tc.Solver.Canonical Note [Equalities with incompatible kinds]-        -- Wrinkle (2) about this case in general, Wrinkle (4b) about the check for-        -- deferred type errors-        maybe_hole_blocker | not (gopt Opt_DeferTypeErrors dflags)-                           , hasCoercionHoleCo co-                           = hole_blocker--                           | otherwise-                           = cteOK+             = cteOK      check_tc :: TyCon -> CheckTyEqResult     check_tc
compiler/GHC/Tc/Utils/Unify.hs-boot view
@@ -1,18 +1,17 @@ module GHC.Tc.Utils.Unify where  import GHC.Prelude+import GHC.Core.Type         ( Mult ) import GHC.Tc.Utils.TcType   ( TcTauType ) import GHC.Tc.Types          ( TcM ) import GHC.Tc.Types.Evidence ( TcCoercion, HsWrapper )-import GHC.Tc.Types.Origin ( CtOrigin )-import GHC.Utils.Outputable( SDoc )-import GHC.Hs.Type     ( Mult )+import GHC.Tc.Types.Origin   ( CtOrigin, TypedThing )   -- This boot file exists only to tie the knot between---              GHC.Tc.Utils.Unify and Inst+--   GHC.Tc.Utils.Unify and GHC.Tc.Utils.Instantiate -unifyType :: Maybe SDoc -> TcTauType -> TcTauType -> TcM TcCoercion-unifyKind :: Maybe SDoc -> TcTauType -> TcTauType -> TcM TcCoercion+unifyType :: Maybe TypedThing -> TcTauType -> TcTauType -> TcM TcCoercion+unifyKind :: Maybe TypedThing -> TcTauType -> TcTauType -> TcM TcCoercion  tcSubMult :: CtOrigin -> Mult -> Mult -> TcM HsWrapper
compiler/GHC/Tc/Utils/Zonk.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP              #-}+ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies     #-} @@ -14,9 +14,6 @@ -- -- This module is an extension of @HsSyn@ syntax, for use in the type checker. module GHC.Tc.Utils.Zonk (-        -- * Extracting types from HsSyn-        hsLitType, hsPatType, hsLPatType,-         -- * Other HsSyn functions         mkHsDictLet, mkHsApp,         mkHsAppTy, mkHsCaseAlt,@@ -40,17 +37,14 @@         zonkCoToCo,         zonkEvBinds, zonkTcEvBinds,         zonkTcMethInfoToMethInfoX,-        lookupTyVarOcc+        lookupTyVarX   ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Platform  import GHC.Builtin.Types-import GHC.Builtin.Types.Prim import GHC.Builtin.Names  import GHC.Hs@@ -73,6 +67,7 @@ import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain  import GHC.Core.Multiplicity import GHC.Core@@ -99,59 +94,6 @@ import Data.List  ( partition ) import Control.Arrow ( second ) -{--************************************************************************-*                                                                      *-       Extracting the type from HsSyn-*                                                                      *-************************************************************************---}--hsLPatType :: LPat GhcTc -> Type-hsLPatType (L _ p) = hsPatType p--hsPatType :: Pat GhcTc -> Type-hsPatType (ParPat _ pat)                = hsLPatType pat-hsPatType (WildPat ty)                  = ty-hsPatType (VarPat _ lvar)               = idType (unLoc lvar)-hsPatType (BangPat _ pat)               = hsLPatType pat-hsPatType (LazyPat _ pat)               = hsLPatType pat-hsPatType (LitPat _ lit)                = hsLitType lit-hsPatType (AsPat _ var _)               = idType (unLoc var)-hsPatType (ViewPat ty _ _)              = ty-hsPatType (ListPat (ListPatTc ty Nothing) _)      = mkListTy ty-hsPatType (ListPat (ListPatTc _ (Just (ty,_))) _) = ty-hsPatType (TuplePat tys _ bx)           = mkTupleTy1 bx tys-                  -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make-hsPatType (SumPat tys _ _ _ )           = mkSumTy tys-hsPatType (ConPat { pat_con = lcon-                  , pat_con_ext = ConPatTc-                    { cpt_arg_tys = tys-                    }-                  })-                                        = conLikeResTy (unLoc lcon) tys-hsPatType (SigPat ty _ _)               = ty-hsPatType (NPat ty _ _ _)               = ty-hsPatType (NPlusKPat ty _ _ _ _ _)      = ty-hsPatType (XPat (CoPat _ _ ty))         = ty-hsPatType SplicePat{}                   = panic "hsPatType: SplicePat"--hsLitType :: HsLit (GhcPass p) -> TcType-hsLitType (HsChar _ _)       = charTy-hsLitType (HsCharPrim _ _)   = charPrimTy-hsLitType (HsString _ _)     = stringTy-hsLitType (HsStringPrim _ _) = addrPrimTy-hsLitType (HsInt _ _)        = intTy-hsLitType (HsIntPrim _ _)    = intPrimTy-hsLitType (HsWordPrim _ _)   = wordPrimTy-hsLitType (HsInt64Prim _ _)  = int64PrimTy-hsLitType (HsWord64Prim _ _) = word64PrimTy-hsLitType (HsInteger _ _ ty) = ty-hsLitType (HsRat _ _ ty)     = ty-hsLitType (HsFloatPrim _ _)  = floatPrimTy-hsLitType (HsDoublePrim _ _) = doublePrimTy- {- ********************************************************************* *                                                                      *          Short-cuts for overloaded numeric literals@@ -178,15 +120,14 @@ -}  tcShortCutLit :: HsOverLit GhcRn -> ExpRhoType -> TcM (Maybe (HsOverLit GhcTc))-tcShortCutLit lit@(OverLit { ol_val = val, ol_ext = rebindable }) exp_res_ty+tcShortCutLit lit@(OverLit { ol_val = val, ol_ext = OverLitRn rebindable _}) exp_res_ty   | not rebindable   , Just res_ty <- checkingExpType_maybe exp_res_ty   = do { dflags <- getDynFlags        ; let platform = targetPlatform dflags        ; case shortCutLit platform val res_ty of             Just expr -> return $ Just $-                         lit { ol_witness = expr-                             , ol_ext = OverLitTc False res_ty }+                         lit { ol_ext = OverLitTc False expr res_ty }             Nothing   -> return Nothing }   | otherwise   = return Nothing@@ -444,9 +385,6 @@ zonkIdBndr :: ZonkEnv -> TcId -> TcM Id zonkIdBndr env v   = do Scaled w' ty' <- zonkScaledTcTypeToTypeX env (idScaledType v)-       ensureNotLevPoly ty'-         (text "In the type of binder" <+> quotes (ppr v))-        return (modifyIdInfo (`setLevityInfoWithType` ty') (setIdMult (setIdType v ty') w'))  zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]@@ -506,7 +444,7 @@ -- as the old one.  This important when zonking the -- TyVarBndrs of a TyCon, whose Names may scope. zonkTyBndrX env tv-  = ASSERT2( isImmutableTyVar tv, ppr tv <+> dcolon <+> ppr (tyVarKind tv) )+  = assertPpr (isImmutableTyVar tv) (ppr tv <+> dcolon <+> ppr (tyVarKind tv)) $     do { ki <- zonkTcTypeToTypeX env (tyVarKind tv)                -- Internal names tidy up better, for iface files.        ; let tv' = mkTyVar (tyVarName tv) ki@@ -572,14 +510,14 @@     new_binds <- mapM (wrapLocMA zonk_ip_bind) binds     let         env1 = extendIdZonkEnvRec env-                 [ n | (L _ (IPBind _ (Right n) _)) <- new_binds]+                 [ n | (L _ (IPBind n _ _)) <- new_binds]     (env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds     return (env2, HsIPBinds x (IPBinds new_dict_binds new_binds))   where-    zonk_ip_bind (IPBind x n e)-        = do n' <- mapIPNameTc (zonkIdBndr env) n+    zonk_ip_bind (IPBind dict_id n e)+        = do dict_id' <- zonkIdBndr env dict_id              e' <- zonkLExpr env e-             return (IPBind x n' e')+             return (IPBind dict_id' n e')  --------------------------------------------- zonkRecMonoBinds :: ZonkEnv -> LHsBinds GhcTc -> TcM (ZonkEnv, LHsBinds GhcTc)@@ -623,12 +561,12 @@                       , fun_matches = new_ms                       , fun_ext = new_co_fn }) } -zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs-                        , abs_ev_binds = ev_binds-                        , abs_exports = exports-                        , abs_binds = val_binds-                        , abs_sig = has_sig })-  = ASSERT( all isImmutableTyVar tyvars )+zonk_bind env (XHsBindsLR (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs+                                    , abs_ev_binds = ev_binds+                                    , abs_exports = exports+                                    , abs_binds = val_binds+                                    , abs_sig = has_sig }))+  = assert ( all isImmutableTyVar tyvars ) $     do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars        ; (env1, new_evs) <- zonkEvBndrsX env0 evs        ; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds@@ -638,11 +576,11 @@             ; new_val_binds <- mapBagM (zonk_val_bind env3) val_binds             ; new_exports   <- mapM (zonk_export env3) exports             ; return (new_val_binds, new_exports) }-       ; return (AbsBinds { abs_ext = noExtField-                          , abs_tvs = new_tyvars, abs_ev_vars = new_evs+       ; return $ XHsBindsLR $+                 AbsBinds { abs_tvs = new_tyvars, abs_ev_vars = new_evs                           , abs_ev_binds = new_ev_binds                           , abs_exports = new_exports, abs_binds = new_val_bind-                          , abs_sig = has_sig }) }+                          , abs_sig = has_sig } }   where     zonk_val_bind env lbind       | has_sig@@ -650,8 +588,8 @@                              , fun_matches = ms                              , fun_ext     = co_fn })) <- lbind       = do { new_mono_id <- updateIdTypeAndMultM (zonkTcTypeToTypeX env) mono_id-                            -- Specifically /not/ zonkIdBndr; we do not-                            -- want to complain about a levity-polymorphic binder+                            -- Specifically /not/ zonkIdBndr; we do not want to+                            -- complain about a representation-polymorphic binder            ; (env', new_co_fn) <- zonkCoFn env co_fn            ; new_ms            <- zonkMatchGroup env' zonkLExpr ms            ; return $ L loc $@@ -661,17 +599,15 @@       | otherwise       = zonk_lbind env lbind   -- The normal case -    zonk_export :: ZonkEnv -> ABExport GhcTc -> TcM (ABExport GhcTc)-    zonk_export env (ABE{ abe_ext = x-                        , abe_wrap = wrap+    zonk_export :: ZonkEnv -> ABExport -> TcM ABExport+    zonk_export env (ABE{ abe_wrap = wrap                         , abe_poly = poly_id                         , abe_mono = mono_id                         , abe_prags = prags })         = do new_poly_id <- zonkIdBndr env poly_id              (_, new_wrap) <- zonkCoFn env wrap              new_prags <- zonkSpecPrags env prags-             return (ABE{ abe_ext = x-                        , abe_wrap = new_wrap+             return (ABE{ abe_wrap = new_wrap                         , abe_poly = new_poly_id                         , abe_mono = zonkIdOcc env mono_id                         , abe_prags = new_prags })@@ -733,7 +669,7 @@ ************************************************************************ -} -zonkMatchGroup :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan+zonkMatchGroup :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns             => ZonkEnv             -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))             -> MatchGroup GhcTc (LocatedA (body GhcTc))@@ -748,7 +684,7 @@                      , mg_ext = MatchGroupTc arg_tys' res_ty'                      , mg_origin = origin }) } -zonkMatch :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan+zonkMatch :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns           => ZonkEnv           -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))           -> LMatch GhcTc (LocatedA (body GhcTc))@@ -760,7 +696,7 @@         ; return (L loc (match { m_pats = new_pats, m_grhss = new_grhss })) }  --------------------------------------------------------------------------zonkGRHSs :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan+zonkGRHSs :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns           => ZonkEnv           -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))           -> GRHSs GhcTc (LocatedA (body GhcTc))@@ -773,7 +709,7 @@           = do (env2, new_guarded) <- zonkStmts new_env zonkLExpr guarded                new_rhs <- zBody env2 rhs                return (GRHS xx new_guarded new_rhs)-    new_grhss <- mapM (wrapLocM zonk_grhs) grhss+    new_grhss <- mapM (wrapLocMA zonk_grhs) grhss     return (GRHSs x new_grhss new_binds)  {-@@ -792,7 +728,7 @@ zonkLExpr  env expr  = wrapLocMA (zonkExpr env) expr  zonkExpr env (HsVar x (L l id))-  = ASSERT2( isNothing (isDataConId_maybe id), ppr id )+  = assertPpr (isNothing (isDataConId_maybe id)) (ppr id) $     return (HsVar x (L l (zonkIdOcc env id)))  zonkExpr env (HsUnboundVar her occ)@@ -805,17 +741,12 @@            ty'  <- zonkTcTypeToTypeX env ty            return (HER ref ty' u) -zonkExpr env (HsRecFld _ (Ambiguous v occ))-  = return (HsRecFld noExtField (Ambiguous (zonkIdOcc env v) occ))-zonkExpr env (HsRecFld _ (Unambiguous v occ))-  = return (HsRecFld noExtField (Unambiguous (zonkIdOcc env v) occ))--zonkExpr _ e@(HsConLikeOut {}) = return e+zonkExpr env (HsRecSel _ (FieldOcc v occ))+  = return (HsRecSel noExtField (FieldOcc (zonkIdOcc env v) occ)) -zonkExpr _ (HsIPVar x id)-  = return (HsIPVar x id)+zonkExpr _ (HsIPVar x _) = dataConCantHappen x -zonkExpr _ e@HsOverLabel{} = return e+zonkExpr _ (HsOverLabel x _) = dataConCantHappen x  zonkExpr env (HsLit x (HsRat e f ty))   = do new_ty <- zonkTcTypeToTypeX env ty@@ -832,9 +763,9 @@   = do new_matches <- zonkMatchGroup env zonkLExpr matches        return (HsLam x new_matches) -zonkExpr env (HsLamCase x matches)+zonkExpr env (HsLamCase x lc_variant matches)   = do new_matches <- zonkMatchGroup env zonkLExpr matches-       return (HsLamCase x new_matches)+       return (HsLamCase x lc_variant new_matches)  zonkExpr env (HsApp x e1 e2)   = do new_e1 <- zonkLExpr env e1@@ -847,52 +778,30 @@        return (HsAppType new_ty new_e t)        -- NB: the type is an HsType; can't zonk that! -zonkExpr _ e@(HsRnBracketOut _ _ _)-  = pprPanic "zonkExpr: HsRnBracketOut" (ppr e)--zonkExpr env (HsTcBracketOut x wrap body bs)-  = do wrap' <- traverse zonkQuoteWrap wrap-       bs' <- mapM (zonk_b env) bs-       return (HsTcBracketOut x wrap' body bs')-  where-    zonkQuoteWrap (QuoteWrapper ev ty) = do-        let ev' = zonkIdOcc env ev-        ty' <- zonkTcTypeToTypeX env ty-        return (QuoteWrapper ev' ty')+zonkExpr env (HsTypedBracket hsb_tc body)+  = (\x -> HsTypedBracket x body) <$> zonkBracket env hsb_tc -    zonk_b env' (PendingTcSplice n e) = do e' <- zonkLExpr env' e-                                           return (PendingTcSplice n e')+zonkExpr env (HsUntypedBracket hsb_tc body)+  = (\x -> HsUntypedBracket x body) <$> zonkBracket env hsb_tc  zonkExpr env (HsSpliceE _ (XSplice (HsSplicedT s))) =   runTopSplice s >>= zonkExpr env  zonkExpr _ e@(HsSpliceE _ _) = pprPanic "zonkExpr: HsSpliceE" (ppr e) -zonkExpr env (OpApp fixity e1 op e2)-  = do new_e1 <- zonkLExpr env e1-       new_op <- zonkLExpr env op-       new_e2 <- zonkLExpr env e2-       return (OpApp fixity new_e1 new_op new_e2)+zonkExpr _ (OpApp x _ _ _) = dataConCantHappen x  zonkExpr env (NegApp x expr op)   = do (env', new_op) <- zonkSyntaxExpr env op        new_expr <- zonkLExpr env' expr        return (NegApp x new_expr new_op) -zonkExpr env (HsPar x e)+zonkExpr env (HsPar x lpar e rpar)   = do new_e <- zonkLExpr env e-       return (HsPar x new_e)--zonkExpr env (SectionL x expr op)-  = do new_expr <- zonkLExpr env expr-       new_op   <- zonkLExpr env op-       return (SectionL x new_expr new_op)--zonkExpr env (SectionR x op expr)-  = do new_op   <- zonkLExpr env op-       new_expr <- zonkLExpr env expr-       return (SectionR x new_op new_expr)+       return (HsPar x lpar new_e rpar) +zonkExpr _ (SectionL x _ _) = dataConCantHappen x+zonkExpr _ (SectionR x _ _) = dataConCantHappen x zonkExpr env (ExplicitTuple x tup_args boxed)   = do { new_tup_args <- mapM zonk_tup_arg tup_args        ; return (ExplicitTuple x new_tup_args boxed) }@@ -920,7 +829,7 @@        return (HsIf x new_e1 new_e2 new_e3)  zonkExpr env (HsMultiIf ty alts)-  = do { alts' <- mapM (wrapLocM zonk_alt) alts+  = do { alts' <- mapM (wrapLocMA zonk_alt) alts        ; ty'   <- zonkTcTypeToTypeX env ty        ; return $ HsMultiIf ty' alts' }   where zonk_alt (GRHS x guard expr)@@ -928,10 +837,10 @@                ; expr'          <- zonkLExpr env' expr                ; return $ GRHS x guard' expr' } -zonkExpr env (HsLet x binds expr)+zonkExpr env (HsLet x tkLet binds tkIn expr)   = do (new_env, new_binds) <- zonkLocalBinds env binds        new_expr <- zonkLExpr new_env expr-       return (HsLet x new_binds new_expr)+       return (HsLet x tkLet new_binds tkIn new_expr)  zonkExpr env (HsDo ty do_or_lc (L l stmts))   = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts@@ -950,7 +859,7 @@                        , rcon_flds = new_rbinds }) }  -- Record updates via dot syntax are replaced by desugared expressions--- in the renamer. See Note [Rebindable Syntax and HsExpansion]. This+-- in the renamer. See Note [Rebindable syntax and HsExpansion]. This -- is why we match on 'rupd_flds = Left rbinds' here and panic otherwise. zonkExpr env (RecordUpd { rupd_flds = Left rbinds                         , rupd_expr = expr@@ -998,8 +907,9 @@         ; return (HsProc x new_pat new_body) }  -- StaticPointers extension-zonkExpr env (HsStatic fvs expr)-  = HsStatic fvs <$> zonkLExpr env expr+zonkExpr env (HsStatic (fvs, ty) expr)+  = do new_ty <- zonkTcTypeToTypeX env ty+       HsStatic (fvs, new_ty) <$> zonkLExpr env expr  zonkExpr env (XExpr (WrapExpr (HsWrap co_fn expr)))   = do (env1, new_co_fn) <- zonkCoFn env co_fn@@ -1009,6 +919,14 @@ zonkExpr env (XExpr (ExpansionExpr (HsExpanded a b)))   = XExpr . ExpansionExpr . HsExpanded a <$> zonkExpr env b +zonkExpr env (XExpr (ConLikeTc con tvs tys))+  = XExpr . ConLikeTc con tvs <$> mapM zonk_scale tys+  where+    zonk_scale (Scaled m ty) = Scaled <$> zonkTcTypeToTypeX env m <*> pure ty+    -- Only the multiplicity can contain unification variables+    -- The tvs come straight from the data-con, and so are strictly redundant+    -- See Wrinkles of Note [Typechecking data constructors] in GHC.Tc.Gen.Head+ zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)  -------------------------------------------------------------------------@@ -1077,18 +995,18 @@   = do new_matches <- zonkMatchGroup env zonkLCmd matches        return (HsCmdLam x new_matches) -zonkCmd env (HsCmdPar x c)+zonkCmd env (HsCmdPar x lpar c rpar)   = do new_c <- zonkLCmd env c-       return (HsCmdPar x new_c)+       return (HsCmdPar x lpar new_c rpar)  zonkCmd env (HsCmdCase x expr ms)   = do new_expr <- zonkLExpr env expr        new_ms <- zonkMatchGroup env zonkLCmd ms        return (HsCmdCase x new_expr new_ms) -zonkCmd env (HsCmdLamCase x ms)+zonkCmd env (HsCmdLamCase x lc_variant ms)   = do new_ms <- zonkMatchGroup env zonkLCmd ms-       return (HsCmdLamCase x new_ms)+       return (HsCmdLamCase x lc_variant new_ms)  zonkCmd env (HsCmdIf x eCond ePred cThen cElse)   = do { (env1, new_eCond) <- zonkSyntaxExpr env eCond@@ -1097,10 +1015,10 @@        ; new_cElse <- zonkLCmd env1 cElse        ; return (HsCmdIf x new_eCond new_ePred new_cThen new_cElse) } -zonkCmd env (HsCmdLet x binds cmd)+zonkCmd env (HsCmdLet x tkLet binds tkIn cmd)   = do (new_env, new_binds) <- zonkLocalBinds env binds        new_cmd <- zonkLCmd new_env cmd-       return (HsCmdLet x new_binds new_cmd)+       return (HsCmdLet x tkLet new_binds tkIn new_cmd)  zonkCmd env (HsCmdDo ty (L l stmts))   = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts@@ -1110,7 +1028,7 @@   zonkCmdTop :: ZonkEnv -> LHsCmdTop GhcTc -> TcM (LHsCmdTop GhcTc)-zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd+zonkCmdTop env cmd = wrapLocMA (zonk_cmd_top env) cmd  zonk_cmd_top :: ZonkEnv -> HsCmdTop GhcTc -> TcM (HsCmdTop GhcTc) zonk_cmd_top env (HsCmdTop (CmdTopTc stack_tys ty ids) cmd)@@ -1119,8 +1037,8 @@        new_ty <- zonkTcTypeToTypeX env ty        new_ids <- mapSndM (zonkExpr env) ids -       MASSERT( isLiftedTypeKind (tcTypeKind new_stack_tys) )-         -- desugarer assumes that this is not levity polymorphic...+       massert (isLiftedTypeKind (tcTypeKind new_stack_tys))+         -- desugarer assumes that this is not representation-polymorphic...          -- but indeed it should always be lifted due to the typing          -- rules for arrows @@ -1132,17 +1050,17 @@ zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1                                     ; (env2, c2') <- zonkCoFn env1 c2                                     ; return (env2, WpCompose c1' c2') }-zonkCoFn env (WpFun c1 c2 t1 d) = do { (env1, c1') <- zonkCoFn env c1-                                     ; (env2, c2') <- zonkCoFn env1 c2-                                     ; t1'         <- zonkScaledTcTypeToTypeX env2 t1-                                     ; return (env2, WpFun c1' c2' t1' d) }+zonkCoFn env (WpFun c1 c2 t1)  = do { (env1, c1') <- zonkCoFn env c1+                                    ; (env2, c2') <- zonkCoFn env1 c2+                                    ; t1'         <- zonkScaledTcTypeToTypeX env2 t1+                                    ; return (env2, WpFun c1' c2' t1') } zonkCoFn env (WpCast co) = do { co' <- zonkCoToCo env co                               ; return (env, WpCast co') } zonkCoFn env (WpEvLam ev)   = do { (env', ev') <- zonkEvBndrX env ev                                  ; return (env', WpEvLam ev') } zonkCoFn env (WpEvApp arg)  = do { arg' <- zonkEvTerm env arg                                  ; return (env, WpEvApp arg') }-zonkCoFn env (WpTyLam tv)   = ASSERT( isImmutableTyVar tv )+zonkCoFn env (WpTyLam tv)   = assert (isImmutableTyVar tv) $                               do { (env', tv') <- zonkTyBndrX env tv                                  ; return (env', WpTyLam tv') } zonkCoFn env (WpTyApp ty)   = do { ty' <- zonkTcTypeToTypeX env ty@@ -1154,12 +1072,29 @@  ------------------------------------------------------------------------- zonkOverLit :: ZonkEnv -> HsOverLit GhcTc -> TcM (HsOverLit GhcTc)-zonkOverLit env lit@(OverLit {ol_ext = OverLitTc r ty, ol_witness = e })+zonkOverLit env lit@(OverLit {ol_ext = x@OverLitTc { ol_witness = e, ol_type = ty } })   = do  { ty' <- zonkTcTypeToTypeX env ty         ; e' <- zonkExpr env e-        ; return (lit { ol_witness = e', ol_ext = OverLitTc r ty' }) }+        ; return (lit { ol_ext = x { ol_witness = e'+                                   , ol_type = ty' } }) }  -------------------------------------------------------------------------+zonkBracket :: ZonkEnv -> HsBracketTc -> TcM HsBracketTc+zonkBracket env (HsBracketTc hsb_thing ty wrap bs)+  = do wrap' <- traverse zonkQuoteWrap wrap+       bs' <- mapM (zonk_b env) bs+       new_ty <- zonkTcTypeToTypeX env ty+       return (HsBracketTc hsb_thing new_ty wrap' bs')+  where+    zonkQuoteWrap (QuoteWrapper ev ty) = do+        let ev' = zonkIdOcc env ev+        ty' <- zonkTcTypeToTypeX env ty+        return (QuoteWrapper ev' ty')++    zonk_b env' (PendingTcSplice n e) = do e' <- zonkLExpr env' e+                                           return (PendingTcSplice n e')++------------------------------------------------------------------------- zonkArithSeq :: ZonkEnv -> ArithSeqInfo GhcTc -> TcM (ArithSeqInfo GhcTc)  zonkArithSeq env (From e)@@ -1182,7 +1117,6 @@        new_e3 <- zonkLExpr env e3        return (FromThenTo new_e1 new_e2 new_e3) - ------------------------------------------------------------------------- zonkStmts :: Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA           => ZonkEnv@@ -1371,27 +1305,20 @@         ; return (HsRecFields flds' dd) }   where     zonk_rbind (L l fld)-      = do { new_id   <- wrapLocM (zonkFieldOcc env) (hsRecFieldLbl fld)-           ; new_expr <- zonkLExpr env (hsRecFieldArg fld)-           ; return (L l (fld { hsRecFieldLbl = new_id-                              , hsRecFieldArg = new_expr })) }+      = do { new_id   <- wrapLocMA (zonkFieldOcc env) (hfbLHS fld)+           ; new_expr <- zonkLExpr env (hfbRHS fld)+           ; return (L l (fld { hfbLHS = new_id+                              , hfbRHS = new_expr })) }  zonkRecUpdFields :: ZonkEnv -> [LHsRecUpdField GhcTc]                  -> TcM [LHsRecUpdField GhcTc] zonkRecUpdFields env = mapM zonk_rbind   where     zonk_rbind (L l fld)-      = do { new_id   <- wrapLocM (zonkFieldOcc env) (hsRecUpdFieldOcc fld)-           ; new_expr <- zonkLExpr env (hsRecFieldArg fld)-           ; return (L l (fld { hsRecFieldLbl = fmap ambiguousFieldOcc new_id-                              , hsRecFieldArg = new_expr })) }----------------------------------------------------------------------------mapIPNameTc :: (a -> TcM b) -> Either (Located HsIPName) a-            -> TcM (Either (Located HsIPName) b)-mapIPNameTc _ (Left x)  = return (Left x)-mapIPNameTc f (Right x) = do r <- f x-                             return (Right r)+      = do { new_id   <- wrapLocMA (zonkFieldOcc env) (hsRecUpdFieldOcc fld)+           ; new_expr <- zonkLExpr env (hfbRHS fld)+           ; return (L l (fld { hfbLHS = fmap ambiguousFieldOcc new_id+                              , hfbRHS = new_expr })) }  {- ************************************************************************@@ -1408,14 +1335,12 @@ zonkPat env pat = wrapLocSndMA (zonk_pat env) pat  zonk_pat :: ZonkEnv -> Pat GhcTc -> TcM (ZonkEnv, Pat GhcTc)-zonk_pat env (ParPat x p)+zonk_pat env (ParPat x lpar p rpar)   = do  { (env', p') <- zonkPat env p-        ; return (env', ParPat x p') }+        ; return (env', ParPat x lpar p' rpar) }  zonk_pat env (WildPat ty)   = do  { ty' <- zonkTcTypeToTypeX env ty-        ; ensureNotLevPoly ty'-            (text "In a wildcard pattern")         ; return (env, WildPat ty') }  zonk_pat env (VarPat x (L l v))@@ -1441,17 +1366,10 @@         ; ty' <- zonkTcTypeToTypeX env ty         ; return (env', ViewPat ty' expr' pat') } -zonk_pat env (ListPat (ListPatTc ty Nothing) pats)+zonk_pat env (ListPat ty pats)   = do  { ty' <- zonkTcTypeToTypeX env ty         ; (env', pats') <- zonkPats env pats-        ; return (env', ListPat (ListPatTc ty' Nothing) pats') }--zonk_pat env (ListPat (ListPatTc ty (Just (ty2,wit))) pats)-  = do  { (env', wit') <- zonkSyntaxExpr env wit-        ; ty2' <- zonkTcTypeToTypeX env' ty2-        ; ty' <- zonkTcTypeToTypeX env' ty-        ; (env'', pats') <- zonkPats env' pats-        ; return (env'', ListPat (ListPatTc ty' (Just (ty2',wit'))) pats') }+        ; return (env', ListPat ty' pats') }  zonk_pat env (TuplePat tys pats boxed)   = do  { tys' <- mapM (zonkTcTypeToTypeX env) tys@@ -1463,8 +1381,7 @@         ; (env', pat') <- zonkPat env pat         ; return (env', SumPat tys' pat' alt arity) } -zonk_pat env p@(ConPat { pat_con = L _ con-                       , pat_args = args+zonk_pat env p@(ConPat { pat_args = args                        , pat_con_ext = p'@(ConPatTc                          { cpt_tvs = tyvars                          , cpt_dicts = evs@@ -1473,17 +1390,8 @@                          , cpt_arg_tys = tys                          })                        })-  = ASSERT( all isImmutableTyVar tyvars )+  = assert (all isImmutableTyVar tyvars) $     do  { new_tys <- mapM (zonkTcTypeToTypeX env) tys--          -- an unboxed tuple pattern (but only an unboxed tuple pattern)-          -- might have levity-polymorphic arguments. Check for this badness.-        ; case con of-            RealDataCon dc-              | isUnboxedTupleTyCon (dataConTyCon dc)-              -> mapM_ (checkForLevPoly doc) (dropRuntimeRepArgs new_tys)-            _ -> return ()-         ; (env0, new_tyvars) <- zonkTyBndrsX env tyvars           -- Must zonk the existential variables, because their           -- /kind/ need potential zonking.@@ -1505,8 +1413,6 @@                  }                )         }-  where-    doc = text "In the type of an element of an unboxed tuple pattern:" $$ ppr p  zonk_pat env (LitPat x lit) = return (env, LitPat x lit) @@ -1534,13 +1440,16 @@         ; ty' <- zonkTcTypeToTypeX env2 ty         ; return (extendIdZonkEnv env2 n',                   NPlusKPat ty' (L loc n') (L l lit1') lit2' e1' e2') }--zonk_pat env (XPat (CoPat co_fn pat ty))-  = do { (env', co_fn') <- zonkCoFn env co_fn+zonk_pat env (XPat ext) = case ext of+  { ExpansionPat orig pat->+    do { (env, pat') <- zonk_pat env pat+       ; return $ (env, XPat $ ExpansionPat orig pat') }+  ; CoPat co_fn pat ty ->+    do { (env', co_fn') <- zonkCoFn env co_fn        ; (env'', pat') <- zonkPat env' (noLocA pat)        ; ty' <- zonkTcTypeToTypeX env'' ty        ; return (env'', XPat $ CoPat co_fn' (unLoc pat') ty')-       }+       }}  zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat) @@ -1557,9 +1466,9 @@         ; return (env', InfixCon p1' p2') }  zonkConStuff env (RecCon (HsRecFields rpats dd))-  = do  { (env', pats') <- zonkPats env (map (hsRecFieldArg . unLoc) rpats)+  = do  { (env', pats') <- zonkPats env (map (hfbRHS . unLoc) rpats)         ; let rpats' = zipWith (\(L l rp) p' ->-                                  L l (rp { hsRecFieldArg = p' }))+                                  L l (rp { hfbRHS = p' }))                                rpats pats'         ; return (env', RecCon (HsRecFields rpats' dd)) }         -- Field selectors have declared types; hence no zonking@@ -1620,7 +1529,7 @@    zonk_it env v      | isId v     = do { v' <- zonkIdBndr env v                        ; return (extendIdZonkEnvRec env [v'], v') }-     | otherwise  = ASSERT( isImmutableTyVar v)+     | otherwise  = assert (isImmutableTyVar v)                     zonkTyBndrX env v                     -- DV: used to be return (env,v) but that is plain                     -- wrong because we may need to go inside the kind@@ -1862,7 +1771,7 @@ T9198 and #19668.  So yes, it seems worth it. -} -zonkTyVarOcc :: ZonkEnv -> TyVar -> TcM TcType+zonkTyVarOcc :: ZonkEnv -> TcTyVar -> TcM Type zonkTyVarOcc env@(ZonkEnv { ze_flexi = flexi                           , ze_tv_env = tv_env                           , ze_meta_tv_env = mtv_env_ref }) tv@@ -1877,13 +1786,19 @@                   Just ty -> return ty                   Nothing -> do { mtv_details <- readTcRef ref                                 ; zonk_meta ref mtv_details } }-  | otherwise+  | otherwise  -- This should never really happen;+               -- TyVars should not occur in the typechecker   = lookup_in_tv_env    where     lookup_in_tv_env    -- Look up in the env just as we do for Ids       = case lookupVarEnv tv_env tv of-          Nothing  -> mkTyVarTy <$> updateTyVarKindM (zonkTcTypeToTypeX env) tv+          Nothing  -> -- TyVar/SkolemTv/RuntimeUnk that isn't in the ZonkEnv+                      -- This can happen for RuntimeUnk variables (which+                      -- should stay as RuntimeUnk), but I think it should+                      -- not happen for SkolemTv.+                      mkTyVarTy <$> updateTyVarKindM (zonkTcTypeToTypeX env) tv+           Just tv' -> return (mkTyVarTy tv')      zonk_meta ref Flexi@@ -1900,9 +1815,11 @@       = do { updTcRef mtv_env_ref (\env -> extendVarEnv env tv ty)            ; return ty } -lookupTyVarOcc :: ZonkEnv -> TcTyVar -> Maybe TyVar-lookupTyVarOcc (ZonkEnv { ze_tv_env = tv_env }) tv-  = lookupVarEnv tv_env tv+lookupTyVarX :: ZonkEnv -> TcTyVar -> TyVar+lookupTyVarX (ZonkEnv { ze_tv_env = tv_env }) tv+  = case lookupVarEnv tv_env tv of+       Just tv -> tv+       Nothing -> pprPanic "lookupTyVarOcc" (ppr tv $$ ppr tv_env)  commitFlexi :: ZonkFlexi -> TcTyVar -> Kind -> TcM Type -- Only monadic so we can do tc-tracing@@ -1911,9 +1828,19 @@       SkolemiseFlexi  -> return (mkTyVarTy (mkTyVar name zonked_kind))        DefaultFlexi+          -- Normally, RuntimeRep variables are defaulted in TcMType.defaultTyVar+          -- But that sees only type variables that appear in, say, an inferred type+          -- Defaulting here in the zonker is needed to catch e.g.+          --    y :: Bool+          --    y = (\x -> True) undefined+          -- We need *some* known RuntimeRep for the x and undefined, but no one+          -- will choose it until we get here, in the zonker.         | isRuntimeRepTy zonked_kind         -> do { traceTc "Defaulting flexi tyvar to LiftedRep:" (pprTyVar tv)               ; return liftedRepTy }+        | isLevityTy zonked_kind+        -> do { traceTc "Defaulting flexi tyvar to Lifted:" (pprTyVar tv)+              ; return liftedDataConTy }         | isMultiplicityTy zonked_kind         -> do { traceTc "Defaulting flexi tyvar to Many:" (pprTyVar tv)               ; return manyDataConTy }@@ -1952,11 +1879,6 @@               -- (undeferred) type errors. Originally, I put in a panic               -- here, but that caused too many uses of `failIfErrsM`.            Nothing -> do { traceTc "Zonking unfilled coercion hole" (ppr hole)-                         ; when debugIsOn $-                           whenNoErrs $-                           MASSERT2( False-                                   , text "Type-correct unfilled coercion hole"-                                     <+> ppr hole )                          ; cv' <- zonkCoVar cv                          ; return $ mkCoVarCo cv' } }                              -- This will be an out-of-scope variable, but keeping
compiler/GHC/Tc/Validity.hs view
@@ -1,5 +1,6 @@-{-# LANGUAGE CPP           #-} +{-# LANGUAGE DerivingStrategies #-}+ {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-} @@ -9,19 +10,17 @@ -}  module GHC.Tc.Validity (-  Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType,+  Rank(..), UserTypeCtxt(..), checkValidType, checkValidMonoType,   checkValidTheta,   checkValidInstance, checkValidInstHead, validDerivPred,   checkTySynRhs,   checkValidCoAxiom, checkValidCoAxBranch,   checkValidTyFamEqn, checkValidAssocTyFamDeflt, checkConsistentFamInst,-  badATErr, arityErr,+  arityErr,   checkTyConTelescope,   allDistinctTyVars   ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Data.Maybe@@ -34,7 +33,7 @@ import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Ppr import GHC.Tc.Utils.TcType hiding ( sizeType, sizeTypes )-import GHC.Builtin.Types ( heqTyConName, eqTyConName, coercibleTyConName, manyDataConTy )+import GHC.Builtin.Types import GHC.Builtin.Names import GHC.Core.Type import GHC.Core.Unify ( tcMatchTyX_BM, BindFlag(..) )@@ -44,6 +43,9 @@ import GHC.Core.TyCon import GHC.Core.Predicate import GHC.Tc.Types.Origin+import GHC.Tc.Types.Rank+import GHC.Tc.Errors.Types+import GHC.Types.Error  -- others: import GHC.Iface.Type    ( pprIfaceType, pprIfaceTypeApp )@@ -55,6 +57,7 @@ import GHC.Core.FamInstEnv    ( isDominatedBy, injectiveBranches, InjectivityCheckResult(..) ) import GHC.Tc.Instance.Family+import GHC.Types.Basic   ( UnboxedTupleOrSum(..), unboxedTupleOrSumExtension ) import GHC.Types.Name import GHC.Types.Var.Env import GHC.Types.Var.Set@@ -68,7 +71,6 @@ import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import GHC.Builtin.Uniques  ( mkAlphaTyVarUnique )-import GHC.Data.Bag      ( emptyBag ) import qualified GHC.LanguageExtensions as LangExt  import Control.Monad@@ -257,27 +259,41 @@       StandaloneKindSigCtxt{} -> False       _            -> True -checkUserTypeError :: Type -> TcM ()--- Check to see if the type signature mentions "TypeError blah"--- anywhere in it, and fail if so.+-- | Check whether the type signature contains custom type errors,+-- and fail if so. --+-- Note that some custom type errors are acceptable:+--+--   - in the RHS of a type synonym, e.g. to allow users to define+--     type synonyms for custom type errors with large messages (#20181),+--   - inside a type family application, as a custom type error+--     might evaporate after performing type family reduction (#20241).+checkUserTypeError :: UserTypeCtxt -> Type -> TcM () -- Very unsatisfactorily (#11144) we need to tidy the type -- because it may have come from an /inferred/ signature, not a -- user-supplied one.  This is really only a half-baked fix; -- the other errors in checkValidType don't do tidying, and so -- may give bad error messages when given an inferred type.-checkUserTypeError = check+checkUserTypeError ctxt ty+  | TySynCtxt {} <- ctxt  -- Do not complain about TypeError on the+  = return ()             -- RHS of type synonyms. See #20181++  | otherwise+  = check ty   where   check ty-    | Just msg     <- userTypeError_maybe ty      = fail_with msg-    | Just (_,ts)  <- splitTyConApp_maybe ty      = mapM_ check ts-    | Just (t1,t2) <- splitAppTy_maybe ty         = check t1 >> check t2-    | Just (_,t1)  <- splitForAllTyCoVar_maybe ty = check t1-    | otherwise                                   = return ()+    | Just msg    <- userTypeError_maybe ty      = fail_with msg+    | Just (_,t1) <- splitForAllTyCoVar_maybe ty = check t1+    | let (_,tys) =  splitAppTys ty              = mapM_ check tys+    -- splitAppTys keeps type family applications saturated.+    -- This means we don't go looking for user type errors+    -- inside type family arguments (see #20241). +  fail_with :: Type -> TcM ()   fail_with msg = do { env0 <- tcInitTidyEnv                      ; let (env1, tidy_msg) = tidyOpenType env0 msg-                     ; failWithTcM (env1, pprUserTypeErrorTy tidy_msg) }+                     ; failWithTcM (env1, TcRnUserTypeError tidy_msg)+                     }   {- Note [When we don't check for ambiguity]@@ -345,6 +361,8 @@ checkValidType :: UserTypeCtxt -> Type -> TcM () -- Checks that a user-written type is valid for the given context -- Assumes argument is fully zonked+-- Assumes arugment is well-kinded;+--    that is, checkValidType doesn't need to do kind checking -- Not used for instance decls; checkValidInstance instead checkValidType ctxt ty   = do { traceTc "checkValidType" (ppr ty <+> text "::" <+> ppr (tcTypeKind ty))@@ -355,23 +373,22 @@                         | otherwise  = r               rank1 = gen_rank r1-             rank0 = gen_rank r0+             rank0 = gen_rank MonoTypeRankZero -             r0 = rankZeroMonoType-             r1 = LimitedRank True r0+             r1 = LimitedRank True MonoTypeRankZero               rank                = case ctxt of                  DefaultDeclCtxt-> MustBeMonoType                  PatSigCtxt     -> rank0-                 RuleSigCtxt _  -> rank1+                 RuleSigCtxt {} -> rank1                  TySynCtxt _    -> rank0 -                 ExprSigCtxt    -> rank1+                 ExprSigCtxt {} -> rank1                  KindSigCtxt    -> rank1                  StandaloneKindSigCtxt{} -> rank1                  TypeAppCtxt | impred_flag -> ArbitraryRank-                             | otherwise   -> tyConArgMonoType+                             | otherwise   -> MonoTypeTyConArg                     -- Normally, ImpredicativeTypes is handled in check_arg_type,                     -- but visible type applications don't go through there.                     -- So we do this check here.@@ -406,7 +423,7 @@        -- (and more complicated) errors in checkAmbiguity        ; checkNoErrs $          do { check_type ve ty-            ; checkUserTypeError ty+            ; checkUserTypeError ctxt ty             ; traceTc "done ct" (ppr ty) }         -- Check for ambiguous types.  See Note [When to call checkAmbiguity]@@ -434,48 +451,15 @@                     (do { dflags <- getDynFlags                         ; expand <- initialExpandMode                         ; check_pred_ty emptyTidyEnv dflags ctxt expand ty })-         else addErrTcM (constraintSynErr emptyTidyEnv actual_kind) }+         else addErrTcM ( emptyTidyEnv+                        , TcRnIllegalConstraintSynonymOfKind (tidyType emptyTidyEnv actual_kind)+                        ) }    | otherwise   = return ()   where     actual_kind = tcTypeKind ty -{--Note [Higher rank types]-~~~~~~~~~~~~~~~~~~~~~~~~-Technically-            Int -> forall a. a->a-is still a rank-1 type, but it's not Haskell 98 (#5957).  So the-validity checker allow a forall after an arrow only if we allow it-before -- that is, with Rank2Types or RankNTypes--}--data Rank = ArbitraryRank         -- Any rank ok--          | LimitedRank   -- Note [Higher rank types]-                 Bool     -- Forall ok at top-                 Rank     -- Use for function arguments--          | MonoType SDoc   -- Monotype, with a suggestion of how it could be a polytype--          | MustBeMonoType  -- Monotype regardless of flags--instance Outputable Rank where-  ppr ArbitraryRank  = text "ArbitraryRank"-  ppr (LimitedRank top_forall_ok r)-                     = text "LimitedRank" <+> ppr top_forall_ok-                                          <+> parens (ppr r)-  ppr (MonoType msg) = text "MonoType" <+> parens msg-  ppr MustBeMonoType = text "MustBeMonoType"--rankZeroMonoType, tyConArgMonoType, synArgMonoType, constraintMonoType :: Rank-rankZeroMonoType   = MonoType (text "Perhaps you intended to use RankNTypes")-tyConArgMonoType   = MonoType (text "Perhaps you intended to use ImpredicativeTypes")-synArgMonoType     = MonoType (text "Perhaps you intended to use LiberalTypeSynonyms")-constraintMonoType = MonoType (vcat [ text "A constraint must be a monotype"-                                    , text "Perhaps you intended to use QuantifiedConstraints" ])- funArgResRank :: Rank -> (Rank, Rank)             -- Function argument and result funArgResRank (LimitedRank _ arg_rank) = (arg_rank, LimitedRank (forAllAllowed arg_rank) arg_rank) funArgResRank other_rank               = (other_rank, other_rank)@@ -719,7 +703,8 @@ -- Rank is allowed rank for function args -- Rank 0 means no for-alls anywhere -check_type _ (TyVarTy _) = return ()+check_type _ (TyVarTy _)+  = return ()  check_type ve (AppTy ty1 ty2)   = do  { check_type ve ty1@@ -728,9 +713,17 @@ check_type ve ty@(TyConApp tc tys)   | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc   = check_syn_tc_app ve ty tc tys-  | isUnboxedTupleTyCon tc = check_ubx_tuple ve ty tys-  | otherwise              = mapM_ (check_arg_type False ve) tys +  -- Check for unboxed tuples and unboxed sums: these+  -- require the corresponding extension to be enabled.+  | isUnboxedTupleTyCon tc+  = check_ubx_tuple_or_sum UnboxedTupleType ve ty tys+  | isUnboxedSumTyCon tc+  = check_ubx_tuple_or_sum UnboxedSumType   ve ty tys++  | otherwise+  = mapM_ (check_arg_type False ve) tys+ check_type _ (LitTy {}) = return ()  check_type ve (CastTy ty _) = check_type ve ty@@ -743,7 +736,7 @@                           , ve_rank = rank, ve_expand = expand }) ty   | not (null tvbs && null theta)   = do  { traceTc "check_type" (ppr ty $$ ppr rank)-        ; checkTcM (forAllAllowed rank) (forAllTyErr env rank ty)+        ; checkTcM (forAllAllowed rank) (env, TcRnForAllRankErr rank (tidyType env ty))                 -- Reject e.g. (Maybe (?x::Int => Int)),                 -- with a decent error message @@ -753,7 +746,7 @@          ; checkTcM (all (isInvisibleArgFlag . binderArgFlag) tvbs                          || vdqAllowed ctxt)-                   (illegalVDQTyErr env ty)+                   (env, TcRnVDQInTermType (tidyType env ty))                 -- Reject visible, dependent quantification in the type of a                 -- term (e.g., `f :: forall a -> a -> Maybe a`) @@ -764,17 +757,17 @@         ; check_type (ve{ve_tidy_env = env'}) tau                 -- Allow foralls to right of arrow -        ; checkEscapingKind env' tvbs' theta tau }+        }   where     (tvbs, phi)   = tcSplitForAllTyVarBinders ty     (theta, tau)  = tcSplitPhiTy phi-    (env', tvbs') = tidyTyCoVarBinders env tvbs+    (env', _)     = tidyTyCoVarBinders env tvbs  check_type (ve@ValidityEnv{ ve_tidy_env = env, ve_ctxt = ctxt                           , ve_rank = rank })            ty@(FunTy _ mult arg_ty res_ty)   = do  { failIfTcM (not (linearityAllowed ctxt) && not (isManyDataConTy mult))-                     (linearFunKindErr env ty)+                     (env, TcRnLinearFuncInKind (tidyType env ty))         ; check_type (ve{ve_rank = arg_rank}) arg_ty         ; check_type (ve{ve_rank = res_rank}) res_ty }   where@@ -824,7 +817,7 @@     check_args_only expand = mapM_ (check_arg expand) tys      check_expansion_only expand-      = ASSERT2( isTypeSynonymTyCon tc, ppr tc )+      = assertPpr (isTypeSynonymTyCon tc) (ppr tc) $         case tcView ty of          Just ty' -> let err_ctxt = text "In the expansion of type synonym"                                     <+> quotes (ppr tc)@@ -871,16 +864,17 @@ -}  -----------------------------------------check_ubx_tuple :: ValidityEnv -> KindOrType -> [KindOrType] -> TcM ()-check_ubx_tuple (ve@ValidityEnv{ve_tidy_env = env}) ty tys-  = do  { ub_tuples_allowed <- xoptM LangExt.UnboxedTuples-        ; checkTcM ub_tuples_allowed (ubxArgTyErr env ty)+check_ubx_tuple_or_sum :: UnboxedTupleOrSum -> ValidityEnv -> KindOrType -> [KindOrType] -> TcM ()+check_ubx_tuple_or_sum tup_or_sum (ve@ValidityEnv{ve_tidy_env = env}) ty tys+  = do  { ub_thing_allowed <- xoptM $ unboxedTupleOrSumExtension tup_or_sum+        ; checkTcM ub_thing_allowed+            (env, TcRnUnboxedTupleOrSumTypeFuncArg tup_or_sum (tidyType env ty))          ; impred <- xoptM LangExt.ImpredicativeTypes-        ; let rank' = if impred then ArbitraryRank else tyConArgMonoType+        ; let rank' = if impred then ArbitraryRank else MonoTypeTyConArg                 -- c.f. check_arg_type                 -- However, args are allowed to be unlifted, or-                -- more unboxed tuples, so can't use check_arg_ty+                -- more unboxed tuples or sums, so can't use check_arg_ty         ; mapM_ (check_type (ve{ve_rank = rank'})) tys }  ----------------------------------------@@ -912,10 +906,10 @@         ; let rank' = case rank of          -- Predictive => must be monotype                         -- Rank-n arguments to type synonyms are OK, provided                         -- that LiberalTypeSynonyms is enabled.-                        _ | type_syn       -> synArgMonoType+                        _ | type_syn       -> MonoTypeSynArg                         MustBeMonoType     -> MustBeMonoType  -- Monotype, regardless                         _other | impred    -> ArbitraryRank-                               | otherwise -> tyConArgMonoType+                               | otherwise -> MonoTypeTyConArg                         -- Make sure that MustBeMonoType is propagated,                         -- so that we don't suggest -XImpredicativeTypes in                         --    (Ord (forall a.a)) => a -> a@@ -933,73 +927,6 @@         ; check_type (ve{ve_ctxt = ctxt', ve_rank = rank'}) ty }  -----------------------------------------forAllTyErr :: TidyEnv -> Rank -> Type -> (TidyEnv, SDoc)-forAllTyErr env rank ty-   = ( env-     , vcat [ hang herald 2 (ppr_tidy env ty)-            , suggestion ] )-  where-    (tvs, _rho) = tcSplitForAllTyVars ty-    herald | null tvs  = text "Illegal qualified type:"-           | otherwise = text "Illegal polymorphic type:"-    suggestion = case rank of-                   LimitedRank {} -> text "Perhaps you intended to use RankNTypes"-                   MonoType d     -> d-                   _              -> Outputable.empty -- Polytype is always illegal---- | Reject type variables that would escape their escape through a kind.--- See @Note [Type variables escaping through kinds]@.-checkEscapingKind :: TidyEnv -> [TyVarBinder] -> ThetaType -> Type -> TcM ()-checkEscapingKind env tvbs theta tau =-  case occCheckExpand (binderVars tvbs) phi_kind of-    -- Ensure that none of the tvs occur in the kind of the forall-    -- /after/ expanding type synonyms.-    -- See Note [Phantom type variables in kinds] in GHC.Core.Type-    Nothing -> failWithTcM $ forAllEscapeErr env tvbs theta tau tau_kind-    Just _  -> pure ()-  where-    tau_kind              = tcTypeKind tau-    phi_kind | null theta = tau_kind-             | otherwise  = liftedTypeKind-        -- If there are any constraints, the kind is *. (#11405)--forAllEscapeErr :: TidyEnv -> [TyVarBinder] -> ThetaType -> Type -> Kind-                -> (TidyEnv, SDoc)-forAllEscapeErr env tvbs theta tau tau_kind-  = ( env-    , vcat [ hang (text "Quantified type's kind mentions quantified type variable")-                2 (text "type:" <+> quotes (ppr (mkSigmaTy tvbs theta tau)))-                -- NB: Don't tidy this type since the tvbs were already tidied-                -- previously, and re-tidying them will make the names of type-                -- variables different from tau_kind.-           , hang (text "where the body of the forall has this kind:")-                2 (quotes (ppr_tidy env tau_kind)) ] )--{--Note [Type variables escaping through kinds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider:--  type family T (r :: RuntimeRep) :: TYPE r-  foo :: forall r. T r--Something smells funny about the type of `foo`. If you spell out the kind-explicitly, it becomes clearer from where the smell originates:--  foo :: ((forall r. T r) :: TYPE r)--The type variable `r` appears in the result kind, which escapes the scope of-its binding site! This is not desirable, so we establish a validity check-(`checkEscapingKind`) to catch any type variables that might escape through-kinds in this way.--}--ubxArgTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc)-ubxArgTyErr env ty-  = ( env, vcat [ sep [ text "Illegal unboxed tuple type as function argument:"-                      , ppr_tidy env ty ]-                , text "Perhaps you intended to use UnboxedTuples" ] )- checkConstraintsOK :: ValidityEnv -> ThetaType -> Type -> TcM () checkConstraintsOK ve theta ty   | null theta                         = return ()@@ -1007,26 +934,8 @@   | otherwise   = -- We are in a kind, where we allow only equality predicates     -- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep, and #16263-    checkTcM (all isEqPred theta) $-    constraintTyErr (ve_tidy_env ve) ty--constraintTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc)-constraintTyErr env ty-  = (env, text "Illegal constraint in a kind:" <+> ppr_tidy env ty)---- | Reject a use of visible, dependent quantification in the type of a term.-illegalVDQTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc)-illegalVDQTyErr env ty =-  (env, vcat-  [ hang (text "Illegal visible, dependent quantification" <+>-          text "in the type of a term:")-       2 (ppr_tidy env ty)-  , text "(GHC does not yet support this)" ] )---- | Reject uses of linear function arrows in kinds.-linearFunKindErr :: TidyEnv -> Type -> (TidyEnv, SDoc)-linearFunKindErr env ty =-  (env, text "Illegal linear function in a kind:" <+> ppr_tidy env ty)+    checkTcM (all isEqPred theta) (env, TcRnConstraintInKind (tidyType env ty))+  where env = ve_tidy_env ve  {- Note [Liberal type synonyms]@@ -1117,15 +1026,8 @@   = return () check_valid_theta env ctxt expand theta   = do { dflags <- getDynFlags-       ; warnTcM (Reason Opt_WarnDuplicateConstraints)-                 (wopt Opt_WarnDuplicateConstraints dflags && notNull dups)-                 (dupPredWarn env dups)        ; traceTc "check_valid_theta" (ppr theta)        ; mapM_ (check_pred_ty env dflags ctxt expand) theta }-  where-    (_,dups) = removeDups nonDetCmpType theta-    -- It's OK to use nonDetCmpType because dups only appears in the-    -- warning  ------------------------- {- Note [Validity checking for constraints]@@ -1163,7 +1065,7 @@     rank | xopt LangExt.QuantifiedConstraints dflags          = ArbitraryRank          | otherwise-         = constraintMonoType+         = MonoTypeConstraint      ve :: ValidityEnv     ve = ValidityEnv{ ve_tidy_env = env@@ -1194,18 +1096,10 @@               -- is wrong.  For user written signatures, it'll be rejected by kind-checking               -- well before we get to validity checking.  For inferred types we are careful               -- to box such constraints in GHC.Tc.Utils.TcType.pickQuantifiablePreds, as described-              -- in Note [Lift equality constraints when quantifying] in GHC.Tc.Utils.TcType+              -- in Note [Lift equality constraints when quantifying] in GHC.Tc.Solver        ForAllPred _ theta head -> check_quant_pred env dflags ctxt pred theta head-      IrredPred {}            -> check_irred_pred under_syn env dflags pred--check_eq_pred :: TidyEnv -> DynFlags -> PredType -> TcM ()-check_eq_pred env dflags pred-  =         -- Equational constraints are valid in all contexts if type-            -- families are permitted-    checkTcM (xopt LangExt.TypeFamilies dflags-              || xopt LangExt.GADTs dflags)-             (eqPredTyErr env pred)+      _                       -> return ()  check_quant_pred :: TidyEnv -> DynFlags -> UserTypeCtxt                  -> PredType -> ThetaType -> PredType -> TcM ()@@ -1223,7 +1117,7 @@                                -- in check_pred_ty             IrredPred {}      | hasTyVarHead head_pred                               -> return ()-            _                 -> failWithTcM (badQuantHeadErr env pred)+            _                 -> failWithTcM (env, TcRnBadQuantPredHead (tidyType env pred))           -- Check for termination        ; unless (xopt LangExt.UndecidableInstances dflags) $@@ -1234,23 +1128,11 @@ check_tuple_pred under_syn env dflags ctxt pred ts   = do { -- See Note [ConstraintKinds in predicates]          checkTcM (under_syn || xopt LangExt.ConstraintKinds dflags)-                  (predTupleErr env pred)+                  (env, TcRnIllegalTupleConstraint (tidyType env pred))        ; mapM_ (check_pred_help under_syn env dflags ctxt) ts }     -- This case will not normally be executed because without     -- -XConstraintKinds tuple types are only kind-checked as * -check_irred_pred :: Bool -> TidyEnv -> DynFlags -> PredType -> TcM ()-check_irred_pred under_syn env dflags pred-    -- The predicate looks like (X t1 t2) or (x t1 t2) :: Constraint-    -- where X is a type function-  =      -- If it looks like (x t1 t2), require ConstraintKinds-         --   see Note [ConstraintKinds in predicates]-         -- But (X t1 t2) is always ok because we just require ConstraintKinds-         -- at the definition site (#9838)-    failIfTcM (not under_syn && not (xopt LangExt.ConstraintKinds dflags)-                            && hasTyVarHead pred)-              (predIrredErr env pred)- {- Note [ConstraintKinds in predicates] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Don't check for -XConstraintKinds under a type synonym, because that@@ -1268,16 +1150,20 @@ check_class_pred env dflags ctxt pred cls tys   | isEqPredClass cls    -- (~) and (~~) are classified as classes,                          -- but here we want to treat them as equalities-  = check_eq_pred env dflags pred+  = -- Equational constraints are valid in all contexts, and+    -- we do not need to check e.g. for FlexibleContexts here, so just do nothing+    -- We used to require TypeFamilies/GADTs for equality constraints,+    -- but not anymore (GHC Proposal #371)+   return ()    | isIPClass cls   = do { check_arity-       ; checkTcM (okIPCtxt ctxt) (badIPPred env pred) }+       ; checkTcM (okIPCtxt ctxt) (env, TcRnIllegalImplicitParam (tidyType env pred)) }    | otherwise     -- Includes Coercible   = do { check_arity        ; checkSimplifiableClassConstraint env dflags ctxt cls tys-       ; checkTcM arg_tys_ok (predTyVarErr env pred) }+       ; checkTcM arg_tys_ok (env, TcRnNonTypeVarArgInConstraint (tidyType env pred)) }   where     check_arity = checkTc (tys `lengthIs` classArity cls)                           (tyConArityErr (classTyCon cls) tys)@@ -1312,8 +1198,11 @@   = do { result <- matchGlobalInst dflags False cls tys        ; case result of            OneInst { cir_what = what }-              -> addWarnTc (Reason Opt_WarnSimplifiableClassConstraints)-                                   (simplifiable_constraint_warn what)+              -> let dia = TcRnUnknownMessage $+                       mkPlainDiagnostic (WarningWithFlag Opt_WarnSimplifiableClassConstraints)+                                         noHints+                                         (simplifiable_constraint_warn what)+                 in addDiagnosticTc dia            _          -> return () }   where     pred = mkClassPred cls tys@@ -1366,7 +1255,7 @@   -- See Note [Implicit parameters in instance decls] okIPCtxt (FunSigCtxt {})        = True okIPCtxt (InfSigCtxt {})        = True-okIPCtxt ExprSigCtxt            = True+okIPCtxt (ExprSigCtxt {})       = True okIPCtxt TypeAppCtxt            = True okIPCtxt PatSigCtxt             = True okIPCtxt GenSigCtxt             = True@@ -1419,52 +1308,7 @@            , vcat [ text "In the context:" <+> pprTheta (tidyTypes env theta)                   , text "While checking" <+> pprUserTypeCtxt ctxt ] ) -eqPredTyErr, predTupleErr, predIrredErr,-   badQuantHeadErr :: TidyEnv -> PredType -> (TidyEnv, SDoc)-badQuantHeadErr env pred-  = ( env-    , hang (text "Quantified predicate must have a class or type variable head:")-         2 (ppr_tidy env pred) )-eqPredTyErr  env pred-  = ( env-    , text "Illegal equational constraint" <+> ppr_tidy env pred $$-      parens (text "Use GADTs or TypeFamilies to permit this") )-predTupleErr env pred-  = ( env-    , hang (text "Illegal tuple constraint:" <+> ppr_tidy env pred)-         2 (parens constraintKindsMsg) )-predIrredErr env pred-  = ( env-    , hang (text "Illegal constraint:" <+> ppr_tidy env pred)-         2 (parens constraintKindsMsg) )--predTyVarErr :: TidyEnv -> PredType -> (TidyEnv, SDoc)-predTyVarErr env pred-  = (env-    , vcat [ hang (text "Non type-variable argument")-                2 (text "in the constraint:" <+> ppr_tidy env pred)-           , parens (text "Use FlexibleContexts to permit this") ])--badIPPred :: TidyEnv -> PredType -> (TidyEnv, SDoc)-badIPPred env pred-  = ( env-    , text "Illegal implicit parameter" <+> quotes (ppr_tidy env pred) )--constraintSynErr :: TidyEnv -> Type -> (TidyEnv, SDoc)-constraintSynErr env kind-  = ( env-    , hang (text "Illegal constraint synonym of kind:" <+> quotes (ppr_tidy env kind))-         2 (parens constraintKindsMsg) )--dupPredWarn :: TidyEnv -> [NE.NonEmpty PredType] -> (TidyEnv, SDoc)-dupPredWarn env dups-  = ( env-    , text "Duplicate constraint" <> plural primaryDups <> text ":"-      <+> pprWithCommas (ppr_tidy env) primaryDups )-  where-    primaryDups = map NE.head dups--tyConArityErr :: TyCon -> [TcType] -> SDoc+tyConArityErr :: TyCon -> [TcType] -> TcRnMessage -- For type-constructor arity errors, be careful to report -- the number of /visible/ arguments required and supplied, -- ignoring the /invisible/ arguments, which the user does not see.@@ -1480,9 +1324,10 @@     tc_type_arity = count isVisibleTyConBinder (tyConBinders tc)     tc_type_args  = length vis_tks -arityErr :: Outputable a => SDoc -> a -> Int -> Int -> SDoc+arityErr :: Outputable a => SDoc -> a -> Int -> Int -> TcRnMessage arityErr what name n m-  = hsep [ text "The" <+> what, quotes (ppr name), text "should have",+  = TcRnUnknownMessage $ mkPlainError noHints $+    hsep [ text "The" <+> what, quotes (ppr name), text "should have",            n_arguments <> comma, text "but has been given",            if m==0 then text "none" else int m]     where@@ -1521,11 +1366,12 @@ Note [Instances of built-in classes in signature files] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -User defined instances for KnownNat, KnownSymbol and Typeable are-disallowed -- they are generated when needed by GHC itself on-the-fly.+User defined instances for KnownNat, KnownSymbol, KnownChar,+and Typeable are disallowed+  -- they are generated when needed by GHC itself, on-the-fly.  However, if they occur in a Backpack signature file, they have an-entirely different meaning. Suppose in M.hsig we see+entirely different meaning. To illustrate, suppose in M.hsig we see    signature M where     data T :: Nat@@ -1544,49 +1390,57 @@ check_special_inst_head :: DynFlags -> Bool -> Bool                         -> UserTypeCtxt -> Class -> [Type] -> TcM () -- Wow!  There are a surprising number of ad-hoc special cases here.+-- TODO: common up the logic for special typeclasses (see GHC ticket #20441). check_special_inst_head dflags is_boot is_sig ctxt clas cls_args    -- If not in an hs-boot file, abstract classes cannot have instances   | isAbstractClass clas   , not is_boot-  = failWithTc abstract_class_msg+  = failWithTc (TcRnAbstractClassInst clas) -  -- For Typeable, don't complain about instances for-  -- standalone deriving; they are no-ops, and we warn about-  -- it in GHC.Tc.Deriv.deriveStandalone.+  -- Complain about hand-written instances of built-in classes+  -- Typeable, KnownNat, KnownSymbol, Coercible, HasField.++  -- Disallow hand-written Typeable instances, except that we+  -- allow a standalone deriving declaration: they are no-ops,+  -- and we warn about them in GHC.Tc.Deriv.deriveStandalone.   | clas_nm == typeableClassName   , not is_sig     -- Note [Instances of built-in classes in signature files]   , hand_written_bindings-  = failWithTc rejected_class_msg+  = failWithTc $ TcRnSpecialClassInst clas False -  -- Handwritten instances of KnownNat/KnownSymbol class-  -- are always forbidden (#12837)-  | clas_nm `elem` [ knownNatClassName, knownSymbolClassName ]-  , not is_sig+  -- Handwritten instances of KnownNat/KnownChar/KnownSymbol+  -- are forbidden outside of signature files (#12837).+  -- Derived instances are forbidden completely (#21087).+  | clas_nm `elem` [ knownNatClassName, knownSymbolClassName, knownCharClassName ]+  , (not is_sig && hand_written_bindings) || derived_instance     -- Note [Instances of built-in classes in signature files]-  , hand_written_bindings-  = failWithTc rejected_class_msg+  = failWithTc $ TcRnSpecialClassInst clas False    -- For the most part we don't allow   -- instances for (~), (~~), or Coercible;   -- but we DO want to allow them in quantified constraints:   --   f :: (forall a b. Coercible a b => Coercible (m a) (m b)) => ...m...-  | clas_nm `elem` [ heqTyConName, eqTyConName, coercibleTyConName ]+  | clas_nm `elem` [ heqTyConName, eqTyConName, coercibleTyConName, withDictClassName ]   , not quantified_constraint-  = failWithTc rejected_class_msg+  = failWithTc $ TcRnSpecialClassInst clas False    -- Check for hand-written Generic instances (disallowed in Safe Haskell)   | clas_nm `elem` genericClassNames   , hand_written_bindings-  =  do { failIfTc (safeLanguageOn dflags) gen_inst_err-        ; when (safeInferOn dflags) (recordUnsafeInfer emptyBag) }+  =  do { failIfTc (safeLanguageOn dflags) (TcRnSpecialClassInst clas True)+        ; when (safeInferOn dflags) (recordUnsafeInfer emptyMessages) }    | clas_nm == hasFieldClassName+  , not quantified_constraint+  -- Don't do any validity checking for HasField contexts+  -- inside quantified constraints (#20989): the validity checks+  -- only apply to user-written instances.   = checkHasFieldInst clas cls_args    | isCTupleClass clas-  = failWithTc tuple_class_msg+  = failWithTc (TcRnTupleConstraintInst clas)    -- Check language restrictions on the args to the class   | check_h98_arg_shape@@ -1600,12 +1454,19 @@     ty_args = filterOutInvisibleTypes (classTyCon clas) cls_args      hand_written_bindings-        = case ctxt of-            InstDeclCtxt stand_alone -> not stand_alone-            SpecInstCtxt             -> False-            DerivClauseCtxt          -> False-            _                        -> True+      = case ctxt of+          InstDeclCtxt standalone -> not standalone+          SpecInstCtxt            -> False+          DerivClauseCtxt         -> False+          SigmaCtxt               -> False+          _                       -> True +    derived_instance+      = case ctxt of+            InstDeclCtxt standalone -> standalone+            DerivClauseCtxt         -> True+            _                       -> False+     check_h98_arg_shape = case ctxt of                             SpecInstCtxt    -> False                             DerivClauseCtxt -> False@@ -1637,15 +1498,6 @@                         text "Only one type can be given in an instance head." $$                         text "Use MultiParamTypeClasses if you want to allow more, or zero." -    rejected_class_msg = text "Class" <+> quotes (ppr clas_nm)-                         <+> text "does not support user-specified instances"-    tuple_class_msg    = text "You can't specify an instance for a tuple constraint"--    gen_inst_err = rejected_class_msg $$ nest 2 (text "(in Safe Haskell)")--    abstract_class_msg = text "Cannot define instance for abstract class"-                         <+> quotes (ppr clas_nm)-     mb_ty_args_msg       | not (xopt LangExt.TypeSynonymInstances dflags)       , not (all tcInstHeadTyNotSynonym ty_args)@@ -1713,9 +1565,10 @@ dropCastsB :: TyVarBinder -> TyVarBinder dropCastsB b = b   -- Don't bother in the kind of a forall -instTypeErr :: Class -> [Type] -> SDoc -> SDoc+instTypeErr :: Class -> [Type] -> SDoc -> TcRnMessage instTypeErr cls tys msg-  = hang (hang (text "Illegal instance declaration for")+  = TcRnUnknownMessage $ mkPlainError noHints $+    hang (hang (text "Illegal instance declaration for")              2 (quotes (pprClassPred cls tys)))        2 msg @@ -1745,7 +1598,7 @@ Consider the (bogus)      instance Eq Char# We elaborate to  'Eq (Char# |> UnivCo(hole))'  where the hole is an-insoluble equality constraint for * ~ #.  We'll report the insoluble+insoluble equality constraint for Type ~ TYPE WordRep.  We'll report the insoluble constraint separately, but we don't want to *also* complain that Eq is not applied to a type constructor.  So we look gaily look through CastTys here.@@ -1783,30 +1636,30 @@  It checks for three things -  * No repeated variables (hasNoDups fvs)+(VD1) No repeated variables (hasNoDups fvs) -  * No type constructors.  This is done by comparing+(VD2) No type constructors.  This is done by comparing         sizeTypes tys == length (fvTypes tys)-    sizeTypes counts variables and constructors; fvTypes returns variables.-    So if they are the same, there must be no constructors.  But there-    might be applications thus (f (g x)).+      sizeTypes counts variables and constructors; fvTypes returns variables.+      So if they are the same, there must be no constructors.  But there+      might be applications thus (f (g x)). -    Note that tys only includes the visible arguments of the class type-    constructor. Including the non-visible arguments can cause the following,-    perfectly valid instance to be rejected:-       class Category (cat :: k -> k -> *) where ...-       newtype T (c :: * -> * -> *) a b = MkT (c a b)-       instance Category c => Category (T c) where ...-    since the first argument to Category is a non-visible *, which sizeTypes-    would count as a constructor! See #11833.+      Note that tys only includes the visible arguments of the class type+      constructor. Including the non-visible arguments can cause the following,+      perfectly valid instance to be rejected:+         class Category (cat :: k -> k -> *) where ...+         newtype T (c :: * -> * -> *) a b = MkT (c a b)+         instance Category c => Category (T c) where ...+      since the first argument to Category is a non-visible *, which sizeTypes+      would count as a constructor! See #11833. -  * Also check for a bizarre corner case, when the derived instance decl-    would look like-       instance C a b => D (T a) where ...-    Note that 'b' isn't a parameter of T.  This gives rise to all sorts of-    problems; in particular, it's hard to compare solutions for equality-    when finding the fixpoint, and that means the inferContext loop does-    not converge.  See #5287.+(VD3) Also check for a bizarre corner case, when the derived instance decl+      would look like+         instance C a b => D (T a) where ...+      Note that 'b' isn't a parameter of T.  This gives rise to all sorts of+      problems; in particular, it's hard to compare solutions for equality+      when finding the fixpoint, and that means the inferContext loop does+      not converge.  See #5287, #21302  Note [Equality class instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1819,22 +1672,27 @@ validDerivPred :: TyVarSet -> PredType -> Bool -- See Note [Valid 'deriving' predicate] validDerivPred tv_set pred+  | not (tyCoVarsOfType pred `subVarSet` tv_set)+  = False  -- Check (VD3)++  | otherwise   = case classifyPredType pred of-       ClassPred cls tys -> cls `hasKey` typeableClassKey-                -- Typeable constraints are bigger than they appear due-                -- to kind polymorphism, but that's OK-                       || check_tys cls tys-       EqPred {}       -> False  -- reject equality constraints-       _               -> True   -- Non-class predicates are ok-  where-    check_tys cls tys-              = hasNoDups fvs-                   -- use sizePred to ignore implicit args-                && lengthIs fvs (sizePred pred)-                && all (`elemVarSet` tv_set) fvs-      where tys' = filterOutInvisibleTypes (classTyCon cls) tys-            fvs  = fvTypes tys' +       ClassPred cls tys+          | isTerminatingClass cls -> True+            -- Typeable constraints are bigger than they appear due+            -- to kind polymorphism, but that's OK++          | otherwise -> hasNoDups visible_fvs                        -- Check (VD1)+                      && lengthIs visible_fvs (sizeTypes visible_tys) -- Check (VD2)+          where+            visible_tys = filterOutInvisibleTypes (classTyCon cls) tys+            visible_fvs = fvTypes visible_tys++       IrredPred {}   -> True   -- Accept (f a)+       EqPred {}      -> False  -- Reject equality constraints+       ForAllPred {}  -> False  -- Rejects quantified predicates+ {- ************************************************************************ *                                                                      *@@ -1868,15 +1726,10 @@ checkValidInstance :: UserTypeCtxt -> LHsSigType GhcRn -> Type -> TcM () checkValidInstance ctxt hs_type ty   | not is_tc_app-  = failWithTc (hang (text "Instance head is not headed by a class:")-                   2 ( ppr tau))+  = failWithTc (TcRnNoClassInstHead tau)    | isNothing mb_cls-  = failWithTc (vcat [ text "Illegal instance for a" <+> ppr (tyConFlavour tc)-                     , text "A class instance must be for a class" ])--  | not arity_ok-  = failWithTc (text "Arity mis-match in instance head")+  = failWithTc (TcRnIllegalClassInst (tyConFlavour tc))    | otherwise   = do  { setSrcSpanA head_loc $@@ -1918,7 +1771,6 @@     TyConApp tc inst_tys = tau   -- See Note [Instances and constraint synonyms]     mb_cls               = tyConClass_maybe tc     Just clas            = mb_cls-    arity_ok             = inst_tys `lengthIs` classArity clas          -- The location of the "head" of the instance     head_loc = getLoc (getLHsInstDeclHead hs_type)@@ -1957,8 +1809,8 @@    check :: VarSet -> PredType -> TcM ()    check foralld_tvs pred      = case classifyPredType pred of-         EqPred {}    -> return ()  -- See #4200.-         IrredPred {} -> check2 foralld_tvs pred (sizeType pred)+         EqPred {}      -> return ()  -- See #4200.+         IrredPred {}   -> check2 foralld_tvs pred (sizeType pred)          ClassPred cls tys            | isTerminatingClass cls            -> return ()@@ -1978,9 +1830,12 @@               -- when the predicates are individually checked for validity     check2 foralld_tvs pred pred_size-     | not (null bad_tvs)     = failWithTc (noMoreMsg bad_tvs what (ppr head_pred))-     | not (isTyFamFree pred) = failWithTc (nestedMsg what)-     | pred_size >= head_size = failWithTc (smallerMsg what (ppr head_pred))+     | not (null bad_tvs)     = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $+       (noMoreMsg bad_tvs what (ppr head_pred))+     | not (isTyFamFree pred) = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $+       (nestedMsg what)+     | pred_size >= head_size = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $+       (smallerMsg what (ppr head_pred))      | otherwise              = return ()      -- isTyFamFree: see Note [Type families in instance contexts]      where@@ -2007,9 +1862,8 @@    occurs = if isSingleton tvs1 then text "occurs"                                else text "occur" -undecidableMsg, constraintKindsMsg :: SDoc-undecidableMsg     = text "Use UndecidableInstances to permit this"-constraintKindsMsg = text "Use ConstraintKinds to permit this"+undecidableMsg :: SDoc+undecidableMsg = text "Use UndecidableInstances to permit this"  {- Note [Type families in instance contexts] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2063,8 +1917,9 @@     --   (b) failure of injectivity     check_branch_compat prev_branches cur_branch       | cur_branch `isDominatedBy` prev_branches-      = do { addWarnAt NoReason (coAxBranchSpan cur_branch) $-             inaccessibleCoAxBranch fam_tc cur_branch+      = do { let dia = TcRnUnknownMessage $+                   mkPlainDiagnostic WarningWithoutFlag noHints (inaccessibleCoAxBranch fam_tc cur_branch)+           ; addDiagnosticAt (coAxBranchSpan cur_branch) dia            ; return prev_branches }       | otherwise       = do { check_injectivity prev_branches cur_branch@@ -2133,8 +1988,7 @@            case drop (tyConArity fam_tc) typats of              [] -> pure ()              spec_arg:_ ->-               addErr $ text "Illegal oversaturated visible kind argument:"-                    <+> quotes (char '@' <> pprParendType spec_arg)+               addErr (TcRnOversaturatedVisibleKindArg spec_arg)           -- The argument patterns, and RHS, are all boxed tau types          -- E.g  Reject type family F (a :: k1) :: k2@@ -2180,7 +2034,7 @@     extract_tv pat pat_vis =       case getTyVar_maybe pat of         Just tv -> pure tv-        Nothing -> failWithTc $+        Nothing -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $           pprWithExplicitKindsWhen (isInvisibleArgFlag pat_vis) $           hang (text "Illegal argument" <+> quotes (ppr pat) <+> text "in:")              2 (vcat [ppr_eqn, suggestion])@@ -2198,6 +2052,7 @@       let dups = findDupsEq ((==) `on` fst) cpt_tvs_vis in       traverse_         (\d -> let (pat_tv, pat_vis) = NE.head d in failWithTc $+               TcRnUnknownMessage $ mkPlainError noHints $                pprWithExplicitKindsWhen (isInvisibleArgFlag pat_vis) $                hang (text "Illegal duplicate variable"                        <+> quotes (ppr pat_tv) <+> text "in:")@@ -2220,9 +2075,9 @@ -- checkFamInstRhs :: TyCon -> [Type]         -- LHS                 -> [(TyCon, [Type])]       -- type family calls in RHS-                -> [SDoc]+                -> [TcRnMessage] checkFamInstRhs lhs_tc lhs_tys famInsts-  = mapMaybe check famInsts+  = map (TcRnUnknownMessage . mkPlainError noHints) $ mapMaybe check famInsts   where    lhs_size  = sizeTyConAppArgs lhs_tc lhs_tys    inst_head = pprType (TyConApp lhs_tc lhs_tys)@@ -2293,7 +2148,7 @@     dodgy_tvs   = cpt_tvs `minusVarSet` inj_cpt_tvs      check_tvs tvs what what2-      = unless (null tvs) $ addErrAt (getSrcSpan (head tvs)) $+      = unless (null tvs) $ addErrAt (getSrcSpan (head tvs)) $ TcRnUnknownMessage $ mkPlainError noHints $         hang (text "Type variable" <> plural tvs <+> pprQuotedList tvs               <+> isOrAre tvs <+> what <> comma)            2 (vcat [ text "but not" <+> what2 <+> text "the family instance"@@ -2324,7 +2179,7 @@        -- Ensure that no type family applications occur a type pattern        ; case tcTyConAppTyFamInstsAndVis tc pat_ty_args of             [] -> pure ()-            ((tf_is_invis_arg, tf_tc, tf_args):_) -> failWithTc $+            ((tf_is_invis_arg, tf_tc, tf_args):_) -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $                ty_fam_inst_illegal_err tf_is_invis_arg                                        (mkTyConApp tf_tc tf_args) }   where@@ -2349,12 +2204,6 @@   = sep [ text "Illegal nested" <+> what         , parens undecidableMsg ] -badATErr :: Name -> Name -> SDoc-badATErr clas op-  = hsep [text "Class", quotes (ppr clas),-          text "does not have an associated type", quotes (ppr op)]-- ------------------------- checkConsistentFamInst :: AssocInstInfo                        -> TyCon     -- ^ Family tycon@@ -2379,7 +2228,7 @@        -- See [Mismatched class methods and associated type families]        -- in TcInstDecls.        ; checkTc (Just (classTyCon clas) == tyConAssoc_maybe fam_tc)-                 (badATErr (className clas) (tyConName fam_tc))+                 (TcRnBadAssociatedType (className clas) (tyConName fam_tc))         ; check_match arg_triples        }@@ -2431,7 +2280,7 @@       , Just rl_subst1 <- tcMatchTyX_BM bind_me rl_subst ty2 ty1       = go lr_subst1 rl_subst1 triples       | otherwise-      = addErrTc (pp_wrong_at_arg vis)+      = addErrTc (TcRnUnknownMessage $ mkPlainError noHints $ pp_wrong_at_arg vis)      -- The /scoped/ type variables from the class-instance header     -- should not be alpha-renamed.  Inferred ones can be.@@ -2859,7 +2708,7 @@ checkTyConTelescope tc   | bad_scope   = -- See "Ill-scoped binders" in Note [Bad TyCon telescopes]-    addErr $+    addErr $ TcRnUnknownMessage $ mkPlainError noHints $     vcat [ hang (text "The kind of" <+> quotes (ppr tc) <+> text "is ill-scoped")               2 pp_tc_kind          , extra@@ -2958,26 +2807,6 @@ sizeTyConAppArgs _tc tys = sizeTypes tys -- (filterOutInvisibleTypes tc tys)                            -- See Note [Invisible arguments and termination] --- Size of a predicate------ We are considering whether class constraints terminate.--- Equality constraints and constraints for the implicit--- parameter class always terminate so it is safe to say "size 0".--- See #4200.-sizePred :: PredType -> Int-sizePred ty = goClass ty-  where-    goClass p = go (classifyPredType p)--    go (ClassPred cls tys')-      | isTerminatingClass cls = 0-      | otherwise = sizeTypes (filterOutInvisibleTypes (classTyCon cls) tys')-                    -- The filtering looks bogus-                    -- See Note [Invisible arguments and termination]-    go (EqPred {})           = 0-    go (IrredPred ty)        = sizeType ty-    go (ForAllPred _ _ pred) = goClass pred- -- | When this says "True", ignore this class constraint during -- a termination check isTerminatingClass :: Class -> Bool@@ -2988,10 +2817,6 @@     || isEqPredClass cls     || cls `hasKey` typeableClassKey     || cls `hasKey` coercibleTyConKey---- | Tidy before printing a type-ppr_tidy :: TidyEnv -> Type -> SDoc-ppr_tidy env ty = pprType (tidyType env ty)  allDistinctTyVars :: TyVarSet -> [KindOrType] -> Bool -- (allDistinctTyVars tvs tys) returns True if tys are
compiler/GHC/ThToHs.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-}@@ -56,7 +57,6 @@  import qualified Data.ByteString as BS import Control.Monad( unless, ap )- import Data.Maybe( catMaybes, isNothing ) import Language.Haskell.TH as TH hiding (sigP) import Language.Haskell.TH.Syntax as TH@@ -96,9 +96,8 @@ -- Reason: so a (head []) in TH code doesn't subsequently --         make GHC crash when it tries to walk the generated tree --- Use the loc everywhere, for lack of anything better--- In particular, we want it on binding locations, so that variables bound in--- the spliced-in declarations get a location that at least relates to the splice point+-- Use the SrcSpan everywhere, for lack of anything better.+-- See Note [Source locations within TH splices].  instance Applicative CvtM where     pure x = CvtM $ \_ loc -> Right (loc,x)@@ -124,23 +123,18 @@ getL :: CvtM SrcSpan getL = CvtM (\_ loc -> Right (loc,loc)) +-- NB: This is only used in conjunction with LineP pragmas.+-- See Note [Source locations within TH splices]. setL :: SrcSpan -> CvtM () setL loc = CvtM (\_ _ -> Right (loc, ())) -returnL :: a -> CvtM (Located a)-returnL x = CvtM (\_ loc -> Right (loc, L loc x))---- returnLA :: a -> CvtM (LocatedA a)-returnLA :: e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn ann)) e)+returnLA :: e -> CvtM (LocatedAn ann e) returnLA x = CvtM (\_ loc -> Right (loc, L (noAnnSrcSpan loc) x))  returnJustLA :: a -> CvtM (Maybe (LocatedA a)) returnJustLA = fmap Just . returnLA --- wrapParL :: (Located a -> a) -> a -> CvtM a--- wrapParL add_par x = CvtM (\_ loc -> Right (loc, add_par (L loc x)))--wrapParLA :: (LocatedA a -> a) -> a -> CvtM a+wrapParLA :: (LocatedAn ann a -> b) -> a -> CvtM b wrapParLA add_par x = CvtM (\_ loc -> Right (loc, add_par (L (noAnnSrcSpan loc) x)))  wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b@@ -172,6 +166,41 @@   Left err -> Left err   Right (loc', v) -> Right (loc', L (noAnnSrcSpan loc) v) +{-+Note [Source locations within TH splices]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider a TH splice such as $(x), where `x` evaluates to `id True`. What+source locations should we use for subexpressions within the splice, such as+`id` and `True`? We basically have two options:++1. Don't give anything within the splice a SrcSpan. That is, use the `noLoc`+   everywhere.+2. Give everything within the splice the same `SrcSpan` as where the splice+   occurs (i.e., where $(x) occurs).++We implement option (2) for the following reasons:++* We want SrcSpans on binding locations so that variables bound in the+  spliced-in declarations get a location that at least relates to the splice+  point.++* Generally speaking, having *some* SrcSpan for each sub-expression in the AST+  in better than having no SrcSpan at all. This extra information can be useful+  for programs that walk over the AST directly.++Because of our choice of option (2), we are very careful not to use the noLoc+function anywhere in GHC.ThToHs. Instead, we thread around a SrcSpan in CvtM+and allow retrieving the SrcSpan through combinators such as getL, returnLA,+wrapParLA, etc.++Note that CvtM is actually a *state* monad vis-à-vis SrcSpan, not just a+reader monad. This is because LineP pragmas can change the source location+within a splice—see testsuite/tests/th/TH_linePragma.hs for an example. This+is a bit unusual, since it changes the source location from that of the splice+point to that of the code being spliced in. Nevertheless, LineP is *the* reason+why CvtM is a state monad.+-}+ ------------------------------------------------------------------- cvtDecs :: [TH.Dec] -> CvtM [LHsDecl GhcPs] cvtDecs = fmap catMaybes . mapM cvtDec@@ -226,6 +255,10 @@        ; returnJustLA (Hs.SigD noExtField (FixSig noAnn                                       (FixitySig noExtField [nm'] (cvtFixity fx)))) } +cvtDec (TH.DefaultD tys)+  = do  { tys' <- traverse cvtType tys+        ; returnJustLA (Hs.DefD noExtField $ DefaultDecl noAnn tys') }+ cvtDec (PragmaD prag)   = cvtPragmaD prag @@ -255,7 +288,7 @@         ; derivs' <- cvtDerivs derivs         ; let defn = HsDataDefn { dd_ext = noExtField                                 , dd_ND = DataType, dd_cType = Nothing-                                , dd_ctxt = Just ctxt'+                                , dd_ctxt = mkHsContextMaybe ctxt'                                 , dd_kindSig = ksig'                                 , dd_cons = cons', dd_derivs = derivs' }         ; returnJustLA $ TyClD noExtField $@@ -271,7 +304,7 @@         ; derivs' <- cvtDerivs derivs         ; let defn = HsDataDefn { dd_ext = noExtField                                 , dd_ND = NewType, dd_cType = Nothing-                                , dd_ctxt = Just ctxt'+                                , dd_ctxt = mkHsContextMaybe ctxt'                                 , dd_kindSig = ksig'                                 , dd_cons = [con']                                 , dd_derivs = derivs' }@@ -291,7 +324,7 @@                    $$ (Outputable.ppr adts'))         ; returnJustLA $ TyClD noExtField $           ClassDecl { tcdCExt = (noAnn, NoAnnSortKey, NoLayoutInfo)-                    , tcdCtxt = Just cxt', tcdLName = tc', tcdTyVars = tvs'+                    , tcdCtxt = mkHsContextMaybe cxt', tcdLName = tc', tcdTyVars = tvs'                     , tcdFixity = Prefix                     , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs'                     , tcdMeths = binds'@@ -342,12 +375,12 @@        ; derivs' <- cvtDerivs derivs        ; let defn = HsDataDefn { dd_ext = noExtField                                , dd_ND = DataType, dd_cType = Nothing-                               , dd_ctxt = Just ctxt'+                               , dd_ctxt = mkHsContextMaybe ctxt'                                , dd_kindSig = ksig'                                , dd_cons = cons', dd_derivs = derivs' }         ; returnJustLA $ InstD noExtField $ DataFamInstD-           { dfid_ext = noAnn+           { dfid_ext = noExtField            , dfid_inst = DataFamInstDecl { dfid_eqn =                            FamEqn { feqn_ext = noAnn                                   , feqn_tycon = tc'@@ -363,11 +396,11 @@        ; derivs' <- cvtDerivs derivs        ; let defn = HsDataDefn { dd_ext = noExtField                                , dd_ND = NewType, dd_cType = Nothing-                               , dd_ctxt = Just ctxt'+                               , dd_ctxt = mkHsContextMaybe ctxt'                                , dd_kindSig = ksig'                                , dd_cons = [con'], dd_derivs = derivs' }        ; returnJustLA $ InstD noExtField $ DataFamInstD-           { dfid_ext = noAnn+           { dfid_ext = noExtField            , dfid_inst = DataFamInstDecl { dfid_eqn =                            FamEqn { feqn_ext = noAnn                                   , feqn_tycon = tc'@@ -397,7 +430,7 @@  cvtDec (TH.RoleAnnotD tc roles)   = do { tc' <- tconNameN tc-       ; let roles' = map (noLoc . cvtRole) roles+       ; roles' <- traverse (returnLA . cvtRole) roles        ; returnJustLA                    $ Hs.RoleAnnotD noExtField (RoleAnnotDecl noAnn tc' roles') } @@ -440,7 +473,7 @@     cvtDir n (ExplBidir cls) =       do { ms <- mapM (cvtClause (mkPrefixFunRhs n)) cls          ; th_origin <- getOrigin-         ; return $ ExplicitBidirectional $ mkMatchGroup th_origin (noLocA ms) }+         ; wrapParLA (ExplicitBidirectional . mkMatchGroup th_origin) ms }  cvtDec (TH.PatSynSigD nm ty)   = do { nm' <- cNameN nm@@ -602,8 +635,8 @@ cvtConstr (RecC c varstrtys)   = do  { c'    <- cNameN c         ; args' <- mapM cvt_id_arg varstrtys-        ; returnLA $ mkConDeclH98 noAnn c' Nothing Nothing-                                   (RecCon (noLocA args')) }+        ; con_decl <- wrapParLA (mkConDeclH98 noAnn c' Nothing Nothing . RecCon) args'+        ; returnLA con_decl }  cvtConstr (InfixC st1 c st2)   = do  { c'   <- cNameN c@@ -618,7 +651,7 @@         ; L _ con'  <- cvtConstr con         ; returnLA $ add_forall tvs' ctxt' con' }   where-    add_cxt lcxt         Nothing           = Just lcxt+    add_cxt lcxt         Nothing           = mkHsContextMaybe lcxt     add_cxt (L loc cxt1) (Just (L _ cxt2))       = Just (L loc (cxt1 ++ cxt2)) @@ -650,7 +683,7 @@   = do  { c'      <- mapM cNameN c         ; args    <- mapM cvt_arg strtys         ; ty'     <- cvtType ty-        ; returnLA $ mk_gadt_decl c' (PrefixConGADT $ map hsLinear args) ty'}+        ; mk_gadt_decl c' (PrefixConGADT $ map hsLinear args) ty'}  cvtConstr (RecGadtC [] _varstrtys _ty)   = failWith (text "RecGadtC must have at least one constructor name")@@ -659,18 +692,21 @@   = do  { c'       <- mapM cNameN c         ; ty'      <- cvtType ty         ; rec_flds <- mapM cvt_id_arg varstrtys-        ; returnLA $ mk_gadt_decl c' (RecConGADT $ noLocA rec_flds) ty' }+        ; lrec_flds <- returnLA rec_flds+        ; mk_gadt_decl c' (RecConGADT lrec_flds noHsUniTok) ty' }  mk_gadt_decl :: [LocatedN RdrName] -> HsConDeclGADTDetails GhcPs -> LHsType GhcPs-             -> ConDecl GhcPs+             -> CvtM (LConDecl GhcPs) mk_gadt_decl names args res_ty-  = ConDeclGADT { con_g_ext  = noAnn-                , con_names  = names-                , con_bndrs  = noLocA mkHsOuterImplicit-                , con_mb_cxt = Nothing-                , con_g_args = args-                , con_res_ty = res_ty-                , con_doc    = Nothing }+  = do bndrs <- returnLA mkHsOuterImplicit+       returnLA $ ConDeclGADT+                   { con_g_ext  = noAnn+                   , con_names  = names+                   , con_bndrs  = bndrs+                   , con_mb_cxt = Nothing+                   , con_g_args = args+                   , con_res_ty = res_ty+                   , con_doc    = Nothing }  cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness cvtSrcUnpackedness NoSourceUnpackedness = NoSrcUnpack@@ -694,12 +730,12 @@ cvt_id_arg (i, str, ty)   = do  { L li i' <- vNameN i         ; ty' <- cvt_arg (str,ty)-        ; return $ noLocA (ConDeclField+        ; returnLA $ ConDeclField                           { cd_fld_ext = noAnn                           , cd_fld_names-                              = [L (locA li) $ FieldOcc noExtField (L li i')]+                              = [L (l2l li) $ FieldOcc noExtField (L li i')]                           , cd_fld_type =  ty'-                          , cd_fld_doc = Nothing}) }+                          , cd_fld_doc = Nothing} }  cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving GhcPs) cvtDerivs cs = do { mapM cvtDerivClause cs }@@ -715,21 +751,22 @@ ------------------------------------------  cvtForD :: Foreign -> CvtM (ForeignDecl GhcPs)-cvtForD (ImportF callconv safety from nm ty)-  -- the prim and javascript calling conventions do not support headers-  -- and are inserted verbatim, analogous to mkImport in GHC.Parser.PostProcess-  | callconv == TH.Prim || callconv == TH.JavaScript-  = mk_imp (CImport (noLoc (cvt_conv callconv)) (noLoc safety') Nothing-                    (CFunction (StaticTarget (SourceText from)-                                             (mkFastString from) Nothing-                                             True))-                    (noLoc $ quotedSourceText from))-  | Just impspec <- parseCImport (noLoc (cvt_conv callconv)) (noLoc safety')-                                 (mkFastString (TH.nameBase nm))-                                 from (noLoc $ quotedSourceText from)-  = mk_imp impspec-  | otherwise-  = failWith $ text (show from) <+> text "is not a valid ccall impent"+cvtForD (ImportF callconv safety from nm ty) =+  do { l <- getL+     ; if -- the prim and javascript calling conventions do not support headers+          -- and are inserted verbatim, analogous to mkImport in GHC.Parser.PostProcess+          |  callconv == TH.Prim || callconv == TH.JavaScript+          -> mk_imp (CImport (L l (cvt_conv callconv)) (L l safety') Nothing+                             (CFunction (StaticTarget (SourceText from)+                                                      (mkFastString from) Nothing+                                                      True))+                             (L l $ quotedSourceText from))+          |  Just impspec <- parseCImport (L l (cvt_conv callconv)) (L l safety')+                                          (mkFastString (TH.nameBase nm))+                                          from (L l $ quotedSourceText from)+          -> mk_imp impspec+          |  otherwise+          -> failWith $ text (show from) <+> text "is not a valid ccall impent" }   where     mk_imp impspec       = do { nm' <- vNameN nm@@ -747,10 +784,11 @@ cvtForD (ExportF callconv as nm ty)   = do  { nm' <- vNameN nm         ; ty' <- cvtSigType ty-        ; let e = CExport (noLoc (CExportStatic (SourceText as)-                                                (mkFastString as)-                                                (cvt_conv callconv)))-                                                (noLoc (SourceText as))+        ; l <- getL+        ; let e = CExport (L l (CExportStatic (SourceText as)+                                              (mkFastString as)+                                              (cvt_conv callconv)))+                                              (L l (SourceText as))         ; return $ ForeignExport { fd_e_ext = noAnn                                  , fd_name = nm'                                  , fd_sig_ty = ty'@@ -774,25 +812,40 @@        ; let src TH.NoInline  = "{-# NOINLINE"              src TH.Inline    = "{-# INLINE"              src TH.Inlinable = "{-# INLINABLE"-       ; let ip   = InlinePragma { inl_src    = SourceText $ src inline-                                 , inl_inline = cvtInline inline+       ; let ip   = InlinePragma { inl_src    = toSrcTxt inline+                                 , inl_inline = cvtInline inline (toSrcTxt inline)                                  , inl_rule   = cvtRuleMatch rm                                  , inl_act    = cvtPhases phases dflt                                  , inl_sat    = Nothing }+                    where+                     toSrcTxt a = SourceText $ src a        ; returnJustLA $ Hs.SigD noExtField $ InlineSig noAnn nm' ip } +cvtPragmaD (OpaqueP nm)+  = do { nm' <- vNameN nm+       ; let ip = InlinePragma { inl_src    = srcTxt+                               , inl_inline = Opaque srcTxt+                               , inl_rule   = Hs.FunLike+                               , inl_act    = NeverActive+                               , inl_sat    = Nothing }+                  where+                    srcTxt = SourceText "{-# OPAQUE"+       ; returnJustLA $ Hs.SigD noExtField $ InlineSig noAnn nm' ip }+ cvtPragmaD (SpecialiseP nm ty inline phases)   = do { nm' <- vNameN nm        ; ty' <- cvtSigType ty        ; let src TH.NoInline  = "{-# SPECIALISE NOINLINE"              src TH.Inline    = "{-# SPECIALISE INLINE"              src TH.Inlinable = "{-# SPECIALISE INLINE"-       ; let (inline', dflt,srcText) = case inline of-               Just inline1 -> (cvtInline inline1, dfltActivation inline1,-                                src inline1)+       ; let (inline', dflt, srcText) = case inline of+               Just inline1 -> (cvtInline inline1 (toSrcTxt inline1), dfltActivation inline1,+                                toSrcTxt inline1)                Nothing      -> (NoUserInlinePrag,   AlwaysActive,-                                "{-# SPECIALISE")-       ; let ip = InlinePragma { inl_src    = SourceText srcText+                                SourceText "{-# SPECIALISE")+               where+                toSrcTxt a = SourceText $ src a+       ; let ip = InlinePragma { inl_src    = srcText                                , inl_inline = inline'                                , inl_rule   = Hs.FunLike                                , inl_act    = cvtPhases phases dflt@@ -806,22 +859,24 @@  cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases)   = do { let nm' = mkFastString nm+       ; rd_name' <- returnLA (quotedSourceText nm,nm')        ; let act = cvtPhases phases AlwaysActive        ; ty_bndrs' <- traverse cvtTvs ty_bndrs        ; tm_bndrs' <- mapM cvtRuleBndr tm_bndrs        ; lhs'   <- cvtl lhs        ; rhs'   <- cvtl rhs+       ; rule <- returnLA $+                   HsRule { rd_ext  = noAnn+                          , rd_name = rd_name'+                          , rd_act  = act+                          , rd_tyvs = ty_bndrs'+                          , rd_tmvs = tm_bndrs'+                          , rd_lhs  = lhs'+                          , rd_rhs  = rhs' }        ; returnJustLA $ Hs.RuleD noExtField             $ HsRules { rds_ext = noAnn                       , rds_src = SourceText "{-# RULES"-                      , rds_rules = [noLocA $-                          HsRule { rd_ext  = noAnn-                                 , rd_name = (noLoc (quotedSourceText nm,nm'))-                                 , rd_act  = act-                                 , rd_tyvs = ty_bndrs'-                                 , rd_tmvs = tm_bndrs'-                                 , rd_lhs  = lhs'-                                 , rd_rhs  = rhs' }] }+                      , rds_rules = [rule] }            } @@ -831,20 +886,22 @@          ModuleAnnotation  -> return ModuleAnnProvenance          TypeAnnotation n  -> do            n' <- tconName n-           return (TypeAnnProvenance  (noLocA n'))+           wrapParLA TypeAnnProvenance n'          ValueAnnotation n -> do            n' <- vcName n-           return (ValueAnnProvenance (noLocA n'))+           wrapParLA ValueAnnProvenance n'        ; returnJustLA $ Hs.AnnD noExtField                      $ HsAnnotation noAnn (SourceText "{-# ANN") target' exp'        } +-- NB: This is the only place in GHC.ThToHs that makes use of the `setL`+-- function. See Note [Source locations within TH splices]. cvtPragmaD (LineP line file)   = do { setL (srcLocSpan (mkSrcLoc (fsLit file) line 1))        ; return Nothing        } cvtPragmaD (CompleteP cls mty)-  = do { cls' <- noLoc <$> mapM cNameN cls+  = do { cls'  <- wrapL $ mapM cNameN cls        ; mty'  <- traverse tconNameN mty        ; returnJustLA $ Hs.SigD noExtField                    $ CompleteMatchSig noAnn NoSourceText cls' mty' }@@ -853,10 +910,10 @@ dfltActivation TH.NoInline = NeverActive dfltActivation _           = AlwaysActive -cvtInline :: TH.Inline -> Hs.InlineSpec-cvtInline TH.NoInline  = Hs.NoInline-cvtInline TH.Inline    = Hs.Inline-cvtInline TH.Inlinable = Hs.Inlinable+cvtInline :: TH.Inline  -> SourceText -> Hs.InlineSpec+cvtInline TH.NoInline   srcText  = Hs.NoInline  srcText+cvtInline TH.Inline     srcText  = Hs.Inline    srcText+cvtInline TH.Inlinable  srcText  = Hs.Inlinable srcText  cvtRuleMatch :: TH.RuleMatch -> RuleMatchInfo cvtRuleMatch TH.ConLike = Hs.ConLike@@ -870,11 +927,11 @@ cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr GhcPs) cvtRuleBndr (RuleVar n)   = do { n' <- vNameN n-       ; return $ noLoc $ Hs.RuleBndr noAnn n' }+       ; returnLA $ Hs.RuleBndr noAnn n' } cvtRuleBndr (TypedRuleVar n ty)   = do { n'  <- vNameN n        ; ty' <- cvtType ty-       ; return $ noLoc $ Hs.RuleBndrSig noAnn n' $ mkHsPatSigType noAnn ty' }+       ; returnLA $ Hs.RuleBndrSig noAnn n' $ mkHsPatSigType noAnn ty' }  --------------------------------------------------- --              Declarations@@ -909,7 +966,7 @@ cvtImplicitParamBind n e = do     n' <- wrapL (ipName n)     e' <- cvtl e-    returnLA (IPBind noAnn (Left n') e')+    returnLA (IPBind noAnn (reLocA n') e')  ------------------------------------------------------------------- --              Expressions@@ -918,8 +975,8 @@ cvtl :: TH.Exp -> CvtM (LHsExpr GhcPs) cvtl e = wrapLA (cvt e)   where-    cvt (VarE s)   = do { s' <- vName s; return $ HsVar noExtField (noLocA s') }-    cvt (ConE s)   = do { s' <- cName s; return $ HsVar noExtField (noLocA s') }+    cvt (VarE s)   = do { s' <- vName s; wrapParLA (HsVar noExtField) s' }+    cvt (ConE s)   = do { s' <- cName s; wrapParLA (HsVar noExtField) s' }     cvt (LitE l)       | overloadedLit l = go cvtOverLit (HsOverLit noComments)                              (hsOverLitNeedsParens appPrec)@@ -933,7 +990,7 @@         go cvt_lit mk_expr is_compound_lit = do           l' <- cvt_lit l           let e' = mk_expr l'-          return $ if is_compound_lit l' then HsPar noAnn (noLocA e') else e'+          if is_compound_lit l' then wrapParLA gHsPar e' else pure e'     cvt (AppE x@(LamE _ _) y) = do { x' <- cvtl x; y' <- cvtl y                                    ; return $ HsApp noComments (mkLHsPar x')                                                           (mkLHsPar y')}@@ -952,20 +1009,23 @@     cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e                             ; let pats = map (parenthesizePat appPrec) ps'                             ; th_origin <- getOrigin-                            ; return $ HsLam noExtField (mkMatchGroup th_origin-                                             (noLocA [mkSimpleMatch LambdaExpr-                                             pats e']))}-    cvt (LamCaseE ms)  = do { ms' <- mapM (cvtMatch CaseAlt) ms+                            ; wrapParLA (HsLam noExtField . mkMatchGroup th_origin)+                                        [mkSimpleMatch LambdaExpr pats e']}+    cvt (LamCaseE ms)  = do { ms' <- mapM (cvtMatch $ LamCaseAlt LamCase) ms                             ; th_origin <- getOrigin-                            ; return $ HsLamCase noAnn-                                                   (mkMatchGroup th_origin (noLocA ms'))+                            ; wrapParLA (HsLamCase noAnn LamCase . mkMatchGroup th_origin) ms'                             }+    cvt (LamCasesE ms)+      | null ms   = failWith (text "\\cases expression with no alternatives")+      | otherwise = do { ms' <- mapM (cvtClause $ LamCaseAlt LamCases) ms+                       ; th_origin <- getOrigin+                       ; wrapParLA (HsLamCase noAnn LamCases . mkMatchGroup th_origin) ms'+                       }     cvt (TupE es)        = cvt_tup es Boxed     cvt (UnboxedTupE es) = cvt_tup es Unboxed     cvt (UnboxedSumE e alt arity) = do { e' <- cvtl e                                        ; unboxedSumChecks alt arity-                                       ; return $ ExplicitSum noAnn-                                                                   alt arity e'}+                                       ; return $ ExplicitSum noAnn alt arity e'}     cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;                             ; return $ mkHsIf x' y' z' noAnn }     cvt (MultiIfE alts)@@ -973,11 +1033,10 @@       | otherwise      = do { alts' <- mapM cvtpair alts                             ; return $ HsMultiIf noAnn alts' }     cvt (LetE ds e)    = do { ds' <- cvtLocalDecs (text "a let expression") ds-                            ; e' <- cvtl e; return $ HsLet noAnn ds' e'}+                            ; e' <- cvtl e; return $ HsLet noAnn noHsTok ds' noHsTok e'}     cvt (CaseE e ms)   = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms                             ; th_origin <- getOrigin-                            ; return $ HsCase noAnn e'-                                                 (mkMatchGroup th_origin (noLocA ms')) }+                            ; wrapParLA (HsCase noAnn e' . mkMatchGroup th_origin) ms' }     cvt (DoE m ss)     = cvtHsDo (DoExpr (mk_mod <$> m)) ss     cvt (MDoE m ss)    = cvtHsDo (MDoExpr (mk_mod <$> m)) ss     cvt (CompE ss)     = cvtHsDo ListComp ss@@ -998,7 +1057,7 @@          ; y' <- cvtl y          ; let px = parenthesizeHsExpr opPrec x'                py = parenthesizeHsExpr opPrec y'-         ; wrapParLA (HsPar noAnn)+         ; wrapParLA gHsPar            $ OpApp noAnn px s' py }            -- Parenthesise both arguments and result,            -- to ensure this operator application does@@ -1006,17 +1065,17 @@            -- See Note [Operator association]     cvt (InfixE Nothing  s (Just y)) = ensureValidOpExp s $                                        do { s' <- cvtl s; y' <- cvtl y-                                          ; wrapParLA (HsPar noAnn) $+                                          ; wrapParLA gHsPar $                                                           SectionR noComments s' y' }                                             -- See Note [Sections in HsSyn] in GHC.Hs.Expr     cvt (InfixE (Just x) s Nothing ) = ensureValidOpExp s $                                        do { x' <- cvtl x; s' <- cvtl s-                                          ; wrapParLA (HsPar noAnn) $+                                          ; wrapParLA gHsPar $                                                           SectionL noComments x' s' }      cvt (InfixE Nothing  s Nothing ) = ensureValidOpExp s $                                        do { s' <- cvtl s-                                          ; return $ HsPar noAnn s' }+                                          ; return $ gHsPar s' }                                        -- Can I indicate this is an infix thing?                                        -- Note [Dropping constructors] @@ -1027,16 +1086,16 @@                                             _ -> mkLHsPar x'                               ; cvtOpApp x'' s y } --  Note [Converting UInfix] -    cvt (ParensE e)      = do { e' <- cvtl e; return $ HsPar noAnn e' }+    cvt (ParensE e)      = do { e' <- cvtl e; return $ gHsPar e' }     cvt (SigE e t)       = do { e' <- cvtl e; t' <- cvtSigType t                               ; let pe = parenthesizeHsExpr sigPrec e'                               ; return $ ExprWithTySig noAnn pe (mkHsWildCardBndrs t') }     cvt (RecConE c flds) = do { c' <- cNameN c-                              ; flds' <- mapM (cvtFld (mkFieldOcc . noLocA)) flds+                              ; flds' <- mapM (cvtFld (wrapParLA mkFieldOcc)) flds                               ; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) noAnn }     cvt (RecUpdE e flds) = do { e' <- cvtl e                               ; flds'-                                  <- mapM (cvtFld (mkAmbiguousFieldOcc . noLocA))+                                  <- mapM (cvtFld (wrapParLA mkAmbiguousFieldOcc))                                            flds                               ; return $ RecordUpd noAnn e' (Left flds') }     cvt (StaticE e)      = fmap (HsStatic noAnn) $ cvtl e@@ -1044,12 +1103,12 @@                               -- important, because UnboundVarE may contain                               -- constructor names - see #14627.                               { s' <- vcName s-                              ; return $ HsVar noExtField (noLocA s') }+                              ; wrapParLA (HsVar noExtField) s' }     cvt (LabelE s)       = return $ HsOverLabel noComments (fsLit s)     cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noComments n' }     cvt (GetFieldE exp f) = do { e' <- cvtl exp-                               ; return $ HsGetField noComments e' (L noSrcSpan (HsFieldLabel noAnn (L noSrcSpan (fsLit f)))) }-    cvt (ProjectionE xs) = return $ HsProjection noAnn $ fmap (L noSrcSpan . HsFieldLabel noAnn . L noSrcSpan . fsLit) xs+                               ; return $ HsGetField noComments e' (L noSrcSpanA (DotFieldOcc noAnn (L noSrcSpanA (fsLit f)))) }+    cvt (ProjectionE xs) = return $ HsProjection noAnn $ fmap (L noSrcSpanA . DotFieldOcc noAnn . L noSrcSpanA . fsLit) xs  {- | #16895 Ensure an infix expression's operator is a variable/constructor. Consider this example:@@ -1084,14 +1143,16 @@ which we don't want. -} -cvtFld :: (RdrName -> t) -> (TH.Name, TH.Exp)-       -> CvtM (LHsRecField' GhcPs t (LHsExpr GhcPs))+cvtFld :: (RdrName -> CvtM t) -> (TH.Name, TH.Exp)+       -> CvtM (LHsFieldBind GhcPs (LocatedAn NoEpAnns t) (LHsExpr GhcPs)) cvtFld f (v,e)-  = do  { v' <- vNameL v; e' <- cvtl e-        ; return (noLocA $ HsRecField { hsRecFieldAnn = noAnn-                                      , hsRecFieldLbl = reLoc $ fmap f v'-                                      , hsRecFieldArg = e'-                                      , hsRecPun      = False}) }+  = do  { v' <- vNameL v+        ; lhs' <- traverse f v'+        ; e' <- cvtl e+        ; returnLA $ HsFieldBind { hfbAnn = noAnn+                                 , hfbLHS = la2la lhs'+                                 , hfbRHS = e'+                                 , hfbPun = False} }  cvtDD :: Range -> CvtM (ArithSeqInfo GhcPs) cvtDD (FromR x)           = do { x' <- cvtl x; return $ From x' }@@ -1109,6 +1170,7 @@                                     boxity }  {- Note [Operator association]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~ We must be quite careful about adding parens:   * Infix (UInfix ...) op arg      Needs parens round the first arg   * Infix (Infix ...) op arg       Needs parens round the first arg@@ -1118,15 +1180,17 @@  Note [Converting UInfix] ~~~~~~~~~~~~~~~~~~~~~~~~-When converting @UInfixE@, @UInfixP@, and @UInfixT@ values, we want to readjust-the trees to reflect the fixities of the underlying operators:+When converting @UInfixE@, @UInfixP@, @UInfixT@, and @PromotedUInfixT@ values,+we want to readjust the trees to reflect the fixities of the underlying+operators:    UInfixE x * (UInfixE y + z) ---> (x * y) + z  This is done by the renamer (see @mkOppAppRn@, @mkConOppPatRn@, and-@mkHsOpTyRn@ in GHC.Rename.HsType), which expects that the input will be completely-right-biased for types and left-biased for everything else. So we left-bias the-trees of @UInfixP@ and @UInfixE@ and right-bias the trees of @UInfixT@.+@mkHsOpTyRn@ in GHC.Rename.HsType), which expects that the input will be+completely right-biased for types and left-biased for everything else. So we+left-bias the trees of @UInfixP@ and @UInfixE@ and right-bias the trees of+@UInfixT@ and @PromotedUnfixT@.  Sample input: @@ -1173,7 +1237,7 @@ --      Do notation and statements ------------------------------------- -cvtHsDo :: HsStmtContext GhcRn -> [TH.Stmt] -> CvtM (HsExpr GhcPs)+cvtHsDo :: HsDoFlavour -> [TH.Stmt] -> CvtM (HsExpr GhcPs) cvtHsDo do_or_lc stmts   | null stmts = failWith (text "Empty stmt list in do-block")   | otherwise@@ -1185,9 +1249,9 @@                       -> return (L loc (mkLastStmt body))                     _ -> failWith (bad_last last') -        ; return $ HsDo noAnn do_or_lc (noLocA (stmts'' ++ [last''])) }+        ; wrapParLA (HsDo noAnn do_or_lc) (stmts'' ++ [last'']) }   where-    bad_last stmt = vcat [ text "Illegal last statement of" <+> pprAStmtContext do_or_lc <> colon+    bad_last stmt = vcat [ text "Illegal last statement of" <+> pprAHsDoFlavour do_or_lc <> colon                          , nest 2 $ Outputable.ppr stmt                          , text "(It should be an expression.)" ] @@ -1204,14 +1268,16 @@   where     cvt_one ds = do { ds' <- cvtStmts ds                     ; return (ParStmtBlock noExtField ds' undefined noSyntaxExpr) }-cvtStmt (TH.RecS ss) = do { ss' <- mapM cvtStmt ss; returnLA (mkRecStmt noAnn (noLocA ss')) }+cvtStmt (TH.RecS ss) = do { ss' <- mapM cvtStmt ss+                          ; rec_stmt <- wrapParLA (mkRecStmt noAnn) ss'+                          ; returnLA rec_stmt }  cvtMatch :: HsMatchContext GhcPs          -> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs)) cvtMatch ctxt (TH.Match p body decs)   = do  { p' <- cvtPat p         ; let lp = case p' of-                     (L loc SigPat{}) -> L loc (ParPat noAnn p') -- #14875+                     (L loc SigPat{}) -> L loc (gParPat p') -- #14875                      _                -> p'         ; g' <- cvtGuard body         ; decs' <- cvtLocalDecs (text "a where clause") decs@@ -1220,14 +1286,14 @@ cvtGuard :: TH.Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)] cvtGuard (GuardedB pairs) = mapM cvtpair pairs cvtGuard (NormalB e)      = do { e' <- cvtl e-                               ; g' <- returnL $ GRHS noAnn [] e'; return [g'] }+                               ; g' <- returnLA $ GRHS noAnn [] e'; return [g'] }  cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs)) cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs                               ; g' <- returnLA $ mkBodyStmt ge'-                              ; returnL $ GRHS noAnn [g'] rhs' }+                              ; returnLA $ GRHS noAnn [g'] rhs' } cvtpair (PatG gs,rhs)    = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs-                              ; returnL $ GRHS noAnn gs' rhs' }+                              ; returnLA $ GRHS noAnn gs' rhs' }  cvtOverLit :: Lit -> CvtM (HsOverLit GhcPs) cvtOverLit (IntegerL i)@@ -1300,12 +1366,13 @@ cvtp :: TH.Pat -> CvtM (Hs.Pat GhcPs) cvtp (TH.LitP l)   | overloadedLit l    = do { l' <- cvtOverLit l-                            ; return (mkNPat (noLoc l') Nothing noAnn) }+                            ; l'' <- returnLA l'+                            ; return (mkNPat l'' Nothing noAnn) }                                   -- Not right for negative patterns;                                   -- need to think about that!   | otherwise          = do { l' <- cvtLit l; return $ Hs.LitPat noExtField l' } cvtp (TH.VarP s)       = do { s' <- vName s-                            ; return $ Hs.VarPat noExtField (noLocA s') }+                            ; wrapParLA (Hs.VarPat noExtField) s' } cvtp (TupP ps)         = do { ps' <- cvtPats ps                             ; return $ TuplePat noAnn ps' Boxed } cvtp (UnboxedTupP ps)  = do { ps' <- cvtPats ps@@ -1325,7 +1392,7 @@                                 }                             } cvtp (InfixP p1 s p2)  = do { s' <- cNameN s; p1' <- cvtPat p1; p2' <- cvtPat p2-                            ; wrapParLA (ParPat noAnn) $+                            ; wrapParLA gParPat $                               ConPat                                 { pat_con_ext = noAnn                                 , pat_con = s'@@ -1339,7 +1406,7 @@ cvtp (ParensP p)       = do { p' <- cvtPat p;                             ; case unLoc p' of  -- may be wrapped ConPatIn                                 ParPat {} -> return $ unLoc p'-                                _         -> return $ ParPat noAnn p' }+                                _         -> return $ gParPat p' } cvtp (TildeP p)        = do { p' <- cvtPat p; return $ LazyPat noAnn p' } cvtp (BangP p)         = do { p' <- cvtPat p; return $ BangPat noAnn p' } cvtp (TH.AsP s p)      = do { s' <- vNameN s; p' <- cvtPat p@@ -1364,11 +1431,11 @@ cvtPatFld (s,p)   = do  { L ls s' <- vNameN s         ; p' <- cvtPat p-        ; return (noLocA $ HsRecField { hsRecFieldAnn = noAnn-                                      , hsRecFieldLbl-                                         = L (locA ls) $ mkFieldOcc (L ls s')-                                      , hsRecFieldArg = p'-                                      , hsRecPun      = False}) }+        ; returnLA $ HsFieldBind { hfbAnn = noAnn+                                 , hfbLHS+                                    = L (l2l ls) $ mkFieldOcc (L (l2l ls) s')+                                 , hfbRHS = p'+                                 , hfbPun = False} }  {- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@. The produced tree of infix patterns will be left-biased, provided @x@ is.@@ -1448,15 +1515,15 @@ cvtDerivClause (TH.DerivClause ds tys)   = do { tys' <- cvtDerivClauseTys tys        ; ds'  <- traverse cvtDerivStrategy ds-       ; returnL $ HsDerivingClause noAnn ds' tys' }+       ; returnLA $ HsDerivingClause noAnn ds' tys' }  cvtDerivStrategy :: TH.DerivStrategy -> CvtM (Hs.LDerivStrategy GhcPs)-cvtDerivStrategy TH.StockStrategy    = returnL (Hs.StockStrategy noAnn)-cvtDerivStrategy TH.AnyclassStrategy = returnL (Hs.AnyclassStrategy noAnn)-cvtDerivStrategy TH.NewtypeStrategy  = returnL (Hs.NewtypeStrategy noAnn)+cvtDerivStrategy TH.StockStrategy    = returnLA (Hs.StockStrategy noAnn)+cvtDerivStrategy TH.AnyclassStrategy = returnLA (Hs.AnyclassStrategy noAnn)+cvtDerivStrategy TH.NewtypeStrategy  = returnLA (Hs.NewtypeStrategy noAnn) cvtDerivStrategy (TH.ViaStrategy ty) = do   ty' <- cvtSigType ty-  returnL $ Hs.ViaStrategy (XViaStrategyPs noAnn ty')+  returnLA $ Hs.ViaStrategy (XViaStrategyPs noAnn ty')  cvtType :: TH.Type -> CvtM (LHsType GhcPs) cvtType = cvtTypeKind "type"@@ -1485,19 +1552,15 @@             , normals `lengthIs` n         -- Saturated             -> returnLA (HsTupleTy noAnn HsBoxedOrConstraintTuple normals)             | otherwise-            -> mk_apps-               (HsTyVar noAnn NotPromoted-                                     (noLocA (getRdrName (tupleTyCon Boxed n))))-               tys'+            -> do { tuple_tc <- returnLA $ getRdrName $ tupleTyCon Boxed n+                  ; mk_apps (HsTyVar noAnn NotPromoted tuple_tc) tys' }            UnboxedTupleT n              | Just normals <- m_normals              , normals `lengthIs` n               -- Saturated              -> returnLA (HsTupleTy noAnn HsUnboxedTuple normals)              | otherwise-             -> mk_apps-                (HsTyVar noAnn NotPromoted-                                   (noLocA (getRdrName (tupleTyCon Unboxed n))))-                tys'+             -> do { tuple_tc <- returnLA $ getRdrName $ tupleTyCon Unboxed n+                   ; mk_apps (HsTyVar noAnn NotPromoted tuple_tc) tys' }            UnboxedSumT n              | n < 2             -> failWith $@@ -1508,9 +1571,8 @@              , normals `lengthIs` n -- Saturated              -> returnLA (HsSumTy noAnn normals)              | otherwise-             -> mk_apps-                (HsTyVar noAnn NotPromoted (noLocA (getRdrName (sumTyCon n))))-                tys'+             -> do { sum_tc <- returnLA $ getRdrName $ sumTyCon n+                   ; mk_apps (HsTyVar noAnn NotPromoted sum_tc) tys' }            ArrowT              | Just normals <- m_normals              , [x',y'] <- normals -> do@@ -1521,11 +1583,10 @@                           _            -> return $                                           parenthesizeHsType sigPrec x'                  let y'' = parenthesizeHsType sigPrec y'-                 returnLA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) x'' y'')+                 returnLA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) x'' y'')              | otherwise-             -> mk_apps-                (HsTyVar noAnn NotPromoted (noLocA (getRdrName unrestrictedFunTyCon)))-                tys'+             -> do { fun_tc <- returnLA $ getRdrName unrestrictedFunTyCon+                   ; mk_apps (HsTyVar noAnn NotPromoted fun_tc) tys' }            MulArrowT              | Just normals <- m_normals              , [w',x',y'] <- normals -> do@@ -1539,23 +1600,22 @@                      w'' = hsTypeToArrow w'                  returnLA (HsFunTy noAnn w'' x'' y'')              | otherwise-             -> mk_apps-                (HsTyVar noAnn NotPromoted (noLocA (getRdrName funTyCon)))-                tys'+             -> do { fun_tc <- returnLA $ getRdrName funTyCon+                   ; mk_apps (HsTyVar noAnn NotPromoted fun_tc) tys' }            ListT              | Just normals <- m_normals              , [x'] <- normals ->                 returnLA (HsListTy noAnn x')              | otherwise-             -> mk_apps-                (HsTyVar noAnn NotPromoted (noLocA (getRdrName listTyCon)))-                tys'+             -> do { list_tc <- returnLA $ getRdrName listTyCon+                   ; mk_apps (HsTyVar noAnn NotPromoted list_tc) tys' }             VarT nm -> do { nm' <- tNameN nm                          ; mk_apps (HsTyVar noAnn NotPromoted nm') tys' }            ConT nm -> do { nm' <- tconName nm                          ; let prom = name_promotedness nm'-                         ; mk_apps (HsTyVar noAnn prom (noLocA nm')) tys'}+                         ; lnm' <- returnLA nm'+                         ; mk_apps (HsTyVar noAnn prom lnm') tys'}             ForallT tvs cxt ty              | null tys'@@ -1596,25 +1656,42 @@                    ; t1' <- cvtType t1                    ; t2' <- cvtType t2                    ; let prom = name_promotedness s'+                   ; ls' <- returnLA s'                    ; mk_apps-                      (HsTyVar noAnn prom (noLocA s'))+                      (HsTyVar noAnn prom ls')                       ([HsValArg t1', HsValArg t2'] ++ tys')                    }             UInfixT t1 s t2-             -> do { t2' <- cvtType t2-                   ; t <- cvtOpAppT t1 s t2'+             -> do { s' <- tconNameN s+                   ; t2' <- cvtType t2+                   ; t <- cvtOpAppT NotPromoted t1 s' t2'                    ; mk_apps (unLoc t) tys'                    } -- Note [Converting UInfix] +           PromotedInfixT t1 s t2+             -> do { s'  <- cNameN s+                   ; t1' <- cvtType t1+                   ; t2' <- cvtType t2+                   ; mk_apps+                      (HsTyVar noAnn IsPromoted s')+                      ([HsValArg t1', HsValArg t2'] ++ tys')+                   }++           PromotedUInfixT t1 s t2+             -> do { s' <- cNameN s+                   ; t2' <- cvtType t2+                   ; t <- cvtOpAppT IsPromoted t1 s' t2'+                   ; mk_apps (unLoc t) tys'+                   } -- Note [Converting UInfix]+            ParensT t              -> do { t' <- cvtType t                    ; mk_apps (HsParTy noAnn t') tys'                    } -           PromotedT nm -> do { nm' <- cName nm-                              ; mk_apps (HsTyVar noAnn IsPromoted-                                         (noLocA nm'))+           PromotedT nm -> do { nm' <- cNameN nm+                              ; mk_apps (HsTyVar noAnn IsPromoted nm')                                         tys' }                  -- Promoted data constructor; hence cName @@ -1623,10 +1700,8 @@               , normals `lengthIs` n   -- Saturated               -> returnLA (HsExplicitTupleTy noAnn normals)               | otherwise-              -> mk_apps-                 (HsTyVar noAnn IsPromoted-                                   (noLocA (getRdrName (tupleDataCon Boxed n))))-                 tys'+              -> do { tuple_tc <- returnLA $ getRdrName $ tupleDataCon Boxed n+                    ; mk_apps (HsTyVar noAnn IsPromoted tuple_tc) tys' }             PromotedNilT              -> mk_apps (HsExplicitListTy noAnn IsPromoted []) tys'@@ -1637,50 +1712,46 @@               , [ty1, L _ (HsExplicitListTy _ ip tys2)] <- normals               -> returnLA (HsExplicitListTy noAnn ip (ty1:tys2))               | otherwise-              -> mk_apps-                 (HsTyVar noAnn IsPromoted (noLocA (getRdrName consDataCon)))-                 tys'+              -> do { cons_tc <- returnLA $ getRdrName consDataCon+                    ; mk_apps (HsTyVar noAnn IsPromoted cons_tc) tys' }             StarT-             -> mk_apps-                (HsTyVar noAnn NotPromoted-                                      (noLocA (getRdrName liftedTypeKindTyCon)))-                tys'+             -> do { type_tc <- returnLA $ getRdrName liftedTypeKindTyCon+                   ; mk_apps (HsTyVar noAnn NotPromoted type_tc) tys' }             ConstraintT-             -> mk_apps-                (HsTyVar noAnn NotPromoted-                                      (noLocA (getRdrName constraintKindTyCon)))-                tys'+             -> do { constraint_tc <- returnLA $ getRdrName constraintKindTyCon+                   ; mk_apps (HsTyVar noAnn NotPromoted constraint_tc) tys' }             EqualityT              | Just normals <- m_normals              , [x',y'] <- normals ->                    let px = parenthesizeHsType opPrec x'                        py = parenthesizeHsType opPrec y'-                   in returnLA (HsOpTy noExtField px (noLocA eqTyCon_RDR) py)+                   in do { eq_tc <- returnLA eqTyCon_RDR+                         ; returnLA (HsOpTy noAnn NotPromoted px eq_tc py) }                -- The long-term goal is to remove the above case entirely and                -- subsume it under the case for InfixT. See #15815, comment:6,                -- for more details.               | otherwise ->-                   mk_apps (HsTyVar noAnn NotPromoted-                            (noLocA eqTyCon_RDR)) tys'+                   do { eq_tc <- returnLA eqTyCon_RDR+                      ; mk_apps (HsTyVar noAnn NotPromoted eq_tc) tys' }            ImplicitParamT n t              -> do { n' <- wrapL $ ipName n                    ; t' <- cvtType t-                   ; returnLA (HsIParamTy noAnn n' t')+                   ; returnLA (HsIParamTy noAnn (reLocA n') t')                    } -           _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty))+           _ -> failWith (text "Malformed " <> text ty_str <+> text (show ty))     }  hsTypeToArrow :: LHsType GhcPs -> HsArrow GhcPs hsTypeToArrow w = case unLoc w of                      HsTyVar _ _ (L _ (isExact_maybe -> Just n))-                        | n == oneDataConName -> HsLinearArrow NormalSyntax Nothing-                        | n == manyDataConName -> HsUnrestrictedArrow NormalSyntax-                     _ -> HsExplicitMult NormalSyntax Nothing w+                        | n == oneDataConName -> HsLinearArrow (HsPct1 noHsTok noHsUniTok)+                        | n == manyDataConName -> HsUnrestrictedArrow noHsUniTok+                     _ -> HsExplicitMult noHsTok w noHsUniTok  -- ConT/InfixT can contain both data constructor (i.e., promoted) names and -- other (i.e, unpromoted) names, as opposed to PromotedT, which can only@@ -1768,14 +1839,18 @@  See the @cvtOpApp@ documentation for how this function works. -}-cvtOpAppT :: TH.Type -> TH.Name -> LHsType GhcPs -> CvtM (LHsType GhcPs)-cvtOpAppT (UInfixT x op2 y) op1 z-  = do { l <- cvtOpAppT y op1 z-       ; cvtOpAppT x op2 l }-cvtOpAppT x op y-  = do { op' <- tconNameN op-       ; x' <- cvtType x-       ; returnLA (mkHsOpTy x' op' y) }+cvtOpAppT :: PromotionFlag -> TH.Type -> LocatedN RdrName -> LHsType GhcPs -> CvtM (LHsType GhcPs)+cvtOpAppT prom (UInfixT x op2 y) op1 z+  = do { op2' <- tconNameN op2+       ; l <- cvtOpAppT prom y op1 z+       ; cvtOpAppT NotPromoted x op2' l }+cvtOpAppT prom (PromotedUInfixT x op2 y) op1 z+  = do { op2' <- cNameN op2+       ; l <- cvtOpAppT prom y op1 z+       ; cvtOpAppT IsPromoted x op2' l }+cvtOpAppT prom x op y+  = do { x' <- cvtType x+       ; returnLA (mkHsOpTy prom x' op y) }  cvtKind :: TH.Kind -> CvtM (LHsKind GhcPs) cvtKind = cvtTypeKind "kind"@@ -1788,18 +1863,18 @@ -- signature is possible). cvtMaybeKindToFamilyResultSig :: Maybe TH.Kind                               -> CvtM (LFamilyResultSig GhcPs)-cvtMaybeKindToFamilyResultSig Nothing   = returnL (Hs.NoSig noExtField)+cvtMaybeKindToFamilyResultSig Nothing   = returnLA (Hs.NoSig noExtField) cvtMaybeKindToFamilyResultSig (Just ki) = do { ki' <- cvtKind ki-                                             ; returnL (Hs.KindSig noExtField ki') }+                                             ; returnLA (Hs.KindSig noExtField ki') }  -- | Convert type family result signature. Used with both open and closed type -- families. cvtFamilyResultSig :: TH.FamilyResultSig -> CvtM (Hs.LFamilyResultSig GhcPs)-cvtFamilyResultSig TH.NoSig           = returnL (Hs.NoSig noExtField)+cvtFamilyResultSig TH.NoSig           = returnLA (Hs.NoSig noExtField) cvtFamilyResultSig (TH.KindSig ki)    = do { ki' <- cvtKind ki-                                           ; returnL (Hs.KindSig noExtField  ki') }+                                           ; returnLA (Hs.KindSig noExtField  ki') } cvtFamilyResultSig (TH.TyVarSig bndr) = do { tv <- cvt_tv bndr-                                           ; returnL (Hs.TyVarSig noExtField tv) }+                                           ; returnLA (Hs.TyVarSig noExtField tv) }  -- | Convert injectivity annotation of a type family. cvtInjectivityAnnotation :: TH.InjectivityAnn@@ -1807,7 +1882,7 @@ cvtInjectivityAnnotation (TH.InjectivityAnn annLHS annRHS)   = do { annLHS' <- tNameN annLHS        ; annRHS' <- mapM tNameN annRHS-       ; returnL (Hs.InjectivityAnn noAnn annLHS' annRHS') }+       ; returnLA (Hs.InjectivityAnn noAnn annLHS' annRHS') }  cvtPatSynSigTy :: TH.Type -> CvtM (LHsSigType GhcPs) -- pattern synonym types are of peculiar shapes, which is why we treat@@ -1815,22 +1890,21 @@ -- see Note [Pattern synonym type signatures and Template Haskell] cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty))   | null exis, null provs = cvtSigType (ForallT univs reqs ty)-  | null univs, null reqs = do { l'  <- getL-                               ; let l = noAnnSrcSpan l'-                               ; ty' <- cvtType (ForallT exis provs ty)-                               ; return $ L l $ mkHsImplicitSigType-                                        $ L l (HsQualTy { hst_ctxt = Nothing-                                                        , hst_xqual = noExtField-                                                        , hst_body = ty' }) }-  | null reqs             = do { l'      <- getL-                               ; let l'' = noAnnSrcSpan l'-                               ; univs' <- cvtTvs univs+  | null univs, null reqs = do { ty' <- cvtType (ForallT exis provs ty)+                               ; ctxt' <- returnLA []+                               ; cxtTy <- wrapParLA mkHsImplicitSigType $+                                          HsQualTy { hst_ctxt = ctxt'+                                                   , hst_xqual = noExtField+                                                   , hst_body = ty' }+                               ; returnLA cxtTy }+  | null reqs             = do { univs' <- cvtTvs univs                                ; ty'    <- cvtType (ForallT exis provs ty)-                               ; let forTy = mkHsExplicitSigType noAnn univs' $ L l'' cxtTy-                                     cxtTy = HsQualTy { hst_ctxt = Nothing+                               ; ctxt'  <- returnLA []+                               ; let cxtTy = HsQualTy { hst_ctxt = ctxt'                                                       , hst_xqual = noExtField                                                       , hst_body = ty' }-                               ; return $ L (noAnnSrcSpan l') forTy }+                               ; forTy <- wrapParLA (mkHsExplicitSigType noAnn univs') cxtTy+                               ; returnLA forTy }   | otherwise             = cvtSigType (ForallT univs reqs (ForallT exis provs ty)) cvtPatSynSigTy ty         = cvtSigType ty @@ -1913,8 +1987,22 @@ mkHsQualTy ctxt loc ctxt' ty   | null ctxt = ty   | otherwise = L loc $ HsQualTy { hst_xqual = noExtField-                                 , hst_ctxt  = Just ctxt'+                                 , hst_ctxt  = ctxt'                                  , hst_body  = ty }++-- | @'mkHsContextMaybe' lc@ returns 'Nothing' if @lc@ is empty and @'Just' lc@+-- otherwise.+--+-- This is much like 'mkHsQualTy', except that it returns a+-- @'Maybe' ('LHsContext' 'GhcPs')@. This is used specifically for constructing+-- superclasses, datatype contexts (#20011), and contexts in GADT constructor+-- types (#20590). We wish to avoid using @'Just' []@ in the case of an empty+-- contexts, as the pretty-printer always prints 'Just' contexts, even if+-- they're empty.+mkHsContextMaybe :: LHsContext GhcPs -> Maybe (LHsContext GhcPs)+mkHsContextMaybe lctxt@(L _ ctxt)+  | null ctxt = Nothing+  | otherwise = Just lctxt  mkHsOuterFamEqnTyVarBndrs :: Maybe [LHsTyVarBndr () GhcPs] -> HsOuterFamEqnTyVarBndrs GhcPs mkHsOuterFamEqnTyVarBndrs = maybe mkHsOuterImplicit (mkHsOuterExplicit noAnn)
compiler/GHC/Types/Name/Shape.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + module GHC.Types.Name.Shape    ( NameShape(..)    , emptyNameShape@@ -11,8 +11,6 @@    ) where -#include "GhclibHsVersions.h"- import GHC.Prelude  import GHC.Driver.Env@@ -29,8 +27,7 @@ import GHC.Iface.Env  import GHC.Utils.Outputable-import GHC.Utils.Misc-import GHC.Utils.Panic+import GHC.Utils.Panic.Plain  import Control.Monad @@ -215,7 +212,7 @@ mergeAvails :: [AvailInfo] -> [AvailInfo] -> [AvailInfo] mergeAvails as1 as2 =     let mkNE as = mkNameEnv [(availName a, a) | a <- as]-    in nameEnvElts (plusNameEnv_C plusAvail (mkNE as1) (mkNE as2))+    in nonDetNameEnvElts (plusNameEnv_C plusAvail (mkNE as1) (mkNE as2))  {- ************************************************************************@@ -233,7 +230,7 @@                                  n <- availNames a                                  return (nameOccName n, a)     in foldM (\subst (a1, a2) -> uAvailInfo flexi subst a1 a2) emptyNameEnv-             (eltsUFM (intersectUFM_C (,) (mkOE as1) (mkOE as2)))+             (nonDetEltsUFM (intersectUFM_C (,) (mkOE as1) (mkOE as2)))              -- Edward: I have to say, this is pretty clever.  -- | Unify two 'AvailInfo's, given an existing substitution @subst@,@@ -268,11 +265,11 @@ uHoleName :: ModuleName -> ShNameSubst -> Name {- hole name -} -> Name           -> Either SDoc ShNameSubst uHoleName flexi subst h n =-    ASSERT( isHoleName h )+    assert (isHoleName h) $     case lookupNameEnv subst h of         Just n' -> uName flexi subst n' n                 -- Do a quick check if the other name is substituted.         Nothing | Just n' <- lookupNameEnv subst n ->-                    ASSERT( isHoleName n ) uName flexi subst h n'+                    assert (isHoleName n) $ uName flexi subst h n'                 | otherwise ->                     Right (extendNameEnv subst h n)
compiler/GHC/Types/TyThing/Ppr.hs view
@@ -6,37 +6,32 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-}+ module GHC.Types.TyThing.Ppr (         pprTyThing,         pprTyThingInContext,         pprTyThingLoc,         pprTyThingInContextLoc,         pprTyThingHdr,-        pprTypeForUser,         pprFamInst   ) where -#include "GhclibHsVersions.h"- import GHC.Prelude -import GHC.Driver.Ppr (warnPprTrace)- import GHC.Types.TyThing ( TyThing(..), tyThingParent_maybe ) import GHC.Types.Name-import GHC.Types.Var.Env( emptyTidyEnv ) -import GHC.Core.Type    ( Type, ArgFlag(..), mkTyVarBinders, tidyOpenType )+import GHC.Core.Type    ( ArgFlag(..), mkTyVarBinders ) import GHC.Core.Coercion.Axiom ( coAxiomTyCon ) import GHC.Core.FamInstEnv( FamInst(..), FamFlavor(..) )-import GHC.Core.TyCo.Ppr ( pprUserForAll, pprTypeApp, pprSigmaType )+import GHC.Core.TyCo.Ppr ( pprUserForAll, pprTypeApp )  import GHC.Iface.Syntax ( ShowSub(..), ShowHowMuch(..), AltPpr(..)   , showToHeader, pprIfaceDecl ) import GHC.Iface.Make ( tyThingToIfaceDecl )  import GHC.Utils.Outputable+import GHC.Utils.Trace  -- ----------------------------------------------------------------------------- -- Pretty-printing entities that we get from the GHC API@@ -169,7 +164,7 @@ -- | Pretty-prints a 'TyThing'. pprTyThing :: ShowSub -> TyThing -> SDoc -- We pretty-print 'TyThing' via 'IfaceDecl'--- See Note [Pretty-printing TyThings]+-- See Note [Pretty printing via Iface syntax] pprTyThing ss ty_thing   = sdocOption sdocLinearTypes $ \show_linear_types ->       pprIfaceDecl ss' (tyThingToIfaceDecl show_linear_types ty_thing)@@ -189,19 +184,8 @@          = case nameModule_maybe name of              Just mod -> Just $ \occ -> getPprStyle $ \sty ->                pprModulePrefix sty mod occ <> ppr occ-             Nothing  -> WARN( True, ppr name ) Nothing+             Nothing  -> warnPprTrace True "pprTyThing" (ppr name) Nothing              -- Nothing is unexpected here; TyThings have External names--pprTypeForUser :: Type -> SDoc--- The type is tidied-pprTypeForUser ty-  = pprSigmaType tidy_ty-  where-    (_, tidy_ty)     = tidyOpenType emptyTidyEnv ty-     -- Often the types/kinds we print in ghci are fully generalised-     -- and have no free variables, but it turns out that we sometimes-     -- print un-generalised kinds (eg when doing :k T), so it's-     -- better to use tidyOpenType here  showWithLoc :: SDoc -> SDoc -> SDoc showWithLoc loc doc
+ compiler/GHC/Types/Unique/MemoFun.hs view
@@ -0,0 +1,21 @@+module GHC.Types.Unique.MemoFun (memoiseUniqueFun) where++import GHC.Prelude+import GHC.Types.Unique+import GHC.Types.Unique.FM++import Data.IORef+import System.IO.Unsafe++memoiseUniqueFun :: Uniquable k => (k -> a) -> k -> a+memoiseUniqueFun fun = unsafePerformIO $ do+  ref <- newIORef emptyUFM+  return $ \k -> unsafePerformIO $ do+    m <- readIORef ref+    case lookupUFM m k of+      Just a  -> return a+      Nothing -> do+        let !a  = fun k+            !m' = addToUFM m k a+        writeIORef ref m'+        return a
− compiler/GHC/Types/Unique/SDFM.hs 
@@ -1,121 +0,0 @@-{-# 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/Unit/Finder.hs view
@@ -3,14 +3,16 @@  -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE FlexibleContexts #-}  -- | Module finder module GHC.Unit.Finder (     FindResult(..),     InstalledFindResult(..),+    FinderOpts(..),     FinderCache,+    initFinderCache,     flushFinderCaches,     findImportedModule,     findPluginModule,@@ -22,6 +24,7 @@     mkHiOnlyModLocation,     mkHiPath,     mkObjPath,+    addModuleToFinder,     addHomeModuleToFinder,     uncacheModule,     mkStubPaths,@@ -29,26 +32,23 @@     findObjectLinkableMaybe,     findObjectLinkable, +    -- Hash cache+    lookupFileCache   ) where -#include "GhclibHsVersions.h"- import GHC.Prelude -import GHC.Driver.Env-import GHC.Driver.Session- import GHC.Platform.Ways  import GHC.Builtin.Names ( gHC_PRIM ) +import GHC.Unit.Env import GHC.Unit.Types import GHC.Unit.Module import GHC.Unit.Home import GHC.Unit.State import GHC.Unit.Finder.Types -import GHC.Data.FastString import GHC.Data.Maybe    ( expectJust ) import qualified GHC.Data.ShortText as ST @@ -57,13 +57,19 @@ import GHC.Utils.Panic  import GHC.Linker.Types+import GHC.Types.PkgQual -import Data.IORef       ( IORef, readIORef, atomicModifyIORef' )+import GHC.Fingerprint+import Data.IORef import System.Directory import System.FilePath import Control.Monad import Data.Time-+import qualified Data.Map as M+import GHC.Driver.Env+    ( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env) )+import GHC.Driver.Config.Finder+import qualified Data.Set as Set  type FileExt = String   -- Filename extension type BaseName = String  -- Basename of file@@ -81,62 +87,125 @@ -- ----------------------------------------------------------------------------- -- The finder's cache ++initFinderCache :: IO FinderCache+initFinderCache = FinderCache <$> newIORef emptyInstalledModuleEnv+                              <*> newIORef M.empty+ -- remove all the home modules from the cache; package modules are--- assumed to not move around during a session.-flushFinderCaches :: HscEnv -> IO ()-flushFinderCaches hsc_env =-  atomicModifyIORef' fc_ref $ \fm -> (filterInstalledModuleEnv is_ext fm, ())+-- assumed to not move around during a session; also flush the file hash+-- cache+flushFinderCaches :: FinderCache -> UnitEnv -> IO ()+flushFinderCaches (FinderCache ref file_ref) ue = do+  atomicModifyIORef' ref $ \fm -> (filterInstalledModuleEnv is_ext fm, ())+  atomicModifyIORef' file_ref $ \_ -> (M.empty, ())  where-        fc_ref       = hsc_FC hsc_env-        home_unit    = hsc_home_unit hsc_env-        is_ext mod _ = not (isHomeInstalledModule home_unit mod)+  is_ext mod _ = not (isUnitEnvInstalledModule ue mod) -addToFinderCache :: IORef FinderCache -> InstalledModule -> InstalledFindResult -> IO ()-addToFinderCache ref key val =+addToFinderCache :: FinderCache -> InstalledModule -> InstalledFindResult -> IO ()+addToFinderCache (FinderCache ref _) key val =   atomicModifyIORef' ref $ \c -> (extendInstalledModuleEnv c key val, ()) -removeFromFinderCache :: IORef FinderCache -> InstalledModule -> IO ()-removeFromFinderCache ref key =+removeFromFinderCache :: FinderCache -> InstalledModule -> IO ()+removeFromFinderCache (FinderCache ref _) key =   atomicModifyIORef' ref $ \c -> (delInstalledModuleEnv c key, ()) -lookupFinderCache :: IORef FinderCache -> InstalledModule -> IO (Maybe InstalledFindResult)-lookupFinderCache ref key = do+lookupFinderCache :: FinderCache -> InstalledModule -> IO (Maybe InstalledFindResult)+lookupFinderCache (FinderCache ref _) key = do    c <- readIORef ref    return $! lookupInstalledModuleEnv c key +lookupFileCache :: FinderCache -> FilePath -> IO Fingerprint+lookupFileCache (FinderCache _ ref) key = do+   c <- readIORef ref+   case M.lookup key c of+     Nothing -> do+       hash <- getFileHash key+       atomicModifyIORef' ref $ \c -> (M.insert key hash c, ())+       return hash+     Just fp -> return fp+ -- ----------------------------------------------------------------------------- -- The three external entry points + -- | Locate a module that was imported by the user.  We have the -- module's name, and possibly a package name.  Without a package -- name, this function will use the search path and the known exposed -- packages to find the module, if a package is specified then only -- that package is searched for the module. -findImportedModule :: HscEnv -> ModuleName -> Maybe FastString -> IO FindResult-findImportedModule hsc_env mod_name mb_pkg =+findImportedModule :: HscEnv -> ModuleName -> PkgQual -> IO FindResult+findImportedModule hsc_env mod fs =+  let fc        = hsc_FC hsc_env+      mhome_unit = hsc_home_unit_maybe hsc_env+      dflags    = hsc_dflags hsc_env+      fopts     = initFinderOpts dflags+  in do+    findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) mhome_unit mod fs++findImportedModuleNoHsc+  :: FinderCache+  -> FinderOpts+  -> UnitEnv+  -> Maybe HomeUnit+  -> ModuleName+  -> PkgQual+  -> IO FindResult+findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =   case mb_pkg of-        Nothing                        -> unqual_import-        Just pkg | pkg == fsLit "this" -> home_import -- "this" is special-                 | otherwise           -> pkg_import+    NoPkgQual  -> unqual_import+    ThisPkg uid | (homeUnitId <$> mhome_unit) == Just uid -> home_import+                | Just os <- lookup uid other_fopts -> home_pkg_import (uid, os)+                | otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr (homeUnitId <$> mhome_unit) $$ ppr uid $$ ppr (map fst all_opts))+    OtherPkg _ -> pkg_import   where-    home_import   = findHomeModule hsc_env mod_name+    all_opts = case mhome_unit of+                Nothing -> other_fopts+                Just home_unit -> (homeUnitId home_unit, fopts) : other_fopts -    pkg_import    = findExposedPackageModule hsc_env mod_name mb_pkg -    unqual_import = home_import+    home_import = case mhome_unit of+                   Just home_unit -> findHomeModule fc fopts home_unit mod_name+                   Nothing -> pure $ NoPackage (panic "findImportedModule: no home-unit")+++    home_pkg_import (uid, opts)+      -- If the module is reexported, then look for it as if it was from the perspective+      -- of that package which reexports it.+      | mod_name `Set.member` finder_reexportedModules opts =+        findImportedModuleNoHsc fc opts ue (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual+      | mod_name `Set.member` finder_hiddenModules opts =+        return (mkHomeHidden uid)+      | otherwise =+        findHomePackageModule fc opts uid mod_name++    any_home_import = foldr orIfNotFound home_import (map home_pkg_import other_fopts)++    pkg_import    = findExposedPackageModule fc fopts units  mod_name mb_pkg++    unqual_import = any_home_import                     `orIfNotFound`-                    findExposedPackageModule hsc_env mod_name Nothing+                    findExposedPackageModule fc fopts units mod_name NoPkgQual +    units     = case mhome_unit of+                  Nothing -> ue_units ue+                  Just home_unit -> homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId home_unit) ue+    hpt_deps :: [UnitId]+    hpt_deps  = homeUnitDepends units+    other_fopts  = map (\uid -> (uid, initFinderOpts (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue)))) hpt_deps+ -- | Locate a plugin module requested by the user, for a compiler -- plugin.  This consults the same set of exposed packages as -- 'findImportedModule', unless @-hide-all-plugin-packages@ or -- @-plugin-package@ are specified.-findPluginModule :: HscEnv -> ModuleName -> IO FindResult-findPluginModule hsc_env mod_name =-  findHomeModule hsc_env mod_name+findPluginModule :: FinderCache -> FinderOpts -> UnitState -> Maybe HomeUnit -> ModuleName -> IO FindResult+findPluginModule fc fopts units (Just home_unit) mod_name =+  findHomeModule fc fopts home_unit mod_name   `orIfNotFound`-  findExposedPluginPackageModule hsc_env mod_name+  findExposedPluginPackageModule fc fopts units mod_name+findPluginModule fc fopts units Nothing mod_name =+  findExposedPluginPackageModule fc fopts units mod_name  -- | Locate a specific 'Module'.  The purpose of this function is to -- create a 'ModLocation' for a given 'Module', that is to find out@@ -144,12 +213,15 @@ -- reading the interface for a module mentioned by another interface, -- for example (a "system import"). -findExactModule :: HscEnv -> InstalledModule -> IO InstalledFindResult-findExactModule hsc_env mod =-    let home_unit = hsc_home_unit hsc_env-    in if isHomeInstalledModule home_unit mod-       then findInstalledHomeModule hsc_env (moduleName mod)-       else findPackageModule hsc_env mod+findExactModule :: FinderCache -> FinderOpts ->  UnitEnvGraph FinderOpts -> UnitState -> Maybe HomeUnit -> InstalledModule -> IO InstalledFindResult+findExactModule fc fopts other_fopts unit_state mhome_unit mod = do+  case mhome_unit of+    Just home_unit+     | isHomeInstalledModule home_unit mod+        -> findInstalledHomeModule fc fopts (homeUnitId home_unit) (moduleName mod)+     | Just home_fopts <- unitEnv_lookup_maybe (moduleUnit mod) other_fopts+        -> findInstalledHomeModule fc home_fopts (moduleUnit mod) (moduleName mod)+    _ -> findPackageModule fc unit_state fopts mod  -- ----------------------------------------------------------------------------- -- Helpers@@ -184,31 +256,26 @@ -- been done.  Otherwise, do the lookup (with the IO action) and save -- the result in the finder cache and the module location cache (if it -- was successful.)-homeSearchCache :: HscEnv -> ModuleName -> IO InstalledFindResult -> IO InstalledFindResult-homeSearchCache hsc_env mod_name do_this = do-  let home_unit = hsc_home_unit hsc_env-      mod = mkHomeInstalledModule home_unit mod_name-  modLocationCache hsc_env mod do_this+homeSearchCache :: FinderCache -> UnitId -> ModuleName -> IO InstalledFindResult -> IO InstalledFindResult+homeSearchCache fc home_unit mod_name do_this = do+  let mod = mkModule home_unit mod_name+  modLocationCache fc mod do_this -findExposedPackageModule :: HscEnv -> ModuleName -> Maybe FastString-                         -> IO FindResult-findExposedPackageModule hsc_env mod_name mb_pkg-  = findLookupResult hsc_env-  $ lookupModuleWithSuggestions-        (hsc_units hsc_env) mod_name mb_pkg+findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> PkgQual -> IO FindResult+findExposedPackageModule fc fopts units mod_name mb_pkg =+  findLookupResult fc fopts+    $ lookupModuleWithSuggestions units mod_name mb_pkg -findExposedPluginPackageModule :: HscEnv -> ModuleName-                               -> IO FindResult-findExposedPluginPackageModule hsc_env mod_name-  = findLookupResult hsc_env-  $ lookupPluginModuleWithSuggestions-        (hsc_units hsc_env) mod_name Nothing+findExposedPluginPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> IO FindResult+findExposedPluginPackageModule fc fopts units mod_name =+  findLookupResult fc fopts+    $ lookupPluginModuleWithSuggestions units mod_name NoPkgQual -findLookupResult :: HscEnv -> LookupResult -> IO FindResult-findLookupResult hsc_env r = case r of+findLookupResult :: FinderCache -> FinderOpts -> LookupResult -> IO FindResult+findLookupResult fc fopts r = case r of      LookupFound m pkg_conf -> do        let im = fst (getModuleInstantiation m)-       r' <- findPackageModule_ hsc_env im (fst pkg_conf)+       r' <- findPackageModule_ fc fopts im (fst pkg_conf)        case r' of         -- TODO: ghc -M is unlikely to do the right thing         -- with just the location of the thing that was@@ -241,7 +308,7 @@                           , fr_suggestions = [] })      LookupNotFound suggest -> do        let suggest'-             | gopt Opt_HelpfulErrors (hsc_dflags hsc_env) = suggest+             | finder_enableSuggestions fopts = suggest              | otherwise = []        return (NotFound{ fr_paths = [], fr_pkg = Nothing                        , fr_pkgs_hidden = []@@ -249,36 +316,40 @@                        , fr_unusables = []                        , fr_suggestions = suggest' }) -modLocationCache :: HscEnv -> InstalledModule -> IO InstalledFindResult -> IO InstalledFindResult-modLocationCache hsc_env mod do_this = do-  m <- lookupFinderCache (hsc_FC hsc_env) mod+modLocationCache :: FinderCache -> InstalledModule -> IO InstalledFindResult -> IO InstalledFindResult+modLocationCache fc mod do_this = do+  m <- lookupFinderCache fc mod   case m of     Just result -> return result     Nothing     -> do         result <- do_this-        addToFinderCache (hsc_FC hsc_env) mod result+        addToFinderCache fc mod result         return result +addModuleToFinder :: FinderCache -> Module -> ModLocation -> IO ()+addModuleToFinder fc mod loc = do+  let imod = toUnitId <$> mod+  addToFinderCache fc imod (InstalledFound loc imod)+ -- This returns a module because it's more convenient for users-addHomeModuleToFinder :: HscEnv -> ModuleName -> ModLocation -> IO Module-addHomeModuleToFinder hsc_env mod_name loc = do-  let home_unit = hsc_home_unit hsc_env-      mod = mkHomeInstalledModule home_unit mod_name-  addToFinderCache (hsc_FC hsc_env) mod (InstalledFound loc mod)+addHomeModuleToFinder :: FinderCache -> HomeUnit -> ModuleName -> ModLocation -> IO Module+addHomeModuleToFinder fc home_unit mod_name loc = do+  let mod = mkHomeInstalledModule home_unit mod_name+  addToFinderCache fc mod (InstalledFound loc mod)   return (mkHomeModule home_unit mod_name) -uncacheModule :: HscEnv -> ModuleName -> IO ()-uncacheModule hsc_env mod_name = do-  let home_unit = hsc_home_unit hsc_env-      mod = mkHomeInstalledModule home_unit mod_name-  removeFromFinderCache (hsc_FC hsc_env) mod+uncacheModule :: FinderCache -> HomeUnit -> ModuleName -> IO ()+uncacheModule fc home_unit mod_name = do+  let mod = mkHomeInstalledModule home_unit mod_name+  removeFromFinderCache fc mod  -- ----------------------------------------------------------------------------- --      The internal workers -findHomeModule :: HscEnv -> ModuleName -> IO FindResult-findHomeModule hsc_env mod_name = do-  r <- findInstalledHomeModule hsc_env mod_name+findHomeModule :: FinderCache -> FinderOpts -> HomeUnit -> ModuleName -> IO FindResult+findHomeModule fc fopts  home_unit mod_name = do+  let uid       = homeUnitAsUnit home_unit+  r <- findInstalledHomeModule fc fopts (homeUnitId home_unit) mod_name   return $ case r of     InstalledFound loc _ -> Found loc (mkHomeModule home_unit mod_name)     InstalledNoPackage _ -> NoPackage uid -- impossible@@ -290,10 +361,33 @@         fr_unusables = [],         fr_suggestions = []       }- where-  home_unit = hsc_home_unit hsc_env-  uid       = homeUnitAsUnit home_unit +mkHomeHidden :: UnitId -> FindResult+mkHomeHidden uid =+  NotFound { fr_paths = []+           , fr_pkg = Just (RealUnit (Definite uid))+           , fr_mods_hidden = [RealUnit (Definite uid)]+           , fr_pkgs_hidden = []+           , fr_unusables = []+           , fr_suggestions = []}++findHomePackageModule :: FinderCache -> FinderOpts -> UnitId -> ModuleName -> IO FindResult+findHomePackageModule fc fopts  home_unit mod_name = do+  let uid       = RealUnit (Definite home_unit)+  r <- findInstalledHomeModule fc fopts home_unit mod_name+  return $ case r of+    InstalledFound loc _ -> Found loc (mkModule uid mod_name)+    InstalledNoPackage _ -> NoPackage uid -- impossible+    InstalledNotFound fps _ -> NotFound {+        fr_paths = fps,+        fr_pkg = Just uid,+        fr_mods_hidden = [],+        fr_pkgs_hidden = [],+        fr_unusables = [],+        fr_suggestions = []+      }++ -- | Implements the search for a module name in the home package only.  Calling -- this function directly is usually *not* what you want; currently, it's used -- as a building block for the following operations:@@ -310,51 +404,64 @@ -- --  4. Some special-case code in GHCi (ToDo: Figure out why that needs to --  call this.)-findInstalledHomeModule :: HscEnv -> ModuleName -> IO InstalledFindResult-findInstalledHomeModule hsc_env mod_name =-   homeSearchCache hsc_env mod_name $+findInstalledHomeModule :: FinderCache -> FinderOpts -> UnitId -> ModuleName -> IO InstalledFindResult+findInstalledHomeModule fc fopts home_unit mod_name = do+  homeSearchCache fc home_unit mod_name $    let-     dflags = hsc_dflags hsc_env-     home_unit = hsc_home_unit hsc_env-     home_path = importPaths dflags-     hisuf = hiSuf dflags-     mod = mkHomeInstalledModule home_unit mod_name+     maybe_working_dir = finder_workingDirectory fopts+     home_path = case maybe_working_dir of+                  Nothing -> finder_importPaths fopts+                  Just fp -> augmentImports fp (finder_importPaths fopts)+     hi_dir_path =+      case finder_hiDir fopts of+        Just hiDir -> case maybe_working_dir of+                        Nothing -> [hiDir]+                        Just fp -> [fp </> hiDir]+        Nothing -> home_path+     hisuf = finder_hiSuf fopts+     mod = mkModule home_unit mod_name       source_exts =-      [ ("hs",   mkHomeModLocationSearched dflags mod_name "hs")-      , ("lhs",  mkHomeModLocationSearched dflags mod_name "lhs")-      , ("hsig",  mkHomeModLocationSearched dflags mod_name "hsig")-      , ("lhsig",  mkHomeModLocationSearched dflags mod_name "lhsig")+      [ ("hs",    mkHomeModLocationSearched fopts mod_name "hs")+      , ("lhs",   mkHomeModLocationSearched fopts mod_name "lhs")+      , ("hsig",  mkHomeModLocationSearched fopts mod_name "hsig")+      , ("lhsig", mkHomeModLocationSearched fopts mod_name "lhsig")       ]       -- we use mkHomeModHiOnlyLocation instead of mkHiOnlyModLocation so that      -- when hiDir field is set in dflags, we know to look there (see #16500)-     hi_exts = [ (hisuf,                mkHomeModHiOnlyLocation dflags mod_name)-               , (addBootSuffix hisuf,  mkHomeModHiOnlyLocation dflags mod_name)+     hi_exts = [ (hisuf,                mkHomeModHiOnlyLocation fopts mod_name)+               , (addBootSuffix hisuf,  mkHomeModHiOnlyLocation fopts mod_name)                ]          -- In compilation manager modes, we look for source files in the home         -- package because we can compile these automatically.  In one-shot         -- compilation mode we look for .hi and .hi-boot files only.-     exts | isOneShot (ghcMode dflags) = hi_exts-          | otherwise                  = source_exts+     (search_dirs, exts)+          | finder_lookupHomeInterfaces fopts = (hi_dir_path, hi_exts)+          | otherwise                         = (home_path, source_exts)    in -  -- special case for GHC.Prim; we won't find it in the filesystem.-  -- This is important only when compiling the base package (where GHC.Prim-  -- is a home module).-  if mod `installedModuleEq` gHC_PRIM-        then return (InstalledFound (error "GHC.Prim ModLocation") mod)-        else searchPathExts home_path mod exts+   -- special case for GHC.Prim; we won't find it in the filesystem.+   -- This is important only when compiling the base package (where GHC.Prim+   -- is a home module).+   if mod `installedModuleEq` gHC_PRIM+         then return (InstalledFound (error "GHC.Prim ModLocation") mod)+         else searchPathExts search_dirs mod exts +-- | Prepend the working directory to the search path.+augmentImports :: FilePath -> [FilePath] -> [FilePath]+augmentImports _work_dir [] = []+augmentImports work_dir (fp:fps) | isAbsolute fp = fp : augmentImports work_dir fps+                                 | otherwise     = (work_dir </> fp) : augmentImports work_dir fps  -- | Search for a module in external packages only.-findPackageModule :: HscEnv -> InstalledModule -> IO InstalledFindResult-findPackageModule hsc_env mod = do+findPackageModule :: FinderCache -> UnitState -> FinderOpts -> InstalledModule -> IO InstalledFindResult+findPackageModule fc unit_state fopts mod = do   let pkg_id = moduleUnit mod-  case lookupUnitId (hsc_units hsc_env) pkg_id of+  case lookupUnitId unit_state pkg_id of      Nothing -> return (InstalledNoPackage pkg_id)-     Just u  -> findPackageModule_ hsc_env mod u+     Just u  -> findPackageModule_ fc fopts mod u  -- | Look up the interface file associated with module @mod@.  This function -- requires a few invariants to be upheld: (1) the 'Module' in question must@@ -363,48 +470,50 @@ -- the 'UnitInfo' must be consistent with the unit id in the 'Module'. -- The redundancy is to avoid an extra lookup in the package state -- for the appropriate config.-findPackageModule_ :: HscEnv -> InstalledModule -> UnitInfo -> IO InstalledFindResult-findPackageModule_ hsc_env mod pkg_conf =-  ASSERT2( moduleUnit mod == unitId pkg_conf, ppr (moduleUnit mod) <+> ppr (unitId pkg_conf) )-  modLocationCache hsc_env mod $+findPackageModule_ :: FinderCache -> FinderOpts -> InstalledModule -> UnitInfo -> IO InstalledFindResult+findPackageModule_ fc fopts mod pkg_conf = do+  massertPpr (moduleUnit mod == unitId pkg_conf)+             (ppr (moduleUnit mod) <+> ppr (unitId pkg_conf))+  modLocationCache fc mod $ -  -- special case for GHC.Prim; we won't find it in the filesystem.-  if mod `installedModuleEq` gHC_PRIM-        then return (InstalledFound (error "GHC.Prim ModLocation") mod)-        else+    -- special case for GHC.Prim; we won't find it in the filesystem.+    if mod `installedModuleEq` gHC_PRIM+          then return (InstalledFound (error "GHC.Prim ModLocation") mod)+          else -  let-     dflags = hsc_dflags hsc_env-     tag = waysBuildTag (ways dflags)+    let+       tag = waysBuildTag (finder_ways fopts) -           -- hi-suffix for packages depends on the build tag.-     package_hisuf | null tag  = "hi"-                   | otherwise = tag ++ "_hi"+             -- hi-suffix for packages depends on the build tag.+       package_hisuf | null tag  = "hi"+                     | otherwise = tag ++ "_hi" -     mk_hi_loc = mkHiOnlyModLocation dflags package_hisuf+       package_dynhisuf = waysBuildTag (addWay WayDyn (finder_ways fopts)) ++ "_hi" -     import_dirs = map ST.unpack $ unitImportDirs pkg_conf-      -- we never look for a .hi-boot file in an external package;-      -- .hi-boot files only make sense for the home package.-  in-  case import_dirs of-    [one] | MkDepend <- ghcMode dflags -> do-          -- there's only one place that this .hi file can be, so-          -- don't bother looking for it.-          let basename = moduleNameSlashes (moduleName mod)-          loc <- mk_hi_loc one basename-          return (InstalledFound loc mod)-    _otherwise ->-          searchPathExts import_dirs mod [(package_hisuf, mk_hi_loc)]+       mk_hi_loc = mkHiOnlyModLocation fopts package_hisuf package_dynhisuf +       import_dirs = map ST.unpack $ unitImportDirs pkg_conf+        -- we never look for a .hi-boot file in an external package;+        -- .hi-boot files only make sense for the home package.+    in+    case import_dirs of+      [one] | finder_bypassHiFileCheck fopts ->+            -- there's only one place that this .hi file can be, so+            -- don't bother looking for it.+            let basename = moduleNameSlashes (moduleName mod)+                loc = mk_hi_loc one basename+            in return $ InstalledFound loc mod+      _otherwise ->+            searchPathExts import_dirs mod [(package_hisuf, mk_hi_loc)]+ -- ----------------------------------------------------------------------------- -- General path searching  searchPathExts :: [FilePath]      -- paths to search                -> InstalledModule -- module name                -> [ (-                     FileExt,                                -- suffix-                     FilePath -> BaseName -> IO ModLocation  -- action+                     FileExt,                             -- suffix+                     FilePath -> BaseName -> ModLocation  -- action                     )                   ]                -> IO InstalledFindResult@@ -413,7 +522,7 @@   where     basename = moduleNameSlashes (moduleName mod) -    to_search :: [(FilePath, IO ModLocation)]+    to_search :: [(FilePath, ModLocation)]     to_search = [ (file, fn path basename)                 | path <- paths,                   (ext,fn) <- exts,@@ -424,17 +533,18 @@      search [] = return (InstalledNotFound (map fst to_search) (Just (moduleUnit mod))) -    search ((file, mk_result) : rest) = do+    search ((file, loc) : rest) = do       b <- doesFileExist file       if b-        then do { loc <- mk_result; return (InstalledFound loc mod) }+        then return $ InstalledFound loc mod         else search rest -mkHomeModLocationSearched :: DynFlags -> ModuleName -> FileExt-                          -> FilePath -> BaseName -> IO ModLocation-mkHomeModLocationSearched dflags mod suff path basename =-  mkHomeModLocation2 dflags mod (path </> basename) suff+mkHomeModLocationSearched :: FinderOpts -> ModuleName -> FileExt+                          -> FilePath -> BaseName -> ModLocation+mkHomeModLocationSearched fopts mod suff path basename =+  mkHomeModLocation2 fopts mod (path </> basename) suff + -- ----------------------------------------------------------------------------- -- Constructing a home module location @@ -468,49 +578,59 @@ -- ext --      The filename extension of the source file (usually "hs" or "lhs"). -mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO ModLocation-mkHomeModLocation dflags mod src_filename = do+mkHomeModLocation :: FinderOpts -> ModuleName -> FilePath -> ModLocation+mkHomeModLocation dflags mod src_filename =    let (basename,extension) = splitExtension src_filename-   mkHomeModLocation2 dflags mod basename extension+   in mkHomeModLocation2 dflags mod basename extension -mkHomeModLocation2 :: DynFlags+mkHomeModLocation2 :: FinderOpts                    -> ModuleName                    -> FilePath  -- Of source module, without suffix                    -> String    -- Suffix-                   -> IO ModLocation-mkHomeModLocation2 dflags mod src_basename ext = do+                   -> ModLocation+mkHomeModLocation2 fopts mod src_basename ext =    let mod_basename = moduleNameSlashes mod -       obj_fn = mkObjPath  dflags src_basename mod_basename-       hi_fn  = mkHiPath   dflags src_basename mod_basename-       hie_fn = mkHiePath  dflags src_basename mod_basename+       obj_fn = mkObjPath  fopts src_basename mod_basename+       dyn_obj_fn = mkDynObjPath  fopts src_basename mod_basename+       hi_fn  = mkHiPath   fopts src_basename mod_basename+       dyn_hi_fn  = mkDynHiPath   fopts src_basename mod_basename+       hie_fn = mkHiePath  fopts src_basename mod_basename -   return (ModLocation{ ml_hs_file   = Just (src_basename <.> ext),+   in (ModLocation{ ml_hs_file   = Just (src_basename <.> ext),                         ml_hi_file   = hi_fn,+                        ml_dyn_hi_file = dyn_hi_fn,                         ml_obj_file  = obj_fn,+                        ml_dyn_obj_file = dyn_obj_fn,                         ml_hie_file  = hie_fn }) -mkHomeModHiOnlyLocation :: DynFlags+mkHomeModHiOnlyLocation :: FinderOpts                         -> ModuleName                         -> FilePath                         -> BaseName-                        -> IO ModLocation-mkHomeModHiOnlyLocation dflags mod path basename = do-   loc <- mkHomeModLocation2 dflags mod (path </> basename) ""-   return loc { ml_hs_file = Nothing }+                        -> ModLocation+mkHomeModHiOnlyLocation fopts mod path basename =+   let loc = mkHomeModLocation2 fopts mod (path </> basename) ""+   in loc { ml_hs_file = Nothing } -mkHiOnlyModLocation :: DynFlags -> Suffix -> FilePath -> String-                    -> IO ModLocation-mkHiOnlyModLocation dflags hisuf path basename- = do let full_basename = path </> basename-          obj_fn = mkObjPath  dflags full_basename basename-          hie_fn = mkHiePath  dflags full_basename basename-      return ModLocation{    ml_hs_file   = Nothing,+-- This function is used to make a ModLocation for a package module. Hence why+-- we explicitly pass in the interface file suffixes.+mkHiOnlyModLocation :: FinderOpts -> Suffix -> Suffix -> FilePath -> String+                    -> ModLocation+mkHiOnlyModLocation fopts hisuf dynhisuf path basename+ = let full_basename = path </> basename+       obj_fn = mkObjPath fopts full_basename basename+       dyn_obj_fn = mkDynObjPath fopts full_basename basename+       hie_fn = mkHiePath fopts full_basename basename+   in ModLocation{    ml_hs_file   = Nothing,                              ml_hi_file   = full_basename <.> hisuf,                                 -- Remove the .hi-boot suffix from                                 -- hi_file, if it had one.  We always                                 -- want the name of the real .hi file                                 -- in the ml_hi_file field.+                             ml_dyn_obj_file = dyn_obj_fn,+                             -- MP: TODO+                             ml_dyn_hi_file  = full_basename <.> dynhisuf,                              ml_obj_file  = obj_fn,                              ml_hie_file  = hie_fn                   }@@ -518,45 +638,75 @@ -- | Constructs the filename of a .o file for a given source file. -- Does /not/ check whether the .o file exists mkObjPath-  :: DynFlags+  :: FinderOpts   -> FilePath           -- the filename of the source file, minus the extension   -> String             -- the module name with dots replaced by slashes   -> FilePath-mkObjPath dflags basename mod_basename = obj_basename <.> osuf+mkObjPath fopts basename mod_basename = obj_basename <.> osuf   where-                odir = objectDir dflags-                osuf = objectSuf dflags+                odir = finder_objectDir fopts+                osuf = finder_objectSuf fopts                  obj_basename | Just dir <- odir = dir </> mod_basename                              | otherwise        = basename +-- | Constructs the filename of a .dyn_o file for a given source file.+-- Does /not/ check whether the .dyn_o file exists+mkDynObjPath+  :: FinderOpts+  -> FilePath           -- the filename of the source file, minus the extension+  -> String             -- the module name with dots replaced by slashes+  -> FilePath+mkDynObjPath fopts basename mod_basename = obj_basename <.> dynosuf+  where+                odir = finder_objectDir fopts+                dynosuf = finder_dynObjectSuf fopts +                obj_basename | Just dir <- odir = dir </> mod_basename+                             | otherwise        = basename++ -- | Constructs the filename of a .hi file for a given source file. -- Does /not/ check whether the .hi file exists mkHiPath-  :: DynFlags+  :: FinderOpts   -> FilePath           -- the filename of the source file, minus the extension   -> String             -- the module name with dots replaced by slashes   -> FilePath-mkHiPath dflags basename mod_basename = hi_basename <.> hisuf+mkHiPath fopts basename mod_basename = hi_basename <.> hisuf  where-                hidir = hiDir dflags-                hisuf = hiSuf dflags+                hidir = finder_hiDir fopts+                hisuf = finder_hiSuf fopts                  hi_basename | Just dir <- hidir = dir </> mod_basename                             | otherwise         = basename +-- | Constructs the filename of a .dyn_hi file for a given source file.+-- Does /not/ check whether the .dyn_hi file exists+mkDynHiPath+  :: FinderOpts+  -> FilePath           -- the filename of the source file, minus the extension+  -> String             -- the module name with dots replaced by slashes+  -> FilePath+mkDynHiPath fopts basename mod_basename = hi_basename <.> dynhisuf+ where+                hidir = finder_hiDir fopts+                dynhisuf = finder_dynHiSuf fopts++                hi_basename | Just dir <- hidir = dir </> mod_basename+                            | otherwise         = basename+ -- | Constructs the filename of a .hie file for a given source file. -- Does /not/ check whether the .hie file exists mkHiePath-  :: DynFlags+  :: FinderOpts   -> FilePath           -- the filename of the source file, minus the extension   -> String             -- the module name with dots replaced by slashes   -> FilePath-mkHiePath dflags basename mod_basename = hie_basename <.> hiesuf+mkHiePath fopts basename mod_basename = hie_basename <.> hiesuf  where-                hiedir = hieDir dflags-                hiesuf = hieSuf dflags+                hiedir = finder_hieDir fopts+                hiesuf = finder_hieSuf fopts                  hie_basename | Just dir <- hiedir = dir </> mod_basename                              | otherwise          = basename@@ -570,14 +720,14 @@ -- from other available information, and they're only rarely needed.  mkStubPaths-  :: DynFlags+  :: FinderOpts   -> ModuleName   -> ModLocation   -> FilePath -mkStubPaths dflags mod location+mkStubPaths fopts mod location   = let-        stubdir = stubDir dflags+        stubdir = finder_stubDir fopts          mod_basename = moduleNameSlashes mod         src_basename = dropExtension $ expectJust "mkStubPaths"
− compiler/GHC/Utils/Monad/State.hs 
@@ -1,46 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE UnboxedTuples #-}--module GHC.Utils.Monad.State where--import GHC.Prelude--newtype State s a = State { runState' :: s -> (# a, s #) }-    deriving (Functor)--instance Applicative (State s) where-   pure x   = State $ \s -> (# x, s #)-   m <*> n  = State $ \s -> case runState' m s of-                            (# f, s' #) -> case runState' n s' of-                                           (# x, s'' #) -> (# f x, s'' #)--instance Monad (State s) where-    m >>= n  = State $ \s -> case runState' m s of-                             (# r, s' #) -> runState' (n r) s'--get :: State s s-get = State $ \s -> (# s, s #)--gets :: (s -> a) -> State s a-gets f = State $ \s -> (# f s, s #)--put :: s -> State s ()-put s' = State $ \_ -> (# (), s' #)--modify :: (s -> s) -> State s ()-modify f = State $ \s -> (# (), f s #)---evalState :: State s a -> s -> a-evalState s i = case runState' s i of-                (# a, _ #) -> a---execState :: State s a -> s -> s-execState s i = case runState' s i of-                (# _, s' #) -> s'---runState :: State s a -> s -> (a, s)-runState s i = case runState' s i of-               (# a, s' #) -> (a, s')
+ compiler/GHC/Utils/Monad/State/Lazy.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE PatternSynonyms #-}++-- | A lazy state monad.+module GHC.Utils.Monad.State.Lazy+  ( -- * The State monda+    State(State)+  , state+  , evalState+  , execState+  , runState+    -- * Operations+  , get+  , gets+  , put+  , modify+  ) where++import GHC.Prelude++import GHC.Exts (oneShot)++-- | A state monad which is lazy in the state.+newtype State s a = State' { runState' :: s -> (# a, s #) }+    deriving (Functor)++pattern State :: (s -> (# a, s #))+              -> State s a++-- This pattern synonym makes the monad eta-expand,+-- which as a very beneficial effect on compiler performance+-- See #18202.+-- See Note [The one-shot state monad trick] in GHC.Utils.Monad+pattern State m <- State' m+  where+    State m = State' (oneShot $ \s -> m s)++instance Applicative (State s) where+   pure x   = State $ \s -> (# x, s #)+   m <*> n  = State $ \s -> case runState' m s of+                            (# f, s' #) -> case runState' n s' of+                                           (# x, s'' #) -> (# f x, s'' #)++instance Monad (State s) where+    m >>= n  = State $ \s -> case runState' m s of+                             (# r, s' #) -> runState' (n r) s'++state :: (s -> (a, s)) -> State s a+state f = State $ \s -> case f s of+                        (r, s') -> (# r, s' #)++get :: State s s+get = State $ \s -> (# s, s #)++gets :: (s -> a) -> State s a+gets f = State $ \s -> (# f s, s #)++put :: s -> State s ()+put s' = State $ \_ -> (# (), s' #)++modify :: (s -> s) -> State s ()+modify f = State $ \s -> (# (), f s #)+++evalState :: State s a -> s -> a+evalState s i = case runState' s i of+                (# a, _ #) -> a+++execState :: State s a -> s -> s+execState s i = case runState' s i of+                (# _, s' #) -> s'+++runState :: State s a -> s -> (a, s)+runState s i = case runState' s i of+               (# a, s' #) -> (a, s')
− 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/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/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.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.0 build-type: Simple name: ghc-lib-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,42 +37,38 @@     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-    includes/MachDeps.h-    includes/stg/MachRegs.h-    includes/CodeGen.Platform.hs+    rts/include/ghcconfig.h+    compiler/MachRegs.h+    compiler/CodeGen.Platform.h+    compiler/Bytecodes.h+    compiler/ClosureTypes.h+    compiler/FunTypes.h     compiler/Unique.h-    compiler/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,@@ -82,11 +78,12 @@         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,         rts,         hpc == 0.6.*,-        ghc-lib-parser == 9.2.8.20230729+        ghc-lib-parser,+        stm     build-tool-depends: alex:alex >= 3.1, happy:happy >= 1.19.4     other-extensions:         BangPatterns@@ -126,8 +123,11 @@         MonoLocalBinds         NoImplicitPrelude         ScopedTypeVariables+        TypeOperators     hs-source-dirs:+        ghc-lib/stage0/libraries/ghc-boot/build         ghc-lib/stage0/compiler/build+        libraries/template-haskell         libraries/ghc-boot         libraries/ghci         compiler@@ -137,6 +137,7 @@         GHC.BaseDir,         GHC.Builtin.Names,         GHC.Builtin.PrimOps,+        GHC.Builtin.PrimOps.Ids,         GHC.Builtin.Types,         GHC.Builtin.Types.Prim,         GHC.Builtin.Uniques,@@ -154,7 +155,6 @@         GHC.Cmm.Switch,         GHC.Cmm.Type,         GHC.CmmToAsm.CFG.Weight,-        GHC.CmmToAsm.Config,         GHC.Core,         GHC.Core.Class,         GHC.Core.Coercion,@@ -167,6 +167,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,@@ -177,10 +178,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,@@ -197,6 +202,7 @@         GHC.Core.Utils,         GHC.CoreToIface,         GHC.Data.Bag,+        GHC.Data.Bool,         GHC.Data.BooleanFormula,         GHC.Data.EnumSet,         GHC.Data.FastMutInt,@@ -211,21 +217,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,@@ -250,6 +265,7 @@         GHC.Hs.Binds,         GHC.Hs.Decls,         GHC.Hs.Doc,+        GHC.Hs.DocString,         GHC.Hs.Dump,         GHC.Hs.Expr,         GHC.Hs.Extension,@@ -259,6 +275,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,@@ -266,12 +287,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,@@ -290,7 +314,6 @@         GHC.Platform.Reg.Class,         GHC.Platform.Regs,         GHC.Platform.S390X,-        GHC.Platform.SPARC,         GHC.Platform.Ways,         GHC.Platform.X86,         GHC.Platform.X86_64,@@ -298,24 +321,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,@@ -327,6 +359,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,@@ -341,6 +375,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,@@ -356,6 +391,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,@@ -391,6 +427,7 @@         GHC.Utils.Binary.Typeable,         GHC.Utils.BufHandle,         GHC.Utils.CliOption,+        GHC.Utils.Constants,         GHC.Utils.Encoding,         GHC.Utils.Error,         GHC.Utils.Exception,@@ -403,17 +440,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,@@ -443,12 +484,14 @@         GHC.ByteCode.Linker         GHC.Cmm.CallConv         GHC.Cmm.CommonBlockElim+        GHC.Cmm.Config         GHC.Cmm.ContFlowOpt         GHC.Cmm.Dataflow         GHC.Cmm.DebugBlock         GHC.Cmm.Graph         GHC.Cmm.Info         GHC.Cmm.Info.Build+        GHC.Cmm.InitFini         GHC.Cmm.LRegSet         GHC.Cmm.LayoutStack         GHC.Cmm.Lexer@@ -477,6 +520,7 @@         GHC.CmmToAsm.CFG         GHC.CmmToAsm.CFG.Dominators         GHC.CmmToAsm.CPrim+        GHC.CmmToAsm.Config         GHC.CmmToAsm.Dwarf         GHC.CmmToAsm.Dwarf.Constants         GHC.CmmToAsm.Dwarf.Types@@ -493,18 +537,20 @@         GHC.CmmToAsm.PPC.Regs         GHC.CmmToAsm.Ppr         GHC.CmmToAsm.Reg.Graph+        GHC.CmmToAsm.Reg.Graph.Base+        GHC.CmmToAsm.Reg.Graph.Coalesce         GHC.CmmToAsm.Reg.Graph.Spill         GHC.CmmToAsm.Reg.Graph.SpillClean         GHC.CmmToAsm.Reg.Graph.SpillCost         GHC.CmmToAsm.Reg.Graph.Stats         GHC.CmmToAsm.Reg.Graph.TrivColorable+        GHC.CmmToAsm.Reg.Graph.X86         GHC.CmmToAsm.Reg.Linear         GHC.CmmToAsm.Reg.Linear.AArch64         GHC.CmmToAsm.Reg.Linear.Base         GHC.CmmToAsm.Reg.Linear.FreeRegs         GHC.CmmToAsm.Reg.Linear.JoinToTargets         GHC.CmmToAsm.Reg.Linear.PPC-        GHC.CmmToAsm.Reg.Linear.SPARC         GHC.CmmToAsm.Reg.Linear.StackMap         GHC.CmmToAsm.Reg.Linear.State         GHC.CmmToAsm.Reg.Linear.Stats@@ -513,24 +559,6 @@         GHC.CmmToAsm.Reg.Liveness         GHC.CmmToAsm.Reg.Target         GHC.CmmToAsm.Reg.Utils-        GHC.CmmToAsm.SPARC-        GHC.CmmToAsm.SPARC.AddrMode-        GHC.CmmToAsm.SPARC.Base-        GHC.CmmToAsm.SPARC.CodeGen-        GHC.CmmToAsm.SPARC.CodeGen.Amode-        GHC.CmmToAsm.SPARC.CodeGen.Base-        GHC.CmmToAsm.SPARC.CodeGen.CondCode-        GHC.CmmToAsm.SPARC.CodeGen.Expand-        GHC.CmmToAsm.SPARC.CodeGen.Gen32-        GHC.CmmToAsm.SPARC.CodeGen.Gen64-        GHC.CmmToAsm.SPARC.CodeGen.Sanity-        GHC.CmmToAsm.SPARC.Cond-        GHC.CmmToAsm.SPARC.Imm-        GHC.CmmToAsm.SPARC.Instr-        GHC.CmmToAsm.SPARC.Ppr-        GHC.CmmToAsm.SPARC.Regs-        GHC.CmmToAsm.SPARC.ShortcutJump-        GHC.CmmToAsm.SPARC.Stack         GHC.CmmToAsm.Types         GHC.CmmToAsm.Utils         GHC.CmmToAsm.X86@@ -544,11 +572,12 @@         GHC.CmmToLlvm         GHC.CmmToLlvm.Base         GHC.CmmToLlvm.CodeGen+        GHC.CmmToLlvm.Config         GHC.CmmToLlvm.Data         GHC.CmmToLlvm.Mangler         GHC.CmmToLlvm.Ppr         GHC.CmmToLlvm.Regs-        GHC.Core.Map.Expr+        GHC.Core.LateCC         GHC.Core.Opt.CSE         GHC.Core.Opt.CallArity         GHC.Core.Opt.CprAnal@@ -568,8 +597,6 @@         GHC.Core.Opt.StaticArgs         GHC.Core.Opt.WorkWrap         GHC.Core.Opt.WorkWrap.Utils-        GHC.Core.Rules-        GHC.Core.Tidy         GHC.Core.TyCon.Set         GHC.CoreToStg         GHC.CoreToStg.Prep@@ -580,11 +607,29 @@         GHC.Data.Graph.Ppr         GHC.Data.Graph.UnVar         GHC.Data.UnionFind+        GHC.Driver.Backpack         GHC.Driver.CodeOutput+        GHC.Driver.Config.Cmm+        GHC.Driver.Config.CmmToAsm+        GHC.Driver.Config.CmmToLlvm+        GHC.Driver.Config.Finder+        GHC.Driver.Config.HsToCore+        GHC.Driver.Config.Stg.Debug+        GHC.Driver.Config.Stg.Lift+        GHC.Driver.Config.Stg.Pipeline+        GHC.Driver.Config.Stg.Ppr+        GHC.Driver.Config.StgToCmm+        GHC.Driver.Config.Tidy+        GHC.Driver.GenerateCgIPEStub         GHC.Driver.Main         GHC.Driver.Make+        GHC.Driver.MakeFile         GHC.Driver.Pipeline+        GHC.Driver.Pipeline.Execute+        GHC.Driver.Pipeline.LogQueue+        GHC.HandleEncoding         GHC.Hs.Stats+        GHC.Hs.Syn.Type         GHC.HsToCore         GHC.HsToCore.Arrows         GHC.HsToCore.Binds@@ -602,10 +647,7 @@         GHC.HsToCore.Pmc         GHC.HsToCore.Pmc.Check         GHC.HsToCore.Pmc.Desugar-        GHC.HsToCore.Pmc.Ppr         GHC.HsToCore.Pmc.Solver-        GHC.HsToCore.Pmc.Solver.Types-        GHC.HsToCore.Pmc.Types         GHC.HsToCore.Pmc.Utils         GHC.HsToCore.Quote         GHC.HsToCore.Types@@ -613,6 +655,7 @@         GHC.HsToCore.Utils         GHC.Iface.Binary         GHC.Iface.Env+        GHC.Iface.Errors         GHC.Iface.Ext.Ast         GHC.Iface.Ext.Binary         GHC.Iface.Ext.Debug@@ -626,6 +669,7 @@         GHC.Iface.Tidy         GHC.Iface.Tidy.StaticPtrTable         GHC.IfaceToCore+        GHC.Linker         GHC.Linker.Dynamic         GHC.Linker.ExtraObj         GHC.Linker.Loader@@ -639,7 +683,10 @@         GHC.Llvm.Syntax         GHC.Llvm.Types         GHC.Parser.Utils+        GHC.Platform.Host+        GHC.Plugins         GHC.Rename.Bind+        GHC.Rename.Doc         GHC.Rename.Env         GHC.Rename.Expr         GHC.Rename.Fixity@@ -650,24 +697,29 @@         GHC.Rename.Splice         GHC.Rename.Unbound         GHC.Rename.Utils+        GHC.Runtime.Debugger         GHC.Runtime.Eval         GHC.Runtime.Heap.Inspect-        GHC.Runtime.Interpreter         GHC.Runtime.Loader         GHC.Settings.IO         GHC.Settings.Utils+        GHC.Stg.BcPrep         GHC.Stg.CSE         GHC.Stg.Debug-        GHC.Stg.DepAnal         GHC.Stg.FVs+        GHC.Stg.InferTags+        GHC.Stg.InferTags.Rewrite+        GHC.Stg.InferTags.Types         GHC.Stg.Lift         GHC.Stg.Lift.Analysis+        GHC.Stg.Lift.Config         GHC.Stg.Lift.Monad         GHC.Stg.Lint         GHC.Stg.Pipeline         GHC.Stg.Stats         GHC.Stg.Subst         GHC.Stg.Unarise+        GHC.Stg.Utils         GHC.StgToByteCode         GHC.StgToCmm         GHC.StgToCmm.ArgRep@@ -686,6 +738,8 @@         GHC.StgToCmm.Monad         GHC.StgToCmm.Prim         GHC.StgToCmm.Prof+        GHC.StgToCmm.Sequel+        GHC.StgToCmm.TagCheck         GHC.StgToCmm.Ticky         GHC.StgToCmm.Utils         GHC.SysTools@@ -722,6 +776,7 @@         GHC.Tc.Instance.FunDeps         GHC.Tc.Instance.Typeable         GHC.Tc.Module+        GHC.Tc.Plugin         GHC.Tc.Solver         GHC.Tc.Solver.Canonical         GHC.Tc.Solver.Interact@@ -735,6 +790,7 @@         GHC.Tc.TyCl.Utils         GHC.Tc.Types.EvTerm         GHC.Tc.Utils.Backpack+        GHC.Tc.Utils.Concrete         GHC.Tc.Utils.Env         GHC.Tc.Utils.Instantiate         GHC.Tc.Utils.Monad@@ -745,9 +801,16 @@         GHC.ThToHs         GHC.Types.Name.Shape         GHC.Types.TyThing.Ppr-        GHC.Types.Unique.SDFM+        GHC.Types.Unique.MemoFun         GHC.Unit.Finder         GHC.Utils.Asm-        GHC.Utils.Monad.State-        GHCi.BinaryArray-        GHCi.ResolvedBCO+        GHC.Utils.Monad.State.Lazy+        GHCi.CreateBCO+        GHCi.InfoTable+        GHCi.ObjLink+        GHCi.Run+        GHCi.Signals+        GHCi.StaticPtrTable+        GHCi.TH+        Language.Haskell.TH.CodeDo+        Language.Haskell.TH.Quote
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/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/Platform/Host.hs view
@@ -0,0 +1,12 @@+module GHC.Platform.Host where++import GHC.Platform.ArchOS++hostPlatformArch :: Arch+hostPlatformArch = ArchX86_64++hostPlatformOS   :: OS+hostPlatformOS   = OSDarwin++hostPlatformArchOS :: ArchOS+hostPlatformArchOS = ArchOS hostPlatformArch hostPlatformOS
+ 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/GHC/HandleEncoding.hs view
@@ -0,0 +1,32 @@+-- | See GHC #10762 and #15021.+module GHC.HandleEncoding (configureHandleEncoding) where++import Prelude -- See note [Why do we import Prelude here?]+import GHC.IO.Encoding (textEncodingName)+import System.Environment+import System.IO++-- | Handle GHC-specific character encoding flags, allowing us to control how+-- GHC produces output regardless of OS.+configureHandleEncoding :: IO ()+configureHandleEncoding = do+   mb_val <- lookupEnv "GHC_CHARENC"+   case mb_val of+    Just "UTF-8" -> do+     hSetEncoding stdout utf8+     hSetEncoding stderr utf8+    _ -> do+     -- Avoid GHC erroring out when trying to display unhandled characters+     hSetTranslit stdout+     hSetTranslit stderr++-- | Change the character encoding of the given Handle to transliterate+-- on unsupported characters instead of throwing an exception+hSetTranslit :: Handle -> IO ()+hSetTranslit h = do+    menc <- hGetEncoding h+    case fmap textEncodingName menc of+        Just name | '/' `notElem` name -> do+            enc' <- mkTextEncoding $ name ++ "//TRANSLIT"+            hSetEncoding h enc'+        _ -> return ()
− libraries/ghci/GHCi/BinaryArray.hs 
@@ -1,78 +0,0 @@-{-# 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/CreateBCO.hs view
@@ -0,0 +1,205 @@+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE CPP #-}++--+--  (c) The University of Glasgow 2002-2006+--++-- | Create real byte-code objects from 'ResolvedBCO's.+module GHCi.CreateBCO (createBCOs) where++import Prelude -- See note [Why do we import Prelude here?]+import GHCi.ResolvedBCO+import GHCi.RemoteTypes+import GHCi.BreakArray+import GHC.Data.SizedSeq++import System.IO (fixIO)+import Control.Monad+import Data.Array.Base+import Foreign hiding (newArray)+import Unsafe.Coerce (unsafeCoerce)+import GHC.Arr          ( Array(..) )+import GHC.Exts+import GHC.IO+import Control.Exception ( ErrorCall(..) )++createBCOs :: [ResolvedBCO] -> IO [HValueRef]+createBCOs bcos = do+  let n_bcos = length bcos+  hvals <- fixIO $ \hvs -> do+     let arr = listArray (0, n_bcos-1) hvs+     mapM (createBCO arr) bcos+  mapM mkRemoteRef hvals++createBCO :: Array Int HValue -> ResolvedBCO -> IO HValue+createBCO _   ResolvedBCO{..} | resolvedBCOIsLE /= isLittleEndian+  = throwIO (ErrorCall $+        unlines [ "The endianness of the ResolvedBCO does not match"+                , "the systems endianness. Using ghc and iserv in a"+                , "mixed endianness setup is not supported!"+                ])+createBCO arr bco+   = +#if MIN_VERSION_ghc_prim(0, 7, 0)+     do linked_bco <- linkBCO' arr bco+#else+     do BCO bco# <- linkBCO' arr bco+#endif++        -- Note [Updatable CAF BCOs]+        -- ~~~~~~~~~~~~~~~~~~~~~~~~~+        -- Why do we need mkApUpd0 here?  Otherwise top-level+        -- interpreted CAFs don't get updated after evaluation.  A+        -- top-level BCO will evaluate itself and return its value+        -- when entered, but it won't update itself.  Wrapping the BCO+        -- in an AP_UPD thunk will take care of the update for us.+        --+        -- Furthermore:+        --   (a) An AP thunk *must* point directly to a BCO+        --   (b) A zero-arity BCO *must* be wrapped in an AP thunk+        --   (c) An AP is always fully saturated, so we *can't* wrap+        --       non-zero arity BCOs in an AP thunk.+        --+        -- See #17424.+        if (resolvedBCOArity bco > 0)+           +#if MIN_VERSION_ghc_prim(0, 7, 0)+           then return (HValue (unsafeCoerce linked_bco))+           else case mkApUpd0# linked_bco of { (# final_bco #) ->+#else+           then return (HValue (unsafeCoerce# bco#))+           else case mkApUpd0# bco# of { (# final_bco #) ->+#endif++                  return (HValue final_bco) }+++toWordArray :: UArray Int Word64 -> UArray Int Word+toWordArray = amap fromIntegral++linkBCO' :: Array Int HValue -> ResolvedBCO -> IO BCO+linkBCO' arr ResolvedBCO{..} = do+  let+      ptrs   = ssElts resolvedBCOPtrs+      n_ptrs = sizeSS resolvedBCOPtrs++      !(I# arity#)  = resolvedBCOArity++      !(EmptyArr empty#) = emptyArr -- See Note [BCO empty array]++      barr a = case a of UArray _lo _hi n b -> if n == 0 then empty# else b+      insns_barr = barr resolvedBCOInstrs+      bitmap_barr = barr (toWordArray resolvedBCOBitmap)+      literals_barr = barr (toWordArray resolvedBCOLits)++  PtrsArr marr <- mkPtrsArray arr n_ptrs ptrs+  IO $ \s ->+    case unsafeFreezeArray# marr s of { (# s, arr #) ->+    case newBCO insns_barr literals_barr arr arity# bitmap_barr of { IO io ->+    io s+    }}+++-- we recursively link any sub-BCOs while making the ptrs array+mkPtrsArray :: Array Int HValue -> Word -> [ResolvedBCOPtr] -> IO PtrsArr+mkPtrsArray arr n_ptrs ptrs = do+  marr <- newPtrsArray (fromIntegral n_ptrs)+  let+    fill (ResolvedBCORef n) i =+      writePtrsArrayHValue i (arr ! n) marr  -- must be lazy!+    fill (ResolvedBCOPtr r) i = do+      hv <- localRef r+      writePtrsArrayHValue i hv marr+    fill (ResolvedBCOStaticPtr r) i = do+      writePtrsArrayPtr i (fromRemotePtr r)  marr+    fill (ResolvedBCOPtrBCO bco) i = do+      +#if MIN_VERSION_ghc_prim(0, 7, 0)+      bco <- linkBCO' arr bco+      writePtrsArrayBCO i bco marr+#else+      BCO bco# <- linkBCO' arr bco+      writePtrsArrayBCO i bco# marr+#endif++    fill (ResolvedBCOPtrBreakArray r) i = do+      BA mba <- localRef r+      writePtrsArrayMBA i mba marr+  zipWithM_ fill ptrs [0..]+  return marr++data PtrsArr = PtrsArr (MutableArray# RealWorld HValue)++newPtrsArray :: Int -> IO PtrsArr+newPtrsArray (I# i) = IO $ \s ->+  case newArray# i undefined s of (# s', arr #) -> (# s', PtrsArr arr #)++writePtrsArrayHValue :: Int -> HValue -> PtrsArr -> IO ()+writePtrsArrayHValue (I# i) hv (PtrsArr arr) = IO $ \s ->+  case writeArray# arr i hv s of s' -> (# s', () #)++writePtrsArrayPtr :: Int -> Ptr a -> PtrsArr -> IO ()+writePtrsArrayPtr (I# i) (Ptr a#) (PtrsArr arr) = IO $ \s ->+  case writeArrayAddr# arr i a# s of s' -> (# s', () #)++-- This is rather delicate: convincing GHC to pass an Addr# as an Any but+-- without making a thunk turns out to be surprisingly tricky.+{-# NOINLINE writeArrayAddr# #-}+writeArrayAddr# :: MutableArray# s a -> Int# -> Addr# -> State# s -> State# s+writeArrayAddr# marr i addr s = unsafeCoerce# writeArray# marr i addr s+++#if MIN_VERSION_ghc_prim(0, 7, 0)+writePtrsArrayBCO :: Int -> BCO -> PtrsArr -> IO ()+#else+writePtrsArrayBCO :: Int -> BCO# -> PtrsArr -> IO ()+#endif++writePtrsArrayBCO (I# i) bco (PtrsArr arr) = IO $ \s ->+  case (unsafeCoerce# writeArray#) arr i bco s of s' -> (# s', () #)+++#if MIN_VERSION_ghc_prim(0, 7, 0)+writePtrsArrayMBA :: Int -> MutableByteArray# s -> PtrsArr -> IO ()+#else+data BCO = BCO BCO#+writePtrsArrayMBA :: Int -> MutableByteArray# s -> PtrsArr -> IO ()+#endif++writePtrsArrayMBA (I# i) mba (PtrsArr arr) = IO $ \s ->+  case (unsafeCoerce# writeArray#) arr i mba s of s' -> (# s', () #)++newBCO :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> IO BCO+newBCO instrs lits ptrs arity bitmap = IO $ \s ->+  +#if MIN_VERSION_ghc_prim(0, 7, 0)+  newBCO# instrs lits ptrs arity bitmap s+#else+  case newBCO# instrs lits ptrs arity bitmap s of+    (# s1, bco #) -> (# s1, BCO bco #)+#endif+++{- Note [BCO empty array]+   ~~~~~~~~~~~~~~~~~~~~~~+Lots of BCOs have empty ptrs or nptrs, but empty arrays are not free:+they are 2-word heap objects.  So let's make a single empty array and+share it between all BCOs.+-}++data EmptyArr = EmptyArr ByteArray#++{-# NOINLINE emptyArr #-}+emptyArr :: EmptyArr+emptyArr = unsafeDupablePerformIO $ IO $ \s ->+  case newByteArray# 0# s of { (# s, arr #) ->+  case unsafeFreezeByteArray# arr s of { (# s, farr #) ->+  (# s, EmptyArr farr #)+  }}
+ libraries/ghci/GHCi/InfoTable.hsc view
@@ -0,0 +1,419 @@+{-# LANGUAGE CPP, MagicHash, ScopedTypeVariables #-}++-- Get definitions for the structs, constants & config etc.+#include "Rts.h"++-- |+-- Run-time info table support.  This module provides support for+-- creating and reading info tables /in the running program/.+-- We use the RTS data structures directly via hsc2hs.+--+module GHCi.InfoTable+  (+    mkConInfoTable+  ) where++import Prelude hiding (fail) -- See note [Why do we import Prelude here?]++import Foreign+import Foreign.C+import GHC.Ptr+import GHC.Exts+import GHC.Exts.Heap+import Data.ByteString (ByteString)+import Control.Monad.Fail+import qualified Data.ByteString as BS+import GHC.Platform.Host (hostPlatformArch)+import GHC.Platform.ArchOS++-- NOTE: Must return a pointer acceptable for use in the header of a closure.+-- If tables_next_to_code is enabled, then it must point the 'code' field.+-- Otherwise, it should point to the start of the StgInfoTable.+mkConInfoTable+   :: Bool    -- TABLES_NEXT_TO_CODE+   -> Int     -- ptr words+   -> Int     -- non-ptr words+   -> Int     -- constr tag+   -> Int     -- pointer tag+   -> ByteString  -- con desc+   -> IO (Ptr StgInfoTable)+      -- resulting info table is allocated with allocateExecPage(), and+      -- should be freed with freeExecPage().++mkConInfoTable tables_next_to_code ptr_words nonptr_words tag ptrtag con_desc = do+  let entry_addr = interpConstrEntry !! ptrtag+  code' <- if tables_next_to_code+    then Just <$> mkJumpToAddr entry_addr+    else pure Nothing+  let+     itbl  = StgInfoTable {+                 entry = if tables_next_to_code+                         then Nothing+                         else Just entry_addr,+                 ptrs  = fromIntegral ptr_words,+                 nptrs = fromIntegral nonptr_words,+                 tipe  = CONSTR,+                 srtlen = fromIntegral tag,+                 code  = code'+              }+  castFunPtrToPtr <$> newExecConItbl tables_next_to_code itbl con_desc+++-- -----------------------------------------------------------------------------+-- Building machine code fragments for a constructor's entry code++funPtrToInt :: FunPtr a -> Int+funPtrToInt (FunPtr a) = I## (addr2Int## a)++mkJumpToAddr :: MonadFail m => EntryFunPtr-> m ItblCodes+mkJumpToAddr a = case hostPlatformArch of+    ArchPPC -> pure $+        -- We'll use r12, for no particular reason.+        -- 0xDEADBEEF stands for the address:+        -- 3D80DEAD lis r12,0xDEAD+        -- 618CBEEF ori r12,r12,0xBEEF+        -- 7D8903A6 mtctr r12+        -- 4E800420 bctr++        let w32 = fromIntegral (funPtrToInt a)+            hi16 x = (x `shiftR` 16) .&. 0xFFFF+            lo16 x = x .&. 0xFFFF+        in Right [ 0x3D800000 .|. hi16 w32,+                   0x618C0000 .|. lo16 w32,+                   0x7D8903A6, 0x4E800420 ]++    ArchX86 -> pure $+        -- Let the address to jump to be 0xWWXXYYZZ.+        -- Generate   movl $0xWWXXYYZZ,%eax  ;  jmp *%eax+        -- which is+        -- B8 ZZ YY XX WW FF E0++        let w32 = fromIntegral (funPtrToInt a) :: Word32+            insnBytes :: [Word8]+            insnBytes+               = [0xB8, byte0 w32, byte1 w32,+                        byte2 w32, byte3 w32,+                  0xFF, 0xE0]+        in+            Left insnBytes++    ArchX86_64 -> pure $+        -- Generates:+        --      jmpq *.L1(%rip)+        --      .align 8+        -- .L1:+        --      .quad <addr>+        --+        -- which looks like:+        --     8:   ff 25 02 00 00 00     jmpq   *0x2(%rip)      # 10 <f+0x10>+        -- with addr at 10.+        --+        -- We need a full 64-bit pointer (we can't assume the info table is+        -- allocated in low memory).  Assuming the info pointer is aligned to+        -- an 8-byte boundary, the addr will also be aligned.++        let w64 = fromIntegral (funPtrToInt a) :: Word64+            insnBytes :: [Word8]+            insnBytes+               = [0xff, 0x25, 0x02, 0x00, 0x00, 0x00, 0x00, 0x00,+                  byte0 w64, byte1 w64, byte2 w64, byte3 w64,+                  byte4 w64, byte5 w64, byte6 w64, byte7 w64]+        in+            Left insnBytes++    ArchAlpha -> pure $+        let w64 = fromIntegral (funPtrToInt a) :: Word64+        in Right [ 0xc3800000      -- br   at, .+4+                 , 0xa79c000c      -- ldq  at, 12(at)+                 , 0x6bfc0000      -- jmp  (at)    # with zero hint -- oh well+                 , 0x47ff041f      -- nop+                 , fromIntegral (w64 .&. 0x0000FFFF)+                 , fromIntegral ((w64 `shiftR` 32) .&. 0x0000FFFF) ]++    ArchARM {} -> pure $+        -- Generates Arm sequence,+        --      ldr r1, [pc, #0]+        --      bx r1+        --+        -- which looks like:+        --     00000000 <.addr-0x8>:+        --     0:       00109fe5    ldr    r1, [pc]      ; 8 <.addr>+        --     4:       11ff2fe1    bx     r1+        let w32 = fromIntegral (funPtrToInt a) :: Word32+        in Left [ 0x00, 0x10, 0x9f, 0xe5+                , 0x11, 0xff, 0x2f, 0xe1+                , byte0 w32, byte1 w32, byte2 w32, byte3 w32]++    ArchAArch64 {} -> pure $+        -- Generates:+        --+        --      ldr     x1, label+        --      br      x1+        -- label:+        --      .quad <addr>+        --+        -- which looks like:+        --     0:       58000041        ldr     x1, <label>+        --     4:       d61f0020        br      x1+       let w64 = fromIntegral (funPtrToInt a) :: Word64+       in Right [ 0x58000041+                , 0xd61f0020+                , fromIntegral w64+                , fromIntegral (w64 `shiftR` 32) ]++    ArchPPC_64 ELF_V1 -> pure $+        -- We use the compiler's register r12 to read the function+        -- descriptor and the linker's register r11 as a temporary+        -- register to hold the function entry point.+        -- In the medium code model the function descriptor+        -- is located in the first two gigabytes, i.e. the address+        -- of the function pointer is a non-negative 32 bit number.+        -- 0x0EADBEEF stands for the address of the function pointer:+        --    0:   3d 80 0e ad     lis     r12,0x0EAD+        --    4:   61 8c be ef     ori     r12,r12,0xBEEF+        --    8:   e9 6c 00 00     ld      r11,0(r12)+        --    c:   e8 4c 00 08     ld      r2,8(r12)+        --   10:   7d 69 03 a6     mtctr   r11+        --   14:   e9 6c 00 10     ld      r11,16(r12)+        --   18:   4e 80 04 20     bctr+       let  w32 = fromIntegral (funPtrToInt a)+            hi16 x = (x `shiftR` 16) .&. 0xFFFF+            lo16 x = x .&. 0xFFFF+       in Right [ 0x3D800000 .|. hi16 w32,+                  0x618C0000 .|. lo16 w32,+                  0xE96C0000,+                  0xE84C0008,+                  0x7D6903A6,+                  0xE96C0010,+                  0x4E800420]++    ArchPPC_64 ELF_V2 -> pure $+        -- The ABI requires r12 to point to the function's entry point.+        -- We use the medium code model where code resides in the first+        -- two gigabytes, so loading a non-negative32 bit address+        -- with lis followed by ori is fine.+        -- 0x0EADBEEF stands for the address:+        -- 3D800EAD lis r12,0x0EAD+        -- 618CBEEF ori r12,r12,0xBEEF+        -- 7D8903A6 mtctr r12+        -- 4E800420 bctr++        let w32 = fromIntegral (funPtrToInt a)+            hi16 x = (x `shiftR` 16) .&. 0xFFFF+            lo16 x = x .&. 0xFFFF+        in Right [ 0x3D800000 .|. hi16 w32,+                   0x618C0000 .|. lo16 w32,+                   0x7D8903A6, 0x4E800420 ]++    ArchS390X -> pure $+        -- Let 0xAABBCCDDEEFFGGHH be the address to jump to.+        -- The following code loads the address into scratch+        -- register r1 and jumps to it.+        --+        --    0:   C0 1E AA BB CC DD       llihf   %r1,0xAABBCCDD+        --    6:   C0 19 EE FF GG HH       iilf    %r1,0xEEFFGGHH+        --   12:   07 F1                   br      %r1++        let w64 = fromIntegral (funPtrToInt a) :: Word64+        in Left [ 0xC0, 0x1E, byte7 w64, byte6 w64, byte5 w64, byte4 w64,+                  0xC0, 0x19, byte3 w64, byte2 w64, byte1 w64, byte0 w64,+                  0x07, 0xF1 ]++    ArchRISCV64 -> pure $+        let w64 = fromIntegral (funPtrToInt a) :: Word64+        in Right [ 0x00000297          -- auipc t0,0+                 , 0x01053283          -- ld    t0,16(t0)+                 , 0x00028067          -- jr    t0+                 , 0x00000013          -- nop+                 , fromIntegral w64+                 , fromIntegral (w64 `shiftR` 32) ]++    arch ->+      -- The arch isn't supported. You either need to add your architecture as a+      -- distinct case, or use non-TABLES_NEXT_TO_CODE mode.+      fail $ "mkJumpToAddr: arch is not supported with TABLES_NEXT_TO_CODE ("+             ++ show arch ++ ")"++byte0 :: (Integral w) => w -> Word8+byte0 w = fromIntegral w++byte1, byte2, byte3, byte4, byte5, byte6, byte7+       :: (Integral w, Bits w) => w -> Word8+byte1 w = fromIntegral (w `shiftR` 8)+byte2 w = fromIntegral (w `shiftR` 16)+byte3 w = fromIntegral (w `shiftR` 24)+byte4 w = fromIntegral (w `shiftR` 32)+byte5 w = fromIntegral (w `shiftR` 40)+byte6 w = fromIntegral (w `shiftR` 48)+byte7 w = fromIntegral (w `shiftR` 56)+++-- -----------------------------------------------------------------------------+-- read & write intfo tables++-- entry point for direct returns for created constr itbls+foreign import ccall "&stg_interp_constr1_entry" stg_interp_constr1_entry :: EntryFunPtr+foreign import ccall "&stg_interp_constr2_entry" stg_interp_constr2_entry :: EntryFunPtr+foreign import ccall "&stg_interp_constr3_entry" stg_interp_constr3_entry :: EntryFunPtr+foreign import ccall "&stg_interp_constr4_entry" stg_interp_constr4_entry :: EntryFunPtr+foreign import ccall "&stg_interp_constr5_entry" stg_interp_constr5_entry :: EntryFunPtr+foreign import ccall "&stg_interp_constr6_entry" stg_interp_constr6_entry :: EntryFunPtr+foreign import ccall "&stg_interp_constr7_entry" stg_interp_constr7_entry :: EntryFunPtr++interpConstrEntry :: [EntryFunPtr]+interpConstrEntry = [ error "pointer tag 0"+                    , stg_interp_constr1_entry+                    , stg_interp_constr2_entry+                    , stg_interp_constr3_entry+                    , stg_interp_constr4_entry+                    , stg_interp_constr5_entry+                    , stg_interp_constr6_entry+                    , stg_interp_constr7_entry ]++data StgConInfoTable = StgConInfoTable {+   conDesc   :: Ptr Word8,+   infoTable :: StgInfoTable+}+++pokeConItbl+  :: Bool -> Ptr StgConInfoTable -> Ptr StgConInfoTable -> StgConInfoTable+  -> IO ()+pokeConItbl tables_next_to_code wr_ptr _ex_ptr itbl = do+  if tables_next_to_code+    then do+      -- Write the offset to the con_desc from the end of the standard InfoTable+      -- at the first byte.+      let con_desc_offset = conDesc itbl `minusPtr` (_ex_ptr `plusPtr` conInfoTableSizeB)+      (#poke StgConInfoTable, con_desc) wr_ptr con_desc_offset+    else do+      -- Write the con_desc address after the end of the info table.+      -- Use itblSize because CPP will not pick up PROFILING when calculating+      -- the offset.+      pokeByteOff wr_ptr itblSize (conDesc itbl)+  pokeItbl (wr_ptr `plusPtr` (#offset StgConInfoTable, i)) (infoTable itbl)++sizeOfEntryCode :: MonadFail m => Bool -> m Int+sizeOfEntryCode tables_next_to_code+  | not tables_next_to_code = pure 0+  | otherwise = do+     code' <- mkJumpToAddr undefined+     pure $ case code' of+       Left  xs -> sizeOf (head xs) * length xs+       Right xs -> sizeOf (head xs) * length xs++-- Note: Must return proper pointer for use in a closure+#if MIN_VERSION_rts(1,0,1)+newExecConItbl :: Bool -> StgInfoTable -> ByteString -> IO (FunPtr ())+newExecConItbl tables_next_to_code obj con_desc = do+    sz0 <- sizeOfEntryCode tables_next_to_code+    let lcon_desc = BS.length con_desc + 1{- null terminator -}+        -- SCARY+        -- This size represents the number of bytes in an StgConInfoTable.+        sz = fromIntegral $ conInfoTableSizeB + sz0+            -- Note: we need to allocate the conDesc string next to the info+            -- table, because on a 64-bit platform we reference this string+            -- with a 32-bit offset relative to the info table, so if we+            -- allocated the string separately it might be out of range.++    ex_ptr <- fillExecBuffer (sz + fromIntegral lcon_desc) $ \wr_ptr ex_ptr -> do+        let cinfo = StgConInfoTable { conDesc = ex_ptr `plusPtr` fromIntegral sz+                                    , infoTable = obj }+        pokeConItbl tables_next_to_code wr_ptr ex_ptr cinfo+        BS.useAsCStringLen con_desc $ \(src, len) ->+            copyBytes (castPtr wr_ptr `plusPtr` fromIntegral sz) src len+        let null_off = fromIntegral sz + fromIntegral (BS.length con_desc)+        poke (castPtr wr_ptr `plusPtr` null_off) (0 :: Word8)++    pure $ if tables_next_to_code+      then castPtrToFunPtr $ ex_ptr `plusPtr` conInfoTableSizeB+      else castPtrToFunPtr ex_ptr+#else+newExecConItbl :: Bool -> StgInfoTable -> ByteString -> IO (FunPtr ())+newExecConItbl tables_next_to_code obj con_desc+   = alloca $ \pcode -> do+        sz0 <- sizeOfEntryCode tables_next_to_code+        let lcon_desc = BS.length con_desc + 1{- null terminator -}+            -- SCARY+            -- This size represents the number of bytes in an StgConInfoTable.+            sz = fromIntegral $ conInfoTableSizeB + sz0+               -- Note: we need to allocate the conDesc string next to the info+               -- table, because on a 64-bit platform we reference this string+               -- with a 32-bit offset relative to the info table, so if we+               -- allocated the string separately it might be out of range.+        wr_ptr <- _allocateExec (sz + fromIntegral lcon_desc) pcode+        ex_ptr <- peek pcode+        let cinfo = StgConInfoTable { conDesc = ex_ptr `plusPtr` fromIntegral sz+                                    , infoTable = obj }+        pokeConItbl tables_next_to_code wr_ptr ex_ptr cinfo+        BS.useAsCStringLen con_desc $ \(src, len) ->+            copyBytes (castPtr wr_ptr `plusPtr` fromIntegral sz) src len+        let null_off = fromIntegral sz + fromIntegral (BS.length con_desc)+        poke (castPtr wr_ptr `plusPtr` null_off) (0 :: Word8)+        _flushExec sz ex_ptr -- Cache flush (if needed)+        pure $ if tables_next_to_code+          then castPtrToFunPtr $ ex_ptr `plusPtr` conInfoTableSizeB+          else castPtrToFunPtr ex_ptr+#endif++-- | Allocate a buffer of a given size, use the given action to fill it with+-- data, and mark it as executable. The action is given a writable pointer and+-- the executable pointer. Returns a pointer to the executable code.+#if MIN_VERSION_rts(1,0,1)+fillExecBuffer :: CSize -> (Ptr a -> Ptr a -> IO ()) -> IO (Ptr a)+#endif++#if MIN_VERSION_rts(1,0,2)++data ExecPage++foreign import ccall unsafe "allocateExecPage"+  _allocateExecPage :: IO (Ptr ExecPage)++foreign import ccall unsafe "freezeExecPage"+  _freezeExecPage :: Ptr ExecPage -> IO ()++fillExecBuffer sz cont+    -- we can only allocate single pages. This assumes a 4k page size which+    -- isn't strictly correct but is a reasonable conservative lower bound.+  | sz > 4096 = fail "withExecBuffer: Too large"+  | otherwise = do+        pg <- _allocateExecPage+        cont (castPtr pg) (castPtr pg)+        _freezeExecPage pg+        return (castPtr pg)++#elif MIN_VERSION_rts(1,0,1)++foreign import ccall unsafe "allocateExec"+  _allocateExec :: CUInt -> Ptr (Ptr a) -> IO (Ptr a)++foreign import ccall unsafe "flushExec"+  _flushExec :: CUInt -> Ptr a -> IO ()++fillExecBuffer sz cont = alloca $ \pcode -> do+    wr_ptr <- _allocateExec (fromIntegral sz) pcode+    ex_ptr <- peek pcode+    cont wr_ptr ex_ptr+    _flushExec (fromIntegral sz) ex_ptr -- Cache flush (if needed)+    return (ex_ptr)++#else++foreign import ccall unsafe "allocateExec"+  _allocateExec :: CUInt -> Ptr (Ptr a) -> IO (Ptr a)++foreign import ccall unsafe "flushExec"+  _flushExec :: CUInt -> Ptr a -> IO ()+++#endif++-- -----------------------------------------------------------------------------+-- Constants and config++wORD_SIZE :: Int+wORD_SIZE = (#const SIZEOF_HSINT)++conInfoTableSizeB :: Int+conInfoTableSizeB = wORD_SIZE + itblSize
+ libraries/ghci/GHCi/ObjLink.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE CPP, UnboxedTuples, MagicHash #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+--+--  (c) The University of Glasgow 2002-2006+--++-- ---------------------------------------------------------------------------+--      The dynamic linker for object code (.o .so .dll files)+-- ---------------------------------------------------------------------------++-- | Primarily, this module consists of an interface to the C-land+-- dynamic linker.+module GHCi.ObjLink+  ( initObjLinker, ShouldRetainCAFs(..)+  , loadDLL+  , loadArchive+  , loadObj+  , unloadObj+  , purgeObj+  , lookupSymbol+  , lookupClosure+  , resolveObjs+  , addLibrarySearchPath+  , removeLibrarySearchPath+  , findSystemLibrary+  )  where++import Prelude -- See note [Why do we import Prelude here?]+import GHCi.RemoteTypes+import Control.Exception (throwIO, ErrorCall(..))+import Control.Monad    ( when )+import Foreign.C+import Foreign.Marshal.Alloc ( free )+import Foreign          ( nullPtr )+import GHC.Exts+import System.Posix.Internals ( CFilePath, withFilePath, peekFilePath )+import System.FilePath  ( dropExtension, normalise )+++++-- ---------------------------------------------------------------------------+-- RTS Linker Interface+-- ---------------------------------------------------------------------------++data ShouldRetainCAFs+  = RetainCAFs+    -- ^ Retain CAFs unconditionally in linked Haskell code.+    -- Note that this prevents any code from being unloaded.+    -- It should not be necessary unless you are GHCi or+    -- hs-plugins, which needs to be able call any function+    -- in the compiled code.+  | DontRetainCAFs+    -- ^ Do not retain CAFs.  Everything reachable from foreign+    -- exports will be retained, due to the StablePtrs+    -- created by the module initialisation code.  unloadObj+    -- frees these StablePtrs, which will allow the CAFs to+    -- be GC'd and the code to be removed.++initObjLinker :: ShouldRetainCAFs -> IO ()+initObjLinker RetainCAFs = c_initLinker_ 1+initObjLinker _ = c_initLinker_ 0++lookupSymbol :: String -> IO (Maybe (Ptr a))+lookupSymbol str_in = do+   let str = prefixUnderscore str_in+   withCAString str $ \c_str -> do+     addr <- c_lookupSymbol c_str+     if addr == nullPtr+        then return Nothing+        else return (Just addr)++lookupClosure :: String -> IO (Maybe HValueRef)+lookupClosure str = do+  m <- lookupSymbol str+  case m of+    Nothing -> return Nothing+    Just (Ptr addr) -> case addrToAny# addr of+      (# a #) -> Just <$> mkRemoteRef (HValue a)++prefixUnderscore :: String -> String+prefixUnderscore+ | cLeadingUnderscore = ('_':)+ | otherwise          = id++-- | 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.+--+loadDLL :: String -> IO (Maybe String)+-- Nothing      => success+-- Just err_msg => failure+loadDLL str0 = do+  let+     -- On Windows, addDLL takes a filename without an extension, because+     -- it tries adding both .dll and .drv.  To keep things uniform in the+     -- layers above, loadDLL always takes a filename with an extension, and+     -- we drop it here on Windows only.+     str | isWindowsHost = dropExtension str0+         | otherwise     = str0+  --+  maybe_errmsg <- withFilePath (normalise str) $ \dll -> c_addDLL dll+  if maybe_errmsg == nullPtr+        then return Nothing+        else do str <- peekCString maybe_errmsg+                free maybe_errmsg+                return (Just str)++loadArchive :: String -> IO ()+loadArchive str = do+   withFilePath str $ \c_str -> do+     r <- c_loadArchive c_str+     when (r == 0) (throwIO (ErrorCall ("loadArchive " ++ show str ++ ": failed")))++loadObj :: String -> IO ()+loadObj str = do+   withFilePath str $ \c_str -> do+     r <- c_loadObj c_str+     when (r == 0) (throwIO (ErrorCall ("loadObj " ++ show str ++ ": failed")))++-- | @unloadObj@ drops the given dynamic library from the symbol table+-- as well as enables the library to be removed from memory during+-- a future major GC.+unloadObj :: String -> IO ()+unloadObj str =+   withFilePath str $ \c_str -> do+     r <- c_unloadObj c_str+     when (r == 0) (throwIO (ErrorCall ("unloadObj " ++ show str ++ ": failed")))++-- | @purgeObj@ drops the symbols for the dynamic library from the symbol+-- table. Unlike 'unloadObj', the library will not be dropped memory during+-- a future major GC.+purgeObj :: String -> IO ()+purgeObj str =+   withFilePath str $ \c_str -> do+     r <- c_purgeObj c_str+     when (r == 0) (throwIO (ErrorCall ("purgeObj " ++ show str ++ ": failed")))++addLibrarySearchPath :: String -> IO (Ptr ())+addLibrarySearchPath str =+   withFilePath str c_addLibrarySearchPath++removeLibrarySearchPath :: Ptr () -> IO Bool+removeLibrarySearchPath = c_removeLibrarySearchPath++findSystemLibrary :: String -> IO (Maybe String)+findSystemLibrary str = do+    result <- withFilePath str c_findSystemLibrary+    case result == nullPtr of+        True  -> return Nothing+        False -> do path <- peekFilePath result+                    free result+                    return $ Just path++resolveObjs :: IO Bool+resolveObjs = do+   r <- c_resolveObjs+   return (r /= 0)++-- ---------------------------------------------------------------------------+-- Foreign declarations to RTS entry points which does the real work;+-- ---------------------------------------------------------------------------++foreign import ccall unsafe "addDLL"                  c_addDLL                  :: CFilePath -> IO CString+foreign import ccall unsafe "initLinker_"             c_initLinker_             :: CInt -> IO ()+foreign import ccall unsafe "lookupSymbol"            c_lookupSymbol            :: CString -> IO (Ptr a)+foreign import ccall unsafe "loadArchive"             c_loadArchive             :: CFilePath -> IO Int+foreign import ccall unsafe "loadObj"                 c_loadObj                 :: CFilePath -> IO Int+foreign import ccall unsafe "purgeObj"                c_purgeObj                :: CFilePath -> IO Int+foreign import ccall unsafe "unloadObj"               c_unloadObj               :: CFilePath -> IO Int+foreign import ccall unsafe "resolveObjs"             c_resolveObjs             :: IO Int+foreign import ccall unsafe "addLibrarySearchPath"    c_addLibrarySearchPath    :: CFilePath -> IO (Ptr ())+foreign import ccall unsafe "findSystemLibrary"       c_findSystemLibrary       :: CFilePath -> IO CFilePath+foreign import ccall unsafe "removeLibrarySearchPath" c_removeLibrarySearchPath :: Ptr() -> IO Bool++-- -----------------------------------------------------------------------------+-- Configuration++#include "ghcautoconf.h"++cLeadingUnderscore :: Bool+#if defined(LEADING_UNDERSCORE)+cLeadingUnderscore = True+#else+cLeadingUnderscore = False+#endif++isWindowsHost :: Bool+#if defined(mingw32_HOST_OS)+isWindowsHost = True+#else+isWindowsHost = False+#endif
− libraries/ghci/GHCi/ResolvedBCO.hs 
@@ -1,77 +0,0 @@-{-# 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/ghci/GHCi/Run.hs view
@@ -0,0 +1,398 @@+{-# LANGUAGE GADTs, RecordWildCards, MagicHash, ScopedTypeVariables, CPP,+    UnboxedTuples #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++-- |+-- Execute GHCi messages.+--+-- For details on Remote GHCi, see Note [Remote GHCi] in+-- compiler/GHC/Runtime/Interpreter.hs.+--+module GHCi.Run+  ( run, redirectInterrupts+  ) where++import Prelude -- See note [Why do we import Prelude here?]+import GHCi.CreateBCO+import GHCi.InfoTable+import GHCi.FFI+import GHCi.Message+import GHCi.ObjLink+import GHCi.RemoteTypes+import GHCi.TH+import GHCi.BreakArray+import GHCi.StaticPtrTable++import Control.Concurrent+import Control.DeepSeq+import Control.Exception+import Control.Monad+import Data.Binary+import Data.Binary.Get+import Data.ByteString (ByteString)+import qualified Data.ByteString.Unsafe as B+import GHC.Exts+import qualified GHC.Exts.Heap as Heap+import GHC.Stack+import Foreign hiding (void)+import Foreign.C+import GHC.Conc.Sync+import GHC.IO hiding ( bracket )+import System.Mem.Weak  ( deRefWeak )+import Unsafe.Coerce++-- -----------------------------------------------------------------------------+-- Implement messages++foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()+        -- Make it "safe", just in case++run :: Message a -> IO a+run m = case m of+  InitLinker -> initObjLinker RetainCAFs+  RtsRevertCAFs -> rts_revertCAFs+  LookupSymbol str -> fmap toRemotePtr <$> lookupSymbol str+  LookupClosure str -> lookupClosure str+  LoadDLL str -> loadDLL str+  LoadArchive str -> loadArchive str+  LoadObj str -> loadObj str+  UnloadObj str -> unloadObj str+  AddLibrarySearchPath str -> toRemotePtr <$> addLibrarySearchPath str+  RemoveLibrarySearchPath ptr -> removeLibrarySearchPath (fromRemotePtr ptr)+  ResolveObjs -> resolveObjs+  FindSystemLibrary str -> findSystemLibrary str+  CreateBCOs bcos -> createBCOs (concatMap (runGet get) bcos)+  FreeHValueRefs rs -> mapM_ freeRemoteRef rs+  AddSptEntry fpr r -> localRef r >>= sptAddEntry fpr+  EvalStmt opts r -> evalStmt opts r+  ResumeStmt opts r -> resumeStmt opts r+  AbandonStmt r -> abandonStmt r+  EvalString r -> evalString r+  EvalStringToString r s -> evalStringToString r s+  EvalIO r -> evalIO r+  MkCostCentres mod ccs -> mkCostCentres mod ccs+  CostCentreStackInfo ptr -> ccsToStrings (fromRemotePtr ptr)+  NewBreakArray sz -> mkRemoteRef =<< newBreakArray sz+  SetupBreakpoint ref ix cnt -> do+    arr <- localRef ref;+    _ <- setupBreakpoint arr ix cnt+    return ()+  BreakpointStatus ref ix -> do+    arr <- localRef ref; r <- getBreak arr ix+    case r of+      Nothing -> return False+      Just w -> return (w == 0)+  GetBreakpointVar ref ix -> do+    aps <- localRef ref+    mapM mkRemoteRef =<< getIdValFromApStack aps ix+  MallocData bs -> mkString bs+  MallocStrings bss -> mapM mkString0 bss+  PrepFFI conv args res -> toRemotePtr <$> prepForeignCall conv args res+  FreeFFI p -> freeForeignCallInfo (fromRemotePtr p)+  MkConInfoTable tc ptrs nptrs tag ptrtag desc ->+    toRemotePtr <$> mkConInfoTable tc ptrs nptrs tag ptrtag desc+  StartTH -> startTH+  GetClosure ref -> do+    clos <- Heap.getClosureData =<< localRef ref+    mapM (\(Heap.Box x) -> mkRemoteRef (HValue x)) clos+  Seq ref -> doSeq ref+  ResumeSeq ref -> resumeSeq ref+  _other -> error "GHCi.Run.run"++evalStmt :: EvalOpts -> EvalExpr HValueRef -> IO (EvalStatus [HValueRef])+evalStmt opts expr = do+  io <- mkIO expr+  sandboxIO opts $ do+    rs <- unsafeCoerce io :: IO [HValue]+    mapM mkRemoteRef rs+ where+  mkIO (EvalThis href) = localRef href+  mkIO (EvalApp l r) = do+    l' <- mkIO l+    r' <- mkIO r+    return ((unsafeCoerce l' :: HValue -> HValue) r')++evalIO :: HValueRef -> IO (EvalResult ())+evalIO r = do+  io <- localRef r+  tryEval (unsafeCoerce io :: IO ())++evalString :: HValueRef -> IO (EvalResult String)+evalString r = do+  io <- localRef r+  tryEval $ do+    r <- unsafeCoerce io :: IO String+    evaluate (force r)++evalStringToString :: HValueRef -> String -> IO (EvalResult String)+evalStringToString r str = do+  io <- localRef r+  tryEval $ do+    r <- (unsafeCoerce io :: String -> IO String) str+    evaluate (force r)++-- | Process the Seq message to force a value.                       #2950+-- If during this processing a breakpoint is hit, return+-- an EvalBreak value in the EvalStatus to the UI process,+-- otherwise return an EvalComplete.+-- The UI process has more and therefore also can show more+-- information about the breakpoint than the current iserv+-- process.+doSeq :: RemoteRef a -> IO (EvalStatus ())+doSeq ref = do+    sandboxIO evalOptsSeq $ do+      _ <- (void $ evaluate =<< localRef ref)+      return ()++-- | Process a ResumeSeq message. Continue the :force processing     #2950+-- after a breakpoint.+resumeSeq :: RemoteRef (ResumeContext ()) -> IO (EvalStatus ())+resumeSeq hvref = do+    ResumeContext{..} <- localRef hvref+    withBreakAction evalOptsSeq resumeBreakMVar resumeStatusMVar $+      mask_ $ do+        putMVar resumeBreakMVar () -- this awakens the stopped thread...+        redirectInterrupts resumeThreadId $ takeMVar resumeStatusMVar++evalOptsSeq :: EvalOpts+evalOptsSeq = EvalOpts+              { useSandboxThread = True+              , singleStep = False+              , breakOnException = False+              , breakOnError = False+              }++-- When running a computation, we redirect ^C exceptions to the running+-- thread.  ToDo: we might want a way to continue even if the target+-- thread doesn't die when it receives the exception... "this thread+-- is not responding".+--+-- Careful here: there may be ^C exceptions flying around, so we start the new+-- thread blocked (forkIO inherits mask from the parent, #1048), and unblock+-- only while we execute the user's code.  We can't afford to lose the final+-- putMVar, otherwise deadlock ensues. (#1583, #1922, #1946)++sandboxIO :: EvalOpts -> IO a -> IO (EvalStatus a)+sandboxIO opts io = do+  -- We are running in uninterruptibleMask+  breakMVar <- newEmptyMVar+  statusMVar <- newEmptyMVar+  withBreakAction opts breakMVar statusMVar $ do+    let runIt = measureAlloc $ tryEval $ rethrow opts $ clearCCS io+    if useSandboxThread opts+       then do+         tid <- forkIO $ do unsafeUnmask runIt >>= putMVar statusMVar+                                -- empty: can't block+         redirectInterrupts tid $ unsafeUnmask $ takeMVar statusMVar+       else+          -- GLUT on OS X needs to run on the main thread. If you+          -- try to use it from another thread then you just get a+          -- white rectangle rendered. For this, or anything else+          -- with such restrictions, you can turn the GHCi sandbox off+          -- and things will be run in the main thread.+          --+          -- BUT, note that the debugging features (breakpoints,+          -- tracing, etc.) need the expression to be running in a+          -- separate thread, so debugging is only enabled when+          -- using the sandbox.+         runIt++-- We want to turn ^C into a break when -fbreak-on-exception is on,+-- but it's an async exception and we only break for sync exceptions.+-- Idea: if we catch and re-throw it, then the re-throw will trigger+-- a break.  Great - but we don't want to re-throw all exceptions, because+-- then we'll get a double break for ordinary sync exceptions (you'd have+-- to :continue twice, which looks strange).  So if the exception is+-- not "Interrupted", we unset the exception flag before throwing.+--+rethrow :: EvalOpts -> IO a -> IO a+rethrow EvalOpts{..} io =+  catch io $ \se -> do+    -- If -fbreak-on-error, we break unconditionally,+    --  but with care of not breaking twice+    if breakOnError && not breakOnException+       then poke exceptionFlag 1+       else case fromException se of+               -- If it is a "UserInterrupt" exception, we allow+               --  a possible break by way of -fbreak-on-exception+               Just UserInterrupt -> return ()+               -- In any other case, we don't want to break+               _ -> poke exceptionFlag 0+    throwIO se++--+-- While we're waiting for the sandbox thread to return a result, if+-- the current thread receives an asynchronous exception we re-throw+-- it at the sandbox thread and continue to wait.+--+-- This is for two reasons:+--+--  * So that ^C interrupts runStmt (e.g. in GHCi), allowing the+--    computation to run its exception handlers before returning the+--    exception result to the caller of runStmt.+--+--  * clients of the GHC API can terminate a runStmt in progress+--    without knowing the ThreadId of the sandbox thread (#1381)+--+-- NB. use a weak pointer to the thread, so that the thread can still+-- be considered deadlocked by the RTS and sent a BlockedIndefinitely+-- exception.  A symptom of getting this wrong is that conc033(ghci)+-- will hang.+--+redirectInterrupts :: ThreadId -> IO a -> IO a+redirectInterrupts target wait = do+  wtid <- mkWeakThreadId target+  wait `catch` \e -> do+     m <- deRefWeak wtid+     case m of+       Nothing -> wait+       Just target -> do throwTo target (e :: SomeException); wait++measureAlloc :: IO (EvalResult a) -> IO (EvalStatus a)+measureAlloc io = do+  setAllocationCounter 0                                 -- #16012+  a <- io+  ctr <- getAllocationCounter+  let allocs = negate $ fromIntegral ctr+  return (EvalComplete allocs a)++-- Exceptions can't be marshaled because they're dynamically typed, so+-- everything becomes a String.+tryEval :: IO a -> IO (EvalResult a)+tryEval io = do+  e <- try io+  case e of+    Left ex -> return (EvalException (toSerializableException ex))+    Right a -> return (EvalSuccess a)++-- This function sets up the interpreter for catching breakpoints, and+-- resets everything when the computation has stopped running.  This+-- is a not-very-good way to ensure that only the interactive+-- evaluation should generate breakpoints.+withBreakAction :: EvalOpts -> MVar () -> MVar (EvalStatus b) -> IO a -> IO a+withBreakAction opts breakMVar statusMVar act+ = bracket setBreakAction resetBreakAction (\_ -> act)+ where+   setBreakAction = do+     stablePtr <- newStablePtr onBreak+     poke breakPointIOAction stablePtr+     when (breakOnException opts) $ poke exceptionFlag 1+     when (singleStep opts) $ setStepFlag+     return stablePtr+        -- Breaking on exceptions is not enabled by default, since it+        -- might be a bit surprising.  The exception flag is turned off+        -- as soon as it is hit, or in resetBreakAction below.++   onBreak :: BreakpointCallback+   onBreak ix# uniq# is_exception apStack = do+     tid <- myThreadId+     let resume = ResumeContext+           { resumeBreakMVar = breakMVar+           , resumeStatusMVar = statusMVar+           , resumeThreadId = tid }+     resume_r <- mkRemoteRef resume+     apStack_r <- mkRemoteRef apStack+     ccs <- toRemotePtr <$> getCCSOf apStack+     putMVar statusMVar $ EvalBreak is_exception apStack_r (I# ix#) (I# uniq#) resume_r ccs+     takeMVar breakMVar++   resetBreakAction stablePtr = do+     poke breakPointIOAction noBreakStablePtr+     poke exceptionFlag 0+     resetStepFlag+     freeStablePtr stablePtr++resumeStmt+  :: EvalOpts -> RemoteRef (ResumeContext [HValueRef])+  -> IO (EvalStatus [HValueRef])+resumeStmt opts hvref = do+  ResumeContext{..} <- localRef hvref+  withBreakAction opts resumeBreakMVar resumeStatusMVar $+    mask_ $ do+      putMVar resumeBreakMVar () -- this awakens the stopped thread...+      redirectInterrupts resumeThreadId $ takeMVar resumeStatusMVar++-- when abandoning a computation we have to+--      (a) kill the thread with an async exception, so that the+--          computation itself is stopped, and+--      (b) fill in the MVar.  This step is necessary because any+--          thunks that were under evaluation will now be updated+--          with the partial computation, which still ends in takeMVar,+--          so any attempt to evaluate one of these thunks will block+--          unless we fill in the MVar.+--      (c) wait for the thread to terminate by taking its status MVar.  This+--          step is necessary to prevent race conditions with+--          -fbreak-on-exception (see #5975).+--  See test break010.+abandonStmt :: RemoteRef (ResumeContext [HValueRef]) -> IO ()+abandonStmt hvref = do+  ResumeContext{..} <- localRef hvref+  killThread resumeThreadId+  putMVar resumeBreakMVar ()+  _ <- takeMVar resumeStatusMVar+  return ()++foreign import ccall "&rts_stop_next_breakpoint" stepFlag      :: Ptr CInt+foreign import ccall "&rts_stop_on_exception"    exceptionFlag :: Ptr CInt++setStepFlag :: IO ()+setStepFlag = poke stepFlag 1+resetStepFlag :: IO ()+resetStepFlag = poke stepFlag 0++type BreakpointCallback+     = Int#    -- the breakpoint index+    -> Int#    -- the module uniq+    -> Bool    -- exception?+    -> HValue  -- the AP_STACK, or exception+    -> IO ()++foreign import ccall "&rts_breakpoint_io_action"+   breakPointIOAction :: Ptr (StablePtr BreakpointCallback)++noBreakStablePtr :: StablePtr BreakpointCallback+noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction++noBreakAction :: BreakpointCallback+noBreakAction _ _ False _ = putStrLn "*** Ignoring breakpoint"+noBreakAction _ _ True  _ = return () -- exception: just continue++-- Malloc and copy the bytes.  We don't have any way to monitor the+-- lifetime of this memory, so it just leaks.+mkString :: ByteString -> IO (RemotePtr ())+mkString bs = B.unsafeUseAsCStringLen bs $ \(cstr,len) -> do+  ptr <- mallocBytes len+  copyBytes ptr cstr len+  return (castRemotePtr (toRemotePtr ptr))++mkString0 :: ByteString -> IO (RemotePtr ())+mkString0 bs = B.unsafeUseAsCStringLen bs $ \(cstr,len) -> do+  ptr <- mallocBytes (len+1)+  copyBytes ptr cstr len+  pokeElemOff (ptr :: Ptr CChar) len 0+  return (castRemotePtr (toRemotePtr ptr))++mkCostCentres :: String -> [(String,String)] -> IO [RemotePtr CostCentre]+#if defined(PROFILING)+mkCostCentres mod ccs = do+  c_module <- newCString mod+  mapM (mk_one c_module) ccs+ where+  mk_one c_module (decl_path,srcspan) = do+    c_name <- newCString decl_path+    c_srcspan <- newCString srcspan+    toRemotePtr <$> c_mkCostCentre c_name c_module c_srcspan++foreign import ccall unsafe "mkCostCentre"+  c_mkCostCentre :: Ptr CChar -> Ptr CChar -> Ptr CChar -> IO (Ptr CostCentre)+#else+mkCostCentres _ _ = return []+#endif++getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)+getIdValFromApStack apStack (I# stackDepth) = do+   case getApStackVal# apStack stackDepth of+        (# ok, result #) ->+            case ok of+              0# -> return Nothing -- AP_STACK not found+              _  -> return (Just (unsafeCoerce# result))
+ libraries/ghci/GHCi/Signals.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE CPP #-}+module GHCi.Signals (installSignalHandlers) where++import Prelude -- See note [Why do we import Prelude here?]+import Control.Concurrent+import Control.Exception+import System.Mem.Weak  ( deRefWeak )++#if !defined(mingw32_HOST_OS)+import System.Posix.Signals+#endif++#if defined(mingw32_HOST_OS)+import GHC.ConsoleHandler+#endif++-- | Install standard signal handlers for catching ^C, which just throw an+--   exception in the target thread.  The current target thread is the+--   thread at the head of the list in the MVar passed to+--   installSignalHandlers.+installSignalHandlers :: IO ()+installSignalHandlers = do+  main_thread <- myThreadId+  wtid <- mkWeakThreadId main_thread++  let interrupt = do+        r <- deRefWeak wtid+        case r of+          Nothing -> return ()+          Just t  -> throwTo t UserInterrupt++#if !defined(mingw32_HOST_OS)+  _ <- installHandler sigQUIT  (Catch interrupt) Nothing+  _ <- installHandler sigINT   (Catch interrupt) Nothing+#else+  -- GHC 6.3+ has support for console events on Windows+  -- NOTE: running GHCi under a bash shell for some reason requires+  -- you to press Ctrl-Break rather than Ctrl-C to provoke+  -- an interrupt.  Ctrl-C is getting blocked somewhere, I don't know+  -- why --SDM 17/12/2004+  let sig_handler ControlC = interrupt+      sig_handler Break    = interrupt+      sig_handler _        = return ()++  _ <- installHandler (Catch sig_handler)+#endif+  return ()
+ libraries/ghci/GHCi/StaticPtrTable.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ForeignFunctionInterface #-}++module GHCi.StaticPtrTable ( sptAddEntry ) where++import Prelude -- See note [Why do we import Prelude here?]+import Data.Word+import Foreign+import GHC.Fingerprint+import GHCi.RemoteTypes++-- | Used by GHCi to add an SPT entry for a set of interactive bindings.+sptAddEntry :: Fingerprint -> HValue -> IO ()+sptAddEntry (Fingerprint a b) (HValue x) = do+    -- We own the memory holding the key (fingerprint) which gets inserted into+    -- the static pointer table and can't free it until the SPT entry is removed+    -- (which is currently never).+    fpr_ptr <- newArray [a,b]+    sptr <- newStablePtr x+    ent_ptr <- malloc+    poke ent_ptr (castStablePtrToPtr sptr)+    spt_insert_stableptr fpr_ptr ent_ptr++foreign import ccall "hs_spt_insert_stableptr"+    spt_insert_stableptr :: Ptr Word64 -> Ptr (Ptr ()) -> IO ()
+ libraries/ghci/GHCi/TH.hs view
@@ -0,0 +1,273 @@+{-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, DeriveGeneric,+    TupleSections, RecordWildCards, InstanceSigs, CPP #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++-- |+-- Running TH splices+--+module GHCi.TH+  ( startTH+  , runModFinalizerRefs+  , runTH+  , GHCiQException(..)+  ) where++{- Note [Remote Template Haskell]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Here is an overview of how TH works with -fexternal-interpreter.++Initialisation+~~~~~~~~~~~~~~++GHC sends a StartTH message to the server (see GHC.Tc.Gen.Splice.getTHState):++   StartTH :: Message (RemoteRef (IORef QState))++The server creates an initial QState object, makes an IORef to it, and+returns a RemoteRef to this to GHC. (see GHCi.TH.startTH below).++This happens once per module, the first time we need to run a TH+splice.  The reference that GHC gets back is kept in+tcg_th_remote_state in the TcGblEnv, and passed to each RunTH call+that follows.+++For each splice+~~~~~~~~~~~~~~~++1. GHC compiles a splice to byte code, and sends it to the server: in+   a CreateBCOs message:++   CreateBCOs :: [LB.ByteString] -> Message [HValueRef]++2. The server creates the real byte-code objects in its heap, and+   returns HValueRefs to GHC.  HValueRef is the same as RemoteRef+   HValue.++3. GHC sends a RunTH message to the server:++  RunTH+   :: RemoteRef (IORef QState)+        -- The state returned by StartTH in step1+   -> HValueRef+        -- The HValueRef we got in step 4, points to the code for the splice+   -> THResultType+        -- Tells us what kind of splice this is (decl, expr, type, etc.)+   -> Maybe TH.Loc+        -- Source location+   -> Message (QResult ByteString)+        -- Eventually it will return a QResult back to GHC.  The+        -- ByteString here is the (encoded) result of the splice.++4. The server runs the splice code.++5. Each time the splice code calls a method of the Quasi class, such+   as qReify, a message is sent from the server to GHC.  These+   messages are defined by the THMessage type.  GHC responds with the+   result of the request, e.g. in the case of qReify it would be the+   TH.Info for the requested entity.++6. When the splice has been fully evaluated, the server sends+   RunTHDone back to GHC.  This tells GHC that the server has finished+   sending THMessages and will send the QResult next.++8. The server then sends a QResult back to GHC, which is notionally+   the response to the original RunTH message.  The QResult indicates+   whether the splice succeeded, failed, or threw an exception.+++After typechecking+~~~~~~~~~~~~~~~~~~++GHC sends a FinishTH message to the server (see GHC.Tc.Gen.Splice.finishTH).+The server runs any finalizers that were added by addModuleFinalizer.+++Other Notes on TH / Remote GHCi++  * Note [Remote GHCi] in compiler/GHC/Runtime/Interpreter.hs+  * Note [External GHCi pointers] in compiler/GHC/Runtime/Interpreter.hs+  * Note [TH recover with -fexternal-interpreter] in GHC.Tc.Gen.Splice+-}++import Prelude -- See note [Why do we import Prelude here?]+import GHCi.Message+import GHCi.RemoteTypes+import GHC.Serialized++import Control.Exception+import Control.Monad.IO.Class (MonadIO (..))+import Data.Binary+import Data.Binary.Put+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as LB+import Data.Data+import Data.Dynamic+import Data.Either+import Data.IORef+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe+import GHC.Desugar+import qualified Language.Haskell.TH        as TH+import qualified Language.Haskell.TH.Syntax as TH+import Unsafe.Coerce++-- | Create a new instance of 'QState'+initQState :: Pipe -> QState+initQState p = QState M.empty Nothing p++-- | The monad in which we run TH computations on the server+newtype GHCiQ a = GHCiQ { runGHCiQ :: QState -> IO (a, QState) }++-- | The exception thrown by "fail" in the GHCiQ monad+data GHCiQException = GHCiQException QState String+  deriving Show++instance Exception GHCiQException++instance Functor GHCiQ where+  fmap f (GHCiQ s) = GHCiQ $ fmap (\(x,s') -> (f x,s')) . s++instance Applicative GHCiQ where+  f <*> a = GHCiQ $ \s ->+    do (f',s')  <- runGHCiQ f s+       (a',s'') <- runGHCiQ a s'+       return (f' a', s'')+  pure x = GHCiQ (\s -> return (x,s))++instance Monad GHCiQ where+  m >>= f = GHCiQ $ \s ->+    do (m', s')  <- runGHCiQ m s+       (a,  s'') <- runGHCiQ (f m') s'+       return (a, s'')++instance MonadFail GHCiQ where+  fail err  = GHCiQ $ \s -> throwIO (GHCiQException s err)++getState :: GHCiQ QState+getState = GHCiQ $ \s -> return (s,s)++noLoc :: TH.Loc+noLoc = TH.Loc "<no file>" "<no package>" "<no module>" (0,0) (0,0)++-- | Send a 'THMessage' to GHC and return the result.+ghcCmd :: Binary a => THMessage (THResult a) -> GHCiQ a+ghcCmd m = GHCiQ $ \s -> do+  r <- remoteTHCall (qsPipe s) m+  case r of+    THException str -> throwIO (GHCiQException s str)+    THComplete res -> return (res, s)++instance MonadIO GHCiQ where+  liftIO m = GHCiQ $ \s -> fmap (,s) m++instance TH.Quasi GHCiQ where+  qNewName str = ghcCmd (NewName str)+  qReport isError msg = ghcCmd (Report isError msg)++  -- See Note [TH recover with -fexternal-interpreter] in GHC.Tc.Gen.Splice+  qRecover (GHCiQ h) a = GHCiQ $ \s -> mask $ \unmask -> do+    remoteTHCall (qsPipe s) StartRecover+    e <- try $ unmask $ runGHCiQ (a <* ghcCmd FailIfErrs) s+    remoteTHCall (qsPipe s) (EndRecover (isLeft e))+    case e of+      Left GHCiQException{} -> h s+      Right r -> return r+  qLookupName isType occ = ghcCmd (LookupName isType occ)+  qReify name = ghcCmd (Reify name)+  qReifyFixity name = ghcCmd (ReifyFixity name)+  qReifyType name = ghcCmd (ReifyType name)+  qReifyInstances name tys = ghcCmd (ReifyInstances name tys)+  qReifyRoles name = ghcCmd (ReifyRoles name)++  -- To reify annotations, we send GHC the AnnLookup and also the+  -- TypeRep of the thing we're looking for, to avoid needing to+  -- serialize irrelevant annotations.+  qReifyAnnotations :: forall a . Data a => TH.AnnLookup -> GHCiQ [a]+  qReifyAnnotations lookup =+    map (deserializeWithData . B.unpack) <$>+      ghcCmd (ReifyAnnotations lookup typerep)+    where typerep = typeOf (undefined :: a)++  qReifyModule m = ghcCmd (ReifyModule m)+  qReifyConStrictness name = ghcCmd (ReifyConStrictness name)+  qLocation = fromMaybe noLoc . qsLocation <$> getState+  qGetPackageRoot        = ghcCmd GetPackageRoot+  qAddDependentFile file = ghcCmd (AddDependentFile file)+  qAddTempFile suffix = ghcCmd (AddTempFile suffix)+  qAddTopDecls decls = ghcCmd (AddTopDecls decls)+  qAddForeignFilePath lang fp = ghcCmd (AddForeignFilePath lang fp)+  qAddModFinalizer fin = GHCiQ (\s -> mkRemoteRef fin >>= return . (, s)) >>=+                         ghcCmd . AddModFinalizer+  qAddCorePlugin str = ghcCmd (AddCorePlugin str)+  qGetQ = GHCiQ $ \s ->+    let lookup :: forall a. Typeable a => Map TypeRep Dynamic -> Maybe a+        lookup m = fromDynamic =<< M.lookup (typeOf (undefined::a)) m+    in return (lookup (qsMap s), s)+  qPutQ k = GHCiQ $ \s ->+    return ((), s { qsMap = M.insert (typeOf k) (toDyn k) (qsMap s) })+  qIsExtEnabled x = ghcCmd (IsExtEnabled x)+  qExtsEnabled = ghcCmd ExtsEnabled+  qPutDoc l s = ghcCmd (PutDoc l s)+  qGetDoc l = ghcCmd (GetDoc l)++-- | The implementation of the 'StartTH' message: create+-- a new IORef QState, and return a RemoteRef to it.+startTH :: IO (RemoteRef (IORef QState))+startTH = do+  r <- newIORef (initQState (error "startTH: no pipe"))+  mkRemoteRef r++-- | Runs the mod finalizers.+--+-- The references must be created on the caller process.+runModFinalizerRefs :: Pipe -> RemoteRef (IORef QState)+                    -> [RemoteRef (TH.Q ())]+                    -> IO ()+runModFinalizerRefs pipe rstate qrefs = do+  qs <- mapM localRef qrefs+  qstateref <- localRef rstate+  qstate <- readIORef qstateref+  _ <- runGHCiQ (TH.runQ $ sequence_ qs) qstate { qsPipe = pipe }+  return ()++-- | The implementation of the 'RunTH' message+runTH+  :: Pipe+  -> RemoteRef (IORef QState)+      -- ^ The TH state, created by 'startTH'+  -> HValueRef+      -- ^ The splice to run+  -> THResultType+      -- ^ What kind of splice it is+  -> Maybe TH.Loc+      -- ^ The source location+  -> IO ByteString+      -- ^ Returns an (encoded) result that depends on the THResultType++runTH pipe rstate rhv ty mb_loc = do+  hv <- localRef rhv+  case ty of+    THExp -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Exp)+    THPat -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Pat)+    THType -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Type)+    THDec -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q [TH.Dec])+    THAnnWrapper -> do+      hv <- unsafeCoerce <$> localRef rhv+      case hv :: AnnotationWrapper of+        AnnotationWrapper thing -> return $!+          LB.toStrict (runPut (put (toSerialized serializeWithData thing)))++-- | Run a Q computation.+runTHQ+  :: Binary a => Pipe -> RemoteRef (IORef QState) -> Maybe TH.Loc -> TH.Q a+  -> IO ByteString+runTHQ pipe rstate mb_loc ghciq = do+  qstateref <- localRef rstate+  qstate <- readIORef qstateref+  let st = qstate { qsLocation = mb_loc, qsPipe = pipe }+  (r,new_state) <- runGHCiQ (TH.runQ ghciq) st+  writeIORef qstateref new_state+  return $! LB.toStrict (runPut (put r))
+ libraries/template-haskell/Language/Haskell/TH/CodeDo.hs view
@@ -0,0 +1,22 @@+-- | This module exists to work nicely with the QualifiedDo+-- extension.+--+-- @+-- import qualified Language.Haskell.TH.CodeDo as Code+--+-- myExample :: Monad m => Code m a -> Code m a -> Code m a+-- myExample opt1 opt2 =+--   Code.do+--    x <- someSideEffect               -- This one is of type `M Bool`+--    if x then opt1 else opt2+-- @+module Language.Haskell.TH.CodeDo((>>=), (>>)) where++import Language.Haskell.TH.Syntax+import Prelude(Monad)++-- | Module over monad operator for 'Code'+(>>=) :: Monad m => m a -> (a -> Code m b) -> Code m b+(>>=) = bindCode+(>>) :: Monad m => m a -> Code m b -> Code m b+(>>)  = bindCode_
+ libraries/template-haskell/Language/Haskell/TH/Quote.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE RankNTypes, ScopedTypeVariables, Safe #-}+{- |+Module : Language.Haskell.TH.Quote+Description : Quasi-quoting support for Template Haskell++Template Haskell supports quasiquoting, which permits users to construct+program fragments by directly writing concrete syntax.  A quasiquoter is+essentially a function with takes a string to a Template Haskell AST.+This module defines the 'QuasiQuoter' datatype, which specifies a+quasiquoter @q@ which can be invoked using the syntax+@[q| ... string to parse ... |]@ when the @QuasiQuotes@ language+extension is enabled, and some utility functions for manipulating+quasiquoters.  Nota bene: this package does not define any parsers,+that is up to you.+-}+module Language.Haskell.TH.Quote(+        QuasiQuoter(..),+        quoteFile,+        -- * For backwards compatibility+        dataToQa, dataToExpQ, dataToPatQ+    ) where++import Language.Haskell.TH.Syntax+import Prelude++-- | The 'QuasiQuoter' type, a value @q@ of this type can be used+-- in the syntax @[q| ... string to parse ...|]@.  In fact, for+-- convenience, a 'QuasiQuoter' actually defines multiple quasiquoters+-- to be used in different splice contexts; if you are only interested+-- in defining a quasiquoter to be used for expressions, you would+-- define a 'QuasiQuoter' with only 'quoteExp', and leave the other+-- fields stubbed out with errors.+data QuasiQuoter = QuasiQuoter {+    -- | Quasi-quoter for expressions, invoked by quotes like @lhs = $[q|...]@+    quoteExp  :: String -> Q Exp,+    -- | Quasi-quoter for patterns, invoked by quotes like @f $[q|...] = rhs@+    quotePat  :: String -> Q Pat,+    -- | Quasi-quoter for types, invoked by quotes like @f :: $[q|...]@+    quoteType :: String -> Q Type,+    -- | Quasi-quoter for declarations, invoked by top-level quotes+    quoteDec  :: String -> Q [Dec]+    }++-- | 'quoteFile' takes a 'QuasiQuoter' and lifts it into one that read+-- the data out of a file.  For example, suppose @asmq@ is an+-- assembly-language quoter, so that you can write [asmq| ld r1, r2 |]+-- as an expression. Then if you define @asmq_f = quoteFile asmq@, then+-- the quote [asmq_f|foo.s|] will take input from file @"foo.s"@ instead+-- of the inline text+quoteFile :: QuasiQuoter -> QuasiQuoter+quoteFile (QuasiQuoter { quoteExp = qe, quotePat = qp, quoteType = qt, quoteDec = qd }) +  = QuasiQuoter { quoteExp = get qe, quotePat = get qp, quoteType = get qt, quoteDec = get qd }+  where+   get :: (String -> Q a) -> String -> Q a+   get old_quoter file_name = do { file_cts <- runIO (readFile file_name) +                                 ; addDependentFile file_name+                                 ; old_quoter file_cts }
+ rts/include/ghcconfig.h view
@@ -0,0 +1,4 @@+#pragma once++#include "ghcautoconf.h"+#include "ghcplatform.h"